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

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