examples/box.lisp @ 6de2b94783d5

More examples
author Steve Losh <steve@stevelosh.com>
date Thu, 13 Apr 2017 12:42:10 +0000
parents 84afcac4fb3a
children a2fb5d06bfb6
(ql:quickload '(:cl-blt :losh :iterate :split-sequence))

(defpackage :cl-blt.examples.box
  (:use :cl :losh :iterate))

(in-package :cl-blt.examples.box)

;;;; GUI ----------------------------------------------------------------------
(defun clear-layer (&optional layer)
  (when layer
    (setf (blt:layer) layer))
  (blt:clear-area 0 0 (blt:width) (blt:height)))


(defun draw-background ()
  (setf (blt:layer) 0)
  (iterate (for-nested ((x :from 0 :below (truncate (blt:width) 2))
                        (y :from 0 :below (truncate (blt:height) 2))))
           (for color = (random-range 0.1 0.3))
           (setf (blt:color) (blt:rgba color color color)
                 (blt:cell-char (* 2 x) (* 2 y))
                 (random-elt "abcdefghijklmnopqrstuvwxyz"))))


(defun draw-outline (x y w h
                     top bottom left right
                     top-left top-right
                     bot-left bot-right)
  (iterate (for bx :from (1+ x) :below (+ x w -1))
           (setf (blt:cell-char bx y) top
                 (blt:cell-char bx (+ y h -1)) bottom))
  (iterate (for by :from (1+ y) :below (+ y h -1))
           (setf (blt:cell-char x by) left
                 (blt:cell-char (+ x w -1) by) right))
  (setf
    (blt:cell-char x y) top-left
    (blt:cell-char (+ x w -1) y) top-right
    (blt:cell-char x (+ y h -1)) bot-left
    (blt:cell-char (+ x w -1) (+ y h -1)) bot-right))

(defun draw-fill (x y w h &optional (char #\full_block))
  (iterate (for-nested ((bx :from x :below (+ x w))
                        (by :from y :below (+ y h))))
           (setf (blt:cell-char bx by) char)))


(defun draw-box-background (x y w h &optional (color (blt:rgba 0 0 0)))
  (setf (blt:color) color)
  (draw-fill (1+ x) (1+ y) (- w 2) (- h 2))
  (draw-outline x y w h
                #\lower_half_block
                #\upper_half_block
                #\right_half_block
                #\left_half_block
                #\quadrant_lower_right
                #\quadrant_lower_left
                #\quadrant_upper_right
                #\quadrant_upper_left))

(defun draw-box-border (x y w h &optional (color (blt:rgba 255 255 255)))
  (setf (blt:color) color)
  (draw-outline x y w h
                #\box_drawings_double_horizontal
                #\box_drawings_double_horizontal
                #\box_drawings_double_vertical
                #\box_drawings_double_vertical
                #\box_drawings_double_down_and_right
                #\box_drawings_double_down_and_left
                #\box_drawings_double_up_and_right
                #\box_drawings_double_up_and_left))

(defun draw-box-contents (x y w h contents
                          &optional (color (blt:rgba 1.0 1.0 1.0)))
  (setf (blt:color) color)
  (blt:print (1+ x) (1+ y)
             (format nil "[font=normal]~A[/font]" contents)
             :width (- w 2) :height (- h 2)))

(defun draw-box (x y w h contents layer)
  (clear-layer layer)
  (clear-layer (1+ layer))

  (setf (blt:layer) layer
        (blt:composition) t)
  (draw-box-background x y w h)
  (draw-box-border x y w h)

  (setf (blt:layer) (1+ layer)
        (blt:composition) nil)
  (blt:clear-area x y w h)
  (draw-box-contents x y w h contents))


(defun make-word-wrap-format-string (width)
  ;; http://cybertiggyr.com/fmt/fmt.pdf
  ;; unfortunately we can't use ~V in here so we'll just use concat instead
  (concatenate 'string
               "~{~<~%~1,"
               ;; Format checks for strictly less than width, but it's more
               ;; natural to give the width as an inclusive range...
               (princ-to-string (1+ width))
               ":;~A~>~^ ~}"))

(defun word-wrap-line (line width)
  (format nil (make-word-wrap-format-string width)
          (split-sequence:split-sequence #\space line)))

(defun word-wrap (string width)
  (format nil "~{~A~^~%~}"
          (iterate
            (for line in (split-sequence:split-sequence #\newline string))
            (collect (word-wrap-line line width)))))


(defun read-string (x y maximum-length &key (font ""))
  (let ((result (make-array maximum-length
                  :element-type 'character
                  :fill-pointer 0)))
    ;; Have to do the `print` fuckery so non-1x1 fonts work right.
    (labels ((draw-string ()
               (blt:print x y (format nil "[font=~A]~V,,,'_A[/font]"
                                      font maximum-length result))))
      (iterate
        (clear-layer)
        (draw-string)
        (blt:refresh)
        (blt:key-case (blt:read)
          (:escape (return))
          (:close (return))
          (:enter (return result))
          (:backspace (when (plusp (length result))
                        (vector-pop result)))
          (t (let ((char (blt:character-input)))
               (when (and char (< (length result) maximum-length))
                 (vector-push char result)))))
        (blt:refresh)
        (finally-protected (clear-layer)
                           (blt:refresh))))))

(defun get-user-input (x y layer prompt maximum-length)
  (draw-box x y (+ 3 (max (length prompt)
                          maximum-length))
            6
            prompt
            layer)
  (setf (blt:layer) (+ layer 2))
  (prog1 (read-string (+ x 1)
                      (+ y 3)
                      maximum-length
                      :font "normal")
    (clear-layer layer)
    (clear-layer (1+ layer))))

(defun get-name ()
  (clear-layer 15)
  (pr (get-user-input 0 10 10 "What is your name?" 15)))


(defun draw ()
  (draw-box 3 3 20 10 (format nil "[color=red]hello~%world! how [font=italic]close[font=normal] can [font=bold]we[font=normal] get here, what if we go over oh no![/color]") 5)

  (draw-box 30 3 40 30 (word-wrap "This is an test.  It has multiple words.  And some spaces too.  It should be wrapped correctly." 10) 7)

  (blt:refresh))

(defun config ()
  (blt:set "normal font: ./examples/UbuntuMono/UbuntuMono-R.ttf, size=10x20, spacing=1x2, align=center;")
  (blt:set "italic font: ./examples/UbuntuMono/UbuntuMono-RI.ttf, size=10x20, spacing=1x2, align=center;")
  (blt:set "bold font: ./examples/UbuntuMono/UbuntuMono-B.ttf, size=10x20, spacing=1x2, align=center;")
  (blt:set "font: ./examples/ProggySquare/ProggySquare.ttf, size=20x20, spacing=2x2, align=dead-center;")
  (blt:set "window.resizeable = false")
  (blt:set "window.cellsize = 10x10")
  (blt:set "window.size = 80x50")
  (blt:set "window.title = Box Demo"))

(defun main ()
  (blt:with-terminal
    (config)
    (draw-background)
    (iterate
      (draw)
      (blt:key-case (blt:read)
        (:space (draw-background))
        (:enter (get-name))
        (:escape (return))
        (:close (return))))))