(module (s9fes char-canvas shape image)

(;export
  ;
  image? image-size
  ;
  string->image
  canvas->image
  ;
  read-image write-image
  load-image store-image
  ;
  real-shape-image
  shape-image)

(import scheme utf8)
(import (chicken base))
(import (chicken fixnum))
(import (chicken pathname))
(import (chicken port))
(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")

;images are shapes but not externally
(define-type image char-canvas)

(: image? (* -> boolean : image))
(: image-size (image -> fixnum fixnum))

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

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

(: string->image (string -> image))
(: canvas->image (canvas -> image))

(: real-shape-image (image #!optional char-transform -> real-shape-plotter))
(: shape-image (image #!optional char-transform -> shape-plotter))

;;

(define (check-image loc obj)
 (assert (%char-canvas? obj) loc "bad argument type - not an image" obj)
 obj )

;;

(define (image? obj) (%char-canvas? obj))

(define (image-size image)
  (check-image 'image-size image)
  (values (%char-canvas-columns image) (%char-canvas-rows image)) )

(define (canvas->image cv) (%canvas-chars (canvas-duplicate cv)))
(define (string->image str) (string->char-canvas str))

(define (read-image #!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-image image #!optional (out (current-output-port)))
  (check-image 'write-image image)
  (write (vector (%char-canvas-columns image) (%char-canvas-rows image)
                 (%char-canvas-cmap image)) out) )

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

(define (store-image image pn)
  (check-image 'store-image image)
  (with-output-to-file pn (lambda () (write-image image))) )

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

(define (real-shape-image image #!optional (compositer (compositor-alpha)))
  (let ((r-xm (/ (%char-canvas-columns image) 2))
        (r-ym (/ (%char-canvas-rows image) 2))
        (image-cv (new-canvas image (%char-canvas-columns image) (%char-canvas-rows image))) )
    (lambda (#!optional cv x0 y0)
      (if cv
          ;too large an image is clipped by `canvas-paste-chars'
          (let ((px (if x0 (round (- x0 r-xm)) 0))
                (py (if y0 (round (- y0 r-ym)) 0)) )
            (canvas-paste-chars cv image-cv px py compositer)
            cv)
          (list 'image 'real image compositer) ) ) ) )

(define (shape-image image #!optional (compositer (compositor-alpha)))
  (let ((pltr (the (or false real-shape-plotter) #f))
        (xm (round (/ (%char-canvas-columns image) 2)))
        (ym (round (/ (%char-canvas-rows image) 2))) )
    (lambda (#!optional cv x0 y0)
      (unless pltr (set! pltr (real-shape-image image compositer)))
      (if cv
          (let* ((px (if x0 (%real-x cv x0) xm))
                 (py (if y0 (%real-y cv y0) ym)) )
            (pltr cv px py) )
          (list 'image 'virtual image compositer) ) ) ) )

;;

(define (image-shape-size info)
  (let ((image (the image (caddr info))))
    (image-size image) ) )

(register-shape-method 'image 'size image-shape-size)

) ;module (s9fes char-canvas shape image)