(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 block)
        (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")

;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 (*info-image info) (the image (@info 0 info)))
(define (*info-compositor info) (the char-transform (@info 1 info)))

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

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

;;

(define (reify-compositor transform-info)
  (case (car transform-info)
    ((alpha ALPHA) (apply compositor-alpha (cdr transform-info)))
    (else
      (error 'reify-compositor "unknown compositor" transform-info)) ) )

;FIXME compositor relflection for user-defined!
(define (reflect-compositor transform) (transform))

(define (reify-image vec)
  (%make-char-canvas (vector-ref vec 0) (vector-ref vec 1) (vector-ref vec 2)) )

(define (reflect-image image)
  (vector (%char-canvas-columns image) (%char-canvas-rows image) (%char-canvas-cmap image)) )

;;

(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))) )

(define (real-shape-image image #!optional (compositer (compositor-alpha)))
  (check-image 'real-shape-image image)
  (assert (procedure? compositer) 'real-shape-image "bad argument tyeo - not compositer" compositer)
  (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))) )
    (shape-lambda-info!
      (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 )
            (^real-info 'image image compositer) ) ) ) ) )

(define (shape-image image #!optional (compositer (compositor-alpha)))
  (check-image 'shape-image image)
  (assert (procedure? compositer) 'shape-image "bad argument tyeo - not compositer" compositer)
  (let ((pltr (the (or false real-shape-plotter) #f))
        (xm (round (/ (%char-canvas-columns image) 2)))
        (ym (round (/ (%char-canvas-rows image) 2))) )
    (shape-lambda-info!
      (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) )
            (^virtual-info 'image image compositer) ) ) ) ) )

;;

(define (class-shape-size shp info)
  (let ((image (*info-image info)))
    (image-size image) ) )

(define (class-shape-reify-args noshp noinfo args)
  `(,(reify-image (car args)) ,(reify-compositor (cadr args))) )

(define (class-shape-reflect shp info)
  (^info (@info-class info) (@info-coords info)
         (reflect-image (*info-image info))
         (reflect-compositor (*info-compositor info))) )

(register-shape 'image shape-image real-shape-image)
(register-shape-method 'image 'size class-shape-size)
(register-shape-method 'image 'reify-args class-shape-reify-args)
(register-shape-method 'image 'reflect class-shape-reflect)

) ;module (s9fes char-canvas shape image)