code.consxy.com Git - clnl/blob - src/main/clnl-gltk/textbox.lisp

   1 (in-package #:clnl-gltk)
   2
   3 ; add word wrpaping, add border optional, so can use for text boxes for the TEXTBOX widget
   4
   5 (defstruct textbox x y width height text word-wrap border)
   6
   7 (setf (documentation 'textbox-text 'function)
   8  "TEXTBOX-TEXT TB => TEXT
   9
  10 ARGUMENTS AND VALUES:
  11
  12   TB: a textbox
  13   TEXT: string currently being displayed
  14
  15 DESCRIPTION:
  16
  17   TEXTBOX-TEXT allows for the retrieving and setting of the internal text
  18   of textbox TB.")
  19
  20 (defun textbox (x y width height &key text (border t) word-wrap)
  21  "TEXTBOX X Y WIDTH HEIGHT &key TEXT BORDER WORD-WRAP => TB
  22
  23 ARGUMENTS AND VALUES:
  24
  25   X: x offset, in pixels
  26   Y: y offset, in pixels
  27   WIDTH: width, in characters
  28   HEIGHT: height, in characters
  29   TEXT: optional string for the textual display
  30   BORDER: boolean, whether we draw a border, defaults to t
  31   WORD-WRAP: boolean, whether we attempt to wrap the text
  32   TB: a textbox that can later be rendered
  33
  34 DESCRIPTION:
  35
  36   TEXTBOX creates a textbox widget.
  37
  38   The widget is defined in terms of characters, rather than pixels.  In this
  39   way, it will never clip a portion of a character off.  It will also display
  40   whatever it can of its text, clipping off characters that are outside.
  41
  42   Multiline strings are supported, and each one appears on a new line.
  43
  44   When BORDER is NIL, no border is drawn and the text box floats, which can be
  45   useful for labels.
  46
  47   When WORD-WRAP is non NIL, the text is attempted to wrap by the following rules.
  48   The wrapping is done at the line if possible, at a breaking character if possible,
  49   or just fits as many letters as it can befoer wrapping.  It then only clips off
  50   on the bottom.  The only breaking character currently is #\Space."
  51  (make-textbox :x x :y y :width width :height height :text text :border border :word-wrap word-wrap))
  52
  53 (defmethod resize ((tb textbox) width height)
  54  (setf (textbox-width tb) width)
  55  (setf (textbox-height tb) height))
  56
  57 (defmethod reposition ((tb textbox) x y)
  58  (setf (textbox-x tb) x)
  59  (setf (textbox-y tb) y))
  60
  61 (defun break-lines (text width)
  62  (cond
  63   ((zerop (length text)) nil)
  64   ((char= #\Space (aref text 0)) (break-lines (subseq text 1) width))
  65   ((char= #\Newline (aref text 0)) (break-lines (subseq text 1) width))
  66   ((let*
  67     ((pos-space
  68       (and
  69        (> (length text) width)
  70        (position #\Space (subseq text 0 width) :from-end t)))
  71      (pos-nl (position #\Newline text))
  72      (pos
  73       (cond
  74        ((and pos-nl (< pos-nl width)) pos-nl)
  75        ((and pos-space (< pos-space width)) pos-space)
  76        ((min width (length text))))))
  77     (cons
  78      (subseq text 0 pos)
  79      (break-lines (subseq text pos) width))))))
  80
  81 (defmethod render ((tb textbox))
  82  (gl:color 1f0 1f0 1f0)
  83  (with-slots (x y width height text border word-wrap) tb
  84   (gl:with-pushed-matrix
  85    (let
  86     ((px-width (+ (* width *font-width*) 6))
  87      (px-height (+ (* height *font-height*) 6)))
  88     (gl:translate x y 0)
  89     (when border (draw-border 0 0 px-width px-height))
  90     (gl:translate 2 (- px-height 4 *font-height*) 0)
  91     (when text
  92      (let
  93       ((lines (if word-wrap (break-lines text width) (cl-ppcre:split "\\n" text))))
  94       (loop
  95        :for line :in lines
  96        :for i :from 0
  97        :do
  98        (when (< i height)
  99         (gl:with-pushed-matrix
 100          (font-print (subseq line 0 (min (length line) width))))
 101         (gl:translate 0 (- *font-height*) 0)))))))))