--- 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)
--- 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")))))))
--- 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 ()
--- 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
--- 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))
--- /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)))
+