Skip to content

Instantly share code, notes, and snippets.

What would you like to do?
Braille pixels images using cl-charms (@ SBCL)
#!/usr/bin/sbcl --script
$ ./braille-pixels.lisp [path]
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)
arrows -- move the cursor on the pixel grid
+ arrows -- move the cursor on the cell grid
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.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*
(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: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*)
(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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.