6de2b94783d5

More examples
[view raw] [browse files]
author Steve Losh <steve@stevelosh.com>
date Thu, 13 Apr 2017 12:42:10 +0000
parents 6fdb6639f071
children a2fb5d06bfb6
branches/tags (none)
files .lispwords examples/box.lisp examples/build.lisp examples/map.lisp examples/sample-map.txt package.lisp src/high-level/bearlibterminal.lisp vendor/make-quickutils.lisp vendor/quickutils.lisp

Changes

--- a/.lispwords	Wed Apr 12 13:08:18 2017 +0000
+++ b/.lispwords	Thu Apr 13 12:42:10 2017 +0000
@@ -1,1 +1,2 @@
 (1 key-case)
+(1 in-layer in-clear-layer)
--- a/examples/box.lisp	Wed Apr 12 13:08:18 2017 +0000
+++ b/examples/box.lisp	Thu Apr 13 12:42:10 2017 +0000
@@ -6,8 +6,9 @@
 (in-package :cl-blt.examples.box)
 
 ;;;; GUI ----------------------------------------------------------------------
-(defun clear-layer (layer)
-  (setf (blt:layer) layer)
+(defun clear-layer (&optional layer)
+  (when layer
+    (setf (blt:layer) layer))
   (blt:clear-area 0 0 (blt:width) (blt:height)))
 
 
@@ -15,7 +16,7 @@
   (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.5 0.9))
