cl-rw

Layered streams for Common Lisp
git clone https://logand.com/git/cl-rw.git/
Log | Files | Refs

commit ab79d7fbe27d4097ee7f8c87f35a9f22b01924e5
parent fd5b26f367ffc566100218a2e065b5408c9e8d61
Author: Tomas Hlavaty <tom@logand.com>
Date:   Sun, 20 Sep 2015 18:17:08 +0200

linux framebuffer experiment

Diffstat:
Afb.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))