fb.lisp (13601B)
1 ;;; Copyright (C) 2015 Tomas Hlavaty <tom@logand.com> 2 ;;; 3 ;;; Permission is hereby granted, free of charge, to any person 4 ;;; obtaining a copy of this software and associated documentation 5 ;;; files (the "Software"), to deal in the Software without 6 ;;; restriction, including without limitation the rights to use, copy, 7 ;;; modify, merge, publish, distribute, sublicense, and/or sell copies 8 ;;; of the Software, and to permit persons to whom the Software is 9 ;;; furnished to do so, subject to the following conditions: 10 ;;; 11 ;;; The above copyright notice and this permission notice shall be 12 ;;; included in all copies or substantial portions of the Software. 13 ;;; 14 ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 17 ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 18 ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 19 ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 21 ;;; DEALINGS IN THE SOFTWARE. 22 23 (defpackage :rw.fb 24 (:use :cl)) 25 26 (in-package :rw.fb) 27 28 ;; (defun fbset () 29 ;; (rw.os:with-program-output (s "fbset") 30 ;; (rw:till (rw:peek-reader (rw:char-reader s))))) 31 ;; fbset is in busybox which breaks everything for me 32 ;;(fbset) 33 34 ;; $ fbset 35 ;; 36 ;; mode "1366x768-0" 37 ;; # D: 0.000 MHz, H: 0.000 kHz, V: 0.000 Hz 38 ;; geometry 1366 768 1366 768 32 39 ;; timings 0 0 0 0 0 0 0 40 ;; accel true 41 ;; rgba 8/16,8/8,8/0,0/0 42 ;; endmode 43 44 (defun unicode-bitmaps (psf2) 45 (let* ((bitmaps (rw.psf::psf2-bitmaps psf2)) 46 (unicode (rw.psf::psf2-unicode psf2)) 47 (z (make-hash-table))) 48 (assert (= 256 (length bitmaps) (length unicode))) 49 (dotimes (i 256 z) 50 (dolist (c (rw:till (rw:peek-reader 51 (rw:utf8-reader (rw:reader (pop unicode)))))) 52 (setf (gethash (code-char c) z) 53 (aref bitmaps i)))))) 54 55 ;;(unicode-bitmaps (rw.psf::load-font "/nix/store/3jzf1724gfkg942i8dbg0ixdncsv0qhf-kbd-2.0.3/share/consolefonts/Lat2-Terminus16.psfu.gz")) 56 57 (defun make-canvas (stream screen-width screen-height) 58 (declare (type fixnum screen-width screen-height)) 59 (let* ((buffer (make-array (* 4 screen-width screen-height) 60 :element-type '(unsigned-byte 8) 61 :initial-element 0)) 62 (font (rw.psf::load-font 63 ;;"/nix/store/sxrgxk6bw27c516zdvjh2mr6nk4hl9ni-terminus-font-4.39/share/consolefonts/ter-g28n.psf.gz" 64 ;;"/nix/store/sxrgxk6bw27c516zdvjh2mr6nk4hl9ni-terminus-font-4.39/share/consolefonts/ter-g28b.psf.gz" 65 ;;"/nix/store/3jzf1724gfkg942i8dbg0ixdncsv0qhf-kbd-2.0.3/share/consolefonts/default8x16.psfu.gz" 66 "/nix/store/3jzf1724gfkg942i8dbg0ixdncsv0qhf-kbd-2.0.3/share/consolefonts/Lat2-Terminus16.psfu.gz" 67 )) 68 (unicode-bitmaps (unicode-bitmaps font))) 69 (lambda (form) 70 (let ((*x* 0) 71 (*y* 0) 72 (*fa* #xff) 73 (*fr* #xaf) 74 (*fg* #xaf) 75 (*fb* #xaf) 76 (*ba* #xff) 77 (*br* 0) 78 (*bg* 0) 79 (*bb* 0)) 80 (declare (special *x* *y* *fa* *fr* *fg* *fb* *ba* *br* *bg* *bb*)) 81 (labels ((pixel (x y a r g b) 82 (let ((i (* 4 (+ x (* y screen-width))))) 83 (setf (aref buffer i) b 84 (aref buffer (1+ i)) g 85 (aref buffer (+ 2 i)) r 86 (aref buffer (+ 3 i)) a))) 87 (lineto (x y) 88 (let* ((x1 (min *x* x)) 89 (x2 (max *x* x)) 90 (y1 (min *y* y)) 91 (y2 (max *y* y)) 92 (dx (- x2 x1)) 93 (dy (- y2 y1))) 94 (if (< dx dy) 95 (loop 96 for y from y1 to y2 97 do (pixel (if (plusp dx) 98 (round (+ x1 (/ (* dy (- y y1)) dx))) 99 x1) 100 y 101 *fa* *fr* *fg* *fb*)) 102 (loop 103 for x from x1 to x2 104 do (pixel x 105 (if (plusp dy) 106 (round (+ y1 (/ (* dx (- x x1)) dy))) 107 y1) 108 *fa* *fr* *fg* *fb*)))) 109 (setq *x* x 110 *y* y)) 111 (bitmap (bitmap) 112 (loop 113 for v across bitmap 114 for y = *y* then (1+ y) 115 do (loop 116 for bit across v 117 for x = *x* then (1+ x) 118 do (if (zerop bit) 119 (pixel x y *ba* *br* *bg* *bb*) 120 (pixel x y *fa* *fr* *fg* *fb*))))) 121 (chara (c) 122 (bitmap (gethash c unicode-bitmaps)) 123 #+nil 124 (let ((n (char-code c))) 125 (if (<= 1 n #x7f) 126 (bitmap (aref (rw.psf::psf2-bitmaps font) n)) 127 (let ((*fr* 0) 128 (*br* 255)) 129 (declare (special *fr* *br*)) 130 (bitmap (aref (rw.psf::psf2-bitmaps font) 131 #.(char-code #\?)))))) 132 (incf *x* (rw.psf::header-width (rw.psf::psf2-header font)))) 133 (rec (f) 134 (if (atom f) 135 (typecase f 136 (string 137 (loop 138 for c across f 139 do (chara c)))) 140 (let* ((h (car f)) 141 (b (cdr f)) 142 (e (if (consp h) (car h) h)) 143 (a (when (consp h) (cdr h)))) 144 (ecase e 145 (:<text 146 (mapc #'rec b)) 147 (:body 148 (mapc #'rec b)) 149 (:circle) 150 (:div 151 (mapc #'rec b)) 152 (:font-preview 153 (destructuring-bind () a 154 (let ((r (rw:reader (rw.psf::psf2-bitmaps font))) 155 (h (rw.psf::psf2-header font)) 156 (x *x*)) 157 (assert (eql 256 (rw.psf::header-length h))) 158 (dotimes (i 16) 159 (setq *x* x) 160 (incf *y* (rw.psf::header-height h)) 161 (dotimes (j 16) 162 (incf *x* (rw.psf::header-width h)) 163 (bitmap (rw:next r))))))) 164 (:h1 165 (let ((*fr* #xff) 166 (*fg* #xff) 167 (*fb* #xff)) 168 (declare (special *fr* *fg* *fb*)) 169 (rec "* ") 170 (mapc #'rec b))) 171 (:h2 172 (let ((*fr* #xcf) 173 (*fg* #xcf) 174 (*fb* #xcf)) 175 (declare (special *fr* *fg* *fb*)) 176 (rec "** ") 177 (mapc #'rec b))) 178 (:h3 179 (let ((*fr* #x8f) 180 (*fg* #x8f) 181 (*fb* #x8f)) 182 (declare (special *fr* *fg* *fb*)) 183 (rec "*** ") 184 (mapc #'rec b))) 185 (:h4 186 (let ((*fr* #x4f) 187 (*fg* #x4f) 188 (*fb* #x4f)) 189 (declare (special *fr* *fg* *fb*)) 190 (rec "**** ") 191 (mapc #'rec b))) 192 (:html 193 (mapc #'rec b)) 194 (:line 195 (destructuring-bind (&key x1 y1 x2 y2 &allow-other-keys) a 196 (setq *x* x1 197 *y* y1) 198 (lineto x2 y2))) 199 (:mandelbrot 200 (let ((x1 -2) 201 (y1 -1.5) 202 (x2 1) 203 (y2 1.5) 204 (w 100) 205 (h 100)) 206 (dotimes (y h) 207 (dotimes (x w) 208 (loop 209 with a = (complex 210 (float (+ (* (/ (- x2 x1) w) x) x1)) 211 (float (+ (* (/ (- y2 y1) h) y) y1))) 212 for z = a then (+ (* z z) a) 213 while (< (abs z) 2) 214 for c from 60 above 0 215 finally (pixel x 216 (+ 300 y) 217 255 218 (mod (* 13 c) 256) 219 (mod (* 7 c) 256) 220 (mod (* 2 c) 256))))))) 221 (:p 222 (mapc #'rec b)) 223 (:polyline 224 (destructuring-bind (&key points &allow-other-keys) a 225 (loop 226 with to = nil 227 with r = (rw:peek-reader (rw:reader points)) 228 while (progn 229 (rw:skip r) 230 (rw:peek r)) 231 do (let* ((x (rw:next-z0 r)) 232 (y (progn 233 (rw:skip r) 234 (assert (eql #\, (rw:next r))) 235 (rw:skip r) 236 (rw:next-z0 r)))) 237 (when to 238 (lineto x y)) 239 (setq *x* x 240 *y* y 241 to t))))) 242 (:rect 243 (destructuring-bind (&key x y width height &allow-other-keys) a 244 (setq *x* x 245 *y* y) 246 (dotimes (i width) 247 (dotimes (j height) 248 (pixel (+ *x* i) (+ *y* j) *fa* *fr* *fg* *fb*))))) 249 (:span 250 (mapc #'rec b)) 251 (:svg 252 (mapc #'rec b)) 253 (:text 254 (destructuring-bind (&key x y &allow-other-keys) a 255 (setq *x* x 256 *y* y) 257 (mapc #'rec b)))))))) 258 (rec form))) 259 (file-position stream 0) 260 (write-sequence buffer stream)))) 261 262 (defun test (&key (device "/dev/fb0") (width 1376 #+nil 1366) (height 768)) 263 (with-open-file (s device 264 :direction :output 265 :if-exists :overwrite 266 :if-does-not-exist :error 267 :element-type '(unsigned-byte 8)) 268 (let ((fb (make-canvas s width height))) 269 (funcall fb 270 '(:html 271 (:body 272 (:mandelbrot) 273 (:h1 "Heading 1") 274 (:h2 "Heading 2") 275 (:h3 "Heading 3") 276 (:h4 "Heading 4") 277 (:p "This is the first paragraph.") 278 (:p "This is the second paragraph with non-ascii character: รค") 279 (:svg 280 ((:rect :x 0 :y 20 :width 20 :height 20 :fill "lime" 281 :stroke-width 4 :stroke "pink")) 282 ((:circle :cx 125 :cy 125 :r 75 :fill "orange")) 283 ((:polyline :points "50,150 50,200 200,200 200,100" 284 :stroke "red" :stroke-width 4 :fill "none")) 285 ((:line :x1 50 :y1 50 :x2 200 :y2 200 :stroke "blue" 286 :stroke-width 4)) 287 ((:text :x 250 :y 150 :font-family "Verdana" :font-size 55) 288 "This is a SVG text element.") 289 (:font-preview))))) 290 (funcall fb "hi"))) 291 (values)) 292 293 ;;(time (test))