;;; blocks.lisp -- 3D character output with Unicode/MS-DOS box-drawing characters
;;; Copyright (c) 2016 Devon Sean McCullough
;;; Licensed under the GNU GPL

#| Inspired by SNOBOL's "block" 3D strings.  Nothing but box drawing implemented yet.

Class   	block-output-stream
Method  	char-at stream x y => char
Method  	clear-page stream
Method  	line-to stream x y
Method  	line-weight stream { 0 | 1 | 2}
Method  	move-to stream x y
Method  	show-page stream &key output fresh-line full
Macro   	with-output-to-block (stream &key width height) declaration* form*
Accessor	x-position stream => position
Accessor	y-position stream => position

Box-drawing joins lines as corners, tees and crosses when possible
but only at the start character of a line, done by looking at the
character under the cursor and by remembering consecutive line-to
operations.  Perhaps there should be a way to avoid this other than
move-to the current position or drawing in the opposite direction.

Line ends are conceptually at character centers but for lack of
half-wide and half-high line segment characters, individual lines
cannot be drawn this way so instead the start character gets a full
segment and the final character gets none, just like ordinary text.

Therefore it does not work to start a line on a future corner
unless the direction is pre-set, which can always be done
with a zero weight line to avoid spurious drawing.

CL-USER> (with-output-to-block (b)
	   ;; Leave the first corner initally blank to join all four corners.
	   ;; Draw the last two lines out from the center to join the center cross.
	   (princ "Box: " b)
	   (line-weight b 2)
	   (move-to b 6 0) (line-to b 15 0) (line-to b 15 8) (line-to b 5 8) (line-to b 5 0) (line-to b 6 0)
	   (line-weight b 1)
	   (move-to b 10 1) (line-to b 10 8)
	   (move-to b 10 4) (line-to b 15 4)
	   (move-to b 10 4) (line-to b 5 4)
	   (move-to b 13 4) (princ 1 b)
	   (move-to b 10 6) (princ 2 b)
	   (move-to b 7 4) (princ 4 b)
	   (move-to b 10 2) (princ 8 b))
Box: ╔═════════╗
     ║    │    ║
     ║    8    ║
     ║    │    ║
     ║─4──┼──1─║
     ║    │    ║
     ║    2    ║
     ║    │    ║
     ╚═════════╝
NIL
|#

(defpackage :blocks
  (:export
   ;; box drawing
   :block-output-stream
   :char-at
   :clear-page
   :line-to
   :line-weight
   :move-to
   :show-page
   ;; SNOBOL4B
   :*fill*
   :block
   :blocksize
   :box
   :def
   :depth
   :dup
   :eject
   :fix
   :front
   :height
   :hor
   :hor-reg
   :it
   :loc
   :lrecl
   #+| fix package errors | :merge
   :node
   :norm-reg
   :ovy
   #+| fix package errors | :print
   :rep
   :ser
   :slab
   :ver
   :ver-reg
   :width))

(in-package :blocks)

