;; Issues
;;

(module (s9fes char-canvas shape cross)

(;export
  ;
  real-shape-cross--
  real-shape-cross-vbar
  real-shape-cross-+
  ;
  real-shape-cross-obar
  real-shape-cross-abar
  real-shape-cross-x
  ;
  shape-cross--
  shape-cross-vbar
  shape-cross-+
  ;
  shape-cross-obar
  shape-cross-abar
  shape-cross-x)

(import scheme utf8)
(import (chicken base))
(import (chicken fixnum))
(import (chicken type))
(import record-variants)
(import (s9fes char-canvas)
        (s9fes char-canvas rect)
        (s9fes char-canvas shape shape))

(include-relative "s9fes.char-canvas.types")
(include-relative "s9fes.char-canvas.inlines")

(include-relative "s9fes.char-canvas.shape.types")
(include-relative "s9fes.char-canvas.shape.inlines")

(: real-shape-cross-- (fixnum #!optional fixnum plotter-config-arg -> real-shape-plotter))
(: real-shape-cross-vbar (fixnum #!optional fixnum plotter-config-arg -> real-shape-plotter))
(: real-shape-cross-+ (fixnum #!optional fixnum plotter-config-arg -> real-shape-plotter))

(: real-shape-cross-obar (fixnum #!optional fixnum plotter-config-arg -> real-shape-plotter))
(: real-shape-cross-abar (fixnum #!optional fixnum plotter-config-arg -> real-shape-plotter))
(: real-shape-cross-x (fixnum #!optional fixnum plotter-config-arg -> real-shape-plotter))

(: shape-cross-- (fixnum #!optional fixnum plotter-config-arg -> real-shape-plotter))
(: shape-cross-vbar (fixnum #!optional fixnum plotter-config-arg -> real-shape-plotter))
(: shape-cross-+ (fixnum #!optional fixnum plotter-config-arg -> real-shape-plotter))

(: shape-cross-obar (fixnum #!optional fixnum plotter-config-arg -> real-shape-plotter))
(: shape-cross-abar (fixnum #!optional fixnum plotter-config-arg -> real-shape-plotter))
(: shape-cross-x (fixnum #!optional fixnum plotter-config-arg -> real-shape-plotter))

;;

(define (cross-shape-args loc wd ht cfg n)
  (assert (and (fixnum? wd) (fixnum? ht)) loc "bad argument type - not fixnums" wd ht)
  (let* ((cfg (validate-plotter-configuration loc cfg n))
         (mx (fx- wd 1)) (my (fx- ht 1))
         (c1 (%plt-cfg-c 0 cfg)) (c2 (if (fx= 1 n) c1 (%plt-cfg-c 1 cfg)))
         (wd/2 (fx/ (fx+ wd 1) 2)) (ht/2 (fx/ (fx+ ht 1) 2))
         (xm0 (fx+ wd/2 -1)) (ym0 (fx+ ht/2 -1)) )
    (values c1 c2 mx my xm0 ym0 cfg) ) )

(define (real-shape-cross-- wd #!optional (ht wd) (cfg (current-plotter-char)))
  (receive (c1 c2 mx my xm0 ym0 cfg) (cross-shape-args 'real-shape-cross-- wd ht cfg 1)
    (lambda (#!optional cv (xm xm0) (ym ym0))
      (if cv
          (let ((x0 (fx- xm xm0)) (y0 (fx- ym ym0)))
            (when c1 (canvas-draw-line cv x0 ym (fx+ x0 mx) ym c1)) )
          (^real-info 'cross-- wd ht cfg) ) ) ) )

(define (real-shape-cross-vbar wd #!optional (ht wd) (cfg (current-plotter-char)))
  (receive (c1 c2 mx my xm0 ym0 cfg) (cross-shape-args real-shape-cross-vbar wd ht cfg 1)
    (lambda (#!optional cv (xm xm0) (ym ym0))
      (if cv
          (let ((x0 (fx- xm xm0)) (y0 (fx- ym ym0)))
            (when c2 (canvas-draw-line cv xm (fx+ y0 my) xm y0 c2)) )
          (^real-info 'cross-vbar wd ht cfg) ) ) ) )

(define (real-shape-cross-+ wd #!optional (ht wd) (cfg (current-plotter-char)))
  (receive (c1 c2 mx my xm0 ym0 cfg) (cross-shape-args 'real-shape-cross-+ wd ht cfg 2)
    (lambda (#!optional cv (xm xm0) (ym ym0))
      (if cv
          (let ((x0 (fx- xm xm0)) (y0 (fx- ym ym0)))
            (when c1 (canvas-draw-line cv x0 ym (fx+ x0 mx) ym c1))
            (when c2 (canvas-draw-line cv xm (fx+ y0 my) xm y0 c2)) ) )
          (^real-info 'cross-+ wd ht cfg) ) ) )

(define (real-shape-cross-obar wd #!optional (ht wd) (cfg (current-plotter-char)))
  (receive (c1 c2 mx my xm0 ym0 cfg) (cross-shape-args 'real-shape-cross-obar wd ht cfg 1)
    (lambda (#!optional cv (xm xm0) (ym ym0))
      (if cv
          (let* ((x0 (fx- xm xm0)) (y0 (fx- ym ym0))
                 (x1 (fx+ x0 mx)) (y1 (fx+ y0 my)) )
            (when c1 (canvas-draw-line cv x0 y1 x1 y0 c1))) )
          (^real-info 'cross-obar wd ht cfg) ) ) )

(define (real-shape-cross-abar wd #!optional (ht wd) (cfg (current-plotter-char)))
  (receive (c1 c2 mx my xm0 ym0 cfg) (cross-shape-args 'real-shape-cross-abar wd ht cfg 1)
    (lambda (#!optional cv (xm xm0) (ym ym0))
      (if cv
          (let* ((x0 (fx- xm xm0)) (y0 (fx- ym ym0))
                 (x1 (fx+ x0 mx)) (y1 (fx+ y0 my)) )
            (when c2 (canvas-draw-line cv x0 y0 x1 y1 c2)) )
          (^real-info 'cross-abar wd ht cfg) ) ) ) )

(define (real-shape-cross-x wd #!optional (ht wd) (cfg (current-plotter-char)))
  (receive (c1 c2 mx my xm0 ym0 cfg) (cross-shape-args 'real-shape-cross-+ wd ht cfg 2)
    (lambda (#!optional cv (xm xm0) (ym ym0))
      (if cv
          (let* ((x0 (fx- xm xm0)) (y0 (fx- ym ym0))
                 (x1 (fx+ x0 mx)) (y1 (fx+ y0 my)) )
            (when c1 (canvas-draw-line cv x0 y1 x1 y0 c1))
            (when c2 (canvas-draw-line cv x0 y0 x1 y1 c2)) )
          (^real-info 'cross-x wd ht cfg) ) ) ) )

;;

(define (virtual-cross-shape-args loc wd ht cfg n)
  (assert (and (exact-integer? wd) (exact-integer? ht)) loc "bad argument type - not exact-integer" wd ht)
  (values (+ (floor (/ wd 2)) -1) ;x
          (+ (floor (/ ht 2)) -1) ;y
          ;extra work but better error
          (validate-plotter-configuration loc cfg n)) )

(define (shape-cross-- wd #!optional (ht wd) (cfg (current-plotter-char)))
  (receive (xm0 ym0 cfg) (virtual-cross-shape-args 'shape-cross-- wd ht cfg 1)
    ;wait until have a canvas
    (let ((plotter (the (or false real-shape-plotter) #f)))
      (lambda (#!optional cv (xm xm0) (ym ym0))
        (if cv
            (begin
              (unless plotter
                (let ((pwd (%real-x cv wd)) (pht (%real-y cv ht)))
                  (set! plotter (real-shape-cross-- pwd pht cfg)) ) )
              (let ((pxm0 (%real-x cv xm0)) (pym0 (%real-y cv ym0)))
                (plotter cv pxm0 pym0)) )
            (^virtual-info 'cross-- wd ht cfg) ) ) ) ) )

(define (shape-cross-vbar wd #!optional (ht wd) (cfg (current-plotter-char)))
  (receive (xm0 ym0 cfg) (virtual-cross-shape-args 'shape-cross-vbar wd ht cfg 1)
    ;wait until have a canvas
    (let ((plotter (the (or false real-shape-plotter) #f)))
      (lambda (#!optional cv (xm xm0) (ym ym0))
        (if cv
            (begin
              (unless plotter
                (let ((pwd (%real-x cv wd)) (pht (%real-y cv ht)))
                  (set! plotter (real-shape-cross-vbar pwd pht cfg)) ) )
              (let ((pxm0 (%real-x cv xm0)) (pym0 (%real-y cv ym0)))
                (plotter cv pxm0 pym0)) )
            (^virtual-info 'cross-vbar wd ht cfg) ) ) ) ) )

(define (shape-cross-+ wd #!optional (ht wd) (cfg (current-plotter-char)))
  (receive (xm0 ym0 cfg) (virtual-cross-shape-args 'shape-cross-+ wd ht cfg 2)
    ;wait until have a canvas
    (let ((plotter (the (or false real-shape-plotter) #f)))
      (lambda (#!optional cv (xm xm0) (ym ym0))
        (if cv
            (begin
              (unless plotter
                (let ((pwd (%real-x cv wd)) (pht (%real-y cv ht)))
                  (set! plotter (real-shape-cross-+ pwd pht cfg)) ) )
              (let ((pxm0 (%real-x cv xm0)) (pym0 (%real-y cv ym0)))
                (plotter cv pxm0 pym0)) )
            (^virtual-info 'cross-+ wd ht cfg) ) ) ) ) )

(define (shape-cross-obar wd #!optional (ht wd) (cfg (current-plotter-char)))
  (receive (xm0 ym0 cfg) (virtual-cross-shape-args 'shape-cross-obar wd ht cfg 1)
    ;wait until have a canvas
    (let ((plotter (the (or false real-shape-plotter) #f)))
      (lambda (#!optional cv (xm xm0) (ym ym0))
        (if cv
            (begin
              (unless plotter
                (let ((pwd (%real-x cv wd)) (pht (%real-y cv ht)))
                  (set! plotter (real-shape-cross-obar pwd pht cfg)) ) )
              (let ((pxm0 (%real-x cv xm0)) (pym0 (%real-y cv ym0)))
                (plotter cv pxm0 pym0)) )
            (^virtual-info 'cross-obar wd ht cfg) ) ) ) ) )

(define (shape-cross-abar wd #!optional (ht wd) (cfg (current-plotter-char)))
  (receive (xm0 ym0 cfg) (virtual-cross-shape-args 'shape-cross-abar wd ht cfg 1)
    ;wait until have a canvas
    (let ((plotter (the (or false real-shape-plotter) #f)))
      (lambda (#!optional cv (xm xm0) (ym ym0))
        (if cv
            (begin
              (unless plotter
                (let ((pwd (%real-x cv wd)) (pht (%real-y cv ht)))
                  (set! plotter (real-shape-cross-abar pwd pht cfg)) ) )
              (let ((pxm0 (%real-x cv xm0)) (pym0 (%real-y cv ym0)))
                (plotter cv pxm0 pym0)) )
            (^virtual-info 'cross-abar wd ht cfg) ) ) ) ) )

(define (shape-cross-x wd #!optional (ht wd) (cfg (current-plotter-char)))
  (receive (xm0 ym0 cfg) (virtual-cross-shape-args 'shape-cross-x wd ht cfg 2)
    ;wait until have a canvas
    (let ((plotter (the (or false real-shape-plotter) #f)))
      (lambda (#!optional cv (xm xm0) (ym ym0))
        (if cv
            (begin
              (unless plotter
                (let ((pwd (%real-x cv wd)) (pht (%real-y cv ht)))
                  (set! plotter (real-shape-cross-x pwd pht cfg)) ) )
              (let ((pxm0 (%real-x cv xm0)) (pym0 (%real-y cv ym0)))
                (plotter cv pxm0 pym0)) )
            (^virtual-info 'cross-x wd ht cfg) ) ) ) ) )

;;

(define CROSS-DEFS '(
  (cross--    ,shape-cross--    ,real-shape-cross--)
  (cross-vbar ,shape-cross-vbar ,real-shape-cross-vbar)
  (cross-+    ,shape-cross-+    ,real-shape-cross-+)
  (cross-obar ,shape-cross-obar ,real-shape-cross-obar)
  (cross-abar ,shape-cross-abar ,real-shape-cross-abar)
  (cross-x    ,shape-cross-x    ,real-shape-cross-x))
)

(define CROSS-IDS (map car CROSS-DEFS))

(for-each (cut apply register-shape <>) CROSS-DEFS)
(for-each (cut register-shape-method <> 'size wh-class-shape-size) CROSS-IDS)

) ;module (s9fes char-canvas shape cross)