;;;; s9fes-char-graphics-test.scm  -*- Scheme -*-
;;;; Kon Lovett, Jul '18

(import test)
(import (test-utils gloss) (only (chicken format) format))
(import (test-utils test))

(import (only (chicken port) with-output-to-string))
(import (only (chicken file) delete-file))
(import (chicken fixnum))
(import (s9fes char-canvas rect) (s9fes char-canvas) (s9fes char-canvas block))
(import (s9fes char-canvas shape shape)
        (s9fes char-canvas shape box)
        (s9fes char-canvas shape circle)
        (s9fes char-canvas shape image)
        (s9fes char-canvas shape cross))

;;;

(define CD-TEST-RESULT-1 (apply string-append '(
  "##      **\n"
  "  ##  **  \n"
  "    **    \n"
  "  **  ##  \n"
  "**      ##\n")))

(define CD-TEST-RESULT-4 (apply string-append '(
  "    221   \n"
  "   2   1  \n"
  "  3 221 0 \n"
  " 3 3   0 0\n"
  " 4 4   7 7\n"
  " 4 4   7 7\n"
  "  4 566 7 \n"
  "   5   6  \n"
  "    566   \n"
  "          \n")))

(define CD-TEST-RESULT-5 (apply string-append '(
  "    *     \n"
  "    *     \n"
  "####*#####\n"
  "    *     \n"
  "    *     \n")))

(define CD-TEST-RESULT-6 (apply string-append '(
  "    22    \n"
  "   2      \n"
  "    22  0 \n"
  "       0 0\n"
  " 4 4   0 0\n"
  " 4 4      \n"
  "  4  66   \n"
  "       6  \n"
  "     66   \n"
  "          \n")))

#; ;UNUSED but ref'ed
(define CD-TEST-RESULT-7 (apply string-append '(
  "        22\n"
  "      22  \n"
  "    12    \n"
  " 011      \n"
  "0         \n")))

(define CD-TEST-RESULT-8 (apply string-append '(
  "  ******  \n"
  " *      * \n"
  "*        *\n"
  "*        *\n"
  "*        *\n"
  "*        *\n"
  "*        *\n"
  "*        *\n"
  " *      * \n"
  "  ******  \n")))

(define CD-TEST-RESULT-10 (apply string-append '(
  "        22\n"
  "   ####2  \n"
  "   ####   \n"
  " 01####   \n"
  "0         \n")))

(define CD-TEST-RESULT-19 (apply string-append '(
  "          \n"
  "  +--+    \n"
  "  |  |    \n"
  "  +--+    \n"
  "          \n")))

(define CD-TEST-RESULT-20 (apply string-append '(
  "    *   22\n"
  "   ####2  \n"
  "##########\n"
  " 01####   \n"
  "0   *     \n")))

(define CD-TEST-RESULT-21 (apply string-append '(
  "          \n"
  "          \n"
  "          \n"
  " 00       \n"
  "0         \n")))

(define CD-TEST-RESULT-22 (apply string-append '(
  "          \n"
  "          \n"
  "     @    \n"
  "          \n"
  "          \n")))

;;;

(test-begin "S9fES Char Graphics Shapes")

(define (sort-symbols ls)
  (import (chicken sort))
  (sort ls (lambda (a b) (string<? (symbol->string a) (symbol->string b)))) )

