src/cowl-font.lisp

   1
   2 (in-package #:cowl)
   3
   4 (defun blankp (char)
   5   (declare (type character char))
   6   (find char '(#\Space #\Newline #\Page #\Tab #\Backspace #\Return #\Linefeed)))
   7
   8 (defun string-split (string &optional (predicate #'blankp))
   9   "Split a string into a list of strings, partitioning by characters matching the predicate.
  10 Default any whitespace character"
  11   (loop for i = 0 then (1+ j)
  12      as j = (position-if predicate string :start i)
  13      collect (subseq string i j)
  14      while j))
  15
  16 (defun font-string-cursor-offset (font string cursor-x)
  17   "Returns the pixels offset from left of a cursor in the string"
  18   (declare (type string string))
  19   (declare (type (integer 0) cursor-x))
  20   (loop for c across string for i from 0 until (= i cursor-x) summing (ftgl:get-font-advance font (make-string 1 :initial-element c))))
  21
  22 (defun font-string-character-position (font string offset-x)
  23   "Returns the integer character index in string at the offset-x"
  24   (declare (type string string))
  25   (declare (type (integer 0) offset-x))
  26
  27   (do* ((i 0 (1+ i))
  28         (c-offset 0))
  29        ((or (>= i (length string))
  30             (> (+ c-offset (/ (ftgl:get-font-advance font (subseq string i (1+ i)))
  31                               2))
  32                offset-x))
  33         i)
  34     (incf c-offset (ftgl:get-font-advance font (subseq string i (1+ i))))))
  35
  36 (defun font-text-wrap (font text width)
  37   "Using a font, wraps a string of text to a given width.
  38 Returns a list of strings of the lines and the height of all the strings in pixels.
  39    "
  40   (let* ((space-width (ftgl:get-font-advance font " "))
  41          lines
  42          lines-tail
  43          (line-width 0)
  44          (num-lines 0))
  45     (flet ((new-line ()
  46              (incf num-lines)
  47              (setf line-width 0)
  48              (let ((prev-tail lines-tail)) ; append to end, maintaining tail
  49                (setf lines-tail (cons (make-array 64 :element-type 'character :initial-element #\Nul :fill-pointer 0) nil))
  50                (when prev-tail
  51                  (setf (cdr prev-tail) lines-tail)))))
  52       (new-line)
  53       (setf lines lines-tail)         ; set the head to the first tail
  54       ;; collect up a list of (word . width)s one the split text
  55       (do ((word-word-width (loop for word in (string-split text) collecting (cons word (ftgl:get-font-advance font word)))
  56                             (cdr word-word-width)))
  57           ((null word-word-width)
  58            (values lines (* num-lines (ftgl:get-font-line-height font))))
  59         (destructuring-bind (word . word-width) (car word-word-width)
  60           ;; add word to line
  61           (loop for c across word do (vector-push-extend c (car lines-tail)))
  62           ;; add word-width to line
  63           (incf line-width word-width)
  64           ;; if there is a next word
  65           (when (cdr word-word-width)
  66             (incf line-width space-width)
  67             (vector-push-extend #\Space (car lines-tail))
  68             ;; if puts us over the edge
  69             (if (> (+ line-width (cdadr word-word-width)) width)
  70                 (new-line))))))))
  71
  72
  73 (defun gl-print (font x y text)
  74   (declare (type string text))
  75   (gl:with-push-attrib (gl:+texture-bit+ gl:+depth-buffer-bit+)
  76     (gl:depth-mask gl:+false+)
  77     (gl:disable gl:+depth-test+)
  78     (gl:enable gl:+blend+)
  79     (gl:blend-func gl:+src-alpha+ gl:+one-minus-src-alpha+)
  80
  81     (gl:with-push-matrix
  82       (gl:translate-f (coerce x 'single-float)
  83                       (coerce y 'single-float)
  84                       0.0)
  85       (ftgl:render-font font text :all))))