Serial port communication in common lisp - common-lisp

Is there a library for serial port communication in Common Lisp on Windows?

Here are a few functions that implement serial communication using SBCL foreign function POSIX calls. Its not as nice as a full library but I solved my problem of talking to the device according to this protocol
https://valelab.ucsf.edu/svn/micromanager2/branches/micromanager1.3/DeviceAdapters/ZeissCAN/ZeissCAN.cpp
package.lisp:
(defpackage :serial
(:shadowing-import-from :cl close open ftruncate truncate time
read write)
(:use :cl :sb-posix)
(:export #:open-serial
#:close-serial
#:fd-type
#:serial-recv-length
#:read-response
#:write-zeiss
#:talk-zeiss))
(defpackage :focus
(:use :cl :serial)
(:export #:get-position
#:set-position
#:connect
#:disconnect))
serial.lisp:
(in-package :serial)
(defconstant FIONREAD #x541B)
(defconstant IXANY #o4000)
(defconstant CRTSCTS #o20000000000)
(deftype fd-type ()
`(unsigned-byte 31))
(defun open-serial (tty)
(declare (string tty)
(values stream fd-type &optional))
(let* ((fd (sb-posix:open
tty (logior O-RDWR
O-NOCTTY #+nil (this terminal can't control this program)
O-NDELAY #+nil (we don't wait until dcd is space)
)))
(term (tcgetattr fd))
(baud-rate B9600))
(fcntl fd F-SETFL (logior O-RDWR O-NOCTTY)) #+nil (reset file status flags, clearing e.g. O-NDELAY)
(cfsetispeed baud-rate term)
(cfsetospeed baud-rate term)
(macrolet ((set-flag (flag &key (on ()) (off ()))
`(setf ,flag (logior ,#on (logand ,flag ,#off)))))
(setf
(aref (termios-cc term) VMIN) 1 #+nil (wake up after 32 chars are read)
(aref (termios-cc term) VTIME) 5 #+nil (wake up when no char arrived for .1 s))
;; check and strip parity, handshake off
(set-flag (termios-iflag term)
:on ()
:off (IXON IXOFF IXANY
IGNBRK BRKINT PARMRK ISTRIP
INLCR IGNCR ICRNL
))
;; process output
(set-flag (termios-oflag term)
:off (OPOST))
;; canonical input but no echo
(set-flag (termios-lflag term)
:on ()
:off (ICANON ECHO ECHONL IEXTEN ISIG))
;; enable receiver, local mode, 8N1 (no parity)
(set-flag (termios-cflag term)
:on (CLOCAL CREAD
CS8 CRTSCTS)
:off (CSTOPB CSIZE PARENB)))
(tcflush fd TCIFLUSH) #+nil (throw away any input data)
(tcsetattr fd TCSANOW term) #+nil (set terminal port attributes)
(values
(sb-sys:make-fd-stream fd :input t :output t
:buffering :full)
fd)))
(defun close-serial (fd)
(declare (fd-type fd)
(values null &optional))
(fcntl fd F-SETFL 0) #+nil (reset file status flags, clearing e.g. O-NONBLOCK)
(sb-posix:close fd) #+nil (this will set DTR low)
nil)
(defun serial-recv-length (fd)
(declare (fd-type fd)
(values (signed-byte 32) &optional))
(sb-alien:with-alien ((bytes sb-alien:int))
(ioctl fd FIONREAD (sb-alien:addr bytes))
bytes))
(defun read-response (tty-fd tty-stream)
(declare (fd-type tty-fd)
(stream tty-stream)
(values string &optional))
(declare (fd-type tty-fd)
(stream tty-stream)
(values string &optional))
(let ((n (serial-recv-length tty-fd)))
(if (eq 0 n)
""
(let ((ret (make-string n)))
(dotimes (i n)
(setf (char ret i) (read-char tty-stream)))
ret))))
(defun write-zeiss (tty-stream command)
(declare (stream tty-stream)
(string command))
(format tty-stream "~a~a" command #\Return)
(finish-output tty-stream))
(defun talk-zeiss (tty-fd tty-stream command)
(declare (fd-type tty-fd)
(stream tty-stream)
(string command)
(values string &optional))
(write-zeiss tty-stream command)
;; I measured that the position is fully transmitted after 30 ms.
(let ((n (do ((i 0 (1+ i))
(n 0 (serial-recv-length tty-fd)))
((or (< 0 n) (<= 30 i)) n)
(sleep .03d0))))
(if (eq 0 n)
""
(read-response tty-fd tty-stream))))
focus.lisp:
(in-package :focus)
(defvar *stream* nil)
(defvar *fd* nil)
(defun run-shell (command)
(with-output-to-string (stream)
(sb-ext:run-program "/bin/bash" (list "-c" command)
:input nil
:output stream)))
(defun find-zeiss-usb-adapter ()
(let ((port (run-shell "dmesg|grep pl2303|grep ttyUSB|tail -n1|sed s+.*ttyUSB+/dev/ttyUSB+g|tr -d '\\n'")))
(if (string-equal "" port)
(error "dmesg output doesn't contain ttyUSB assignment. This can happen when the system ran a long time. You could reattach the USB adapter that is connected to the microscope.")
port)))
#+nil
(find-zeiss-usb-adapter)
(defun connect (&optional (devicename (find-zeiss-usb-adapter)))
(multiple-value-bind (s fd)
(open-serial devicename)
(defparameter *stream* s)
(defparameter *fd* fd)))
#+nil
(connect)
(defun disconnect ()
(close-serial *fd*)
(setf *stream* nil))
#+nil
(disconnect)
#+nil
(serial-recv-length *fd*)
#+nil ;; do cat /dev/ttyUSB1 in some terminal, or use read-response below
(progn
(format *stream* "HPTv0~a" #\Return)
(finish-output *stream*))
#+nil
(progn
(format *stream* "FPZp~a" #\Return)
(finish-output *stream*))
#+nil
(read-response *fd* *stream*)
#+nil
(response->pos-um (read-response *fd* *stream*))
#+nil
(close-serial *fd2*)
#+nil
(time
(response->pos-um (talk-zeiss *fd2* *s2* "FPZp")))
#+nil ;; measure the time it takes until the full response has arrived
(progn
(format *s2* "FPZp~a" #\Return)
(finish-output *s2*)
(dotimes (i 10)
(sleep .01d0)
(format t "~a~%" (list i (serial-recv-length *fd2*))))
(read-response *fd2* *s2*))
(defconstant +step-size+ .025s0 "Distance of one z step in micrometer.")
(defun response->pos-um (answer)
(declare (string answer)
(values single-float &optional))
(if (equal "PF" (subseq answer 0 2))
(let* ((uval (the fixnum (read-from-string
(format nil "#x~a" (subseq answer 2)))))
(val (if (eq 0 (logand uval #x800000))
uval ;; positive
(- uval #xffffff 1))))
(* +step-size+ val))
(error "unexpected answer on serial port.")))
;; some tricks with two's complement here! be sure to generate a
;; 24bit signed number consecutive application of pos-um->request and
;; response->pos-um should be the identity (if you don't consider the
;; prefix "PF" that response->pos-um expects)
(defun pos-um->request (pos-um)
(declare (single-float pos-um)
(values string &optional))
(format nil "~6,'0X"
(let ((val (round pos-um +step-size+)))
(if (< val 0)
(+ #xffffff val 1)
val))))
(defun get-position ()
(declare (values single-float &optional))
(response->pos-um (talk-zeiss *fd* *stream* "FPZp")))
(defun set-position (position-um)
"Decreasing the position moves away from sample."
(declare (single-float position-um))
(write-zeiss *stream*
(format nil "FPZT~a" (pos-um->request position-um))))
#+nil
(format nil "FPZT~a" (pos-um->request -8.0d0))
#+nil
(defparameter current-pos (get-position *fd* *stream*))
#+nil
(format t "pos: ~a~%" (get-position *fd2* *s2*))
# +nil
(time (format t "response ~a~%"
(set-position *s2* (+ current-pos 0.7d0))))
#+nil
(progn
(set-position *s2* (+ current-pos 135d0))
(dotimes (i 20)
(format t "pos ~a~%" (list i (get-position *fd2* *s2*)))))
#+nil
(loop for i below 100 do
(sleep .1)
(format t "~a~%" (response->pos-um (talk-zeiss "FPZp"))))

I don't know if there's a free one available, but LispWorks has one - SERIAL-PORT.
Failing that, you might have to write your own. You could try simply writing the FFI wrappers for the Windows calls (GetCommState, WaitCommEvent, etc.) as a start. It's most certainly doable.

This isn't really a lisp question, but I'll attempt to answer it anyway. Short answer: no. Long answer: possibly. It depends on how the FFI works and what environment you're using(raw windows, cygwin, mingw) If you are using raw windows, the chances is very slim. Actually, either way I'd bet the chances are slim. Lisp is a fairly high-level language, and isn't designed for stuff such as this.

Related

Why does the Lisp reader return `(list 1 2 3)` instead of `(1 2 3)` when using reader macros?

Recently, I tried to understand reader macros better. I have read an article about using reader macros to read in objects in JSON format.
With slightly adapted code from above article (it only reads (or is supposed to read) arrays [1,2,3] into lists (1 2 3))
(defun read-next-object (separator delimiter &optional (input-stream *standard-input*))
(flet ((peek-next-char ()
(peek-char t input-stream t nil t))
(discard-next-char ()
(read-char input-stream t nil t)))
(if (and delimiter (char= (peek-next-char) delimiter))
(progn
(discard-next-char)
nil)
(let* ((object (read input-stream t nil t))
(next-char (peek-next-char)))
(cond
((char= next-char separator) (discard-next-char))
((and delimiter (char= next-char delimiter)) nil)
(t (error "Unexpected next char: ~S" next-char)))
object))))
(defun read-separator (stream char)
(declare (ignore stream))
(error "Separator ~S shouldn't be read alone" char))
(defun read-delimiter (stream char)
(declare (ignore stream))
(error "Delimiter ~S shouldn't be read alone" char))
(defun read-left-bracket (stream char)
(declare (ignore char))
(let ((*readtable* (copy-readtable)))
(set-macro-character #\, 'read-separator)
(loop
for object = (read-next-object #\, #\] stream)
while object
collect object into objects
finally (return `(list ,#objects)))))
the intent is to call read on strings and have it produce Lisp lists.
With following test code I get:
(with-input-from-string (stream "[1,2,3]")
(let ((*readtable* (copy-readtable)))
(set-macro-character #\[ 'read-left-bracket)
(set-macro-character #\] 'read-delimiter)
(read stream)))
;; => (LIST 1 2 3)
I expected to get (1 2 3) instead.
Now, when I change the current readtable "permanently", i.e. call set-macro-character in the top-level, and type [1,2,3] at the prompt, I get indeed (1 2 3).
Why, then, does
(with-input-from-string (stream "(1 2 3)")
(read stream)))
;; => (1 2 3)
give the "expected" result? What am I missing? Is there some eval hidden, somewhere? (I'm aware of the quasi-quote above, but some in-between reasoning is missing...)
Thanks!
EDIT:
Using
(defun read-left-bracket (stream char)
(declare (ignore char))
(let ((*readtable* (copy-readtable)))
(set-macro-character #\, 'read-separator)
(loop
for object = (read-next-object #\, #\] stream)
while object
collect object)))
I get what I expect. Entering '[1,2,3] at the REPL behaves like entering "real" lists.
Reading from strings also works as intended.
You have
(return `(list ,#objects))
in your code. Thus [...] is read as (list ...).
Next if you use the REPL and evaluate
> [...]
Then it is as you were evaluating
> (list 1 2 3)
which returns (1 2 3).

Access to function arguments by their names in Common Lisp

I want to get a function argument value, using an argument name.
The following code don't works, because symbol-value working only with global variables:
(defun test1 (&key v1)
(format t "V1: ~A~%" (symbol-value (intern "V1"))))
Is there a portable way to do this in Common Lisp?
You can use a custom environment to map strings to functions:
(use-package :alexandria)
(defvar *env* nil)
(defun resolve (name &optional (env *env*))
(if-let (entry (assoc name env :test #'string=))
(cdr entry)
(error "~s not found in ~a" name env)))
(defmacro bind (bindings env &body body)
(assert (symbolp env))
(let ((env (or env '*env*)))
(loop
for (n v) in bindings
collect `(cons ,n ,v) into fresh-list
finally
(return
`(let ((,env (list* ,#fresh-list ,env)))
,#body)))))
(defmacro call (name &rest args)
`(funcall (resolve ,name) ,#args))
For example:
(bind (("a" (lambda (u) (+ 3 u)))
("b" (lambda (v) (* 5 v))))
nil
(call "a" (call "b" 10)))
Here is another version of an explicit named-binding hack. Note this isn't well (or at all) tested, and also note the performance is not going to be great.
(defun named-binding (n)
;; Get a binding by its name: this is an error outside
;; WITH-NAMED-BINDINGS
(declare (ignore n))
(error "out of scope"))
(defun (setf named-binding) (val n)
;; Set a binding by its name: this is an error outside
;; WITH-NAMED-BINDINGS
(declare (ignore val n))
(error "out of scope"))
(defmacro with-named-bindings ((&rest bindings) &body decls/forms)
;; establish a bunch of bindings (as LET) but allow access to them
;; by name
(let ((varnames (mapcar (lambda (b)
(cond
((symbolp b) b)
((and (consp b)
(= (length b) 2)
(symbolp (car b)))
(car b))
(t (error "bad binding ~S" b))))
bindings))
(decls (loop for df in decls/forms
while (and (consp df) (eql (car df) 'declare))
collect df))
(forms (loop for dft on decls/forms
for df = (first dft)
while (and (consp df) (eql (car df) 'declare))
finally (return dft)))
(btabn (make-symbol "BTAB")))
`(let (,#bindings)
,#decls
(let ((,btabn (list
,#(mapcar (lambda (v)
`(cons ',v (lambda (&optional (val nil valp))
(if valp
(setf ,v val)
,v))))
varnames))))
(flet ((named-binding (name)
(let ((found (assoc name ,btabn)))
(unless found
(error "no binding ~S" name))
(funcall (cdr found))))
((setf named-binding) (val name)
(let ((found (assoc name ,btabn)))
(unless found
(error "no binding ~S" name))
(funcall (cdr found) val))))
(declare (inline named-binding (setf named-binding)))
,#forms)))))
And now:
> (with-named-bindings ((x 1))
(setf (named-binding 'x) 2)
(named-binding 'x))
2
Even better:
(defun amusing (x y)
(with-named-bindings ((x x) (y y))
(values #'named-binding #'(setf named-binding))))
(multiple-value-bind (reader writer) (amusing 1 2)
(funcall writer 2 'x)
(funcall reader 'x))
will work.

How do I play an FM demodulated sample on the sound card in Common Lisp?

I have created a Common Lisp library binding for libbladerf and can receive signals in Common Lisp. I have a function that demodulates an FM signal and is defined as follows:
(defun fm-demodulate-sc16-q11-samples (device frequency)
(configure-channel device (channel-rx 0) frequency 1000 40000000 30)
(init-sync device)
(enable-module device (channel-rx 0) t)
(with-foreign-objects ((rx-samples :uint16 8192)
(metadata :pointer))
(let ((status (bladerf_sync_rx (mem-ref device :pointer) rx-samples 4096 metadata 5000))
(samples-array (make-array 8192 :element-type 'float :initial-element 0.0 :fill-pointer 0)))
(if (< status 0)
(error "Failed to recieve IQ samples error: ~S" status)
(progn
(loop for i below 4096 by 4
do
(let* ((previous-i (mem-aref rx-samples :int16 (1+ i)))
(previous-q (mem-aref rx-samples :int16 i))
(current-i (mem-aref rx-samples :int16 (+ i 3)))
(current-q (mem-aref rx-samples :int16 (+ i 2)))
(previous-complex (complex previous-i previous-q))
(current-complex (complex current-i current-q))
(dif-complex (* (conjugate previous-complex) current-complex)))
(vector-push (atan-complex-number dif-complex) samples-array)))
samples-array)))))
I then pass this to cl-portaudio using the following code:
(defconstant +frames-per-buffer+ 1024)
(defconstant +sample-rate+ 44100d0)
(defconstant +sample-format+ :float)
(defconstant +num-channels+ 2)
(defun play-demodulated-fm ()
(with-audio
(with-default-audio-stream (astream +num-channels+ +num-channels+ :sample-format +sample-format+ :sample-rate +sample-rate+ :frames-per-buffer +frames-per-buffer+)
(dotimes (i 20)
(write-stream astream (fm-demodulate-sc16-q11-samples *dev* 863000000)))))
When I play this all I hear is a clipping sound and the following warning:
array is copied and/or coerced, lisp type is T, requested CFFI type is FLOAT
ALSA lib pcm.c:8432:(snd_pcm_recover) underrun occurred
What is the correct way of playing an FM demodulated signal with cl-portaudio?
I tried to play a simple tone with cl-portaudio and got the very same error as you reported:
array is copied and/or coerced, lisp type is T, requested CFFI type is FLOAT
After a long night of trying and digging the net I finally cooked the following piece of code making a sound. Probably not 'CleanCode', but should do as a start.
(eval-when (:compile-toplevel)
(ql:quickload "cl-portaudio"))
(defconstant +sample-rate+ 44100d0)
(defconstant +sample-format+ :float)
(defconstant +input-channels+ 0)
(defconstant +output-channels+ 1)
(defconstant +sound-frequency+ 800)
(defconstant +angle-per-tick+ (* 2d0 pi (/ +sound-frequency+ +sample-rate+)))
(defconstant +audio-buffer-size+ 4096
"The number of samples in the audio buffer.")
(defconstant +audio-buffer-time+ (* +audio-buffer-size+ (/ +sample-rate+))
"The total time the information in the audio buffer represents, in seconds.")
(defun make-audio-buffer ()
(make-array +audio-buffer-size+
:element-type 'single-float
:initial-element 0.0))
(defun make-sine-wave (&optional (angle 0d0))
(loop
with buffer = (make-audio-buffer)
for i from 0 below +audio-buffer-size+
for cur-angle = (+ angle (* i +angle-per-tick+))
do
(setf (aref buffer i) (coerce (sin cur-angle) 'single-float))
finally
(return-from make-sine-wave (values buffer (mod cur-angle (* 2 pi))))))
(defun play-note()
(portaudio:with-audio
(portaudio:with-default-audio-stream
(audio-stream +input-channels+ +output-channels+
:sample-format :float
:sample-rate +sample-rate+
:frames-per-buffer +audio-buffer-size+)
(loop
for i from 1 to 8
with angle = 0d0
do
(multiple-value-bind
(buffer new-angle)
(make-sine-wave angle)
(portaudio:write-stream audio-stream buffer)
(setf angle new-angle))))))

Read in data from the user in a loop

For a little game I am working on, I want to read in the names of the players. I have two solutions so far which I find both a bit cumbersome. Version 1 forces the user to additionally state that he/she wants to add more players:
(defun read-player ()
(loop :while (y-or-n-p "Add another player?")
:do (format t "~& Name of player #~D: " (1+ (length players)))
:collect (read-line) :into players
:finally (print players)))
Version 2 needs a duplicate of the format expression:
(defun read-player2 ()
(let ((players '()))
(format t "~& Name of player #~D: " (1+ (length players)))
(loop :for player = (read-line)
:until (string= player "")
:collect player :into players
:do (format t "~& Name of player #~D: " (1+ (length players)))
:finally (print players))))
Is there a synthesis of my two approaches? Not bothering the user with additional questions and not repeating code?
How about using progn when reading the player?
(defun read-players ()
(loop :for player-count :upfrom 1
:for player =
(progn
(format t "~& Name of player #~D (RET to stop): " player-count)
(finish-output)
(read-line))
:while (plusp (length player))
:collect player))
> (read-players)
Name of player #1 (RET to stop): r
Name of player #2 (RET to stop): g
Name of player #3 (RET to stop):
==> ("r" "g")
PS. It is relatively common to add a function like
(defun ask-user (format-string &rest format-arguments)
(fresh-line)
(apply #'format t format-string format-arguments)
(finish-output)
(read-line))
or, if you are fond of format magic,
(defun ask-user (format-string &rest format-arguments)
(format t "~&~?: " format-string format-arguments)
(finish-output)
(read-line))
This would make your read-players even more readable:
(defun read-players ()
(loop :for player-count :upfrom 1
:for player = (ask-user "Name of player #~D (RET to stop)" player-count)
:while (plusp (length player))
:collect player))

How to abstract a mancala board in lisp

I'm trying to make a Mancala game in Lisp. It's going to have an AI to play against a human player, but I'm stuck. I can't find the way to represent the board as list; the major issue in my mind is how to move the tokens. Here are the references of how to play mancala
I'm thinking about a circular list, but I can't find any clear documentation on how to do that in Lisp.
Sorry about my grammar; English is not my native language.
Now I havent read the rules (sorry!) so this is just to address the idea of using a circular data structure.
A data structure doesnt have to be circular. As long as you pretend it is it will work!
Have a read of the mod function.
;; a1 a6 b1 b6
(defparameter *board* '(nil nil nil nil nil nil nil nil nil nil nil nil))
(defun wrap-position (pos)
(mod pos (length *board*)))
(defun push-token (position)
(push t (nth (wrap-position position) *board*)))
(defun pull-token (position)
(let ((contents (nth (wrap-position position) *board*)))
(setf (nth (wrap-position position) *board*) (rest contents))))
(defun print-board ()
(format t "| ~{~10<~a~>~} |~%| ~{~10<~a~>~} |" (reverse (subseq *board* 6))
(subseq *board* 0 6))
*board*)
Now the technique above is destructive. If you don't know yet what that is in lisp have a google or search here on stackoveflow, there are some good descriptions. It is worth looking into as you may find that your AI want to 'try out' lots of potential moves with 'damaging' the actual game board, a non destructive approach can help with this. The phenomenal book land of lisp has some great info on this.
Here is a simple usage example
CL-USER> *board*
(NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL)
CL-USER> (push-token 5)
(T)
CL-USER> *board*
(NIL NIL NIL NIL NIL (T) NIL NIL NIL NIL NIL NIL)
CL-USER> (push-token 5)
(T T)
CL-USER> *board*
(NIL NIL NIL NIL NIL (T T) NIL NIL NIL NIL NIL NIL)
CL-USER> (PULL-token 5)
(T)
CL-USER> *board*
(NIL NIL NIL NIL NIL (T) NIL NIL NIL NIL NIL NIL)
...I change the board before doing the next bit...
CL-USER> (print-board)
| NIL NIL NIL NIL NIL NIL |
| NIL NIL NIL NIL NIL (T T T T) |
Now have a look at Sylwester's answer and see that you can replace the sublists with just a number of stones. You will need to change the print-board obviously but that gives you a very simple model you can manipulate very easily (almost can be the big step you need to make this non-destructive). Have a go!
I would have used an array of 14 fixnums. index 0-5 are pits for A, 6 is A's basket. 7-12 are pits for player B and 13 is B's basket. You do minimax with copy-array.
If you want lists I would have either had A and B's lists individually or interleaved them. You could also just have a list of 14 cons.
Sorry, I couldn't really understand how to play the game, but here's something I could think about w/r to how to go about the board:
(defstruct (mancala-cell
(:print-object
(lambda (cell stream)
(format stream "<stones: ~d>"
(length (mancala-cell-stones cell))))))
(stones nil :type list)
(next nil))
(defun make-cells ()
(labels ((%make-cells (head count)
(let ((next (make-mancala-cell)))
(setf (mancala-cell-next head) next)
(if (> count 0) (%make-cells next (1- count)) next))))
(let* ((first (make-mancala-cell))
(last (%make-cells first 12)))
(setf (mancala-cell-next last) first))))
(defstruct (mancala-board
(:print-object
(lambda (board stream)
(loop :for i :from 0 :below 12
:for cell := (mancala-board-cells board)
:then (mancala-cell-next cell)
:do (princ (case i
(6 #\Newline) (0 "") (otherwise #\-))
stream)
(princ cell stream)))))
(cells (make-cells) :type mancala-cell))
(print (make-mancala-board))
;; <stones: 0>-<stones: 0>-<stones: 0>-<stones: 0>-<stones: 0>-<stones: 0>
;; <stones: 0>-<stones: 0>-<stones: 0>-<stones: 0>-<stones: 0>-<stones: 0>
Then here's one more example:
(defstruct (mancala-cell
(:print-object
(lambda (cell stream)
(format stream "<stones: ~d>"
(mancala-cell-stones cell)))))
(stones 4 :type fixnum))
(defconstant +null-cell+ (make-mancala-cell))
(deftype mancala-grid () '(array mancala-cell (12)))
(defun make-cells ()
(loop
:for i :from 0 :below 12
:with result := (make-array
12 :element-type 'mancala-cell
:initial-element +null-cell+)
:do (setf (aref result i) (make-mancala-cell))
:finally (return result)))
(defstruct (mancala-board
(:print-object
(lambda (board stream)
(loop :for i :from 0 :below 12
:for cell :across (mancala-board-cells board)
:do (princ (case i
(6 #\Newline) (0 "") (otherwise #\-))
stream)
(princ cell stream)))))
(cells (make-cells) :type mancala-grid))
(defun map-cells-in-range (function board &key (start 0) (end 12))
(loop
:for i :from start :below end
:with board := (mancala-board-cells board)
:collect (funcall function (aref board (mod i 12)))))
(defun fold-cells-in-range (function board &key (start 0) (end 12))
(loop
:for i :from start :below (1- end)
:with board := (mancala-board-cells board)
:for cell := (aref board (mod i 12))
:for result := (funcall
function
(aref board (mod i 12))
(aref board (mod (1+ i) 12)))
:then (funcall function result (aref board (mod (1+ i) 12)))
:finally (return result)))
(fold-cells-in-range
(lambda (a b)
(+ (mancala-cell-stones b)
(if (integerp a) a (mancala-cell-stones a))))
(make-mancala-board)) ; 48

Resources