Move from github, collapse gltk and strictmath, add candle

[clnl] / src / main / clnl-gltk / textbox.lisp

diff --git a/src/main/clnl-gltk/textbox.lisp b/src/main/clnl-gltk/textbox.lisp
new file mode 100644 (file)
index 0000000..a2940ae
--- /dev/null
+++ b/src/main/clnl-gltk/textbox.lisp
@@ -0,0 +1,101 @@
+(in-package #:clnl-gltk)
+
+; add word wrpaping, add border optional, so can use for text boxes for the TEXTBOX widget
+
+(defstruct textbox x y width height text word-wrap border)
+
+(setf (documentation 'textbox-text 'function)
+ "TEXTBOX-TEXT TB => TEXT
+
+ARGUMENTS AND VALUES:
+
+  TB: a textbox
+  TEXT: string currently being displayed
+
+DESCRIPTION:
+
+  TEXTBOX-TEXT allows for the retrieving and setting of the internal text
+  of textbox TB.")
+
+(defun textbox (x y width height &key text (border t) word-wrap)
+ "TEXTBOX X Y WIDTH HEIGHT &key TEXT BORDER WORD-WRAP => TB
+
+ARGUMENTS AND VALUES:
+
+  X: x offset, in pixels
+  Y: y offset, in pixels
+  WIDTH: width, in characters
+  HEIGHT: height, in characters
+  TEXT: optional string for the textual display
+  BORDER: boolean, whether we draw a border, defaults to t
+  WORD-WRAP: boolean, whether we attempt to wrap the text
+  TB: a textbox that can later be rendered
+
+DESCRIPTION:
+
+  TEXTBOX creates a textbox widget.
+
+  The widget is defined in terms of characters, rather than pixels.  In this
+  way, it will never clip a portion of a character off.  It will also display
+  whatever it can of its text, clipping off characters that are outside.
+
+  Multiline strings are supported, and each one appears on a new line.
+
+  When BORDER is NIL, no border is drawn and the text box floats, which can be
+  useful for labels.
+
+  When WORD-WRAP is non NIL, the text is attempted to wrap by the following rules.
+  The wrapping is done at the line if possible, at a breaking character if possible,
+  or just fits as many letters as it can befoer wrapping.  It then only clips off
+  on the bottom.  The only breaking character currently is #\Space."
+ (make-textbox :x x :y y :width width :height height :text text :border border :word-wrap word-wrap))
+
+(defmethod resize ((tb textbox) width height)
+ (setf (textbox-width tb) width)
+ (setf (textbox-height tb) height))
+
+(defmethod reposition ((tb textbox) x y)
+ (setf (textbox-x tb) x)
+ (setf (textbox-y tb) y))
+
+(defun break-lines (text width)
+ (cond
+  ((zerop (length text)) nil)
+  ((char= #\Space (aref text 0)) (break-lines (subseq text 1) width))
+  ((char= #\Newline (aref text 0)) (break-lines (subseq text 1) width))
+  ((let*
+    ((pos-space
+      (and
+       (> (length text) width)
+       (position #\Space (subseq text 0 width) :from-end t)))
+     (pos-nl (position #\Newline text))
+     (pos
+      (cond
+       ((and pos-nl (< pos-nl width)) pos-nl)
+       ((and pos-space (< pos-space width)) pos-space)
+       ((min width (length text))))))
+    (cons
+     (subseq text 0 pos)
+     (break-lines (subseq text pos) width))))))
+
+(defmethod render ((tb textbox))
+ (gl:color 1f0 1f0 1f0)
+ (with-slots (x y width height text border word-wrap) tb
+  (gl:with-pushed-matrix
+   (let
+    ((px-width (+ (* width *font-width*) 6))
+     (px-height (+ (* height *font-height*) 6)))
+    (gl:translate x y 0)
+    (when border (draw-border 0 0 px-width px-height))
+    (gl:translate 2 (- px-height 4 *font-height*) 0)
+    (when text
+     (let
+      ((lines (if word-wrap (break-lines text width) (cl-ppcre:split "\\n" text))))
+      (loop
+       :for line :in lines
+       :for i :from 0
+       :do
+       (when (< i height)
+        (gl:with-pushed-matrix
+         (font-print (subseq line 0 (min (length line) width))))
+        (gl:translate 0 (- *font-height*) 0)))))))))