(defconstant +box-drawing-joins+
  ;;    ↑   ↑   ↑   ↑   ↑   ↑   ↑   ↑   ₈   ₈   ₈   ₈   ₈   ₈   ₈   ₈
  ;;   ←0→ ←1₁ ←2→ ←3₁ ₄4→ ₄5₁ ₄6→ ₄7₁ ←8→ ←9₁ ←A→ ←B₁ ₄C→ ₄D₁ ₄E→ ₄F₁
  ;;    ↓   ↓   ₂   ₂   ↓   ↓   ₂   ₂   ↓   ↓   ₂   ₂   ↓   ↓   ₂   ₂
  #2A((nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)
      (nil nil nil #\┌ nil #\─ #\┐ #\┬ nil #\└ #\│ #\├ #\┘ #\┴ #\┤ #\┼)
      (nil nil nil #\╔ nil #\═ #\╗ #\╦ nil #\╚ #\║ #\╠ #\╝ #\╩ #\╣ #\╬))
  "Unicode/MS-DOS box drawing characters indexed by a bit mask of →↓←↑ line segments 1248.")

(defconstant +box-drawing-vectors+
  (make-array 3 :initial-contents (list (make-array 16 :displaced-to +box-drawing-joins+)
					(make-array 16 :displaced-to +box-drawing-joins+ :displaced-index-offset 16)
					(make-array 16 :displaced-to +box-drawing-joins+ :displaced-index-offset 32)))
  "Like `+box-drawing-joins+' as searchable vectors.")

(defconstant +box-drawing-lines+
  #2A((nil #\─ nil nil nil)
      (nil #\─ #\│ #\─ #\│)
      (nil #\═ #\║ #\═ #\║))
  "Unicode/MS-DOS box drawing lines indexed by ?→↓←↑ direction 0…4.")

(defconstant +box-drawing-new-mask+
  ;;                                ? → ↓ ← ↑
  (make-array 5 :initial-contents '(0 1 2 4 8)
	      :element-type '(integer 0 15))
  "Unicode/MS-DOS box drawing outbound stubs indexed by new ?→↓←↑ direction 0…4.")

(defconstant +box-drawing-old-mask+
  ;;                                ? → ↓ ← ↑
  (make-array 5 :initial-contents '(0 4 8 1 2))
  "Unicode/MS-DOS box drawing inbound stubs indexed by old ?→↓←↑ direction 0…4.
Logior these notional old single-segment masks with the new masks
to derive real new multi-segment box drawing characters.")

(defmacro with-output-to-block ((stream &key (width 80) (height 24) (show t)) &body body)
  "With STREAM bound to a block output stream, run BODY and show the block."
  (let ((output (gensym)))
    `(let ((,stream (make-instance 'block-output-stream :width ,width :height ,height))
	   (,output ,show))
       ,@body
       (when ,output
	 (show-page ,stream :output ,output)))))

(defclass block-output-stream (fundamental-character-output-stream)
  ;; TO DO: Thread-safety, dynamic width & height, line-wrap, page-wrap, tab-width, ...
  ;; Consider (:default-initargs :width 80 :height 24 ...)
  ;; path-direction 0? 1→ 2↓ 3← 4↑
  ((width :initarg :width :initform 80 :type '(integer 0))
   (height :initarg :height :initform 24 :type '(integer 0))
   (x :accessor x-position :initform 0 :type 'integer)
   (y :accessor y-position :initform 0 :type 'integer)
   (buffer :type '(simple-array character (* *)))
   (line-weight :initform 1 :type '(integer 0 2))
   (path-direction :initform 0 :type '(integer 0 4))
   (path-x :type '(integer 0))
   (path-y :type '(integer 0))))

(defmethod initialize-instance :after ((stream block-output-stream) &rest initargs)
  ;; Consider &key width height
  (declare (ignore initargs))
  (with-slots (buffer width height) stream
    (setf buffer (make-array (list height width)
			     :initial-element #\Space
			     :element-type 'character))))

(defmethod stream-write-char ((stream block-output-stream) char)
  "Write block STREAM character CHAR and advance cursor."
  (with-slots (buffer width height x y) stream
    (case char
      (#\Tab
       (setq x (logand -8 (+ 8 x))))
      (#\NewLine
       (setq x 0
	     y (1+ y)))
      (t
       (when (and (<= 0 x) (< x width)
		  (<= 0 y) (< y height))
	 (setf (aref buffer y x) char))
       (setq x (1+ x))))
    char))

(defmethod clear-page ((stream block-output-stream))
  "Clear the block STREAM to its initial blank state.
Unshown output is lost."
  (with-slots (buffer width height x y path-direction) stream
    (setf x 0
	  y 0
	  path-direction 0)
    (dotimes (j height)
      (dotimes (i width)
	(setf (aref buffer j i) #\Space)))))

(defmethod show-page ((stream block-output-stream) &key (output *standard-output*) (fresh-line t) full)
  "Output the block STREAM buffer to *standard-output*
or to the optional keyword argument OUTPUT stream
which when nil returns a string like `format' does.
Optional FRESH-LINE nil inhibits initial fresh-line.
Optional FULL inhibits right and bottom margin trim."
  ;; TO DO: full-width, full-height, full
  ;; Maybe flush :output nil in favor of a separate method or no method.
  ;; Maybe clear the page by default?
  (if (null output)
      (with-output-to-string (out)
	(show-page stream
			  :output out
			  :fresh-line fresh-line
			  :full full))
      (with-slots (buffer width height) stream
	(when fresh-line
	  (fresh-line output))
	(if full
	    (dotimes (y height)
	      (dotimes (x width)
		(princ (aref buffer y x) output))
	      (terpri output))
	    (let ((last-y 0))
	      (dotimes (y height)
		(let ((last-x 0))
		  (dotimes (x width)
		    (let ((char (aref buffer y x)))
		      (unless (char= #\Space char)
			(dotimes (i (- x last-x))
			  (princ #\Space output))
			(princ char output)
			(setq last-x (1+ x)))))
		  (unless (zerop last-x)
		    (dotimes (i (- y last-y))
		      (terpri output))
		    (terpri output)
		    (setq last-y (1+ y))))))))))

(defmethod char-at ((stream block-output-stream) x y)
  "Return the character at X, Y or space if out of bounds."
  (with-slots (buffer width height) stream
    (if (and (< x width)
	     (< y height))
	(aref buffer y x)
	#\Space)))

(defmethod move-to ((stream block-output-stream) x y)
  "Move the block STREAM cursor to X, Y page coordinates.
Upper left is 0, 0 per tradition."
  (with-slots ((old-x x) (old-y y) path-direction) stream
    (setf old-x x
	  old-y y
	  path-direction 0)))

(defmethod line-weight ((stream block-output-stream) weight)
  "Set line WEIGHT to 0, 1 or 2."
  (with-slots (line-weight) stream
    (setf line-weight weight)))

(defmethod line-to ((stream block-output-stream) x y)
  "Draw a line from the cursor to X, Y using line-drawing characters.
The cursor moves to X, Y which is unchanged, as in character output.
Considers prior direction to merge line drawing characters."
  ;; TO DO: Double lines.
  (declare (type (integer 0) x y))
  (with-slots (buffer (old-x x) (old-y y) width height line-weight path-direction path-x path-y) stream
    (unless (and (not (zerop path-direction))
		 (= path-x old-x)
		 (= path-y old-y))
      (setf path-direction 0))
    (let* ((Δx (- x old-x))
	   (Δy (- y old-y))
	   (sx (signum Δx))
	   (sy (signum Δy))
	   (direction (or (aref #(() 4  ()
				  3  0  1
				  () 2  ())
				(+ (1+ sx)
				   (* 3 (1+ sy))))
			  (error "Diagonal lines not implemented.")))
	   (distance (abs (+ Δx Δy)))
	   (line (aref +box-drawing-lines+ line-weight direction))
	   (old-char (if (and (< old-x width)
			      (< old-y height))
			 (aref buffer old-y old-x)
			 #\Space))
	   (old-mask (or (position old-char (aref +box-drawing-vectors+ line-weight))
			 (if (not (zerop path-direction))
			     (aref +box-drawing-old-mask+ path-direction)
			     0)))
	   (new-mask (aref +box-drawing-new-mask+ direction))
	   (mask (logior old-mask new-mask))
	   (join (aref +box-drawing-joins+ line-weight mask)))
      (if line
	  (progn 
	    (when join
	      (setf (aref buffer old-y old-x) join)
	      (incf old-x sx)
	      (incf old-y sy)
	      (decf distance))
	    (dotimes (s distance)
	      (setf (aref buffer old-y old-x) line)
	      (incf old-x sx)
	      (incf old-y sy)))
	  (setf old-x x
		old-y y))
      (unless (and (= x old-x)
		   (= y old-y))
	(error "internal bug Δ ~D,~D s ~D,~D	~D,~D ≠ ~D,~D"
	       Δx Δy sx sy old-x old-y x y))
      (setf path-x x
	    path-y y
	    path-direction direction))))

;;; Blocks a new datatype for SNOBOL4, James F. Gimpel, Communications of the ACM, Volume 15 Issue 6, June 1972, Pages 438-447 
;;;   http://www.snobol4.org/csnobol4/curr/doc/snobol4blocks.1.html
;;;	Behold awesome blocks' elegance!
;;; TO DO:
;;; Emacs syntax coloring should not mistake lambda lists for invocations.

;;; Incompatible changes from SNOBOL4B:
;;; * Names are lispy: dashes and enclosing asterisks.
;;;	Affects HOR-REG, NORM-REG, VER-REG and *FILL*.
;;; * Constants are keywords.
;;;	Affects BLOCKSIZE, DUP, LOC and SLAB direction arguments.
;;;	Affects HOR-REG, 
;;; * Deferred blocks are symbols.
;;;	Affects DEF.
;;; * Orientation codes are in X, Y, Z order: 0 = Horizontal, 1 = Vertical, 2 = Normal.
;;;	Affects BLOCKSIZE, DUP, LOC and SLAB direction arguments.
;;; * Arguments are in X, Y, Z order: (box width height depth)
;;;	Affects BOX, FRONT, 
;;; * Normal plane registration :BACK preferred, :REAR deprecated.
;;;	Affects NORM-REG, 

;;; Representations soon to flush in favor of block/array/string.
;;; (SIMPLE-ARRAY CHARACTER (* * *)) a D x H x W physical block
;;; cons: car = direction 0...2, cdr = list of concatenated blocks
;;; cons: car = registration = :left or :right, cdr = block
;;; symbol = deferred block variable name

(defstruct block
	   "A Snobol4b style block."
	   flags
	   data)

(defvar *fill* #\Space
  "The fill character (defaults to space).")

(defun d (&rest args)
  (apply #'format *debug-io* args)
  (finish-output *debug-io*))

(defun ensure-block (block &optional make-fresh)
  "Coerce number/string/vector/array/block BLOCK to block.
Optional MAKE-FRESH to ensure a fresh copy not sharing toplevel structure."
  ;; TO DO:  Might we need copy-on-write?
  (typecase block
    (block (d "block") (if make-fresh
	       (copy-block block)
	       block))
    ((array character (* * *)) (d "3d-char") (make-block :data block))
    (number (d "#") (let ((string (princ-to-string block)))
	      (make-block :data (make-array `(1 1 ,(length string))
					    :element-type 'character
					    :initial-contents `((,string))))))
    (vector (d "1d") (make-block :data (make-array `(1 1 ,(length block))
					  :element-type 'character
					  :initial-contents `((,block)))))
    ((array t (* *)) (d "2d") (make-block :data (make-array `(1 .,(array-dimensions block))
						   :element-type 'character
						   :initial-contents `(,block))))
    ((array t (* * *)) (d "3d") (make-block :data (make-array (array-dimensions block)
						     :element-type 'character
						     :initial-contents block)))
    (t (d "t") (error "Cannot coerce to block from ~S"
	      block))))

(defun bchar (block)
  "Returns character representation of block B as an array of strings, dimensioned d x h, where d is the depth of the block and h is the height of the block."
  (let* ((blk (fix (ensure-block block)))
	 (data (block-data blk)))
    (if (arrayp data)
	(let* ((w (array-dimension data 2))
	       (h (array-dimension data 1))
	       (d (array-dimension data 0))
	       (a (make-array h :element-type 'string)))
	  (assert (= 1 d))
	  (dotimes (i h a)
	    (setf (aref a i) (make-array w
					 :element-type 'character
					 :displaced-to data
					 :displaced-index-offset (* i w)))))
	(error "Not yet implemented."))))

(defun box (width height depth)
  "Returns a block of fill characters of width W, height H and depth D."
  (make-array (list depth height width) 
	      :element-type 'character
	      :initial-element *fill*))

(defun blocksize (block direction)
  "Return integer size of block B in direction DIR."
  (array-dimension (ensure-block block) (- 2 direction)))

(defun def (block)
  "Returns a BLOCK whose organization is deferred."
  (pushnew ':deferred (block-flags (ensure-block block))))

(defun depth (b)
  "Returns integer depth of block B."
  (array-dimension b 2))

(defun dup (b dir n)
  "Duplicate block B N times in direction DIR."
  (list* dir (coerce (make-array n :initial-element b) 'list)))

(defun eject (&optional (stream *standard-output*))
  "Eject a page, i.e., print a form feed character optional STREAM which defaults as usual."
  (write-char #\Page stream))

(defun fix (b)
  "Returns a block whose organization is physical -- all positioning is done at this time, and no information on how the block was formed is retained."
  (typecase b
    (array b)
    (t (error "not yet implemented"))))

(defun front (w h)
  "A special case of `box'.  Returns a block of fill characters of width W and height H and of depth zero."
  (box w h 0))

(defun height (b)
  "Returns integer height of block B."
  (array-dimension b 1))

(defun hor (n)
  "A special case of `box'.  Returns a block of fill characters whose width is N and height and depth are zero."
  (box 0 0 n))

(defun hor-reg (b)
  "Accessor which returns or sets the horizontal registration of block B.  Values: :left, :right or :centered."
  (or (and (consp b)
	   (find-if (lambda (k)
		      (member k '(:left :right)))
		    b))
      :centered))
 
(defun (setf hor-reg) (b new-value)
  "Accessor which sets the horizontal registration of block B to NEW-VALUE: :left, :right or :centered."
  (unless (eq (hor-reg b) new-value)
    (error "not yet implemented")))

(defun it (b)
  "Returns a block whose organization is iterated orthogonally to parent."
  (cons ':it b))

(defun loc (node block direction)
  "Returns the location of NODE in BLOCK in DIRECTION."
  (error "not yet implemented."))

(defun lrecl (unit)
  "Undocumented!!  Accessor for I/O unit record length???"
  (error "Not implemented, unclear whether it should be."))

#+| fix package errors |
(defun merge (block &rest blocks)
  "Returns a BLOCK whose organization is merged."
  (declare (ignore block blocks))
  (error "Not yet implemented."))

(defun node (block)
  "Returns a BLOCK which is marked as a mergeable node."
  (error "Not yet implemented."))

(defun norm-reg (b)
  "Accessor which returns or sets the normal plane registration of BLOCK b.  Values: 'FRONT', 'REAR', '' (centered)."
  (error "Not yet implemented."))

(defun (setf norm-reg) (b new-value)
  "Accessor which sets the normizontal registration of block B to NEW-VALUE: :left, :right or :centered."
  (unless (eq (norm-reg b) new-value)
    (error "not yet implemented")))

(defun ovy (b1 b2)
  "Overlay -- concatenation in the normal plane."
  (error "Not yet implemented."))

#+| fix package errors |
(defun print (block &optional stream)
  "Prints BLOCK to optional STREAM which defaults as usual."
  (error "Not yet implemented."))

(defun rep (block)
  "Returns a BLOCK whose organization is replicated."
  (error "Not yet implemented."))

(defun ser (b1 b2)
  "“Serial?” -- concatenation in the vertical plane."
  (error "Not yet implemented."))

(defun slab (b dir offset length)
  "Returns a physical block which is a cross-sectional cut of b, in direction dir"
  (error "Not yet implemented."))

(defun ver (n)
  "A special case of box.  Returns a block of fill characters whose height is N."
  (box 0 n 0))

(defun ver-reg (b)
       (error "Not yet implemented."))
  "Accessor which returns or sets the vertical registration of block B.  Values: :top, :bottom or :centered."

(defun width (b)
  "Returns integer width of block B."
  (error "Not yet implemented."))

;;; blocks.lisp end