# HG changeset patch
# User Steve Losh <steve@stevelosh.com>
# Date 1498156664 0
# Node ID a2fb5d06bfb67ac07e848c6fdc8e629cfe8659b1
# Parent  6de2b94783d573bdc15bd883c97bbe8da33b5e30
Add box drawing util

diff -r 6de2b94783d5 -r a2fb5d06bfb6 .lispwords
--- a/.lispwords	Thu Apr 13 12:42:10 2017 +0000
+++ b/.lispwords	Thu Jun 22 18:37:44 2017 +0000
@@ -1,2 +1,3 @@
 (1 key-case)
 (1 in-layer in-clear-layer)
+(1 save-value with-value save-values)
diff -r 6de2b94783d5 -r a2fb5d06bfb6 cl-blt.asd
--- a/cl-blt.asd	Thu Apr 13 12:42:10 2017 +0000
+++ b/cl-blt.asd	Thu Jun 22 18:37:44 2017 +0000
@@ -18,4 +18,5 @@
                 ((:module "low-level" :serial t
                   :components ((:file "bearlibterminal")))
                  (:module "high-level" :serial t
-                  :components ((:file "bearlibterminal")))))))
+                  :components ((:file "bearlibterminal")
+                               (:file "boxes")))))))
diff -r 6de2b94783d5 -r a2fb5d06bfb6 examples/box.lisp
--- a/examples/box.lisp	Thu Apr 13 12:42:10 2017 +0000
+++ b/examples/box.lisp	Thu Jun 22 18:37:44 2017 +0000
@@ -1,17 +1,10 @@
 (ql:quickload '(:cl-blt :losh :iterate :split-sequence))
 
 (defpackage :cl-blt.examples.box
-  (:use :cl :losh :iterate))
+  (:use :cl :losh :iterate :bearlibterminal.quickutils))
 
 (in-package :cl-blt.examples.box)
 