+           (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"))))
@@ -111,6 +112,50 @@
             (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)
 
@@ -136,5 +181,6 @@
       (draw)
       (blt:key-case (blt:read)
         (:space (draw-background))
+        (:enter (get-name))
         (:escape (return))
         (:close (return))))))
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/examples/build.lisp	Thu Apr 13 12:42:10 2017 +0000
@@ -0,0 +1,7 @@
+(load "examples/map.lisp")
+(sb-ext:gc :full t)
+(sb-ext:save-lisp-and-die
+  "map"
+  :toplevel #'cl-blt.examples.map::main
+  :executable t)
+
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/examples/map.lisp	Thu Apr 13 12:42:10 2017 +0000
@@ -0,0 +1,116 @@
+;; (ql:quickload '(:cl-blt :losh :iterate :split-sequence))
+(asdf:load-system :cl-blt)
+(asdf:load-system :losh)
+(asdf:load-system :iterate)
+(asdf:load-system :split-sequence)
+
+(defpackage :cl-blt.examples.map
+  (:use :cl :losh :iterate :bearlibterminal.quickutils))
+
+(in-package :cl-blt.examples.map)
+
+(defun clear-layer (&optional layer)
+  (when layer
+    (setf (blt:layer) layer))
+  (blt:clear-area 0 0 (blt:width) (blt:height)))
+
+(defmacro in-layer (layer &body body)
+  (let ((previous-layer (gensym)))
+    `(let ((,previous-layer (blt:layer)))
+       (setf (blt:layer) ,layer)
+       (unwind-protect (progn ,@body)
+         (setf (blt:layer) ,previous-layer)))))
+
+(defmacro in-clear-layer (layer &body body)
+  `(in-layer ,layer
+     (clear-layer)
+     ,@body))
+
+
+(defstruct tile
+  (glyph #\Space :type character)
+  (color 0 :type blt::color))
+
+(defun draw-map (map)
+  (in-clear-layer 0
+    (iterate
+      (with (map-width map-height) = (array-dimensions map))
+      (for-nested ((x :from 0 :below (min map-width (truncate (blt:width) 2)))
+                   (y :from 0 :below (min map-height (truncate (blt:height) 2)))))
+      (for tile = (aref map x y))
+      (setf (blt:color) (tile-color tile)
+            (blt:cell-char (* 2 x) (* 2 y)) (tile-glyph tile)))))
+
+(defun make-random-tile ()
+  (make-tile :glyph (random-elt ",.")
+             :color (blt:hsva 0.4
+                              (random-range 0.4 0.9)
+                              (random-range 0.4 0.9))))
+
+(defun make-random-map (width height)
+  (let ((map (make-array (list width height)
+               :element-type 'tile
+               :initial-element (make-random-tile))))
+    (iterate
+      (for (_ x y) :in-array map)
+      (setf (aref map x y) (make-random-tile)))
+    map))
+
+
+(defun read-map-from-file (filename)
+  (iterate
+    (with lines = (split-sequence:split-sequence
+                    #\newline
+                    (read-file-into-string filename)))
+    (with height = (length lines))
+    (with width = (reduce #'max (mapcar #'length lines)))
+    (with result = (make-array (list width height)
+                     :element-type 'tile
+                     :initial-element (make-tile)))
+    (for y :from 0)
+    (for line :in lines)
+    (iterate (for x :from 0)
+             (for char :in-vector line)
+             (setf (aref result x y)
+                   (make-tile :glyph char
+                              :color (blt:hsva 1.0 0.0 1.0))))
+    (finally (return result))))
+
+(defparameter *map* nil)
+(defparameter *size* 10)
+
+(defun draw ()
+  (blt:clear)
+  (draw-map *map*)
+  (blt:refresh))
+
+(defun resize (new-cell-size)
+  (let ((c new-cell-size)
+        (cc (* 2 new-cell-size)))
+    (blt:set (format nil "normal font: ./examples/UbuntuMono/UbuntuMono-R.ttf, size=~Dx~D, spacing=1x2, align=center;" c cc))
+    (blt:set (format nil "italic font: ./examples/UbuntuMono/UbuntuMono-RI.ttf, size=~Dx~D, spacing=1x2, align=center;" c cc))
+    (blt:set (format nil "bold font: ./examples/UbuntuMono/UbuntuMono-B.ttf, size=~Dx~D, spacing=1x2, align=center;" c cc))
+    (blt:set (format nil "font: ./examples/ProggySquare/ProggySquare.ttf, size=~Dx~D, spacing=2x2, align=dead-center;" cc cc))
+    (blt:set (format nil "window.cellsize = ~Dx~D" c c))))
+
+(defun config ()
+  (blt:set "window.resizeable = true")
+  (blt:set "window.size = 80x50")
+  (blt:set "window.title = Map Demo"))
+
+(defun main ()
+  (blt:with-terminal
+    (setf *size* 10)
+    (setf *map* (make-random-map 10 10))
+    (resize *size*)
+    (config)
+    (iterate
+      (draw)
+      (blt:key-case (blt:read)
+        (:space (setf *map* (make-random-map (random-range 1 100)
+                                             (random-range 1 100))))
+        (:r (setf *map* (read-map-from-file "examples/sample-map.txt")))
+        (:numpad-plus (incf *size* 1) (resize *size*))
+        (:numpad-minus (setf *size* (max 1 (1- *size*))) (resize *size*))
+        (:escape (return))
+        (:close (return))))))
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/examples/sample-map.txt	Thu Apr 13 12:42:10 2017 +0000
@@ -0,0 +1,30 @@
+...................................................................,......
+............,,,,,,,,,,,,,,,,,,,,,,,,,..............................,......
+..................,,,,,,,..........................................,.,,...
+.........................,,,,,,,,,,,,...........,..................,,.....
+...................,,,...............,...........,,,,,.............,,.....
+..................,..,................,...............,...........,,,.....
+.........---------------,,,............,,,,,,,,,,,.....,,,,,,.....,,,.....
+.........-             -,,,,...,,,,,,,,,,,,.......,,,,,,,,,.....,,.,,.....
+.........-             -,,,,,,,.......,,,,,,,,,,,,,,,...........,..,......
+.........-             -..,.,......,,,,,,,,,....................,..,......
+........,-             -,,,,,..,,,,,,........................,,,,..,......
+.......,,----+----------,,,,,,,,,,,...............,,,.........,....,......
+.......,....._.......,,,,,,,...,,...........,,,......,,,......,....,......
+.......,....._....,,,,,.,,,,,,,,,,,........,.,..........,......,...,......
+............._...,,,,,,,,...,..........,,,,.,............,.....,...,......
+............._....,,,,,,,,,,,,,,,,,,,,,,...,.............,,....,...,,,,,,.
+............._,,,,.,,,,,,,,,,......,,,,,,,,.............,.......,..,.....,
+............._..,,,,,,,,..........,,,............,,,,,,,.........,.,.....,
+...........,,_,,............,,,,,,,,,,,,,,,.....,.................,,...,,.
+............._...........,,,,,,,,,,..,.........,...............,,,,,,,,,,.
+......,......_.........,,,,,,,,,,,,,,....,,,,,,....,,,,,,,,,,,,.,..,,,,...
+.....,......._.........,,,,,,,..........,.........,,,,,,,,,,,,,,...,......
+....,,,,,,,..__________,,,,,,,,,,,,,,,,,,,,,,,,,,,..................,.....
+.....,,,,.............____..........,...,,,,,,,,,..,,,,,.............,....
+....,......................_......,,,,,,............,................,....
+....,,,,,,,,................__.....................,.................,....
+........,.....................__..............,,,,,,,,,,,,....,,,,,.,.....
+...,,,,,........................__............,,,,,..,,,,,,,,,....,,......
+..,..............................._................,,,............,,......
+,,.................................____...................................
--- a/package.lisp	Wed Apr 12 13:08:18 2017 +0000
+++ b/package.lisp	Thu Apr 13 12:42:10 2017 +0000
@@ -15,35 +15,35 @@
     :cell-char
     :cell-code
     :cell-color
+    :character-input
     :clear
     :clear-area
     :close
     :color
     :color-name
-    :mouse
-    :mouse-x
-    :mouse-y
+    :color-to-hsva
+    :color-to-rgba
     :composition
     :crop
     :has-input-p
     :height
+    :hsva
     :key-case
     :layer
+    :mouse
+    :mouse-x
+    :mouse-y
     :open
     :peek
     :print
     :read
     :refresh
+    :rgba
     :set
     :sleep
     :width
     :with-terminal
 
-    :rgba
-    :hsva
-    :color-to-rgba
-    :color-to-hsva
-
     )
   (:shadow
 
--- a/src/high-level/bearlibterminal.lisp	Wed Apr 12 13:08:18 2017 +0000
+++ b/src/high-level/bearlibterminal.lisp	Thu Apr 13 12:42:10 2017 +0000
@@ -370,6 +370,11 @@
   (blt/ll:terminal-delay (truncate (* seconds 1000))))
 
 
+(defun character-input ()
+  (when (state-boolean blt/ll:+tk-wchar+)
+    (code-char (blt/ll:terminal-state blt/ll:+tk-wchar+))))
+
+
 (defun width ()
   (blt/ll:terminal-state blt/ll:+tk-width+))
 
--- a/vendor/make-quickutils.lisp	Wed Apr 12 13:08:18 2017 +0000
+++ b/vendor/make-quickutils.lisp	Thu Apr 13 12:42:10 2017 +0000
@@ -11,6 +11,7 @@
                :mkstr
                :once-only
                :rcurry
+               :read-file-into-string
                :symb
                :with-gensyms
 
--- a/vendor/quickutils.lisp	Wed Apr 12 13:08:18 2017 +0000
+++ b/vendor/quickutils.lisp	Thu Apr 13 12:42:10 2017 +0000
@@ -2,7 +2,7 @@
 ;;;; See http://quickutil.org for details.
 
 ;;;; To regenerate:
-;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:COMPOSE :CURRY :ENSURE-BOOLEAN :ENSURE-LIST :MKSTR :ONCE-ONLY :RCURRY :SYMB :WITH-GENSYMS) :ensure-package T :package "BEARLIBTERMINAL.QUICKUTILS")
+;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:COMPOSE :CURRY :ENSURE-BOOLEAN :ENSURE-LIST :MKSTR :ONCE-ONLY :RCURRY :READ-FILE-INTO-STRING :SYMB :WITH-GENSYMS) :ensure-package T :package "BEARLIBTERMINAL.QUICKUTILS")
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (unless (find-package "BEARLIBTERMINAL.QUICKUTILS")
@@ -16,7 +16,9 @@
   (setf *utilities* (union *utilities* '(:MAKE-GENSYM-LIST :ENSURE-FUNCTION
                                          :COMPOSE :CURRY :ENSURE-BOOLEAN
                                          :ENSURE-LIST :MKSTR :ONCE-ONLY :RCURRY
-                                         :SYMB :STRING-DESIGNATOR :WITH-GENSYMS))))
+                                         :WITH-OPEN-FILE* :WITH-INPUT-FROM-FILE
+                                         :READ-FILE-INTO-STRING :SYMB
+                                         :STRING-DESIGNATOR :WITH-GENSYMS))))
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (defun make-gensym-list (length &optional (x "G"))
     "Returns a list of `length` gensyms, each generated as if with a call to `make-gensym`,
@@ -159,6 +161,58 @@
         (multiple-value-call fn (values-list more) (values-list arguments)))))
   
 
