Hi I'm adapting the following UCI lisp code to common lisp.
This is the original function:
(DE MATCH-ARGS (PAT-ARGS CONST BINDING-FORM)
(LOOP ((INITIAL PAT-ARG NIL CONST-VAL NIL)
(WHILE (SETQ PAT-ARG (POP PAT-ARGS)))
(DO (SETQ CONST-VAL (FILLER:ROLE (ROLE:PAIR PAT-ARG) CONST)))
(WHILE (SETQ BINDING-FORM
(MATCH (FILLER:PAIR PAT-ARG)
CONST-VAL
BINDING-FORM)))
(RESULT BINDING-FORM]
Here's my current adaptation of it:
(defun match-args (pat-args const binding-form)
(loop (initial pat-arg nil const-val nil)
(while (setq pat-arg (pop pat-args)))
do (setq const-val (filler/role (role/pair pat-arg) const))
(while (setq binding-form
(match (filler/pair pat-arg)
const-val
binding-form)))
(result binding-form)))
Here's the error that it shows:
*** - LOOP: illegal syntax near (INITIAL PAT-ARG NIL CONST-VAL NIL) in
(LOOP (INITIAL PAT-ARG NIL CONST-VAL NIL) (WHILE (SETQ PAT-ARG (POP PAT-ARGS))) DO
(SETQ CONST-VAL (FILLER/ROLE (ROLE/PAIR PAT-ARG) CONST))
(WHILE (SETQ BINDING-FORM (MATCH (FILLER/PAIR PAT-ARG) CONST-VAL BINDING-FORM)))
(RESULT BINDING-FORM))
Please help. Match, filler/role, filler/pair and role/pair are all custom functions.
i would say it'd look something like this:
(defun match-args (pat-args const binding-form)
(loop for pat-arg in pat-args
for const-val = (filler/role (role/pair pat-arg) const)
do (setq binding-form
(match (filler/pair pat-arg)
const-val
binding-form))
while binding-form
collect binding-form))
it would be better if you could show the source of those functions (or at least their protocol), and input parameters example.
Related
The following code snippet compiles under SBCL 2.2.3 (using Emacs/SLIME, C-c C-k), and the .fasl is loaded without errors.
On a subsequent call to test-sets in the REPL, the value of *evens* is set to *all*. Reading the documentation I could find, I cannot figure out why this happens and why calling test-sets would result in nil. Thank you in advance to everyone reading and/or responding.
(defun get-n (n)
"Return a list of integers from 0 up to n-1"
(do ((i (1- n) (1- i))
(res nil (cons i res)))
((< i 0) res)))
(defun get-odd-n (n)
"Returns a list of odd integers from 1 up to n-1"
(do ((i (1- n) (1- i))
(res nil (if (oddp i)
(cons i res) res)))
((< i 0) res)))
(defun get-even-n (n)
"Returns a list of even integers from 0 up to n-1"
(do ((i (1- n) (1- i))
(res nil (if (evenp i)
(cons i res) res)))
((< i 0) res)))
(defconstant +n+ 10)
(defparameter *all* (get-n +n+))
(defparameter *odds* (get-odd-n +n+))
(defparameter *evens* (get-even-n +n+))
(defun test-sets ()
"After compiling and loading .fasl,
why is *evens* altered after calling test-sets?"
(and (equal (sort (intersection *evens* *all*) #'<) *evens*)
(equal (sort (intersection *odds* *all*) #'<) *odds*)
(equal (sort (union *odds* *evens*) #'<) *all*)
(equal (sort (set-difference *all* *odds* :test #'eql) #'<) *evens*)
(equal (sort (set-difference *all* *evens* :test #'eql) #'<) *odds*)))
The UNION result shares list structure with its inputs.
SORT is destructive.
->
SORT changes the list structure, incl. the list structure *evens* points to.
Solution:
Either: define a non-destructive SORT
Or: or copy the list which is the argument to SORT
(sort (copy-list ...) ...)
I am trying to make a 'pseudo OO system':
(defun bank-account ()
(let ((balance))
(labels ((init (x)
(setf balance x))
(increment (x)
(setf balance (+ balance x)))
(get-balance ()
balance))
(lambda (func)
(case func (init #'init)
(increment #'increment)
(get-balance #'get-balance))))))
(defparameter bank-account-object (bank-account))
(funcall (funcall bank-account-object 'init) 42)
(funcall (funcall bank-account-object 'increment) 10)
(funcall (funcall bank-account-object 'get-balance))
Q: are there better ways to accomplish the same without using CLOS, defstruct, or defmacro?
The problem that I see with this is that it is closed for extension, and I see no simple way to add extensibility.
Minor nitpick: that's not a bank-system but a bank-account. When you think about that further, it seems to me that the interesting part about this example domain has not been touched: double accounting, i. e. ensuring the null-sum invariant.
There are two sayings: a closure is a poor man's object, and an object is a poor man's closure. I have the feeling that you are more in the realm of the former here. However, it might be a good learning experience to think about this—as long as you don't put it into production somewhere…
;; The "class"
(defun create-bank-account ()
(let ((balance))
(labels ((init (x)
(setf balance x))
(increment (x)
(setf balance (+ balance x)))
(get-balance ()
balance))
(lambda (func)
(case func (init #'init)
(increment #'increment)
(get-balance #'get-balance))))))
;; The "methods"
(defun init-balance (object amount)
(funcall (funcall object 'init) amount))
(defun increment-balance (object amount)
(funcall (funcall object 'increment) amount))
(defun get-balance (object)
(funcall (funcall object 'get-balance)))
;; Example usage
(defparameter bank-account (create-bank-account))
(init-balance bank-account 42) ; => 42
(increment-balance bank-account 10) ; => 52
(get-balance bank-account) ; => 52
As mentioned in other answers, the resulting object might be hard to extend. That could be a feature, but one possible way to improve on it is to let it be redefined dynamically. You can even switch from classes to protoypes.
(ql:quickload :optima)
(defpackage :obj (:use :cl :optima))
(in-package :obj)
(defun make-object (&optional prototype)
(let ((properties (make-hash-table :test #'eq))
(self))
(flet ((resolve (key)
(or (gethash key properties)
(and prototype (funcall prototype :get key)))))
(setf self
(lambda (&rest args)
(optima:ematch args
((list :get :prototype) prototype)
((list :get key) (resolve key))
((list :set :prototype p)
(cerror "Continue" "Changing prototype object, are you sure?")
(setf prototype p))
((list :set key value)
(if value
(setf (gethash key properties) value)
(remhash key properties)))
((list :invoke method args)
(let ((resolved (resolve method)))
(if resolved
(apply resolved self args)
(funcall (or (resolve :no-such-method)
(error "No such method: ~a in ~a"
method
self))
self
method))))))))))
Some helper symbols:
;; call built-in command
(defmacro $ (obj method &rest args)
`(funcall ,obj ,method ,#args))
;; access property
(declaim (inline # (setf #)))
(defun # (o k) ($ o :get k))
(defun (setf #) (v o k) ($ o :set k v))
;; invoke method
(defun % (o m &rest a)
($ o :invoke m a))
A simple test
(let ((a (make-object)))
;; set name property
(setf (# a :name) "a")
;; inherit
(let ((b (make-object a)))
(print (list (# b :name)
;; shadow name property
(setf (# b :name) "b")
(# a :name)))
;; define a method
(setf (# a :foo) (lambda (self) (print "FOO")))
;; invoke it
(% a :foo)))
Bank account
(defun create-bank-account (&optional parent)
(let ((account (make-object parent)))
(prog1 account
(setf (# account :init)
(lambda (self x)
(setf (# self :balance) x)))
(setf (# account :increment)
(lambda (self increment)
(incf (# self :balance) increment))))))
(let ((account (create-bank-account)))
(% account :init 0)
(% account :increment 100)
(# account :balance))
100
I'm looking at the LispWorks Hyperspec on dotimes but I don't understand what the third variable [result-form] is doing. The examples are as follows:
(dotimes (temp-one 10 temp-one)) => 10
(setq temp-two 0) => 0
(dotimes (temp-one 10 t) (incf temp-two)) => T
temp-two => 10
The Hyperspec says
...Then result-form is evaluated. At the time result-form is
processed, var is bound to the number of times the body was executed.
Not sure what this is saying. Why is the third variable necessary in these two dotimes examples? I seem to be able to leave it out entirely in the second example and it works. My next example (not sure where I found it),
(defun thing (n)
(let ((s 0))
(dotimes (i n s)
(incf s i))))
Puzzles me as well. What use is s serving?
Since dotimes is a macro, looking at it's macro expansion can make things clearer:
Take your first example and expand it:
(pprint (MACROEXPAND-1 '(dotimes (temp-one 10 temp-one))))
I get the following output: (Yours may vary depending on the CL implementation)
(BLOCK NIL
(LET ((#:G8255 10) (TEMP-ONE 0))
(DECLARE (CCL::UNSETTABLE TEMP-ONE))
(IF (CCL::INT>0-P #:G8255)
(TAGBODY
#:G8254 (LOCALLY (DECLARE (CCL::SETTABLE TEMP-ONE))
(SETQ TEMP-ONE (1+ TEMP-ONE)))
(UNLESS (EQL TEMP-ONE #:G8255) (GO #:G8254))))
TEMP-ONE))
There's a lot going on, but the key thing to look at is that temp-one is bound to the value 0, and is returned as the expression's value (in standard lisp evaluation order).
Take the last example:
(pprint (macroexpand-1 '(dotimes (i n s) (incf s i))))
outputs:
(BLOCK NIL
(LET ((#:G8253 N) (I 0))
(DECLARE (CCL::UNSETTABLE I))
(IF (CCL::INT>0-P #:G8253)
(TAGBODY
#:G8252 (INCF S I)
(LOCALLY (DECLARE (CCL::SETTABLE I))
(SETQ I (1+ I)))
(UNLESS (EQL I #:G8253) (GO #:G8252))))
S))
As you can see S here is treated the same way as temp-one in the example before.
Try one without passing the last variable:
(pprint (macroexpand-1 '(dotimes (i n) (do-something i))))
and you get:
(BLOCK NIL
(LET ((#:G8257 N) (I 0))
(DECLARE (CCL::UNSETTABLE I))
(IF (CCL::INT>0-P #:G8257)
(TAGBODY
#:G8256 (DO-SOMETHING I)
(LOCALLY (DECLARE (CCL::SETTABLE I))
(SETQ I (1+ I)))
(UNLESS (EQL I #:G8257) (GO #:G8256))))
NIL))
Notice how NIL is the return value.
How do I go about finding the complete dependency tree for a given project in Common Lisp?
I've tried using (ql-dist:dependency-tree "my-project") which errors ((ql-dist:find-system "my-project") returns nil whether my system is loaded or not), and (slot-value (asdf/system:find-system "my-project") 'asdf/component:sideway-dependencies) seems to return only direct dependencies where I'm looking for the full tree (it also seems to return conditional/implementation-specific dependencies, such as sb-posix and sb-bsd-sockets, which I'd prefer to do without).
Is there a standard one-step way of doing this, or will I need to recursively walk the output of that sideway-dependencies slot and filter idiosyncratically?
Here's a crack at the solution:
Take 3 (this could probably be a its own project at this stage):
(defgeneric ->key (thing))
(defmethod ->key ((thing string))
(intern (string-upcase thing) :keyword))
(defmethod ->key ((thing symbol))
(if (keywordp thing)
thing
(intern (symbol-name thing) :keyword)))
(defgeneric dependencies-of (system))
(defmethod dependencies-of ((system symbol))
(mapcar #'->key (slot-value (asdf/system:find-system system) 'asdf/component:sideway-dependencies)))
(defun ordered-dep-tree (dep-tree)
(let ((res))
(labels ((in-res? (dep-name) (member dep-name res))
(insert-pass (remaining)
(loop for (dep . sub-deps) in remaining
for unmet-sub-deps = (remove-if #'in-res? sub-deps)
if (null unmet-sub-deps) do (push dep res)
else collect (cons dep unmet-sub-deps) into next-rems
finally (return next-rems))))
(loop for (dep . callers) in dep-tree for deps-of = (dependencies-of dep)
if (null deps-of) do (push dep res)
else collect (cons dep deps-of) into non-zeros
finally (loop while non-zeros
do (setf non-zeros (insert-pass non-zeros)))))
(reverse res)))
(defgeneric dependency-tree (system))
(defmethod dependency-tree ((system symbol))
(let ((res (make-hash-table)))
(labels ((rec (sys)
(loop with deps = (dependencies-of sys)
for dep in deps for dep-k = (->key dep)
unless (gethash dep-k res) do (rec dep)
do (pushnew (->key sys) (gethash dep-k res)))))
(rec system))
(ordered-dep-tree (alexandria:hash-table-alist res))))
That still doesn't filter for sb-*-style packages, but I figure I can do that in a separate pass. It seems to work though...
CL-USER> (dependency-tree :hunchentoot)
(:SB-BSD-SOCKETS :TRIVIAL-BACKTRACE :RFC2388 :SB-ROTATE-BYTE
:TRIVIAL-GARBAGE :TRIVIAL-FEATURES :CL-PPCRE :ALEXANDRIA :SB-POSIX
:CL-BASE64 :TRIVIAL-GRAY-STREAMS :USOCKET :MD5 :BABEL :FLEXI-STREAMS
:BORDEAUX-THREADS :CHUNGA :CFFI :CL-FAD :CL+SSL)
I think that's a list of all packages that need to be loaded before :hunchentoot, presented in an order they can be loaded (no package appears before all of its dependencies appear). It doesn't handle circular dependencies, but I don't think asdf does either, so...
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