-;;;; GUI ----------------------------------------------------------------------
-(defun clear-layer (&optional layer)
-  (when layer
-    (setf (blt:layer) layer))
-  (blt:clear-area 0 0 (blt:width) (blt:height)))
-
-
 (defun draw-background ()
   (setf (blt:layer) 0)
   (iterate (for-nested ((x :from 0 :below (truncate (blt:width) 2))
@@ -22,88 +15,44 @@
                  (random-elt "abcdefghijklmnopqrstuvwxyz"))))
 
 
-(defun draw-outline (x y w h
-                     top bottom left right
-                     top-left top-right
-                     bot-left bot-right)
-  (iterate (for bx :from (1+ x) :below (+ x w -1))
-           (setf (blt:cell-char bx y) top
-                 (blt:cell-char bx (+ y h -1)) bottom))
-  (iterate (for by :from (1+ y) :below (+ y h -1))
-           (setf (blt:cell-char x by) left
-                 (blt:cell-char (+ x w -1) by) right))
-  (setf
-    (blt:cell-char x y) top-left
-    (blt:cell-char (+ x w -1) y) top-right
-    (blt:cell-char x (+ y h -1)) bot-left
-    (blt:cell-char (+ x w -1) (+ y h -1)) bot-right))
-
-(defun draw-fill (x y w h &optional (char #\full_block))
-  (iterate (for-nested ((bx :from x :below (+ x w))
-                        (by :from y :below (+ y h))))
-           (setf (blt:cell-char bx by) char)))
-
-
-(defun draw-box-background (x y w h &optional (color (blt:rgba 0 0 0)))
-  (setf (blt:color) color)
-  (draw-fill (1+ x) (1+ y) (- w 2) (- h 2))
-  (draw-outline x y w h
-                #\lower_half_block
-                #\upper_half_block
-                #\right_half_block
-                #\left_half_block
-                #\quadrant_lower_right
-                #\quadrant_lower_left
-                #\quadrant_upper_right
-                #\quadrant_upper_left))
-
-(defun draw-box-border (x y w h &optional (color (blt:rgba 255 255 255)))
-  (setf (blt:color) color)
-  (draw-outline x y w h
-                #\box_drawings_double_horizontal
-                #\box_drawings_double_horizontal
-                #\box_drawings_double_vertical
-                #\box_drawings_double_vertical
-                #\box_drawings_double_down_and_right
-                #\box_drawings_double_down_and_left
-                #\box_drawings_double_up_and_right
-                #\box_drawings_double_up_and_left))
-
-(defun draw-box-contents (x y w h contents
-                          &optional (color (blt:rgba 1.0 1.0 1.0)))
-  (setf (blt:color) color)
-  (blt:print (1+ x) (1+ y)
-             (format nil "[font=normal]~A[/font]" contents)
-             :width (- w 2) :height (- h 2)))
-
-(defun draw-box (x y w h contents layer)
-  (clear-layer layer)
-  (clear-layer (1+ layer))
-
-  (setf (blt:layer) layer
-        (blt:composition) t)
-  (draw-box-background x y w h)
-  (draw-box-border x y w h)
-
-  (setf (blt:layer) (1+ layer)
-        (blt:composition) nil)
-  (blt:clear-area x y w h)
-  (draw-box-contents x y w h contents))
-
-
-(defun make-word-wrap-format-string (width)
-  ;; http://cybertiggyr.com/fmt/fmt.pdf
-  ;; unfortunately we can't use ~V in here so we'll just use concat instead
-  (concatenate 'string
-               "~{~<~%~1,"
-               ;; Format checks for strictly less than width, but it's more
-               ;; natural to give the width as an inclusive range...
-               (princ-to-string (1+ width))
-               ":;~A~>~^ ~}"))
 
 (defun word-wrap-line (line width)
-  (format nil (make-word-wrap-format-string width)
-          (split-sequence:split-sequence #\space line)))
+  (with-output-to-string (*standard-output*)
+    (let ((pos 0)
+          (spaces 0)
+          (words (split-sequence:split-sequence #\space line)))
+      (flet ((add (s)
+               (incf pos (length s))
+               (princ s))
+             (linebreak ()
+               (setf pos 0 spaces 0)
+               (terpri)))
+        (iterate
+          (until (null words))
+          (for word = (pop words))
+          (for len = (length word))
+          (cond
+            ;; chomp leading whitespace
+            ((and (zerop pos) (zerop len))
+             nil)
+            ;; if we have multiple spaces in a row, preserve them (maybe)
+            ((zerop len)
+             (incf spaces))
+            ;; if we're dealing with a single word that's too long, reluctantly
+            ;; split it into pieces
+            ((and (zerop pos) (> len width))
+             (add (subseq word 0 width))
+             (linebreak)
+             (push (subseq word width) words))
+            ;; if this would send us beyond the limit, break
+            ((> (+ spaces len pos) width)
+             (linebreak)
+             (push word words))
+            ;; otherwise concat
+            (t
+             (add (make-string spaces :initial-element #\space))
+             (add word)
+             (setf spaces 1))))))))
 
 (defun word-wrap (string width)
   (format nil "~{~A~^~%~}"
@@ -112,6 +61,7 @@
             (collect (word-wrap-line line width)))))
 
 
+
 (defun read-string (x y maximum-length &key (font ""))
   (let ((result (make-array maximum-length
                   :element-type 'character
@@ -121,7 +71,7 @@
                (blt:print x y (format nil "[font=~A]~V,,,'_A[/font]"
                                       font maximum-length result))))
       (iterate
-        (clear-layer)
+        (blt::clear-layer)
         (draw-string)
         (blt:refresh)
         (blt:key-case (blt:read)
@@ -134,33 +84,42 @@
                (when (and char (< (length result) maximum-length))
                  (vector-push char result)))))
         (blt:refresh)
-        (finally-protected (clear-layer)
+        (finally-protected (blt::clear-layer)
                            (blt:refresh))))))
 
 (defun get-user-input (x y layer prompt maximum-length)
-  (draw-box x y (+ 3 (max (length prompt)
-                          maximum-length))
-            6
-            prompt
-            layer)
+  (blt:draw-box layer x y (+ 3 (max (length prompt)
+                                    maximum-length))
+                6
+                prompt
+                :border-color (blt:rgba 1.0 1.0 1.0)
+                :background-color (blt:rgba 0.4 0.0 0.0))
   (setf (blt:layer) (+ layer 2))
   (prog1 (read-string (+ x 1)
                       (+ y 3)
                       maximum-length
                       :font "normal")
-    (clear-layer layer)
-    (clear-layer (1+ layer))))
+    (blt::clear-layer layer)
+    (blt::clear-layer (1+ layer))))
 
 (defun get-name ()
-  (clear-layer 15)
-  (pr (get-user-input 0 10 10 "What is your name?" 15)))
+  (blt::clear-layer 15)
+  (pr (get-user-input 0 10 10 "[font=normal]What is your name?[/font]" 15)))
 
 
 (defun draw ()
-  (draw-box 3 3 20 10 (format nil "[color=red]hello~%world! how [font=italic]close[font=normal] can [font=bold]we[font=normal] get here, what if we go over oh no![/color]") 5)
+  (setf (blt:color) (blt:rgba 1.0 1.0 0.0))
+
+  (blt:draw-box 5 3 3 20 10
+                (format nil "[font=normal][color=red]hello~%world! how [font=italic]close[font=normal] can [font=bold]we[font=normal] get here, what if we go over oh no![/color]"))
 
-  (draw-box 30 3 40 30 (word-wrap "This is an test.  It has multiple words.  And some spaces too.  It should be wrapped correctly." 10) 7)
-
+  (blt:draw-box 7 30 3 42 30
+                (word-wrap (format nil "123456789x123456789x123456789x more?~% ~%~
+                                    This is an test.  It has multiple words.  ~
+                                    And some spaces too.  It should be wrapped correctly.~%~
+                                    foo foo foo foo  foos     and a bar")
+                           20)
+                :border (random-elt '(:light :heavy :double)))
   (blt:refresh))
 
 (defun config ()
diff -r 6de2b94783d5 -r a2fb5d06bfb6 package.lisp
--- a/package.lisp	Thu Apr 13 12:42:10 2017 +0000
+++ b/package.lisp	Thu Jun 22 18:37:44 2017 +0000
@@ -44,6 +44,8 @@
     :width
     :with-terminal
 
+    :draw-box
+
     )
   (:shadow
 
diff -r 6de2b94783d5 -r a2fb5d06bfb6 src/high-level/bearlibterminal.lisp
--- a/src/high-level/bearlibterminal.lisp	Thu Apr 13 12:42:10 2017 +0000
+++ b/src/high-level/bearlibterminal.lisp	Thu Jun 22 18:37:44 2017 +0000
@@ -30,6 +30,28 @@
      ',name))
 
 
+(defmacro save-value (thing &body body)
+  (with-gensyms (old)
+    `(let ((,old (,thing)))
+       (prog1
+           (progn ,@body)
+         (setf (,thing) ,old)))))
+
+(defmacro save-values (things &body body)
+  (if (null things)
+    `(progn ,@body)
+    `(save-value ,(first things)
+       (save-values ,(rest things) ,@body))))
+
+(defmacro with-value ((thing value) &body body)
+  (with-gensyms (old)
+    `(let ((,old (,thing)))
+       (setf (,thing) ,value)
+       (prog1
+           (progn ,@body)
+         (setf (,thing) ,old)))))
+
+
 ;;;; Colors -------------------------------------------------------------------
 (deftype color ()
   '(unsigned-byte 32))
@@ -243,8 +265,8 @@
 
 (defun-inline onoff-to-boolean (onoff)
   (ecase onoff
-    (blt/ll:+tk-on+ t)
-    (blt/ll:+tk-off+ nil)))
+    (#.blt/ll:+tk-on+ t)
+    (#.blt/ll:+tk-off+ nil)))
 
 (defun-inline int-to-boolean (int)
   (not (zerop int)))
@@ -280,6 +302,12 @@
     ((:middle :center) blt/ll:+tk-align-middle+)))
 
 
+(defun signed-to-unsigned (integer)
+  ;; bearlibterminal's terminal_state returns a signed integer, but some of the
+  ;; state values (e.g. colors) need to be unsigned integers.
+  (+ integer (expt 2 32)))
+
+
 ;;;; Error Checking -----------------------------------------------------------
 (define-condition bearlibterminal-error (error) ())
 
@@ -304,19 +332,6 @@
   (check (blt/ll:terminal-set-8 configuration-string)))
 
 
-(defun refresh ()
-  (blt/ll:terminal-refresh))
-
-(defun clear ()
-  (blt/ll:terminal-clear))
-
-(defun clear-area (x y width height)
-  (blt/ll:terminal-clear-area x y width height))
-
-(defun crop (x y width height)
-  (blt/ll:terminal-crop x y width height))
-
-
 (defun layer ()
   (blt/ll:terminal-state blt/ll:+tk-layer+))
 
@@ -325,18 +340,45 @@
   new-value)
 
 
+(defun refresh ()
+  (blt/ll:terminal-refresh))
+
+
+(defun clear ()
+  (blt/ll:terminal-clear))
+
+(defun clear-area (x y width height)
+  (blt/ll:terminal-clear-area x y width height))
+
+(defun clear-current-layer ()
+  (clear-area 0 0 (blt:width) (blt:height)))
+
+(defun clear-layer (&optional layer)
+  "Clear `layer`, or the current layer if not given."
+  (if layer
+    (with-value (blt:layer layer)
+      (clear-current-layer))
+    (clear-current-layer)))
+
+
+(defun crop (x y width height)
+  (blt/ll:terminal-crop x y width height))
+
+
 (defun color ()
-  (blt/ll:terminal-state blt/ll:+tk-color+))
+  (signed-to-unsigned (blt/ll:terminal-state blt/ll:+tk-color+)))
 
 (defun (setf color) (color)
-  (blt/ll:terminal-color color))
+  (blt/ll:terminal-color color)
+  color)
 
 
 (defun background-color ()
-  (blt/ll:terminal-state blt/ll:+tk-bkcolor+))
+  (signed-to-unsigned (blt/ll:terminal-state blt/ll:+tk-bkcolor+)))
 
 (defun (setf background-color) (color)
-  (blt/ll:terminal-bkcolor color))
+  (blt/ll:terminal-bkcolor color)
+  color)
 
 
 (defun composition ()
@@ -394,10 +436,12 @@
 
 
 (defun (setf cell-code) (code-point x y)
-  (blt/ll:terminal-put x y code-point))
+  (blt/ll:terminal-put x y code-point)
+  code-point)
 
 (defun (setf cell-char) (character x y)
-  (blt/ll:terminal-put x y (character-to-code-point character)))
+  (blt/ll:terminal-put x y (character-to-code-point character))
+  character)
 
 
 (defun cell-color (x y &optional (index 0))
diff -r 6de2b94783d5 -r a2fb5d06bfb6 src/high-level/boxes.lisp
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/high-level/boxes.lisp	Thu Jun 22 18:37:44 2017 +0000
@@ -0,0 +1,127 @@
+(in-package :bearlibterminal/high-level)
+
+(defun draw-box-outline (x y w h
+                         top bottom left right
+                         top-left top-right
+                         bot-left bot-right)
+  (loop :for bx :from (1+ x) :below (+ x w -1)
+        :do (setf (blt:cell-char bx y) top
+                  (blt:cell-char bx (+ y h -1)) bottom))
+  (loop :for by :from (1+ y) :below (+ y h -1)
+        :do (setf (blt:cell-char x by) left
+                  (blt:cell-char (+ x w -1) by) right))
+  (setf
+    (blt:cell-char x y) top-left
+    (blt:cell-char (+ x w -1) y) top-right
+    (blt:cell-char x (+ y h -1)) bot-left
+    (blt:cell-char (+ x w -1) (+ y h -1)) bot-right)
+  (values))
+
+(defun draw-box-fill (x y w h)
+  (loop :for bx :from x :below (+ x w)
+        :do (loop :for by :from y :below (+ y h)
+                  :do (setf (blt:cell-char bx by) #\full_block))))
+
+
+(defun draw-box-background (x y w h color)
+  (setf (blt:color) color)
+  (draw-box-fill (1+ x) (1+ y) (- w 2) (- h 2))
+  (draw-box-outline x y w h
+                    #\lower_half_block
+                    #\upper_half_block
+                    #\right_half_block
+                    #\left_half_block
+                    #\quadrant_lower_right
+                    #\quadrant_lower_left
+                    #\quadrant_upper_right
+                    #\quadrant_upper_left))
+
+
+(defun draw-box-border-light (x y w h color)
+  (setf (blt:color) color)
+  (draw-box-outline x y w h
+                    #\box_drawings_light_horizontal
+                    #\box_drawings_light_horizontal
+                    #\box_drawings_light_vertical
+                    #\box_drawings_light_vertical
+                    #\box_drawings_light_down_and_right
+                    #\box_drawings_light_down_and_left
+                    #\box_drawings_light_up_and_right
+                    #\box_drawings_light_up_and_left))
+
+(defun draw-box-border-heavy (x y w h color)
+  (setf (blt:color) color)
+  (draw-box-outline x y w h
+                    #\box_drawings_heavy_horizontal
+                    #\box_drawings_heavy_horizontal
+                    #\box_drawings_heavy_vertical
+                    #\box_drawings_heavy_vertical
+                    #\box_drawings_heavy_down_and_right
+                    #\box_drawings_heavy_down_and_left
+                    #\box_drawings_heavy_up_and_right
+                    #\box_drawings_heavy_up_and_left))
+
+(defun draw-box-border-double (x y w h color)
+  (setf (blt:color) color)
+  (draw-box-outline x y w h
+                    #\box_drawings_double_horizontal
+                    #\box_drawings_double_horizontal
+                    #\box_drawings_double_vertical
+                    #\box_drawings_double_vertical
+                    #\box_drawings_double_down_and_right
+                    #\box_drawings_double_down_and_left
+                    #\box_drawings_double_up_and_right
+                    #\box_drawings_double_up_and_left))
+
+
+(defun draw-box-contents (x y w h contents)
+  (blt:print (1+ x) (1+ y) contents
+             :width (- w 2)
+             :height (- h 2)))
+
+
+(defun draw-box (layer x y width height contents &key
+                 (border :light)
+                 (background-color (blt:rgba 0 0 0))
+                 (border-color (blt:rgba 255 255 255)))
+  "Draw a box.
+
+  Two layers will be used to draw the box: `layer` and `(1+ layer)`, and they
+  will be cleared before drawing it.
+
+  The border of the box will be one cell wide/tall.  `border` specifies the type
+  of border to draw, and can be one of `:light`, `:heavy`, or `:double`, or
+  `nil` for a transparent border.
+
+  `background-color` and `border-color` specify the colors to use.  If `nil` is
+  given they will not be drawn.
+
+  The `width` and `height` measurements include the two border cells.  For
+  example: a `width` of `10` would have `8` cells of content space.
+
+  `contents` will be `print`ed inside the box with the appropriate bounds.
+
+  **EXPERIMENTAL**: This function is experimental and may change or be remove
+  entirely in the future.
+
+  "
+  (save-values (blt:composition blt:layer)
+    (clear-layer layer)
+    (clear-layer (1+ layer))
+
+    (setf (blt:layer) layer
+          (blt:composition) t)
+
+    (save-value blt:color
+      (when background-color
+        (draw-box-background x y width height background-color))
+      (when (and border border-color)
+        (ecase border
+          (:light (draw-box-border-light x y width height border-color))
+          (:heavy (draw-box-border-heavy x y width height border-color))
+          (:double (draw-box-border-double x y width height border-color)))))
+
+    (setf (blt:layer) (1+ layer)
+          (blt:composition) nil)
+    (draw-box-contents x y width height contents)))
+