(module (s9fes char-canvas block)

(;export
   ;
  canvas-copy-chars canvas-paste-chars
  canvas-flood-chars canvas-clear-chars canvas-scroll-chars
  ;
  canvas-copy canvas-paste
  canvas-flood canvas-clear canvas-scroll)

(cond-expand
  (chicken-5
    (import scheme utf8)
    (import (only (chicken base)
      unless when assert include-relative define-inline define-constant void))
    (import (only utf8-srfi-13 string-pad-right)) )
  (chicken-6
    (import (scheme base))
    (import (only (srfi 13) string-pad-right)) )
  (else
    ;FIXME error available?
    (error "unknown CHICKEN") ) )

(import (chicken type))
(import (chicken fixnum))
(import (only (chicken port) with-output-to-string with-input-from-string))
(import (only (chicken io) read-lines))
(import (only (chicken string) string-split))
(import (only (chicken format) format))
(import (only (srfi 1) make-list cons* reverse!))
(import (only utf8-srfi-13 string-pad-right))
(import record-variants)
(import (s9fes char-canvas) (s9fes char-canvas rect))

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

; Real Coords

(: canvas-copy-chars (canvas #!optional char-rect char-transform -> canvas))
(: canvas-paste-chars (canvas canvas #!optional fixnum fixnum char-transform -> void))

(: canvas-flood-chars (canvas char #!optional char-rect -> void))
(: canvas-clear-chars (canvas #!optional char-rect -> void))
(: canvas-scroll-chars (canvas fixnum fixnum #!optional char-rect -> void))

; Virtual Coords

(: canvas-copy (canvas #!optional rect char-transform -> canvas))
(: canvas-paste (canvas canvas #!optional integer integer char-transform -> void))

(: canvas-flood (canvas char #!optional rect -> void))
(: canvas-clear (canvas #!optional rect -> void))
(: canvas-scroll (canvas integer integer #!optional rect -> void))

;;

;srfi-133 sort'a

(cond-expand
  (chicken-5
    (define (vector-copy! trg tdx src sdx edx)
      (do ((i tdx (fx+ i 1)) (j sdx (fx+ j 1)))
          ((fx>= j edx))
        (vector-set! trg i (vector-ref src j)) ) ) )
      (else) )

(define (vector-transform! trans trg tdx src sdx edx)
  (do ((i tdx (fx+ i 1)) (j sdx (fx+ j 1)))
      ((fx>= j edx))
    (vector-set! trg i (trans (vector-ref trg i) (vector-ref src j) i j)) ) )

;fx-utils inlines
(define-inline (fxpositive? n) (fx< 0 n))
(define-inline (fxnegative? n) (fx> 0 n))
(define-inline (fxabs n) (if (fxnegative? n) (fxneg n) n))

;;
(define-inline (%rect-real/optional cv rgn)
  (and rgn
       (%rect-real cv rgn)) )

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

;;

(: *canvas-copy! (canvas fixnum canvas fixnum fixnum fixnum (or false char-transform) -> canvas))

;@tcv @scv canvas (not char-canvs)
;@ti @si cmap indexes
;@rw @rh chars coords
(define (*canvas-copy! tcv ti scv si rw rh trans)
  (define copier (if trans
                     (lambda (t ti s si sz) (vector-transform! trans t ti s si sz))
                     vector-copy!))
  (let* ((tccv (%canvas-chars tcv)) (sccv (%canvas-chars scv))
         (tcmp (%char-canvas-cmap tccv)) (tw (%char-canvas-columns tccv)) (th (%char-canvas-rows tccv))
         (scmp (%char-canvas-cmap sccv)) (sw (%char-canvas-columns sccv)) (sh (%char-canvas-rows sccv))
         (slen (vector-length scmp))    ;{w * h}
         (tlen (vector-length tcmp)) )
      (do ((rh rh (fx- rh 1))
           (ti ti (fx+ ti tw))
           (si si (fx+ si sw)) )
          ;quit when out of rows
          ((or (fx<= rh 0)
               ;or out of source (this is an error!)
               (fx>= si slen)
               ;or out of target (this is an error!)
               (fx>= ti tlen)) tcv)
        (copier tcmp ti scmp si (fx+ si rw)) ) ) )

;;

(define (canvas-copy-chars cv #!optional rgn trans)
  (check-canvas 'canvas-copy-chars cv)
  (let* ((cv-chars (%canvas-chars cv))
         (cv-rgn (%char-canvas-rect cv-chars))
         (rgn (if rgn (rect-intersection rgn cv-rgn) cv-rgn)) )
    (if (not (fxpositive? (%rect-area rgn)))
        (make-canvas (%rect-wd rgn) (%rect-ht rgn))
        (let* ((rgn-wd (%rect-wd rgn)) (rgn-ht (%rect-ht rgn))
               (cvd (make-canvas rgn-wd rgn-ht))
               (idx (%char-canvas-index cv-chars (%rect-x rgn) (%rect-y rgn))) )
          (*canvas-copy! cvd 0 cv idx rgn-wd rgn-ht trans) ) ) ) )

(define (canvas-paste-chars cv scv #!optional (x 0) (y 0) trans)
  (check-canvas 'canvas-paste-chars cv)
  (let ((rgn (rect-intersection (%rect x y (%canvas-columns scv) (%canvas-rows scv))
                                (%char-canvas-rect (%canvas-chars cv)))))
    (when (fxpositive? (%rect-area rgn))
      (let ((scv
              (if (and (fx= (%rect-wd rgn) (%canvas-columns scv))
                       (fx= (%rect-ht rgn) (%canvas-rows scv)))
                ;then do it
                scv
                ;else clip the source to fit
                (canvas-copy-chars
                  scv
                  (%rect (fx- x (%rect-x rgn)) (fx- y (%rect-y rgn))
                         (%rect-wd rgn) (%rect-ht rgn))))) )
        (*canvas-copy! cv (%char-canvas-index (%canvas-chars cv) x y)
                          scv 0 (%canvas-columns scv) (%canvas-rows scv)
                          trans) ) ) )
  (void) )

(define (canvas-flood-chars cv #!optional (c (current-plotter-char)) rgn)
  (check-canvas 'canvas-flood-chars cv)
  (if (not rgn)
      ;then entire canvas
      (%set-canvas-cmap! cv (%make-cmap (%canvas-columns cv) (%canvas-rows cv) c))
      ;else canvas window
      (let* ((s (make-string (%rect-wd rgn) c))
             (xll (%rect-x rgn))
             (yll (%rect-y rgn))
             (yur (fx- (fx+ yll (%rect-ht rgn)) 1)) )
        (do ((y yll (fx+ y 1)))
            ((fx> y yur))
          (*canvas-draw-string cv xll y s) ) ) ) )

(define (canvas-clear-chars cv #!optional rgn)
  (canvas-flood-chars cv (current-plotter-bkgd-char) rgn) )

; "scrolls in" a clear bkgd. supply a bkgd
; bkgd can be generated or static (func or scalar)

(define (canvas-scroll-chars cv dx dy #!optional rgn (c (current-plotter-bkgd-char)))
  (check-canvas 'canvas-scroll-chars cv)
  ;scroll the canvas region - scrolled off-canvas is a clear
  (if (not rgn)
      ;then clearing the canvas
      (canvas-flood-chars cv c)
      ;else contents
      (let* ((wd (%rect-wd rgn))
             (ht (%rect-ht rgn))
             ;clip shift to window - when total direction irrelevent
             ;FIXME < is an error?
             ;now out-of-bounds is = wd|ht
             (dx (if (fx<= wd (fxabs dx)) wd dx))
             (dy (if (fx<= ht (fxabs dy)) ht dy)) )

        ;constrain to canvas
        (define (clip-h h) (fxmin wd (fxmax 0 h)))
        (define (clip-v v) (fxmin ht (fxmax 0 v)))

        ;scroll size is region size?
        (if (and (fx= wd dx) (fx= ht dy))
            ;then clear the window (since nothing to save, 0 sav wd|ht)
            (canvas-flood-chars cv c)
            ;else contents
            (let* ((xll (%rect-x rgn))
                   (yll (%rect-y rgn))
                   ;old area (saved)
                   (sav-rgn (%rect (clip-h (fx- xll dx))
                                   (clip-v (fx- yll dy))
                                   ;saved rgn must be < rgn!
                                   (clip-h (fx- wd (fxabs dx)))
                                   (clip-v (fx- ht (fxabs dy)))))
                   ;new area (effected)
                   (eff-rgn (%rect (clip-h (fx+ xll dx))
                                   (clip-v (fx+ yll dy))
                                   ;effected rgn is elastic
                                   (clip-h (fx- wd dx))
                                   (clip-v (fx- ht dy)))) )
              ;copy the saved from the old position (if any)
              ;clear the original
              ;paste the saved to the new position (if any)
              (cond ((fx= wd dx)
                      (canvas-flood-chars cv c (%rect (%rect-x rgn) (%rect-y sav-rgn)
                                                      (%rect-wd rgn) (%rect-ht sav-rgn))))
                    ((fx= ht dy)
                      (canvas-flood-chars cv c (%rect (%rect-x sav-rgn) (%rect-y rgn)
                                                      (%rect-wd sav-rgn) (%rect-ht rgn))))
                    (else
                      (let ((scv (canvas-copy-chars cv sav-rgn)))
                        (canvas-flood-chars cv c rgn)
                        (canvas-paste-chars cv scv (%rect-x eff-rgn) (%rect-y eff-rgn)) ) ) ) ) ) ) ) )

;;


(define (canvas-copy cv #!optional rgn trans)
  (check-canvas 'canvas-copy cv)
  (canvas-copy-chars cv (%rect-real/optional cv rgn) trans) )

(define (canvas-paste cv scv #!optional (x 0) (y 0) trans)
  (check-canvas 'canvas-paste cv)
  (canvas-paste-chars cv scv (%real-x cv x) (%real-y cv y) trans) )

(define (canvas-flood cv #!optional (c (current-plotter-char)) rgn)
   (check-canvas 'canvas-flood cv)
 (canvas-flood-chars cv c (%rect-real/optional cv rgn)) )

(define (canvas-clear cv #!optional rgn)
  (check-canvas 'canvas-clear cv)
  (canvas-clear-chars cv (%rect-real/optional cv rgn)) )

(define (canvas-scroll cv dx dy #!optional rgn (c (current-plotter-bkgd-char)))
  (check-canvas 'canvas-scroll cv)
  (canvas-scroll-chars cv (%real-x cv dx) (%real-y cv dy)
                          (%rect-real/optional cv rgn)
                          c) )

) ;module (s9fes char-canvas)