(module (s9fes char-canvas shape icon)

(;export
  ;
  string->icon
  canvas->icon
  ;
  read-icon write-icon
  load-icon store-icon
  ;
  shape-icon
  virtual-shape-icon
  ;
  draw-icon
  plot-icon)

(import scheme utf8)
(import (chicken base))
(import (chicken fixnum))
(import (chicken pathname))
(import (chicken port))
(import (chicken type))
(import (s9fes char-canvas))

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

;icons are shapes but not externally
(define-type icon char-canvas)

(: read-icon (#!optional input-port -> icon))
(: write-icon (icon #!optional output-port -> void))

(: load-icon (pathname -> icon))
(: store-icon (icon pathname -> void))

(: string->icon (string -> icon))
(: canvas->icon (canvas -> icon))

(: shape-icon (icon #!optional char-transform -> shape-plotter))
(: virtual-shape-icon (icon #!optional char-transform -> virtual-shape-plotter))

(: draw-icon (canvas icon #!optional fixnum fixnum -> void))
(: plot-icon (canvas icon #!optional integer integer -> void))

;;

(define (canvas->icon cv)
  (canvas-chars (canvas-duplicate cv)) )

(define (string->icon str)
  (string->char-canvas str) )

(define (read-icon #!optional (in (current-input-port)))
  (let ((vec (read in)))
    (make-char-canvas (vector-ref vec 0) (vector-ref vec 1)
                      (vector-ref vec 2)) ) )

(define (write-icon icon #!optional (out (current-output-port)))
  (write (vector (char-canvas-columns icon) (char-canvas-rows icon)
                 (char-canvas-cmap icon)) out) )

(define (load-icon pn)
  (with-input-from-file pn read-icon) )

(define (store-icon icon pn)
  (with-output-to-file pn (lambda () (write-icon icon))) )

;@c transparent char
(define ((compositor-alpha #!optional (c (current-plotter-bkgd-char))) tc sc i j)
  (if (char=? c sc) tc sc) )

(define (shape-icon icon #!optional (compositer (compositor-alpha)))
  (let ((r-xm (/ (char-canvas-columns icon) 2))
        (r-ym (/ (char-canvas-rows icon) 2))
        (icon-cv (new-canvas icon (char-canvas-columns icon) (char-canvas-rows icon))) )
    (lambda (#!optional cv x y)
      (if cv
          (let ((px (if x (round (- x r-xm)) 0))
                (py (if y (round (- y r-ym)) 0)) )
            (canvas-paste-chars cv icon-cv px py compositer)
            cv)
          (list icon compositer) ) ) ) )

(define (virtual-shape-icon icon #!optional (compositer (compositor-alpha)))
  (let ((pltr (the (or false shape-plotter) #f))
        (xm (round (/ (char-canvas-columns icon) 2)))
        (ym (round (/ (char-canvas-rows icon) 2))) )
    (lambda (#!optional cv x y)
      (unless pltr (set! pltr (shape-icon icon compositer)))
      (if cv
          (let*-values (((v-xm v-ym) (if (not (and x y))
                                         (canvas-virtual cv xm ym)
                                         (values -1 -1)))
                        ((x y) (canvas-physical cv (or x v-xm) (or y v-ym))) )
            (pltr cv x y) )
          (list icon compositer) ) ) ) )

(define (draw-icon canvas icon #!optional x y)
  ((shape-icon icon) canvas x y)
  (void) )

(define (plot-icon canvas icon #!optional x y)
  ((virtual-shape-icon icon) canvas x y)
  (void) )

) ;module (s9fes char-canvas icon)