commit ab79d7fbe27d4097ee7f8c87f35a9f22b01924e5
parent fd5b26f367ffc566100218a2e065b5408c9e8d61
Author: Tomas Hlavaty <tom@logand.com>
Date: Sun, 20 Sep 2015 18:17:08 +0200
linux framebuffer experiment
Diffstat:
| A | fb.lisp | | | 254 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
1 file changed, 254 insertions(+), 0 deletions(-)
diff --git a/fb.lisp b/fb.lisp
@@ -0,0 +1,254 @@
+;;; Copyright (C) 2015 Tomas Hlavaty <tom@logand.com>
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use, copy,
+;;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;;; of the Software, and to permit persons to whom the Software is
+;;; furnished to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE.
+
+(defpackage :rw.fb
+ (:use :cl))
+
+(in-package :rw.fb)
+
+;; (defun fbset ()
+;; (rw.os:with-program-output (s "fbset")
+;; (rw:till (rw:peek-reader (rw:char-reader s)))))
+;; fbset is in busybox which breaks everything for me
+;;(fbset)
+
+;; $ fbset
+;;
+;; mode "1366x768-0"
+;; # D: 0.000 MHz, H: 0.000 kHz, V: 0.000 Hz
+;; geometry 1366 768 1366 768 32
+;; timings 0 0 0 0 0 0 0
+;; accel true
+;; rgba 8/16,8/8,8/0,0/0
+;; endmode
+
+(defun make-canvas (stream screen-width screen-height)
+ (declare (type fixnum screen-width screen-height))
+ (let ((buffer (make-array (* 4 screen-width screen-height)
+ :element-type '(unsigned-byte 8)
+ :initial-element 0))
+ (font (rw.psf::load-font
+ ;;"/nix/store/sxrgxk6bw27c516zdvjh2mr6nk4hl9ni-terminus-font-4.39/share/consolefonts/ter-g28n.psf.gz"
+ ;;"/nix/store/sxrgxk6bw27c516zdvjh2mr6nk4hl9ni-terminus-font-4.39/share/consolefonts/ter-g28b.psf.gz"
+ ;;"/nix/store/3jzf1724gfkg942i8dbg0ixdncsv0qhf-kbd-2.0.3/share/consolefonts/default8x16.psfu.gz"
+ "/nix/store/3jzf1724gfkg942i8dbg0ixdncsv0qhf-kbd-2.0.3/share/consolefonts/Lat2-Terminus16.psfu.gz"
+ )))
+ (lambda (form)
+ (let ((*x* 0)
+ (*y* 0)
+ (*fa* #xff)
+ (*fr* #xaf)
+ (*fg* #xaf)
+ (*fb* #xaf)
+ (*ba* #xff)
+ (*br* 0)
+ (*bg* 0)
+ (*bb* 0))
+ (declare (special *x* *y* *fa* *fr* *fg* *fb* *ba* *br* *bg* *bb*))
+ (labels ((pixel (x y a r g b)
+ (let ((i (* 4 (+ x (* y screen-width)))))
+ (setf (aref buffer i) b
+ (aref buffer (1+ i)) g
+ (aref buffer (+ 2 i)) r
+ (aref buffer (+ 3 i)) a)))
+ (lineto (x y)
+ (let* ((x1 (min *x* x))
+ (x2 (max *x* x))
+ (y1 (min *y* y))
+ (y2 (max *y* y))
+ (dx (- x2 x1))
+ (dy (- y2 y1)))
+ (if (< dx dy)
+ (loop
+ for y from y1 to y2
+ do (pixel (if (plusp dx)
+ (round (+ x1 (/ (* dy (- y y1)) dx)))
+ x1)
+ y
+ *fa* *fr* *fg* *fb*))
+ (loop
+ for x from x1 to x2
+ do (pixel x
+ (if (plusp dy)
+ (round (+ y1 (/ (* dx (- x x1)) dy)))
+ y1)
+ *fa* *fr* *fg* *fb*))))
+ (setq *x* x
+ *y* y))
+ (bitmap (bitmap)
+ (loop
+ for v across bitmap
+ for y = *y* then (1+ y)
+ do (loop
+ for bit across v
+ for x = *x* then (1+ x)
+ do (if (zerop bit)
+ (pixel x y *ba* *br* *bg* *bb*)
+ (pixel x y *fa* *fr* *fg* *fb*)))))
+ (chara (c)
+ (let ((n (char-code c)))
+ (if (<= 1 n #x7f)
+ (bitmap (aref (rw.psf::psf2-bitmaps font) n))
+ (let ((*fr* 0)
+ (*br* 255))
+ (declare (special *fr* *br*))
+ (bitmap (aref (rw.psf::psf2-bitmaps font)
+ #.(char-code #\?))))))
+ (incf *x* (rw.psf::header-width (rw.psf::psf2-header font))))
+ (rec (f)
+ (if (atom f)
+ (typecase f
+ (string
+ (loop
+ for c across f
+ do (chara c))))
+ (let* ((h (car f))
+ (b (cdr f))
+ (e (if (consp h) (car h) h))
+ (a (when (consp h) (cdr h))))
+ (ecase e
+ (:<text
+ (mapc #'rec b))
+ (:body
+ (mapc #'rec b))
+ (:circle)
+ (:div
+ (mapc #'rec b))
+ (:font-preview
+ (destructuring-bind () a
+ (let ((r (rw:reader (rw.psf::psf2-bitmaps font)))
+ (h (rw.psf::psf2-header font))
+ (x *x*))
+ (assert (eql 256 (rw.psf::header-length h)))
+ (dotimes (i 16)
+ (setq *x* x)
+ (incf *y* (rw.psf::header-height h))
+ (dotimes (j 16)
+ (incf *x* (rw.psf::header-width h))
+ (bitmap (rw:next r)))))))
+ (:h1
+ (let ((*fr* #xff)
+ (*fg* #xff)
+ (*fb* #xff))
+ (declare (special *fr* *fg* *fb*))
+ (rec "* ")
+ (mapc #'rec b)))
+ (:h2
+ (let ((*fr* #xcf)
+ (*fg* #xcf)
+ (*fb* #xcf))
+ (declare (special *fr* *fg* *fb*))
+ (rec "** ")
+ (mapc #'rec b)))
+ (:h3
+ (let ((*fr* #x8f)
+ (*fg* #x8f)
+ (*fb* #x8f))
+ (declare (special *fr* *fg* *fb*))
+ (rec "*** ")
+ (mapc #'rec b)))
+ (:h4
+ (let ((*fr* #x4f)
+ (*fg* #x4f)
+ (*fb* #x4f))
+ (declare (special *fr* *fg* *fb*))
+ (rec "**** ")
+ (mapc #'rec b)))
+ (:html
+ (mapc #'rec b))
+ (:line
+ (destructuring-bind (&key x1 y1 x2 y2 &allow-other-keys) a
+ (setq *x* x1
+ *y* y1)
+ (lineto x2 y2)))
+ (:p
+ (mapc #'rec b))
+ (:polyline
+ (destructuring-bind (&key points &allow-other-keys) a
+ (loop
+ with to = nil
+ with r = (rw:peek-reader (rw:reader points))
+ while (progn
+ (rw:skip r)
+ (rw:peek r))
+ do (let* ((x (rw:next-z0 r))
+ (y (progn
+ (rw:skip r)
+ (assert (eql #\, (rw:next r)))
+ (rw:skip r)
+ (rw:next-z0 r))))
+ (when to
+ (lineto x y))
+ (setq *x* x
+ *y* y
+ to t)))))
+ (:rect
+ (destructuring-bind (&key x y width height &allow-other-keys) a
+ (setq *x* x
+ *y* y)
+ (dotimes (i width)
+ (dotimes (j height)
+ (pixel (+ *x* i) (+ *y* j) *fa* *fr* *fg* *fb*)))))
+ (:span
+ (mapc #'rec b))
+ (:svg
+ (mapc #'rec b))
+ (:text
+ (destructuring-bind (&key x y &allow-other-keys) a
+ (setq *x* x
+ *y* y)
+ (mapc #'rec b))))))))
+ (rec form)))
+ (write-sequence buffer stream))))
+
+(defun test (&key (device "/dev/fb0") (width 1376 #+nil 1366) (height 768))
+ (with-open-file (s device
+ :direction :output
+ :if-exists :overwrite
+ :if-does-not-exist :error
+ :element-type '(unsigned-byte 8))
+ (let ((fb (make-canvas s width height)))
+ (funcall fb
+ '(:html
+ (:body
+ (:h1 "Heading 1")
+ (:h2 "Heading 2")
+ (:h3 "Heading 3")
+ (:h4 "Heading 4")
+ (:p "This is the first paragraph.")
+ (:p "This is the second paragraph with non-ascii character: รค")
+ (:svg
+ ((:rect :x 0 :y 20 :width 20 :height 20 :fill "lime"
+ :stroke-width 4 :stroke "pink"))
+ ((:circle :cx 125 :cy 125 :r 75 :fill "orange"))
+ ((:polyline :points "50,150 50,200 200,200 200,100"
+ :stroke "red" :stroke-width 4 :fill "none"))
+ ((:line :x1 50 :y1 50 :x2 200 :y2 200 :stroke "blue"
+ :stroke-width 4))
+ ((:text :x 250 :y 150 :font-family "Verdana" :font-size 55)
+ "This is a SVG text element.")
+ (:font-preview)))))
+ (file-position s 0)
+ (funcall fb "hi")))
+ (values))
+
+;;(time (test))
