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

   1 (in-package #:clnl-gltk)
   2
   3 (defstruct inputbox x y width first-drawn-char cursor text)
   4
   5 (defun inputbox (x y width)
   6  "INPUTBOX X Y WIDTH => IB
   7
   8 ARGUMENTS AND VALUES:
   9
  10   X: x offset, in pixels
  11   Y: y offset, in pixels
  12   WIDTH: width, in characters
  13   IB: an inputbox that can later be rendered
  14
  15 DESCRIPTION:
  16
  17   INPUTBOX creates an inputbox widget.
  18
  19   The inputbox is a simple, single lined, box that can hold a mutating string.
  20   Use the various INPUTBOX-* functions to add to it and modify it.  As a string
  21   is added to it that is too large, it will scroll the characters automatically.
  22
  23   The widget is defined in terms of characters, rather than pixels.  In this
  24   way, it will never clip a portion of a character off."
  25  (make-inputbox :x x :y y :width width :text "" :first-drawn-char 0 :cursor 0))
  26
  27 (defmethod resize ((ib inputbox) width height)
  28  (declare (ignore y))
  29  (setf (inputbox-width ib) width))
  30
  31 (defmethod render ((ib inputbox))
  32  (gl:color 1f0 1f0 1f0)
  33  (with-slots (x y width first-drawn-char cursor text) ib
  34   (gl:with-pushed-matrix
  35    (let
  36     ((px-width (+ (* width *font-width*) 6))
  37      (px-height (+ (* 1 *font-height*) 6)))
  38     (gl:translate x y 0)
  39     (gl:line-width 1f0)
  40     (gl:begin :lines)
  41     (gl:vertex 0 0)
  42     (gl:vertex px-width 0)
  43     (gl:vertex px-width 0)
  44     (gl:vertex px-width px-height)
  45     (gl:vertex px-width px-height)
  46     (gl:vertex 0 px-height)
  47     (gl:vertex 0 px-height)
  48     (gl:vertex 0 0)
  49     (gl:end)
  50     (gl:translate 2 (- px-height 4 *font-height*) 0)
  51
  52     (font-print (subseq text first-drawn-char cursor))
  53
  54     (gl:color 1f0 1f0 1f0 1f0)
  55     (gl:begin :quads)
  56     (gl:vertex 0 0)
  57     (gl:vertex *font-width* 0)
  58     (gl:vertex *font-width* (1+ *font-height*))
  59     (gl:vertex 0 (1+ *font-height*))
  60     (gl:end)
  61     (when (< cursor (length text))
  62      (gl:color 0.0f0 0.0f0 0.0f0 1f0)
  63      (font-print (subseq text cursor (1+ cursor))))
  64
  65     (gl:color 1f0 1f0 1f0 1f0)
  66
  67     (when (< cursor (1- (length text)))
  68      (font-print (subseq text (1+ cursor) (min (length text) (+ first-drawn-char width)))))))))
  69
  70 (defun add-char (ib c)
  71  (with-slots (width first-drawn-char cursor text) ib
  72   (setf (inputbox-text ib) (format nil "~A~A~A" (subseq text 0 cursor) (code-char c) (subseq text cursor)))
  73   (incf cursor)
  74   (when (<= (+ first-drawn-char width) cursor) (incf first-drawn-char))))
  75
  76 (defun delete-char (ib)
  77  (with-slots (width first-drawn-char cursor text) ib
  78   (when (and (< 0 cursor) (< 0 (length text)))
  79    (setf (inputbox-text ib) (concatenate 'string (subseq text 0 (1- cursor)) (subseq text cursor)) )))
  80  (left ib))
  81
  82 (defun empty (ib) ; for control u
  83  (with-slots (first-drawn-char cursor text) ib
  84   (setf text (subseq text cursor))
  85   (setf cursor 0)
  86   (setf first-drawn-char 0)))
  87
  88 ; May someday make this generic
  89 (defun clear (ib)
  90  "FUNCTION CLEAR IB => RESULT
  91
  92 ARGUMENTS AND VALUES:
  93
  94   IB: an inputbox
  95   RESULT: undefined
  96
  97 DESCRIPTION:
  98
  99   Rests the inputbox IB to empty."
 100  (with-slots (first-drawn-char cursor text) ib
 101   (setf text "")
 102   (setf cursor 0)
 103   (setf first-drawn-char 0)
 104   nil))
 105
 106 ; May someday make this generic
 107 (defun value (ib)
 108  "FUNCTION VALUE IB => TEXT
 109
 110 ARGUMENTS AND VALUES:
 111
 112   IB: an inputbox
 113   TEXT: a string, the text currently in IB
 114
 115 DESCRIPTION:
 116
 117   Returns the TEXT that currently resides in the inputbox IB."
 118  (inputbox-text ib))
 119
 120 (defun left (ib)
 121  (with-slots (first-drawn-char cursor) ib
 122   (when (< 0 cursor)
 123    (decf cursor)
 124    (when (< cursor first-drawn-char)
 125     (decf first-drawn-char)))))
 126
 127 (defun right (ib)
 128  (with-slots (first-drawn-char width cursor text) ib
 129   (when (< cursor (length text))
 130    (incf cursor)
 131    (when (<= (+ first-drawn-char width) cursor)
 132     (incf first-drawn-char)))))
 133
 134 ; Generic this later if we add other keyboard widgets
 135 (defun key-pressed (ib key)
 136  "KEY-PRESSED IB KEY => RESULT
 137
 138 ARGUMENTS AND VALUES:
 139
 140   IB: An inputbox
 141   KEY: Key pressed, an integer or a symbol
 142   RESULT: Undefined
 143
 144 DESCRIPTION:
 145
 146   KEY-PRESSED will do the appropriate thing in the case of a key being pressed.
 147
 148   When an integer, will insert the text into the appropriate location, if it's
 149   an ascii character less than 256.
 150
 151   The other values acceptable are:
 152
 153   :key-left moves the cursor one to the left
 154   :key-right moves the cursor one to the right"
 155  (cond
 156   ((and (integerp key) (< 31 key 256)) (add-char ib key))
 157   ((equal key 8) (delete-char ib))
 158   ((equal key 21) (empty ib))
 159   ((equal key :key-left) (left ib))
 160   ((equal key :key-right) (right ib))))