src/cowl-text.lisp

   1 (in-package #:cowl)
   2 (compiler-opts)
   3
   4 (defclass text (widget)
   5   ((font :initarg :font :initform (default-font) :accessor font-of
   6          :documentation "font object to render the text in")
   7    (text :type string :initarg :text :accessor text-of
   8          :documentation "The text to display.")
   9    (text-updater :initarg :text-updater :type (function (widget) string) :accessor text-updater-of
  10                  :documentation "A function that can be associated with this input from which the
  11 text can be derived.")
  12    (lines :type list :accessor lines-of
  13           :documentation "The actual lines of text to display.
  14 Use the text property unless you really want to explicitely set the lines.")
  15    (wrap :type boolean :initform t :initarg :wrap :accessor wrap
  16          :documentation "Whether or not to wrap the text to the current size."))
  17   (:documentation "Wrappable text object on the on-screen-display system."))
  18
  19
  20 (defgeneric display-text-of (text)
  21   (:documentation "Can be used to display a different set of characters than is input"))
  22
  23 (defmethod display-text-of ((text text))
  24   (text-of text))
  25
  26
  27 (defmethod initialize-instance :after ((text text) &key height width (wrap nil wrap-p))
  28   (unless height
  29     (setf (current-size-of (y text))
  30           (setf (ideal-size-of (y text))
  31                 (ftgl:get-font-line-height (font-of text)))))
  32   ;; if wrap is not specified,
  33   (unless wrap-p
  34     (if width
  35         ;; wrap if width is specified
  36         (setf (wrap text) t)
  37         ;; don't wrap if no width is specified
  38         (setf (wrap text) nil)))
  39
  40   ;; if we don't have text, but we do have a text-updater
  41   (when (and (not (slot-boundp text 'text))
  42              (slot-boundp text 'text-updater))
  43     (setf (text-of text)
  44           (funcall (text-updater-of text) text)))
  45
  46   ;; if we aren't wrapping, no width is specified and we have text
  47   (when (and (not wrap) (not width)
  48              (slot-boundp text 'text))
  49     ;; set the ideal-width to the size of the text ; ;
  50     (setf (current-size-of (x text))
  51           (setf (ideal-size-of (x text))
  52                 (ftgl:get-font-advance (font-of text) (display-text-of text))))))
  53
  54
  55 (defmethod update-text ((text text))
  56   "Calls the updater callback if one exists and sets to as the current text"
  57   (when (slot-boundp text 'text-updater)
  58    (setf (text-of text)
  59          (funcall (slot-value text 'text-updater) text))))
  60
  61 (defmethod cursor-x-y-to-position ((text text) ix iy)
  62   (+ (min ix (length (elt (lines-of text) iy)))
  63      (loop for y below iy for line in (lines-of text) summing (length line))))
  64
  65 (defmethod ideal-width-of ((text text))
  66   (if (wrap text)
  67       (call-next-method)
  68       (max (call-next-method)
  69            (ftgl:get-font-advance (font-of text) (display-text-of text)))))
  70
  71
  72 (defmethod ideal-height-of ((text text))
  73   (if (wrap text)
  74       (nth-value 1 (font-text-wrap (font-of text) (display-text-of text) (ideal-size-of (x text))))
  75       (max (call-next-method)
  76            (ftgl:get-font-line-height (font-of text)))))
  77
  78 (defmethod layout ((text text))
  79   (with-accessors ((font font-of) (lines lines-of) (x x) (y y) (wrap wrap) (text display-text-of)) text
  80     (if wrap
  81       (setf lines (font-text-wrap font text (current-size-of x)))
  82       (setf lines (list text)))))
  83
  84
  85 (defmethod draw ((text text))
  86   (when (slot-boundp text 'lines)
  87     (with-accessors ((font font-of)
  88                      (lines lines-of)
  89                      (foreground-colour foreground-colour-of)) text
  90       (apply #'gl:color-4f foreground-colour)
  91       (let ((font-height (round (ftgl:get-font-line-height font))))
  92         (gl:rotate-f 180.0 1.0 0.0 0.0)
  93         (loop for iy downfrom (- 0 font-height (round (ftgl:get-font-descender font))) by font-height
  94            for line in lines
  95            do (gl-print font 0 iy line)))))
  96   (when (next-method-p) (call-next-method)))