cl-rw

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

psf.lisp (3392B)

      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.psf
     24   (:use :cl))
     25 
     26 (in-package :rw.psf)
     27 
     28 ;; https://www.win.tue.nl/~aeb/linux/kbd/font-formats-1.html
     29 
     30 (defun next-bitmap (reader height width)
     31   (let ((z (make-array height)))
     32     (dotimes (j height z)
     33       (let ((v (make-array width :element-type 'bit))
     34             (r (rw:bit-reader reader)))
     35         (dotimes (i width)
     36           (setf (bit v i) (rw:next r)))
     37         (setf (aref z j) v)))))
     38 
     39 (defun next-bitmaps (reader length height width)
     40   (let ((z (make-array length)))
     41     (dotimes (i length z)
     42       (setf (aref z i) (next-bitmap reader height width)))))
     43 
     44 (defun next-unicode (reader)
     45   (loop
     46      ;; seq #xfe, doesn't seem to be true
     47      while (rw:peek reader)
     48      collect (prog1 (rw:till reader '(#xff))
     49                (assert (eql #xff (rw:next reader))))))
     50 
     51 (rw.wire:defstruc header ()
     52   (rw:u32le magic)
     53   (rw:u32le version)
     54   (rw:u32le headersize)
     55   (rw:u32le flags)
     56   (rw:u32le length)
     57   (rw:u32le charsize)
     58   (rw:u32le height)
     59   (rw:u32le width))
     60 
     61 (defstruct psf2 header bitmaps unicode)
     62 
     63 (defun next-psf2 (octet-reader)
     64   (let* ((h (next-header octet-reader))
     65          (height (header-height h))
     66          (width (header-width h)))
     67     (assert (eql #x864ab572 (header-magic h)))
     68     (assert (eql 0 (header-version h)))
     69     (assert (eql 32 (header-headersize h)))
     70     (assert (eql (header-charsize h) (* height (floor (+ width 7) 8))))
     71     (make-psf2 :header h
     72                :bitmaps (next-bitmaps octet-reader (header-length h) height width)
     73                :unicode (ecase (header-flags h)
     74                           ;;(0)
     75                           (1 ;; unicode
     76                            (next-unicode octet-reader))))))
     77 
     78 (defun load-font (pathname)
     79   (rw.os:with-program-output (s "zcat" (list pathname))
     80     (let ((r (rw:peek-reader (rw:byte-reader s))))
     81       (prog1 (next-psf2 r)
     82         (assert (not (rw:till r)))))))
     83 
     84 ;;setfont -v
     85 ;;(print (load-font "/nix/store/sxrgxk6bw27c516zdvjh2mr6nk4hl9ni-terminus-font-4.39/share/consolefonts/ter-g28n.psf.gz"))
     86 ;;(print (load-font "/nix/store/3jzf1724gfkg942i8dbg0ixdncsv0qhf-kbd-2.0.3/share/consolefonts/default8x16.psfu.gz"))
     87 ;;(print (load-font "/nix/store/3jzf1724gfkg942i8dbg0ixdncsv0qhf-kbd-2.0.3/share/consolefonts/Lat2-Terminus16.psfu.gz"))