Braille pixels images using cl-charms (@ SBCL)

braille-pixels.lisp

#!/usr/bin/sbcl --script

#|

Usage
=====
$ ./braille-pixels.lisp [path]

Main
====
q           -- quits the program
b           -- blanks the canvas
s           -- saves the image into path (default is braille-image.txt)
l           -- loads the image from path (default is braille-image.txt)

Movement
========
arrows      -- move the cursor on the pixel grid
control
+ arrows    -- move the cursor on the cell grid

Drawing
=======
space       -- toggles the current braille pixel

/ *         -- toggles braille pixels in the current cell
8 9
5 6
2 3

|#


(load "~/.sbclrc")
(ql:quickload "cl-charms" :silent t)
;(load "braille-pixels.lisp")
;(braille-pixels:main)

;;; braille-pixels.lisp

(defpackage braille-pixels
  (:use :cl :charms)
  (:export :main))
(in-package :braille-pixels)

(defconstant +default-path+ #p"braille-image.txt")
(defvar *path* (second sb-ext:*posix-argv*))
(unless *path* (setf *path* +default-path+))

(defconstant +cell-width+ 2)
(defconstant +cell-height+ 4)

(defun in-cell-coords (x y)
   (values (mod x +cell-width+) (mod y +cell-height+)))
   
(defconstant +braille-patterns-block+ #x2800)

(defun toggle (pattern x y)
  (flet ((encode (x y)
           (cond ((= 3 y) (+ x (* y +cell-width+)))
                 (t (+ y (* x 3))))))
    (code-char (logior +braille-patterns-block+ (logxor (if (>= #1=(char-code pattern) +braille-patterns-block+) #1# 0) (dpb 1 (byte #2=(1+ (encode x y)) (1- #2#)) 0))))))

(defun paint% (global-x global-y)
  (multiple-value-bind (x y) (in-cell-coords global-x global-y)
    (charms:with-restored-cursor charms:*standard-window*
      (charms:write-string-at-cursor
       charms:*standard-window*
       (format nil "~a" (toggle (charms:char-at-cursor charms:*standard-window*) x y))))))

(defun normal-cell-coords (x y)
  (multiple-value-bind (width height) (charms:window-dimensions charms:*standard-window*)
     (values (mod (floor x +cell-width+) width) (mod (floor y +cell-height+) height))))

(defun blank ()
 (multiple-value-bind (width height) (charms:window-dimensions charms:*standard-window*)
    (loop for y below height
          for w = (if (= y (1- height)) (1- width) width)
          do (charms:write-string-at-point charms:*standard-window* (format nil "~v,,,va" w (code-char +braille-patterns-block+) "") 0 y))
    (charms:write-char-at-point charms:*standard-window* #\Q (1- width) (1- height))))
    
(defun save-pixel-image (&optional (path +default-path+))
  (multiple-value-bind (width height) (charms:window-dimensions charms:*standard-window*)
    (with-open-file (fs path :direction :output :if-exists :supersede)
        (loop for y below height
              do (progn (loop for x below width for c = (charms:char-at-point charms:*standard-window* x y)
                            do (write-char c fs))
                        (terpri fs))))))
                        
(defun load-pixel-image (&optional (path +default-path+))
  (multiple-value-bind (width height) (charms:window-dimensions charms:*standard-window*)
    (with-open-file (fs path :direction :input :if-does-not-exist nil)
      (when fs
        (loop for y below height
              for w = (if (= y (1- height)) (1- width) width)
              do (loop named horizontal for x below w for c = (read-char fs nil nil)
                            when (eq c #\Newline) do (return-from horizontal)
                            when c do (charms:write-string-at-point charms:*standard-window* (format nil "~a" c) x y)
                            finally (read-line fs nil nil)))))))

(defun |#!-reader| (stream subchar arg)
  (declare (ignore subchar arg))
    (code-char (symbol-value (find-symbol (symbol-name (read stream t nil t)) 'charms/ll))))
(set-dispatch-macro-character #\# #\! #'|#!-reader|)

(defconstant +CTRL-KEY-UP+ (code-char 566))
(defconstant +CTRL-KEY-LEFT+ (code-char 545))
(defconstant +CTRL-KEY-DOWN+ (code-char 525))
(defconstant +CTRL-KEY-RIGHT+ (code-char 560))

(defun main ()
  (flet ((paint (x y) 
             (unless (multiple-value-call #'charms::last-position-p charms:*standard-window* (normal-cell-coords x y)) (paint% x y)))
         (merge-coords (global-x global-y x y)
             (values (+ (* (floor global-x +cell-width+) +cell-width+) x) (+ (* (floor global-y +cell-height+) +cell-height+) y))))
    (charms:with-curses ()
      (charms:disable-echoing)
      (charms:enable-raw-input :interpret-control-characters t)
      (charms:enable-extra-keys charms:*standard-window*)
      (charms:enable-non-blocking-mode charms:*standard-window*)
      (charms:refresh-window charms:*standard-window*)
      (blank)
      (when (not (eq *path* +default-path+)) (load-pixel-image *path*))

      (loop named driver-loop
            with x = 0
            with y = 0
            for c = (charms:get-char charms:*standard-window* :ignore-error t)
            do (progn
                ;; Refresh the window
                (charms:refresh-window charms:*standard-window*)

                ;; Show input
                #|(when c
                  (charms:write-string-at-point charms:*standard-window* (format nil "~s ~50s" c (ignore-errors (char-code c))) 0 0))|#

                ;; Process input
                (case c
                  ((nil) nil)
                  ((#\b) (blank))
                  ((#!KEY_UP) (decf y))
                  ((#!KEY_LEFT)  (decf x))
                  ((#!KEY_DOWN) (incf y))
                  ((#!KEY_RIGHT) (incf x))
                  ((#.+CTRL-KEY-UP+) (decf y +cell-height+))
                  ((#.+CTRL-KEY-LEFT+)  (decf x +cell-width+))
                  ((#.+CTRL-KEY-DOWN+) (incf y +cell-height+))
                  ((#.+CTRL-KEY-RIGHT+) (incf x +cell-width+))
                  ((#\s) (save-pixel-image *path*))
                  ((#\l) (load-pixel-image *path*))
                  ((#\Space) (paint x y))
                  ((#\/) (multiple-value-call #'paint (merge-coords x y 0 0)))
                  ((#\*) (multiple-value-call #'paint (merge-coords x y 1 0)))
                  ((#\8) (multiple-value-call #'paint (merge-coords x y 0 1)))
                  ((#\9) (multiple-value-call #'paint (merge-coords x y 1 1)))
                  ((#\5) (multiple-value-call #'paint (merge-coords x y 0 2)))
                  ((#\6) (multiple-value-call #'paint (merge-coords x y 1 2)))
                  ((#\2) (multiple-value-call #'paint (merge-coords x y 0 3)))
                  ((#\3) (multiple-value-call #'paint (merge-coords x y 1 3)))                                                                        
                  ((#\q) (return-from driver-loop)))

                ;; Move the cursor to the new location
                (multiple-value-call #'charms:move-cursor charms:*standard-window* (normal-cell-coords x y)))))))
                
;;; script
(braille-pixels:main)