(define REGED-SHAPES (sort-symbols
        '(box circle image cross-- cross-vbar cross-+ cross-obar cross-abar cross-x)))

;until layout coded
(define FAKE-BB (rect 0 0 0 0))

(test-group "shapes"
  (test REGED-SHAPES (sort-symbols (registered-shapes)))
)

(test-group "shapes - cross draw"

  (define draw-x
    (let ((pltr (real-shape-cross-x 10 5 '(#\# #\*))))
      (lambda (#!optional cv)
        (if (not cv) (pltr)
            (begin
              (pltr cv)
              (canvas->string cv))) ) ) )

  (define draw-+
    (let ((pltr (real-shape-cross-+ 10 5 '(#\# #\*))))
      (lambda (#!optional cv)
        (if (not cv) (pltr)
            (begin
              (pltr cv)
              (canvas->string cv))) ) ) )

  (let ((cv (make-canvas 10 5)))
    (test "draw X args" (^real-info cross-x 10 5 '(#\# #\*)) (draw-x))
    (test "draw X example" CD-TEST-RESULT-1 (draw-x cv))
    (canvas-clear cv)

    (test "draw + args" (^real-info cross-+ 10 5 '(#\# #\*)) (draw-+))
    (test "draw + example" CD-TEST-RESULT-5 (draw-+ cv))
    (canvas-clear cv) )
)

(test-group "shapes - cross plot"

  (define plot-x
    (let ((pltr (shape-cross-x 10 10 '(#\# #\*))))
      (test "shape-size" '(10 10) (receive (shape-size pltr)))
      (test "shape-layout" pltr (shape-layout pltr FAKE-BB))
      (lambda (#!optional cv)
        (if (not cv) (pltr)
            (begin
              (pltr cv)
              (canvas->string cv))) ) ) )

  (define plot-+
    (let ((pltr (shape-cross-+ 10 10 '(#\# #\*))))
      (test "shape-size" '(10 10) (receive (shape-size pltr)))
      (test "shape-layout" pltr (shape-layout pltr FAKE-BB))
      (lambda (#!optional cv)
        (if (not cv) (pltr)
            (begin
              (pltr cv)
              (canvas->string cv))) ) ) )

  (let ((cv (make-canvas 10 5 10 10)))
    (test "plot + args" (^virtual-info cross-x 10 10 '(#\# #\*)) (plot-x))
    (test "plot X example" CD-TEST-RESULT-1 (plot-x cv))
    (canvas-clear cv)

    (test "plot + args" (^virtual-info cross-+ 10 10 '(#\# #\*)) (plot-+))
    (test "plot + example" CD-TEST-RESULT-5 (plot-+ cv))
    (canvas-clear cv) )
)

(test-group "shapes - box"
  (define cv (make-canvas 10 5 200 500))

  (test-group "real"
    ((real-shape-box 4 3) cv 2 1)
    (test "box draw" CD-TEST-RESULT-19 (canvas->string cv))

    (let ((pltr (real-shape-box 4 3)))
      (test "box args" (^real-info box 4 3 ASCII-FRAME-CHARS SINGLE-FRAME-DIMS) (pltr))
      (canvas-clear cv)
      ;default position is 1/2 size: 2 1
      (test "center" CD-TEST-RESULT-19 (canvas->string (pltr cv)))

      (test "shape-size" '(4 3) (receive (shape-size pltr)))
      (test "shape-layout" pltr (shape-layout pltr FAKE-BB)) )
  )

  (test-group "virt"
    (canvas-clear cv)
    ((shape-box 80 300) cv 40 150)
    (test "box plot" CD-TEST-RESULT-19 (canvas->string cv))

    (let ((pltr (shape-box 80 300)))
      (test "box args" (^virtual-info box 80 300 ASCII-FRAME-CHARS SINGLE-FRAME-DIMS) (pltr))
      (canvas-clear cv)
      ;default position is 1/2 size: 40 150
      (test "center" CD-TEST-RESULT-19 (canvas->string (pltr cv)))

      (test "shape-size" '(80 300) (receive (shape-size pltr)))
      (test "shape-layout" pltr (shape-layout pltr FAKE-BB)) )
  )
)

(test-group "shapes - circle"

  (define numd-octant-cfg '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7))
  (define even-octant-cfg '(#\0 #f  #\2 #f  #\4 #f  #\6 #f))

  (define octant-plotter      (circle-octant-plotter numd-octant-cfg))
  (define even-octant-plotter (circle-octant-plotter even-octant-cfg))

  (test-group "circle () - default vc"
    (let ((cv (make-canvas 10 10))
          (vc (circle-octant-visitor 5 5 octant-plotter)) )
      (generate-circle-octant cv 2 vc)
      (generate-circle-octant cv 4 vc)
      (test "circles" CD-TEST-RESULT-4 (canvas->string cv)) )
  )

  (test-group "circle (_)"
    (let ((cv (make-canvas 10 10 200 500))
          (vc (virtual-circle-octant-visitor 100 250 octant-plotter)) )
      (generate-virtual-circle-octant cv 100 vc)
      (generate-virtual-circle-octant cv 200 vc)
      (test "circles" CD-TEST-RESULT-4 (canvas->string cv)) )
  )

  (test-group "circle octants () - default vc"
    (let ((cv (make-canvas 10 10))
          (vc (circle-octant-visitor 5 5 even-octant-plotter)) )
      (generate-circle-octant cv 2 vc)
      (generate-circle-octant cv 4 vc)
      (test "circles" CD-TEST-RESULT-6 (canvas->string cv)) )
  )

  (test-group "circle octants () draw - default vc"
    (let ((cv (make-canvas 10 10)))
      ((real-shape-circle 2 even-octant-cfg) cv 5 5)
      ((real-shape-circle 4 even-octant-cfg) cv 5 5)
      (test "circles" CD-TEST-RESULT-6 (canvas->string cv)) )
  )

  (test-group "circle (_) plot"
    (let ((cv (make-canvas 10 10 200 500)))
      ((shape-circle 100 numd-octant-cfg) cv 100 250)
      ((shape-circle 200 numd-octant-cfg) cv 100 250)
      (test "circles" CD-TEST-RESULT-4 (canvas->string cv)) )
  )

  (test-group "circle (_) real-shape - default vc"
    (let ((cv (make-canvas 10 10))
          (s1 (real-shape-circle 2 even-octant-cfg))
          (s2 (real-shape-circle 4 even-octant-cfg)) )
      (test "circles args" `(,(^real-info circle 2 even-octant-cfg)
                             ,(^real-info circle 4 even-octant-cfg))
                           (list (s1) (s2)))
      (s1 cv 5 5)
      (s2 cv 5 5)
      (test "circles" CD-TEST-RESULT-6 (canvas->string cv))

      (test "shape-size" '(2 2) (receive (shape-size s1)))
      (test "shape-size" '(4 4) (receive (shape-size s2)))
      (test "shape-layout" s1 (shape-layout s1 FAKE-BB))
      (test "shape-layout" s2 (shape-layout s2 FAKE-BB)) )
  )

  (test-group "circle (_) virtual-shape"
    (let ((cv (make-canvas 10 10 200 500))
          (s1 (shape-circle 100 numd-octant-cfg))
          (s2 (shape-circle 200 numd-octant-cfg)) )
      (test "circles args" `(,(^virtual-info circle 100 numd-octant-cfg)
                             ,(^virtual-info circle 200 numd-octant-cfg))
                           (list (s1) (s2)))
      (s1 cv 100 250)
      (s2 cv 100 250)
      (test "circles" CD-TEST-RESULT-4 (canvas->string cv))

      (test "shape-size" '(100 100) (receive (shape-size s1)))
      (test "shape-size" '(200 200) (receive (shape-size s2)))
      (test "shape-layout" s1 (shape-layout s1 FAKE-BB))
      (test "shape-layout" s2 (shape-layout s2 FAKE-BB)) )
  )

  (test-group "polygon"
    (let ((cv (make-canvas 10 10 100 100)))
      (canvas-plot-lines cv (circle-polygon-lines 50 50 50 50))
      (test "circle poly 1" CD-TEST-RESULT-8 (canvas->string cv)) )
  )
)

(test-group "shapes - image"
  (define TST-FILNAM "test-1.icn9fes")

  (define overwrite (lambda (t s i j) s))

  (let ((cv (make-canvas 10 5 10 10))
        (ic1 (string->image CD-TEST-RESULT-10)) )

    (test-assert "is image" (image? ic1))

    (test "canvas->image" ic1 (canvas->image (string->canvas CD-TEST-RESULT-10)))

    (store-image ic1 TST-FILNAM)
    (test "matches saved" ic1 (load-image TST-FILNAM))
    (delete-file TST-FILNAM)

    ;empty canvas w/ #\space bkgd for each test
    ;like CD-TEST-RESULT-10

    ;unneeded (canvas-clear cv)
    ((real-shape-image ic1) cv)
    (test "over real-shape-image" CD-TEST-RESULT-10 (canvas->string cv))

    (canvas-clear cv)
    ((shape-image ic1) cv)
    (test "over shape-image" CD-TEST-RESULT-10 (canvas->string cv))

    (let* ((tcv (string->canvas CD-TEST-RESULT-5))
           (pltr (real-shape-image ic1)) )
      (test "alpha real-shape-image" CD-TEST-RESULT-20 (canvas->string (pltr tcv)))
      (test "shape-size" '(10 5) (receive (shape-size pltr))) )

    (let* ((tcv (string->canvas CD-TEST-RESULT-5))
           (pltr (shape-image ic1)) )
      (test "alpha shape-image" CD-TEST-RESULT-20 (canvas->string (pltr tcv)))
      (test "shape-size" '(10 5) (receive (shape-size pltr))) )
  )
)

;;

;#|
(import (s9fes char-canvas shape fpad)
        (s9fes char-canvas shape jpad)
        (s9fes char-canvas shape hgroup)
        (s9fes char-canvas shape vgroup))

(define VISIBLE-PAD-CHARS (pad-characters #\- #\_ #\* #\%))

(define CD-TEST-RESULT-23 (apply string-append '(
	"               \n"
	" ------------- \n"
	" ------------- \n"
	" ------------- \n"
	" *        22 %%\n"
	" *   ####2   %%\n"
	" *   ####    %%\n"
	" * 01####    %%\n"
	" *0          %%\n"
	" _____________ \n"
	" _____________ \n"
	"               \n"
	"               \n"
	"               \n"
	"               \n")))

(test-group "shapes - fpad"
  (define shpimg10x5 (real-shape-image (string->image CD-TEST-RESULT-10)))
  (define fpad (shape-fpad shpimg10x5 (pad-dimensions 3 2 1 2) VISIBLE-PAD-CHARS))

  (test '(13 10) (receive (shape-size fpad)))
  (test '(6 7 5 5) (receive (shape-center fpad)))
  (test 1 (shape-cardinality fpad))
  (test `(,shpimg10x5) (shape-elements fpad))
  (test-assert (shape-justified? fpad))

  (let* ((cv (make-canvas 15 15))
         (pltr (shape-layout fpad (canvas-rect cv))) )
    (test-assert "already justified" (eq? pltr fpad))
    (test CD-TEST-RESULT-23 (canvas->string (fpad cv 7 8)))
  )
)

#; ;FIXME this is overflow on right
(define CD-TEST-RESULT-25 (apply string-append '(
	"---------------\n"
	"---------------\n"
	"---------------\n"
	"---------------\n"
	"*         22 %%\n"
	"*    ####2   %%\n"
	"*    ####    %%\n"
	"*  01####    %%\n"
	"* 0          %%\n"
	"_______________\n"
	"_______________\n"
	"_______________\n"
	"_______________\n"
	"_______________\n")))

;overflow on left?
(define CD-TEST-RESULT-25 (apply string-append '(
	"---------------\n"
	"---------------\n"
	"---------------\n"
	"---------------\n"
	"**        22  %\n"
	"**   ####2    %\n"
	"**   ####     %\n"
	"** 01####     %\n"
	"**0           %\n"
	"_______________\n"
	"_______________\n"
	"_______________\n"
	"_______________\n"
	"_______________\n"
  "               \n")))

(test-group "shapes - jpad"
  (define shpimg10x5 (real-shape-image (string->image CD-TEST-RESULT-10)))
  (define jpad (shape-jpad shpimg10x5 (pad-dimensions 3 2 1 2) 'center 'center VISIBLE-PAD-CHARS))

  (test '(13 10) (receive (shape-size jpad)))
  (test '(6 7 5 5) (receive (shape-center jpad)))
  (test 1 (shape-cardinality jpad))
  (test `(,shpimg10x5) (shape-elements jpad))
  (test-assert "unjustified" (not (shape-justified? jpad)))

  (let* ((cv (make-canvas 15 15))
         (pltr (shape-layout jpad (canvas-rect cv))) )

    (test-assert "jpad != pltr" (not (eq? pltr jpad)))
    (test-assert "justified" (shape-justified? pltr))

    ;????
    (test '(7 8 7 8) (receive (shape-center pltr)))

    (test CD-TEST-RESULT-25 (canvas->string (pltr cv 7 8)))
  )
)

(test-group "shapes - hgroup"
)

(test-group "shapes - vgroup"
)

(define CD-TEST-RESULT-24 (apply string-append '(
	"   ~                          \n"
	"   ~                          \n"
	"   ~                          \n"
	"                              \n"
	"                       ~~~~~~~\n"
	"   ~                   ~~~~~~~\n"
	"   ~                   ~~~~~~~\n"
	"   ~                   ~~~~~~~\n"
	"                       ~~~~~~~\n"
	"                       ~~~~~~~\n"
	"   ~                   ~~~~~~~\n"
	"   ~                   ~~~~~~~\n"
	"   ~                   ~~~~~~~\n"
	"                       ~~~~~~~\n"
	"                       ~~~~~~~\n"
	"                       ~~~~~~~\n"
	"                       ~~~~~~~\n"
	"                       ~~~~~~~\n"
	"       ***             ~~~~~~~\n"
	"      *   *                   \n"
	"     *     *           ~~~~~~~\n"
	"     *     *           ~~~~~~~\n"
	"     *     *           ~~~~~~~\n"
	"      *   *                   \n"
	"       ***                    \n"
	"                              \n"
	"                              \n"
	"                              \n"
	"**                            \n"
	"**                            \n")))


(test-group "shapes - layout"
  (define 1-dims (pad-dimensions 1 1 1 1))
  (define ~-chars (pad-characters #\~ #\~ #\~ #\~))

  ;[hgroup jpad[circle] jpad[vgroup[jpad[cross] fpad[cross] jpad[cross]]] jpad[image]]
  ;FIXME need chars to distinguish each shape
  (define hgrouped
          (shape-hgroup
            (shape-jpad (shape-circle 3) 1-dims 'center 'center ~-chars)
            (shape-jpad
              (shape-vgroup
                (shape-jpad (shape-cross-abar 3) 1-dims 'center 'center ~-chars)
                (shape-fpad (shape-cross-+ 3) 1-dims ~-chars)
                (shape-jpad (shape-cross-obar 3) 1-dims 'center 'center ~-chars))
              1-dims 'center 'center ~-chars)
            (shape-jpad (shape-circle 3) 1-dims 'center 'center ~-chars)))

  (test-assert "unjustified" (not (shape-justified? hgrouped)))

  (let* ((cv (make-canvas 30 30))
         (pltr (shape-layout hgrouped (canvas-rect cv))) )
    (test-assert "justified" (not (eq? pltr hgrouped)))
    (test CD-TEST-RESULT-24 (canvas->string (pltr cv 8 8)))
  )
)

;|#

;;;

(test-end "S9fES Char Graphics Shapes")

(test-exit)