; Scheme 9 from Empty Space, Function Library
; By Nils M Holm, 2010,2012
; Placed in the Public Domain
;
; (canvas-draw canvas integer-X integer-Y char)       ==>  unspecific
; (canvas-draw-string canvas int-X int-Y string)      ==>  unspecific
; (canvas-dump canvas)                                ==>  vector
; (canvas-plot canvas integer-X integer-Y char)       ==>  unspecific
; (canvas-plot-line canvas X Y DX DY char)            ==>  unspecific
; (make-canvas int-X int-Y int-W int-H)               ==>  canvas
;
; (load-from-library "char-canvas.scm")
;
; This is a set of routines for drawing characters and lines on
; a scaled, character-based (a.k.a. "ASCII Art") canvas.
;
; MAKE-CANVAS creates a char canvas with a physical size of
; x=INT-X times y=INT-Y characters. The virtual size of the
; canvas is INT-W (width) times INT-H (height) "pixels". "Real
; coordinates" relate to the physical size of the canvas.
; "Virtual coordinates" are translated to real coordinates by
; scaling. Both types of coordinates are specified in X/Y
; notation. The origin 0/0 is at the lower left corner of the
; canvas. The new canvas will be filled with blanks initially.
;
; CANVAS-DRAW draws character CHAR at position INTEGER-X/INTEGER-Y.
; It uses real coordinates. CANVAS-DRAWSTRING draws a string
; instead of a single character. When the X or Y coordinate is
; outside of the canvas, C will not be drawn. When STRING extends
; beyond the limits of the canvas, it will be clipped.
;
; CANVAS-PLOT draws the character CHAR at the virtual position
; INTEGER-X/INTEGER-Y. CANVAS-PLOT-LINE draws a line from the
; virtual position X/Y to DX/DY using the character CHAR. All
; arguments must be integers. Lines originating or extending
; outside of the canvas will be clipped.
;
; CANVAS-DUMP returns a vector of strings that contain the
; characters written to the canvas. The vector indexes are the
; Y-coordinates, the string offsets the X-coordinates.
;
; Example:   (let ((c (make-canvas 10 5 10 10)))
;              (canvas-plot-line c 0 9 9 0 #\#)
;              (canvas-plot-line c 0 0 9 9 #\*)
;              (canvas-dump c))                   ==>  #("##      **"
;                                                        "  ##  **  "
;                                                        "    **    "
;                                                        "  **  ##  "
;                                                        "**      ##")

(module (s9fes char-canvas)

(;export
  ;
  ;char-canvas
  canvas
  ;
  make-canvas new-canvas
  canvas?
  canvas-columns canvas-rows
  canvas-width canvas-height
  ;
  canvas-physical canvas-virtual
  ;
  canvas->list canvas->vector canvas->string
  ;
  canvas-print
  ASCII-FRAME-CHARS THIN-FRAME-CHARS THICK-FRAME-CHARS
  ;
  string->canvas
  with-output-to-canvas
  ;
  current-plotter-char current-plotter-bkgd-char
  ;
  canvas-draw
  canvas-draw-string
  canvas-draw-line
  canvas-draw-lines
  ;
  canvas-copy-chars canvas-paste-chars
  canvas-flood-chars canvas-clear-chars canvas-scroll-chars
  ;
  canvas-plot
  canvas-plot-string
  canvas-plot-line
  canvas-plot-lines
  ;
  canvas-copy canvas-paste
  canvas-flood canvas-clear canvas-scroll
  ;internal
  validate-plotter-configuration
  ;deprecated
  canvas-dump)

(import scheme utf8)
(import (except (chicken base) vector-copy!))
(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 (srfi 1) make-list cons* reverse!))
(import (only utf8-srfi-13 string-pad-right))

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

; Virtual Canvas

(: make-canvas (fixnum fixnum #!optional integer integer -> canvas))
(: new-canvas ((or char-canvas canvas) integer integer -> canvas))

(: canvas? (* -> boolean : canvas))

(: canvas-columns (canvas -> fixnum))
(: canvas-rows (canvas -> fixnum))
(: canvas-width (canvas -> integer))
(: canvas-height (canvas -> integer))

(: canvas-physical (canvas integer integer -> fixnum fixnum))
(: canvas-virtual (canvas fixnum fixnum -> integer integer))

(: canvas->list (canvas -> (list-of string)))
(: canvas->vector (canvas -> (vector-of string)))
(: canvas->string (canvas -> string))

(: current-plotter-char (#!optional char -> char))
(: current-plotter-bkgd-char (#!optional char -> char))

(: canvas-print (canvas #!optional (or true box-frame-chars) -> void))

(: string->canvas (string -> canvas))
(: with-output-to-canvas (procedure -> canvas))

#; ;config char is kinda brush? config is currently oval config, w/ 1st char overload
(: current-plotter-configuration (#!optional plotter-configuration -> plotter-configuration))
(: validate-plotter-configuration ((or false symbol) * fixnum #!optional (or false char) -> plotter-configuration))

; Physical Coords

(: canvas-draw (canvas fixnum fixnum #!optional char -> void))
(: canvas-draw-string (canvas fixnum fixnum string -> void))
(: canvas-draw-line (canvas fixnum fixnum fixnum fixnum #!optional char -> void))
(: canvas-draw-lines (canvas (list-of fixnum) #!optional (or false char plotter-configuration) -> void))

(: canvas-copy-chars (canvas #!optional char-rect -> canvas))
(: canvas-paste-chars (canvas canvas #!optional fixnum fixnum -> 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-plot (canvas integer integer #!optional char -> void))
(: canvas-plot-string (canvas integer integer string -> void))
(: canvas-plot-line (canvas integer integer integer integer #!optional char -> void))
(: canvas-plot-lines (canvas (list-of integer) #!optional (or false char plotter-configuration) -> void))

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

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

#|
;outline in the canvas
(: canvas-frame-chars (canvas #!optional fixnum fixnum fixnum fixnum char char char char char char -> void))
(: canvas-frame (canvas #!optional integer integer integer integer char char char char char char -> void))

;or canvas-frame => new canvas w/ a frame chars
|#

;;

;srfi-133 sort'a

(define (vector->string v #!optional (st 0) (ed (vector-length v)))
  (let ((s (make-string (fx- ed st))))
    (do ((vi st (fx+ vi 1))
         (si 0 (fx+ si 1)) )
        ((fx= ed vi) s)
      (string-set! s si (vector-ref v vi)) ) ) )

(define (string->vector s #!optional (st 0) (ed (string-length s)))
  (let ((v (make-vector (fx- ed st))))
    (do ((vi 0 (fx+ vi 1))
         (si st (fx+ si 1)) )
        ((fx= ed si) v)
      (vector-set! v vi (string-ref s si)) ) ) )

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

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

;moremacros
(define-syntax swap!
  (syntax-rules ()
    ((swap! ?a ?b)
      (let ((_tmp ?a))
        (set! ?a ?b)
        (set! ?b _tmp)) ) ) )

;;

; Physical Canvas

(define-record-type char-canvas
  (*make-char-canvas width height cmap)
  char-canvas?
  (width char-canvas-columns) ;fixnum
  (height char-canvas-rows)   ;fixnum
  (cmap char-canvas-cmap set-char-canvas-cmap!))

(define-inline (char-canvas-index ccv x y) (fx+ x (fx* y (char-canvas-columns ccv))))

;max physical
(define-inline (char-canvas-xmax ccv) (fx- (char-canvas-columns ccv) 1))
(define-inline (char-canvas-ymax ccv) (fx- (char-canvas-rows ccv) 1))

; Virtual Canvas

(define-record-type canvas
  (make-canvas* pcv x-scale y-scale)
  canvas?
  (pcv canvas-chars)
  (x-scale canvas-x-scale)
  (y-scale canvas-y-scale))

(define-inline (make-cmap x-max y-max c)
  (make-vector (fx* x-max y-max) c) )

(define (canvas-columns cv) (char-canvas-columns (canvas-chars cv)))
(define (canvas-rows cv) (char-canvas-rows (canvas-chars cv)))

(define-inline (canvas-cmap cv) (char-canvas-cmap (canvas-chars cv)))
(define-inline (set-canvas-cmap! cv cmap) (set-char-canvas-cmap! (canvas-chars cv) cmap))

;NOTE `floor', not `round': could (right) clip

(define-inline (physical-x cv x) (floor (* x (canvas-x-scale cv))))
(define-inline (physical-y cv y) (floor (* y (canvas-y-scale cv))))

(define-inline (optional-physical-x cv x) (and x (physical-x cv x)))
(define-inline (optional-physical-y cv y) (and y (physical-y cv y)))

(define-inline (*rect-physical cv rgn)
  (*rect (physical-x cv (*rect-x rgn))
         (physical-y cv (*rect-y rgn))
         (physical-x cv (*rect-wd rgn))
         (physical-y cv (*rect-ht rgn))) )

(define-inline (*rect-physical/optional cv rgn)
  (and rgn
       (*rect-physical cv rgn)) )

(define-inline (virtual-x cv x) (floor (/ x (canvas-x-scale cv))))
(define-inline (virtual-y cv y) (floor (/ y (canvas-y-scale cv))))

(define (canvas-physical cv x y) (values (physical-x cv x) (physical-y cv y)))
(define (canvas-virtual cv x y) (values (virtual-x cv x) (virtual-y cv y)))

(define (canvas-width cv) (virtual-x cv (canvas-columns cv)))
(define (canvas-height cv) (virtual-y cv (canvas-rows cv)))

;max virtual
(define-inline (canvas-xmax cv) (- (canvas-width cv) 1))
(define-inline (canvas-ymax cv) (- (canvas-height cv) 1))

(define-inline (canvas-index cv x y)
  (char-canvas-index (canvas-chars cv) (physical-x cv x) (physical-y cv y)) )

(define (virtuals->physicals cv ls)
  (let loop ((ls ls) (os '()))
    ;empty or just 1?
    (if (or (null? ls) (null? (cdr ls)))
        ;then quit & deal w/ it later
        (reverse! os)
        ;else next pair
        (loop (cddr ls) (cons* (physical-y cv (cadr ls)) ;x y ... -> y x ...
                               (physical-x cv (car ls))
                               os)) ) ) )

#; ;cmap coords!
(define-inline (cmap-copy-rows! tcmp tw th ti scmp sw sh si rw rh)
  (let ((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)) )
      (vector-copy! tcmp ti scmp si (fx+ si rw)) ) ) )

;#tcv scv canvas (not char-canvs)
;@ti @si cmap indexes
;@rw @rh chars coords
;
(define (*canvas-copy! tcv ti scv si rw rh)
  (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)
        (vector-copy! tcmp ti scmp si (fx+ si rw)) ) ) )

(: make-char-canvas (fixnum fixnum char -> char-canvas))
;
(define-inline (make-char-canvas x-max y-max c)
  (*make-char-canvas x-max y-max (make-cmap x-max y-max c)) )

(: canvas-fold-lines (canvas (fixnum 'a string -> 'a) 'a -> 'a))
;
;folds the canvas rows in low to high order
(define (canvas-fold-lines cv func seed)
  (let ((wd (canvas-columns cv)) (ht (canvas-rows cv))
        (cmap (canvas-cmap cv)) )
    (let loop ((y (fx- ht 1)) (st 0) (acc seed))
      (if (fx< y 0) acc
          (let ((ed (fx+ st wd)))
            (loop (fx- y 1) ed (func y acc (vector->string cmap st ed))) ) ) ) ) )

;FIXME the window (virtual-shared-canvas + rectangle) should be viewports?

(define (canvas-of obj)
  (cond ((canvas? obj)  obj)
        #;((*wndw? obj)   (*wndw-canvas obj))
        (else           #f)) )

(define (char-canvas-of obj)
  (cond ((char-canvas? obj) obj)
        ((canvas-of obj)    => canvas-chars)
        (else               #f)) )

(define (check-canvas-of loc obj)
  (or (canvas-of obj)
      (error loc "not a canvas | window" obj)) )

(define (check-char-canvas-of loc obj)
  (or (char-canvas-of obj)
      (error loc "not a char-canvas | canvas | window" obj)) )

;;

(define current-plotter-char (make-parameter #\*
  (lambda (x)
    (if (char? x) x
        (error 'current-plotter-char "invalid char" x)))))

(define current-plotter-bkgd-char (make-parameter #\space
  (lambda (x)
    (if (char? x) x
        (error 'current-plotter-bkgd-char "invalid char" x)))))

;;

(define (new-canvas acv v-x-max v-y-max)
  (assert (and (integer? v-x-max) (integer? v-y-max)))
  (assert (and (<= 1 v-x-max) (<= 1 v-y-max)))
  (let ((pcv (check-char-canvas-of 'new-canvas acv)))
    (make-canvas* pcv
                  (/ (char-canvas-columns pcv) v-x-max)
                  (/ (char-canvas-rows pcv) v-y-max)) ) )

(define (make-canvas x-max y-max #!optional (v-x-max x-max) (v-y-max y-max))
  (assert (and (fixnum? x-max) (fixnum? y-max)))
  (assert (and (fx<= 1 x-max) (fx<= 1 y-max)))
  (new-canvas (make-char-canvas x-max y-max (current-plotter-bkgd-char)) v-x-max v-y-max) )

;A `cmap' is in reverse visual order. The visually top row is stored last in
;buffer. As such the sequence does not to be reversed.

(define (canvas->list cv)
  (canvas-fold-lines cv (lambda (y l s) (cons s l)) '()) )

(define (canvas->vector cv)
  (canvas-fold-lines cv (lambda (y v s) (vector-set! v y s) v) (make-vector (canvas-rows cv))) )

(define (canvas->string cv)
  (apply string-append (canvas-fold-lines cv (lambda (y l s) (cons* s "\n" l)) '())) )

(define canvas-dump canvas->vector)

;@lines list-of string, where all s in lines same length
(define (list->char-canvas lines)
  (if (null? lines)
      (*make-char-canvas 0 0 (make-cmap 0 0 #\nul))
      (*make-char-canvas (string-length (car lines)) (length lines)
                         (string->vector (apply string-append lines))) ) )

(define (string->canvas str)
  (let* ((lines (with-input-from-string str read-lines))
         (wd (apply max (map string-length lines)))
         (ht (length lines))
         (c (current-plotter-bkgd-char))
         (lines (map (lambda (ln)
                       (if (< (string-length ln) wd)
                           (string-pad-right ln (- wd (string-length ln)) c)
                           ln))
                     lines)) )
    (new-canvas (list->char-canvas (reverse lines)) wd ht) ) )

(define (with-output-to-canvas thunk) (string->canvas (with-output-to-string thunk)))

;FIXME should frame chars be a string?

;                     #(thc bhc lvc rvc tlc trc blc brc)
(define ASCII-FRAME-CHARS #(#\- #\- #\| #\| #\+ #\+ #\+ #\+))
(define THIN-FRAME-CHARS  #(#\─ #\─ #\│ #\│ #\┌ #\┐ #\└ #\┘))
(define THICK-FRAME-CHARS  #(#\━ #\━ #\┃ #\┃ #\┏ #\┓ #\┗ #\┛))

(define (canvas-print cv #!optional frm)
  (if (not frm)
      ;then dump
      (for-each print (canvas->list cv))
      ;else surround
      (let ((frm (if (boolean? frm) ASCII-FRAME-CHARS frm))
            (lns (canvas->list cv)) )
        (unless (null? lns)
          (let* ((wd (string-length (car lns)))
                 (hd (make-string wd (frame-th frm)))
                 (tl (make-string wd (frame-bh frm))) )
            (print (frame-tl frm) hd (frame-tr frm))
            (for-each (lambda (ln) (print (frame-lv frm) ln (frame-rv frm))) lns)
            (print (frame-bl frm) tl (frame-br frm))) ) ) ) )

;;

(define-inline (config-char? x) (or (not (car x)) (char? (car x))))

(define-inline (plotter-configuration-list loc cfg n d)
  (cond ((char? cfg)
          (make-list n cfg) )
        ((list? cfg)
          (let ((l (length cfg)))
            (cond ((fx= l n) cfg)
                  ((fx< l n) (append cfg (make-list (fx- n l) d)))
                  (else
                    (error loc "invalid configuration, too many elements" cfg n d)) ) ) )
        (else
          (error loc "invalid configuration, unrecognized form" cfg n d))) )

(define (validate-plotter-configuration loc cfg n #!optional (d (current-plotter-char)))
  (let ((cs (plotter-configuration-list loc cfg n d)) )
    (let check ((cr cs))
      (cond ((null? cr)         cs)
            ((config-char? cr)  (check (cdr cr)))
            (else
              (error loc "invalid configuration, invalid element" cs)) ) ) ) )

;;

;Clips!
(define (canvas-draw cv x y #!optional (c (current-plotter-char)))
  (let ((ht (canvas-rows cv)) (wd (canvas-columns cv))
        (cmap (canvas-cmap cv)) )
    (when (and (fx<= 0 y) (fx<= y (fx- ht 1))
               (fx<= 0 x) (fx<= x (fx- wd 1)))
      (vector-set! cmap (fx+ (fx* y wd) x) c)) ) )

;Clips!
(define (canvas-draw-string cv x y s)
  (let ((ht (canvas-rows cv)) (wd (canvas-columns cv))
        (cmap (canvas-cmap cv))
        (len (string-length s)) )
    (when (and (fx<= 0 y) (fx<= y (fx- ht 1))
               (fx<= 0 x) (fx<= x (fx- wd 1)))
      (let ((lno (fx* y wd)))
        (do ((x x (fx+ x 1))
             (i 0 (fx+ 1 i)) )
            ((or (fx>= i len)
                 (fx>= x wd)) )
          (vector-set! cmap (fx+ lno x) (string-ref s i)))) ) ) )

(define (canvas-draw-line cv x0 y0 xn yn #!optional (c (current-plotter-char)))
  (let ((steep (fx> (fxabs (fx- yn y0)) (fxabs (fx- xn x0)))))
    (when steep
      (swap! x0 y0)
      (swap! xn yn))
    (when (fx> x0 xn)
      (swap! x0 xn)
      (swap! y0 yn))
    (let* ((dx (fx- xn x0))
           (dy (fxabs (fx- yn y0)))
           (de (if (fx= 0 dx) 0 (/ dy dx)))
           (ys (if (fx< y0 yn) 1 -1)) )
      (let plot ((x x0) (y y0) (e 0))
        (when (fx<= x xn)
          (if steep
              (canvas-draw cv y x c)
              (canvas-draw cv x y c))
          (let ((e (+ e de))
                (x (fx+ x 1)) )
            (if (<= 1/2 e)
                (plot x (fx+ y ys) (- e 1))
                (plot x y          e) ) ) ) ) ) ) )

(define-inline (**canvas-draw-lines cv x0 y0 ls cfg)
  ;(assert (<= (fx/ (length ls) 2) (length cfg)))
  (let loop ((x0 x0) (y0 y0) (ls ls) (rem cfg))
    (unless (null? ls)
      (let ((xn (car ls)) (yn (cadr ls)))
        ;conditional draw
        (let ((c (car rem))) (when c (canvas-draw-line cv x0 y0 xn yn c)))
        ;next coords
        (loop xn yn (cddr ls) (cdr rem)) ) ) ) )

(define (*canvas-draw-lines cv ls cfg)
  ;(assert (<= (fx/ (length ls) 2) (length cfg)))
  (let ((x0 (car ls)) (y0 (cadr ls)))
    (if (null? (cddr ls))
        ;then single point
        (canvas-draw cv x0 y0 (car cfg))
        ;else at least one line
        (**canvas-draw-lines cv x0 y0 (cddr ls) cfg) ) ) )

(define (canvas-draw-lines cv ls #!optional (cfg (current-plotter-char)))
  (let ((len (length ls)))
    (unless (zero? len)
      (assert (even? len) 'canvas-draw-lines "must be list-of x y ..." ls)
      (let ((cfg (validate-plotter-configuration 'canvas-draw-lines cfg (fx/ len 2))))
        (*canvas-draw-lines cv ls cfg) ) ) ) )

;;

(define (canvas-copy-chars cv #!optional (rgn (*char-canvas->rect (canvas-chars cv))))
  (let* ((rgn-wd (*rect-wd rgn)) (rgn-ht (*rect-ht rgn))
         (cvd (make-canvas rgn-wd rgn-ht))
         (idx (char-canvas-index (canvas-chars cv) (*rect-x rgn) (*rect-y rgn))) )
    (*canvas-copy! cvd 0 cv idx rgn-wd rgn-ht) ) )

(define (canvas-paste-chars cv scv #!optional (x 0) (y 0))
  (*canvas-copy! cv (char-canvas-index (canvas-chars cv) x y) scv 0 (canvas-columns scv) (canvas-rows scv))
  (void) )

(define (canvas-flood-chars cv #!optional (c (current-plotter-char)) rgn)
  (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)))
  ;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-plot cv x y #!optional (c (current-plotter-char)))
  (canvas-draw cv (physical-x cv x) (physical-y cv y) c) )

(define (canvas-plot-string cv x y s)
  (canvas-draw-string cv (physical-x cv x) (physical-y cv y) s) )

(define (canvas-plot-line cv x0 y0 xn yn #!optional (c (current-plotter-char)))
  (canvas-draw-line cv
                    (physical-x cv x0) (physical-y cv y0)
                    (physical-x cv xn) (physical-y cv yn)
                    c) )

(define (canvas-plot-lines cv ls #!optional (cfg (current-plotter-char)))
  (let ((len (length ls)))
    (unless (zero? len)
      (assert (even? len) 'canvas-plot-lines "must be list-of x y ..." ls)
      (let ((cfg (validate-plotter-configuration 'canvas-plot-lines cfg (fx/ len 2))))
        (*canvas-draw-lines cv (virtuals->physicals cv ls) cfg) ) ) ) )

;;

(define (canvas-copy cv #!optional (rgn (*canvas->rect cv)))
  (canvas-copy-chars cv (*rect-physical/optional cv rgn)) )

(define (canvas-paste cv scv #!optional (x 0) (y 0))
  (canvas-paste-chars cv scv (optional-physical-x cv x) (optional-physical-y cv y)) )

(define (canvas-flood cv #!optional (c (current-plotter-char)) rgn)
  (canvas-flood-chars cv c (*rect-physical/optional cv rgn)) )

(define (canvas-clear cv #!optional rgn)
  (canvas-clear-chars cv (*rect-physical/optional cv rgn)) )

(define (canvas-scroll cv dx dy #!optional rgn (c (current-plotter-bkgd-char)))
  (canvas-scroll-chars cv (physical-x cv dx) (physical-y cv dy)
                          (*rect-physical/optional cv rgn)
                          c) )

) ;module (s9fes char-canvas)