; 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
  ;
  make-canvas
  canvas?
  canvas-columns canvas-rows
  canvas-width canvas-height
  canvas-physical canvas-virtual
  ;
  canvas-dump
  canvas-print
  canvas->string
  ;
  canvas-clear
  canvas-scroll
  ;
  canvas-draw
  canvas-draw-string
  ;
  current-plotter-char
  validate-plotter-configuration
  ;
  canvas-plot
  canvas-plot-string
  canvas-plot-line
  canvas-plot-lines)

(import scheme utf8)
(import (chicken base))
(import (chicken fixnum))
(import (chicken port))
(import (chicken type))

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

(: make-canvas (fixnum fixnum #!optional 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-clear (canvas #!optional fixnum fixnum fixnum fixnum -> void))
(: canvas-scroll (canvas fixnum fixnum #!optional fixnum fixnum fixnum fixnum -> void))

(: canvas-dump (canvas -> (list-of string)))
(: canvas-print (canvas -> void))
(: canvas->string (canvas -> string))

(: canvas-draw (canvas fixnum fixnum char -> void))
(: canvas-draw-string (canvas fixnum fixnum string -> void))

(: validate-plotter-configuration (symbol * fixnum #!optional (or false char) --> plotter-configuration))

(: canvas-plot (canvas integer integer char -> void))
(: canvas-plot-string (canvas integer integer string -> void))
(: canvas-plot-line (canvas integer integer integer integer char -> void))
(: canvas-plot-lines (canvas (list-of integer) char -> void))

;;

;srfi-1
(define (make-list n #!optional (f #f)) (vector->list (make-vector n f)))

;srfi-133
(define (vector->string v) (list->string (vector->list v)))

;fx-utils
(define (fxnegative? n) (fx> 0 n))
(define (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)) ) ) )

;;

(define-record-type canvas
  (make-canvas* width height x-scale y-scale cmap)
  canvas?
  (width canvas-columns) ;fixnum
  (height canvas-rows) ;fixnum
  (x-scale canvas-x-scale) ;rational
  (y-scale canvas-y-scale) ;rational
  (cmap canvas-cmap set-canvas-cmap!))

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

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

(define (make-cmap x-max y-max)
  (let ((v (make-vector y-max)))
    (do ((i 0 (fx+ i 1)))
        ((fx= i y-max))
      (vector-set! v i (make-vector x-max #\space)))
    v ) )

;;

(define (make-canvas x-max y-max #!optional (v-x-max x-max) (v-y-max y-max))
  (make-canvas* x-max y-max
                (/ x-max v-x-max) (/ y-max v-y-max)
                (make-cmap x-max y-max)) )

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

;do not expose the cv
(define (canvas-dump cv)
  (map vector->string (vector->list (canvas-cmap cv))) )

;do not expose the cv
(define (canvas-print cv)
  (let ((y-max (canvas-rows cv))
        (cmap (canvas-cmap cv)) )
    (do ((i 0 (fx+ i 1)))
        ((fx= i y-max))
      (print (vector->string (vector-ref cmap i))) ) ) )

(define (canvas->string cv)
  (with-output-to-string (lambda () (canvas-print cv))) )

(define (canvas-clear cv #!optional xul yul xlr ylr)
  (if (and xul yul xlr ylr)
      ;then canvas window
      (let* ((wd (fx- xlr xul))
             (s (make-string wd #\space)) )
        ;(assert (and (fx<= xlr xul) (fx<= ylr yul)))
        (do ((y ylr (fx+ y 1)))
            ((fx> y yul))
          (canvas-draw-string cv xul y s) ) )
      ;else entire canvas
      (set-canvas-cmap! cv
                        (make-cmap (canvas-columns cv) (canvas-rows cv))) ) )

(define (canvas-scroll cv dx dy #!optional (xul 0) (yul (fx- (canvas-rows cv) 1))
                                           (xlr (fx- (canvas-columns cv) 1)) (ylr 0))
  (assert (and (fixnum? dx) (fixnum? dy)
               (fixnum? xul) (fixnum? yul)
               (fixnum? xlr) (fixnum? ylr)))
  (let ((wd (fx+ (fx- xlr xul) 1)) (ht (fx+ (fx- yul ylr) 1)))
    (if (and (fx= (fxabs dx) wd) (fx= (fxabs dy) ht))
        ;then clearing the window
        (canvas-clear cv xul yul xlr ylr)
        ;else contents
        (begin
          (assert (and (fx< (fxabs dx) wd) (fx< (fxabs dy) ht)))
          (void)
    ) ) ) )

;;

(define (canvas-draw cv x y c)
  (let* ((cmap (canvas-cmap cv))
         (k (canvas-rows cv)))
    (when (and (fx<= 0 y) (fx<= y (fx- k 1))
               (fx<= 0 x) (fx<= x (fx- (canvas-columns cv)
                                       1)))
      (vector-set! (vector-ref cmap (fx- (fx- k y) 1)) x c))) )

(define (canvas-draw-string cv x y s)
  (let* ((ks (string-length s))
         (line (vector-ref (canvas-cmap cv)
                           (fx- (fx- (canvas-rows cv)
                                     y)
                                1)))
         (kw (canvas-columns cv)) )
    (do ((x x (fx+ 1 x))
         (i 0 (fx+ 1 i)))
        ((or (fx>= i ks)
             (fx>= x kw)))
      (vector-set! line x (string-ref s i)))) )

;;

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

(define (validate-plotter-configuration loc cfg n #!optional (d (current-plotter-char)))
  (let ((cs
          (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)))) )
    (let check ((cr cs))
      (cond ((null? cr) cs )
            ((or (not (car cr)) (char? (car cr))) (check (cdr cr)) )
            (else
              (error loc "invalid configuration, invalid element" cs) ) ) ) ) )

;;

(define (canvas-plot cv x y c)
  (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 c)
  (let ((steep (> (abs (- yn y0))
                  (abs (- xn x0))))
        (x0 (physical-x cv x0))
        (y0 (physical-y cv y0))
        (xn (physical-x cv xn))
        (yn (physical-y cv yn)) )
    (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))))
      (let ((de (/ 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)))
              (when (<= 1/2 e)
                (set! y (fx+ y ys))
                (set! e (- e 1)))
              (plot (fx+ x 1) y e) ) ) ) ) ) ) )

(define (canvas-plot-lines cv ls c)
  (unless (null? ls)
    (assert (even? (length ls)) 'canvas-plot-lines "must be list-of x y ..." ls)
    (let ((x0 (car ls)) (y0 (cadr ls)))
      (if (fx= 2 (length ls))
          ;then single point
          (canvas-plot cv x0 y0 c)
          ;else at least one line
          (let loop ((x0 x0) (y0 y0) (ls (cddr ls)))
            (let ((xn (car ls)) (yn (cadr ls)) (ls (cddr ls)))
              (canvas-plot-line cv x0 y0 xn yn c)
              (unless (null? ls)
                (loop xn yn ls) ) ) ) ) ) ) )

) ;module (s9fes char-canvas)