+  (defmacro with-open-file* ((stream filespec &key direction element-type
+                                                   if-exists if-does-not-exist external-format)
+                             &body body)
+    "Just like `with-open-file`, but `nil` values in the keyword arguments mean to use
+the default value specified for `open`."
+    (once-only (direction element-type if-exists if-does-not-exist external-format)
+      `(with-open-stream
+           (,stream (apply #'open ,filespec
+                           (append
+                            (when ,direction
+                              (list :direction ,direction))
+                            (when ,element-type
+                              (list :element-type ,element-type))
+                            (when ,if-exists
+                              (list :if-exists ,if-exists))
+                            (when ,if-does-not-exist
+                              (list :if-does-not-exist ,if-does-not-exist))
+                            (when ,external-format
+                              (list :external-format ,external-format)))))
+         ,@body)))
+  
+
+  (defmacro with-input-from-file ((stream-name file-name &rest args
+                                                         &key (direction nil direction-p)
+                                                         &allow-other-keys)
+                                  &body body)
+    "Evaluate `body` with `stream-name` to an input stream on the file
+`file-name`. `args` is sent as is to the call to `open` except `external-format`,
+which is only sent to `with-open-file` when it's not `nil`."
+    (declare (ignore direction))
+    (when direction-p
+      (error "Can't specifiy :DIRECTION for WITH-INPUT-FROM-FILE."))
+    `(with-open-file* (,stream-name ,file-name :direction :input ,@args)
+       ,@body))
+  
+
+  (defun read-file-into-string (pathname &key (buffer-size 4096) external-format)
+    "Return the contents of the file denoted by `pathname` as a fresh string.
+
+The `external-format` parameter will be passed directly to `with-open-file`
+unless it's `nil`, which means the system default."
+    (with-input-from-file
+        (file-stream pathname :external-format external-format)
+      (let ((*print-pretty* nil))
+        (with-output-to-string (datum)
+          (let ((buffer (make-array buffer-size :element-type 'character)))
+            (loop
+              :for bytes-read = (read-sequence buffer file-stream)
+              :do (write-sequence buffer datum :start 0 :end bytes-read)
+              :while (= bytes-read buffer-size)))))))
+  
+
   (defun symb (&rest args)
     "Receives any number of objects, concatenates all into one string with `#'mkstr` and converts them to symbol.
 
@@ -213,6 +267,6 @@
   
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (export '(compose curry ensure-boolean ensure-list mkstr once-only rcurry
-            symb with-gensyms with-unique-names)))
+            read-file-into-string symb with-gensyms with-unique-names)))
 
 ;;;; END OF quickutils.lisp ;;;;