Conway's lifegame on terminal, using braille to show dots

life_braille.ros

#!/bin/sh
#|-*- mode:lisp -*-|#
#|
exec ros -Q -- $0 "$@"
|#
(ql:quickload :cl-charms :silent t)
(defpackage :ros.script.braille_life.3667932619
  (:use :cl :charms/ll))
(in-package :ros.script.braille_life.3667932619)

;; (declaim (optimize (speed 3) (debug 0)))

(defun make-board (w h)
  (make-array (list w h)
	      :element-type 'bit
	      :initial-element 0))

(defun randomize-board (board)
  (dotimes (i (array-total-size board))
    (setf (row-major-aref board i) (random 2)))
  board)

(defun print-board-no-curses (board)
  "print status of board to `*standard-output*`."
  (destructuring-bind (w h) (array-dimensions board)
    (dotimes (y h)
      (fresh-line)
      (dotimes (x w)
	(princ (if (plusp (aref board x y)) "o" "_")))
      (terpri))))

(defun board-by-braille-at (board x0 y0)
  "return a braille character, corresponding to
4x2 area beginning at (`x0`, `y0`) of `board`."
  (declare (type (simple-array bit) board)
	   (type fixnum x0 y0))
  (let ((shift
	 (+ (* (aref board (+ x0 0) (+ y0 0)) 1)
	    (* (aref board (+ x0 0) (+ y0 1)) 2)
	    (* (aref board (+ x0 0) (+ y0 2)) 4)
	    (* (aref board (+ x0 1) (+ y0 0)) 8)
	    (* (aref board (+ x0 1) (+ y0 1)) 16)
	    (* (aref board (+ x0 1) (+ y0 2)) 32)
	    (* (aref board (+ x0 0) (+ y0 3)) 64)
	    (* (aref board (+ x0 1) (+ y0 3)) 128)))
	(base #x2800))
    (code-char (+ base shift))))

(defun print-board-curses-braille (board window)
  "display `board` into `window`, using braille"
  (declare (type (simple-array bit) board))
  (destructuring-bind (w h) (array-dimensions board)
    (declare (type fixnum w h))
    (let ((buf (make-string (ash w -1))))
      (dotimes (y (ash h -2))
	(dotimes (x (ash w -1))
	  (setf (char buf x)
		(board-by-braille-at board (* x 2) (* y 4))))
	(wmove window y 0)
	(waddstr window buf)))))

(defun step-board (board)
  "return a new board, representing the next generation of `board`."
  (destructuring-bind (w h) (array-dimensions board)
    (let ((new-board (make-board w h)))
      (declare (type (simple-array bit) board new-board))
      (labels ((population-at (board x y)
		 (declare (type fixnum x y w h))
		 (if (and (< -1 x w)
			  (< -1 y h))
		     (aref board x y)
		     0))
	       (count-neighbor (board x y)
		 (+ (population-at board (1- x) (1- y))
		    (population-at board (1- x) y)
		    (population-at board (1- x) (1+ y))
		    (population-at board x      (1- y))
		    (population-at board x      (1+ y))
		    (population-at board (1+ x) (1- y))
		    (population-at board (1+ x) y)
		    (population-at board (1+ x) (1+ y))))
	       (get-next-state (board x y)
		 (if (or (and (= (population-at board x y) 1)
			      (member (count-neighbor board x y) '(2 3)))
			 (and (= (population-at board x y) 0)
			      (= (count-neighbor board x y) 3)))
		     1 0)))
	(declare (type fixnum w h))
	(dotimes (y h)
	  (dotimes (x w)
	    (setf (aref new-board x y)
		  (get-next-state board x y))))
	new-board))))

(defun count-population (board)
  "count alive cell in `board`."
  (let ((count 0))
    (dotimes (i (array-total-size board))
      (incf count (row-major-aref board i)))
    count))

(defun run ()
  (cbreak)
  (noecho)
  (curs-set 0)
  (keypad *stdscr* TRUE)
  (nodelay *stdscr* TRUE)
  (let ((main-window (newwin (1- *lines*) *cols* 1 0))
	(status-window (newwin 1 *cols* 0 0)))
    (do ((ch (getch) (getch))
	 (generation 0 (1+ generation))
	 (board (randomize-board (make-board (* 2 *cols*) (* 4 (1- *lines*))))
		(step-board board)))
	((= ch (char-code #\q)))
      (when (= ch (char-code #\r))
	(setf board (randomize-board board)
	      generation 0))
      (wclear status-window)
      (wprintw status-window " generation %4d | %4d cells alive | q to quit, r to restart"
	       :int generation
	       :int (count-population board))
      (wrefresh status-window)
      (wclear main-window)
      (print-board-curses-braille board main-window)
      (wrefresh main-window)
      ;; (wnoutrefresh main-window)
      ;; (doupdate)
      (sleep 0.05))
    (delwin main-window)
    (delwin status-window)))

(defun main (&rest argv)
  (declare (ignorable argv))
  (initscr)
  (unwind-protect
       (run)
    (endwin)))