Related
I am working on a complicated macro and have run into a roadblock.
(defmacro for-each-hashtable-band (body vars on &optional counter name)
`(block o
(with-hash-table-iterator (next-entry ,on)
(destructuring-bind
,(apply #'append vars)
(let ((current-band (list ,#(mapcar #'not (apply #'append vars)))))
(for (i 1 ,(length (apply #'append vars)) 2)
(multiple-value-bind
(succ k v) (next-entry)
(if succ
(progn
(setf (nth i current-band) k)
(setf (nth (+ 1 i) current-band) v))
(return-from o nil))))
current-band)
,#body))))
im getting "Evaluation aborted on #<UNDEFINED-FUNCTION NEXT-ENTRY {100229C693}>"
i dont understand why next-entry appears to be invisible to the macro i have created.
I've tried stripping down this to a small replicable example but i couldnt find a minimal scenario without the macro i created where next-entry would be invisible besides this scenario no matter what I tried, i've always managed to find a way to call next-entry in my other examples so im stumped as to why i cannot get it working here
I've tested the for macro ive created and it seems to generally work in most cases but for some reason it cannot see this next-entry variable. How do i make it visible?
In your code there are multiple places where the macro generates bindings in a way that is subject to variable capture (pdf).
(defmacro for-each-hashtable-band (body vars on &optional counter name)
`(block o ;; VARIABLE CAPTURE
(with-hash-table-iterator (next-entry ,on) ;; VARIABLE CAPTURE
(destructuring-bind ,(apply #'append vars)
(let ((current-band ;;; VARIABLE CAPTURE
(list ,#(mapcar #'not (apply #'append vars)))))
(for
(i ;;; VARIABLE CAPTURE
1 ,(length (apply #'append vars)) 2)
(multiple-value-bind (succ k v) ;;; VARIABLE CAPTURE
,(next-entry) ;;; WRONG EVALUATION TIME
(if succ
(progn
(setf (nth i current-band) k)
(setf (nth (+ 1 i) current-band) v))
(return-from o nil))))
current-band)
,#body))))
A simplified example of such a capture is:
`(let ((x 0)) ,#body)
Here above, the x variable is introduced, but if the code is expanded in a context where xis already bound, then body will not be able to reference that former x binding and will always see x bound to zero (you generally don't want this behavior).
Write a function instead
Instead of writing a big macro for this, let's first try understanding what you want to achieve and write instead a higher-order function, ie. a function that calls user-provided functions.
If I understand correctly, your function iterates over a hash-table by bands of entries. I assume vars holds a list of (key value) pairs of symbols, for example ((k1 v1) (k2 v2)). Then, body works on all the key/value pairs in the band.
In the following code, the function map-each-hashtable-band accepts a function, a hash-table, and instead of vars it accepts a size, the width of the band (the number of pairs).
Notice how in your code, you only have one loop, which builds a band using the hash-table iterator. But then, since the macro is named for-each-hashtable-band, I assume you also want to loop over all the bands. The macro with-hash-table-iterator provides an iterator but does not loop itself. That's why here I have two loops.
(defun map-each-hashtable-band (function hash-table band-size)
(with-hash-table-iterator (next-entry hash-table)
(loop :named outer-loop :do
(loop
:with key and value and next-p
:repeat band-size
:do (multiple-value-setq (next-p key value) (next-entry))
:while next-p
:collect key into current-band
:collect value into current-band
:finally (progn
(when current-band
(apply function current-band))
(unless next-p
(return-from outer-loop)))))))
For example:
(map-each-hashtable-band (lambda (&rest band) (print `(:band ,band)))
(alexandria:plist-hash-table
'(:a 0 :b 1 :c 2 :d 3 :e 4 :f 5 :g 6))
2)
NB. Iterating over a hash-table happens in an arbitrary order, there is no guarantee that you'll see the entries in any particular kind of order, this is implementation-dependant.
With my current version of SBCL this prints the following:
(:BAND (:A 0 :B 1))
(:BAND (:C 2 :D 3))
(:BAND (:E 4 :F 5))
(:BAND (:G 6))
Wrap the function in a macro
The previous function might not be exactly the behavior you want, so you need to adapt to your needs, but once it does what you want, you can wrap a macro around it.
(defmacro for-each-hashtable-band (vars hash-table &body body)
`(map-each-hashtable-band (lambda ,(apply #'append vars) ,#body)
,hash-table
,(length vars)))
For example:
(let ((test (alexandria:plist-hash-table '(:a 0 :b 1 :c 2 :d 3 :e 4 :f 5))))
(for-each-hashtable-band ((k1 v1) (k2 v2)) test
(format t "~a -> ~a && ~a -> ~a ~%" k1 v1 k2 v2)))
This prints:
A -> 0 && B -> 1
C -> 2 && D -> 3
E -> 4 && F -> 5
Macro-only solution, for completeness
If you want to have only one, single macro, you can start by inlining the body of the above function in the macro, you don't need to use apply anymore, but instead you need to establish bindings around the body, using destructuring-bind as you did. A first draft would be to simply as follows, but notice that this is not a proper solution:
(defmacro for-each-hashtable-band (vars hash-table &body body)
(let ((band-size (length vars)))
`(with-hash-table-iterator (next-entry ,hash-table)
(loop :named outer-loop :do
(loop
:with key and value and next-p
:repeat ,band-size
:do (multiple-value-setq (next-p key value) (next-entry))
:while next-p
:collect key into current-band
:collect value into current-band
:finally (progn
(when current-band
(destructuring-bind ,(apply #'append vars) current-band
,#body))
(unless next-p
(return-from outer-loop))))))))
In order to be free of variable capture problems with macros, each temporary variable you introduce must be named after a symbol that cannot exist in any context you expand your code. So instead we first unquote all the variables, making the macro definition fail to compile:
(defmacro for-each-hashtable-band (vars hash-table &body body)
(let ((band-size (length vars)))
`(with-hash-table-iterator (,next-entry ,hash-table)
(loop :named ,outer-loop :do
(loop
:with ,key and ,value and ,next-p
:repeat ,band-size
:do (multiple-value-setq (,next-p ,key ,value) (,next-entry))
:while ,next-p
:collect ,key into ,current-band
:collect ,value into ,current-band
:finally (progn
(when ,current-band
(destructuring-bind ,(apply #'append vars) ,current-band
,#body))
(unless ,next-p
(return-from ,outer-loop))))))))
When compiling the macro, the macro is supposed to inject symbols into the code, but here we have a compilation error that says undefined variables:
;; undefined variables: CURRENT-BAND KEY NEXT-ENTRY NEXT-P OUTER-LOOP VALUE
So now, those variables should be fresh symbols:
(defmacro for-each-hashtable-band (vars hash-table &body body)
(let ((band-size (length vars)))
(let ((current-band (gensym))
(key (gensym))
(next-entry (gensym))
(next-p (gensym))
(outer-loop (gensym))
(value (gensym)))
`(with-hash-table-iterator (,next-entry ,hash-table)
(loop :named ,outer-loop :do
(loop
:with ,key and ,value and ,next-p
:repeat ,band-size
:do (multiple-value-setq (,next-p ,key ,value) (,next-entry))
:while ,next-p
:collect ,key into ,current-band
:collect ,value into ,current-band
:finally (progn
(when ,current-band
(destructuring-bind ,(apply #'append vars) ,current-band
,#body))
(unless ,next-p
(return-from ,outer-loop)))))))))
This above is a bit verbose, but you could simplify that.
Here is what the previous for-each-hashtable-band example expands into with this new macro:
(with-hash-table-iterator (#:g1576 test)
(loop :named #:g1578
:do (loop :with #:g1575
and #:g1579
and #:g1577
:repeat 2
:do (multiple-value-setq (#:g1577 #:g1575 #:g1579) (#:g1576))
:while #:g1577
:collect #:g1575 into #:g1574
:collect #:g1579 into #:g1574
:finally (progn
(when #:g1574
(destructuring-bind
(k1 v1 k2 v2)
#:g1574
(format t "~a -> ~a && ~a -> ~a ~%" k1 v1 k2
v2)))
(unless #:g1577 (return-from #:g1578))))))
Each time you expand it, the #:gXXXX variables are different, and cannot possibly shadow existing bindings, so for example, the body can use variables named like current-band or value without breaking the expanded code.
I do the following code to retrieve only the keys of a plist:
(loop :for (key nil) :on config :by #'cddr
:collect key))
Running this produces:
CONFIG-TEST> (loop :for (key nil) :on '(:foo 1 :bar 2) :by #'cddr
:collect key)
(:FOO :BAR)
Is there a more 'functional' way to do this than using LOOP?
Not really...
CL-USER 35 > (let ((? nil))
(mapcon (lambda (l)
(when (setf ? (not ?))
(list (first l))))
'(:foo 1 :bar 2)))
(:FOO :BAR)
or maybe:
(defun mapncar (fn list &key (start 0) (n 1))
(loop for l = (nthcdr start list) then (nthcdr n l)
while l
collect (funcall fn (first l))))
CL-USER 61 > (mapncar #'identity '(a 1 b 2 c 3) :n 2)
(A B C)
CL-USER 62 > (mapncar #'identity '(a 1 b 2 c 3) :start 1 :n 2)
(1 2 3)
Using the SERIES package, scan-plist returns two series, one for the keys, the other for values:
(scan-plist '(:a 3 :b 2))
=> #Z(:A :B)
#Z(3 2)
You can rely on this to collect the first series as a list:
(collect 'list (scan-plist '(:a 3 :b 2)))
More generally, you may want to process the values in some way, so you would use mapping. For example, here is a plist-alist made with SERIES:
(defun plist-alist (plist)
(collect 'list
(mapping (((k v) (scan-plist plist))) (cons k v))))
What stylistic direction would do take us?
CL-USER> (do ((result (list) (cons (car plist) result))
(plist '(:foo 1 :bar 2) (cddr plist)))
((null plist) (reverse result)))
(:FOO :BAR)
By the way, I'd write the loop with less syntax, will this bite me?
CL-USER> (loop for key in '(:foo 1 :bar 2) by 'cddr
collecting key)
(:FOO :BAR)
If you are sure that none of the values are of type symbol, you could filter for symbols:
(remove-if-not #'symbolp '(:a 1 :b 2)) ;;=> (:A :B)
Much less efficient, but universersal:
filter for symbolp and getf-ability
(Only keys of a plist are getf-able from the plist, thus this is the check whether it is a key or not. However, a check, whether an element in a plist is symbolp is cheaper and removes most of the non-key values,
thus saving time and cost).
(defun get-plist-keys (plist)
(remove-if-not #'(lambda (x) (and (symbolp x) (getf plist x))) plist))
(get-plist-keys '(:a 1 :b 2 :c :d))
;; => (:A :B :C)
(ql:quickload :alexandria)
(mapcar #'car (alexandria:plist-alist '(:a 1 :b 2)))
;; => (:A :B)
To remove dependency of alexandria, define yourself plist-alist:
(defun plist-alist (l &optional (acc '()))
(cond ((null l) (nreverse acc))
(t (plist-alist (cddr l) (cons (cons (car l) (cadr l)) acc)))))
However, dependency on :alexandria should not be counted as dependency.
directly
Actyally, one could change plist-alist definition to obtain only the keys:
(defun plist-keys (l &optional (acc '()))
(cond ((null l) (nreverse acc))
(t (plist-keys (cddr l) (cons (car l) acc)))))
And likewise the values:
(defun plist-vals (l &optional (acc '()))
(cond ((null l) (nreverse acc))
(t (plist-vals (cddr l) (cons (cadr l) acc)))))
With the Serapeum library, which I consider as a second must-have just after Alexandria: use plist-keys :)
(serapeum:plist-keys '(:a 1 :b 2))
;; (:A :B)
https://github.com/ruricolist/serapeum/blob/master/REFERENCE.md#plist-keys-plist
Here's its implementation:
(defun plist-keys (plist)
"Return the keys of a plist."
(collecting*
(doplist (k v plist)
(collect k))))
It also has plist-values.
This question already has an answer here:
Unusual stack overflow when inserting nodes in binary tree
(1 answer)
Closed 3 years ago.
I was getting stack overflow with the following code, then I tried it in SBCL and it worked. Wondering what causes the difference there.
Specifically: While I do plan to move to SBCL at some point, can
this be made to work in CLISP?
(defvar *objs* nil) ; [1]
(defun parents (obj) (gethash :parents obj))
(defun obj (&rest parents) ; [2]
(let ((obj (make-hash-table)))
(push obj *objs*)
(setf (parents obj) parents)
obj))
(defun (setf parents) (val obj) ; [3]
(prog1 (setf (gethash :parents obj) val)
(make-precedence obj)))
(defun make-precedence (obj) ; [4]
(setf (gethash :preclist obj) (precedence obj))
(dolist (x *objs*)
(if (member obj (gethash :preclist x))
(setf (gethash :preclist x) (precedence x)))))
(defun precedence (obj) ; [5]
(delete-duplicates (traverse obj)))
(defun traverse (x) ; [6]
(cons x (mapcan #'traverse (gethash :parents x))))
;; [1] We'll store a list of objects we create in *obj*.
;; [2] Function to create an object, called like (setf scoundrel (obj)).
;; [3] Set an objects (multiple) parents & rebuild precedence list for all affected objs.
;; [4] Rebuild precedence list for obj, then for all affected objs.
;; [5] Returns a list of object and all its ancestors in precedence order as we define it.
;; (Can read it like (-> obj traverse delete-duplicates) if it helps)
;; [6] Cons an object to all its parents recursively; depth first search.
;; I pulled this out of labels in precedence above it for clarity & testability.
;; Source: PG's ANSI Common Lisp, Chapter 17, "Example: Objects".
Example - SBCL
(setf scoundrel (obj))
; #<HASH-TABLE :TEST EQL :COUNT 2 {1001A01893}>
(setf sc2 (obj scoundrel))
; #<HASH-TABLE :TEST EQL :COUNT 2 {1001A1F153}>
*objs*
; (#<HASH-TABLE :TEST EQL :COUNT 2 {1001A1F153}>
; #<HASH-TABLE :TEST EQL :COUNT 2 {1001A01893}>)
(parents scoundrel)
; NIL
; T
(parents sc2)
; (#<HASH-TABLE :TEST EQL :COUNT 2 {1001A01893}>)
; T
Example - GNU CLISP
(setf scoundrel (obj))
;; - Lisp stack overflow. RESET
*objs*
;; - Lisp stack overflow. RESET
It might be worth mentioning that I haven't studied the dual interpreted and compiled nature of lisp a lot yet. So far I've simply been using it as an interpreted language; by pasting the above functions into the clisp repl.
So I suspect that compiling all these functions could be one thing to consider. I note we can compile and compile-file, I can't see an operator which compiles all user defined functions though.
GNU CLISP prints the contents of the hash table by default. In your case, it contains circular structures.
Either set *PRINT-CIRCLE* to T, to enable printing circular structures without stack overflow.
> (setq *print-circle* t)
T
> *objs*
(#1=#S(HASH-TABLE :TEST FASTHASH-EQL (:PRECLIST . (#1#)) (:PARENTS . NIL)))
Or set *PRINT-ARRAY* and *PRINT-READABLY* to NIL, to disable printing the contents of the hash table.
> (setq *print-circle* nil *print-array* nil *print-readably* nil)
NIL
> *objs*
(#<HASH-TABLE :TEST FASTHASH-EQL :COUNT 2 #x000335098D40>)
Is it possible to define methods that dispatch on particular elements (such as the first) in a sequence? Is it possible to do this without using "fully general" predicate dispatch machinery?
I have a program below that rewrites an expression in propositional calculus in negative normal form (i.e. all negation appears before a variable). It also removes all connectives besides and and or and replaces them with equivalent definitions.
It heavily uses methods, but I don't think I'm using the object system to full effect.
I want to be able to have a bunch of separate defmethod cases for normalize and normalize-not based on the symbol 'and, 'or, 'not, 'imp, 'iff currently heading the expression.
In particular, I'd like to be able to write something similar to the following
(defmethod normalize-all ((exprs ('and list)))
`(and ,#normalize-all (cdr exprs)))
as a standalone definition governing what happens when exprs is a list with 'and as its car.
What I have now performs "top-level" type checks only and uses cond heavily in the body of functions.
(defmethod normalize-all ((exprs list))
(loop for x in exprs collecting (normalize x)))
(defmethod prepend-not-to-all ((exprs list))
(loop for x in exprs collecting (list 'not x)))
(defmethod normalize ((expr symbol))
expr)
(defmethod normalize-not ((expr symbol))
`(not ,expr))
(defmethod normalize ((expr cons))
(let
((head (car expr))
(tail (cdr expr)))
(cond
((eq head 'and)
`(and ,#(normalize-all tail)))
((eq head 'or)
`(or ,#(normalize-all tail)))
((eq head 'imp)
`(or
,(normalize `(not ,(first tail)))
,(normalize (second tail))))
((eq head 'iff)
`(and ,(normalize `(imp ,(first tail) ,(second tail)))
,(normalize `(imp ,(second tail) ,(first tail)))))
((eq head 'not)
(normalize-not (first tail))))))
(defmethod normalize-not ((expr cons))
(let
((head (car expr))
(tail (cdr expr)))
(cond
((eq head 'and)
`(or ,#(normalize-all (prepend-not-to-all tail))))
((eq head 'or)
`(and ,#(normalize-all (prepend-not-to-all tail))))
((eq head 'imp)
`(and
,(normalize (first tail))
,(normalize-not (second tail))))
((eq head 'iff)
`(or
(normalize-not `(imp ,(first tail) ,(second tail)))
(normalize-not `(imp ,(second tail) ,(first tail)))))
((eq head 'not)
(normalize (first tail))))))
(print (normalize '(iff a b)))
More generally, I'm trying to mimic one style of writing functions in Haskell that looks like the following, because the cases are easy to inspect.
f :: Int -> String -> Int
f 0 _ = ...
f 1 (x:xs) = ...
f n _ | n `mod` 2 == 0 = ...
| otherwise = ...
The pattern appearing before the pipe is based on the structure of the types involved. Ints have no structure (n+k patterns don't count are gone anyway), so we can only match on particular integers, ignore the integer with _ or capture it with a variable.
Arbitrary boolean-valued expressions can appear after the | and control whether the definition on the rhs is in effect or not. (n `mod` 2 == 0 checks whether a number is even, otherwise is just True but reads better).
Cases that are textually earlier always have precedence over ones that are textually later. And f is closed in the sense that all components of its definition must appear at the definition site.
There's not built in way to do this. If you want to mimic the Haskell style, you could use a pattern matching library such as Trivia. It doesn't allow you to write the clauses in separate top-level forms though.
;; Dependencies: (ql:quickload '(:fare-quasiquote :trivia :trivia.quasiquote))
(defpackage #:normalize
(:use #:cl #:named-readtables #:trivia)
(:export #:normalize #:imp #:iff))
(in-package #:normalize)
(in-readtable :fare-quasiquote)
(defun normalize-all (exprs)
(mapcar #'normalize exprs))
(defun prepend-not-to-all (exprs)
(mapcar (lambda (x) `(not ,x)) exprs))
(defun-ematch normalize (expr)
;; The body of DEFUN-EMATCH is a list of clauses starting with the
;; pattern and followed by a body of forms to execute when the
;; pattern matches the sole argument (formatted here for the sake of
;; readability with the pattern on the left and the body on the
;; right). The EMATCH variant signals an error if no pattern matches
;; the input.
((type symbol) expr)
(`(and ,#tail) `(and ,#(normalize-all tail)))
(`(or ,#tail) `(or ,#(normalize-all tail)))
(`(imp ,a ,b) `(or ,(normalize `(not ,a))
,(normalize b)))
(`(iff ,a ,b) `(and ,(normalize `(imp ,a ,b))
,(normalize `(imp ,b ,a))))
(`(not ,expr) (normalize-not expr)))
(defun-ematch normalize-not (expr)
((type symbol) `(not ,expr))
(`(and ,#tail) `(or ,#(normalize-all (prepend-not-to-all tail))))
(`(or ,#tail) `(and ,#(normalize-all (prepend-not-to-all tail))))
(`(imp ,a ,b) `(and ,(normalize a)
,(normalize-not b)))
(`(iff ,a ,b) `(or ,(normalize-not `(imp ,a ,b))
,(normalize-not `(imp ,b ,a))))
(`(not ,expr) (normalize expr)))
(normalize '(iff foo bar))
;=> (AND (OR (NOT FOO) BAR) (OR (NOT BAR) FOO))
Alternatively, you could have another generic function to handle lists. Something like
(defmethod normalize ((expression list))
(normalize-list (first expression)
(rest expression)))
(defmethod normalize-list ((operator (eql 'and)) arguments)
`(and ,#(normalize-all arguments)))
(defmethod normalize-list ((operator (eql 'or)) arguments)
`(or ,#(normalize-all arguments)))
;; ...
But that's going to get way more verbose than pattern matching.
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