Alpha-beta pruning in Common Lisp - artificial-intelligence

I tried coding Alpha-beta using the pseudocode found in Wikipedia. After the program reaches (EQ depth 0) it returns the heuristic value but depth continues deacreasing causing a cycle. Right now my code looks like this:
(defun ab(tab node depth a b)
(cond ((EQ depth 0) (calculaH tab))
((eq (mod depth 2) 0) (setq v -999999) (setq movimiento (sigMov depth node tab)) (loop while (not(null movimiento))
do (setq v (max v (ab (nth 3 movimiento) movimiento (- depth 1) a b)))
(setq a (max a v))
(cond((<= b a) (break))
(t (setq movimiento (sigMov depth movimiento tab))))) (return v))
(t (setq v 999999) (setq movimiento (sigMov depth node tab)) (loop while (not(null movimiento))
do (setq v (min v (ab (nth 3 movimiento) movimiento (- depth 1) a b)))
(setq a (min b v))
(cond((<= b a) (break))
(t (setq movimiento (sigMov depth movimiento tab))))) (return v))))
Should I increase depth value somwhere in my code? Why doesn´t the recursion increases the value by itself?

The alpha-beta prunning algorithm on Wikipedia can be translated in Lisp almost as-is. Since it uses infinite values, let's not hack around with "999999" but define min and max functions that work reliably with those special values:
(defpackage :alphabeta
(:use :cl)
;; custom min/max functions that support infinity
(:shadow min max))
(in-package :alphabeta)
(defvar -∞ '-∞ "Negative infinity symbol")
(defvar +∞ '+∞ "Positive infinity symbol")
(defun min (a b)
(cond
((eql a +∞) b)
((eql b +∞) a)
((eql a -∞) -∞)
((eql b -∞) -∞)
(t (cl:min a b))))
(defun max (a b)
(cond
((eql a -∞) b)
((eql b -∞) a)
((eql a +∞) +∞)
((eql b +∞) +∞)
(t (cl:max a b))))
The code also relies on auxiliary functions, which I declare here to avoid warnings:
;; You need to implement the followning functions
(declaim (ftype function terminal-node-p heuristic-value children))
Then, the pseudo-code can be written nearly identically:
(defun alphabeta (node depth α β maximizing-player-p)
(when (or (= depth 0) (terminal-node-p node))
(return-from alphabeta (heuristic-value node)))
(if maximizing-player-p
(let ((value -∞))
(dolist (child (children node))
(setf value (max value (alphabeta child (1- depth) α β nil)))
(setf α (max α value))
(when (<= β α)
;; β cut-off
(return)))
value)
(let ((value +∞))
(dolist (child (children node))
(setf value (min value (alphabeta child (1- depth) α β t)))
(setf α (min α value))
(when (<= β α)
;; α cut-off
(return)))
value)))
Never compare numbers with EQ. Use = if you expect to compare only numbers.
Always introduce local variables with let, never setq a variable which is not defined in current scope. Your code fails because your Lisp implementation define global variables the first time you call setq on unbound symbols. After that, you mutate global variables in your recursive code, which make it dysfunctional.
Do not have overlong lines (this is true in most languages), indent properly.
BREAK in Lisp enters the debugger. If you want to exit a loop early, use RETURN (this works because iteration constructs like DO introduce an anonymous BLOCK.

Related

Coloring N segments using M colors with dynamic programming

Problem: I have N contiguous segments numbered from 1 to N and M colors also numbered from 1 to M.
Now, there are two numbers U and V defined as:
U = color(i) + color(j)
V = color(j) + color(k)
U, V are coprime.
where 1 <= i,j,k <= N and
j = i+1, k=j+1
Problem is to find the number of ways that all N segments can be colored such that the above property holds for all i,j,k.
Is there a dynamic programming solution to this problem? What is it?
I have a recursive but non-[dynamic programming] implementation of this that should help get you pointed in the right direction. It's implemented in Common Lisp since there's no language specified.
The way to extend it to be a dynamic programming solution would be to add a cache.
count-all-coprime-triple-colorings constructs all the colorings in memory and then checks each of them for satisfying the coprime triple condition.
count-all-coprime-triple-colorings-lazy tries to aggressively prune the colorings we even consider by ruling out colorings with a prefix that doesn't satisfy the coprime condition.
This approach could be improved by noting that only the last two elements of the prefix are relevant, so you could use that to populate the cache.
(defun coprime-p (a b)
"check whether a and b are coprime"
(= (gcd a b) 1))
(defun coprime-triple-p (a b c)
"check whether (a+b) and (b+c) are coprime"
(coprime-p (+ a b) (+ b c)))
(defun coprime-triple-sequence-p (seq)
"check whether seq is a sequence of corpime triples"
(cond
;; if the length is less than 2 then
;; every triple is trivially coprime
((<= (length seq) 2) t)
(t (let
((a (nth 0 seq))
(b (nth 1 seq))
(c (nth 2 seq))
(tail (cdr seq)))
(if (coprime-triple-p a b c)
(coprime-triple-sequence-p tail)
nil)))))
(defun curry-cons (x)
"curried cons operator"
(lambda (list) (cons x list)))
(defun all-colorings (sections colors)
"generate all possible #colors-colorings of sections"
(assert (>= sections 0))
(assert (>= colors 1))
(cond
;; if there are no sections
;; then there are no colorings
((= sections 0) ())
;; when we have one section there is one coloring
;; for each color
((= sections 1) (loop for i from 1 upto colors collecting (list i)))
(t
;; wildly inefficient
(loop for i from 1 upto colors appending
(mapcar (curry-cons i) (all-colorings (1- sections) colors))))))
(defun count-all-coprime-triple-colorings (sections colors)
"count all the colorings that have coprime triples"
(loop for i in (all-colorings sections colors) counting (coprime-triple-sequence-p i)))
(defun coprime-triple-check-boundary (reversed-prefix suffix)
"prefix = [...a, b] ; suffix = [c,...] ; check
gcd(a+b, b+c) != 1"
;; if there aren't enough elements in reversed-prefix and suffix
;; then we admit the list
(if (and (nth 1 reversed-prefix) (nth 0 suffix))
(let
((b (nth 0 reversed-prefix)) (a (nth 1 reversed-prefix)) (c (nth 0 suffix)))
(coprime-triple-p a b c))
t))
(defun count-all-coprime-triple-colorings-lazy (sections colors reversed-prefix)
"count the number of sequences with coprime triples with a particular number
of sections and colors with a particular reversed-prefix."
(let
((sections-- (1- sections)))
(cond
((= sections 0) 1)
(t (loop for i from 1 upto colors summing
(if (coprime-triple-check-boundary reversed-prefix (list i))
(count-all-coprime-triple-colorings-lazy sections-- colors (cons i reversed-prefix))
0))))))
(defun summarize-coloring (i j)
"summarize the given coloring number"
(print (list "triples" i "colors" j
(count-all-coprime-triple-colorings-lazy i j nil))))
(loop for i from 1 upto 9 doing
(loop for j from 1 upto 9 doing (summarize-coloring i j)))

Implement a faster algorithm

I have been stuck on this question for days. Apparently I need to write a better algorithm to win the algorithm below. The below code is implemented from the famous Aima file. Is there any expert here who could guide me on how to win the algorithm?
(defun find-closest (list)
(x (car (array-dimensions list)))
(y (cadr (array-dimensions list)))
(let ((elems (aref list x y)))
(dolist (e elems)
(when (eq (type-of e) type)
(return-from find-closest (list x y)))) nil))
I tried implementing a DFS but failed and I do not quite know why. Below is my code.
(defun find-closest (list)
(let ((open (list list))
(closed (list))
(steps 0)
(expanded 0)
(stored 0))
(loop while open do
(let ((x (pop open)))
(when (finished? x)
(return (format nil "Found ~a in ~a steps.
Expanded ~a nodes, stored a maximum of ~a nodes." x steps expanded stored)))
(incf steps)
(pushnew x closed :test #'equal)
(let ((successors (successors x)))
(incf expanded (length successors))
(setq successors
(delete-if (lambda (a)
(or (find a open :test #'equal)
(find a closed :test #'equal)))
successors))
(setq open (append open successors))
(setq stored (max stored (length open))))))))
Looking at the code, the function find-some-in-grid returns the first found thing of type. This will, essentially, give you O(n * m) time for an n * m world (imagine a world, where you have one dirt on each line, alternating between "left-most" and "right-most".
Since you can pull out a list of all dirt locations, you can build a shortest traversal, or at least a shorter-than-dump traversal, by instead of picking whatever dirt you happen to find first you pick the closest (for some distance metric, from the code it looks like you have Manhattan distances (that is, you can only move along the X xor the Y axis, not both at the same time). That should give you a robot that is at least as good as the dumb-traversal robot and frequently better, even if it's not optimal.
With the provision that I do NOT have the book and base implementation purely on what's in your question, something like this might work:
(defun find-closest-in-grid (radar type pos-x pos-y)
(labels ((distance (x y)
(+ (abs (- x pos-x))
(abs (- y pos-y)))))
(destructuring-bind (width height)
(array-dimensions radar)
(let ((best nil)
((best-distance (+ width height))))
(loop for x from 0 below width
do (loop for y from 0 below height
do (loop for element in (aref radar x y)
do (when (eql (type-of element) type)
(when (<= (distance x y) best-distance)
(setf best (list x y))
(setf best-distance (distance x y))))))))
best)))

Binding LET variables to new values in CLisp

I'm trying to take the minimum and maximum values of a list and return them as a cons.
;;
;; Find minimum and maximum of a list
;;
(defun min-max (l)
(let ((n 0) (min 0) (max 0) (size (numAtomsInList l)))
(loop (when (= n (- size 1)) (return))
(cond
((> (nth n l) (nth (+ n 1) l))) (setq min 5) ;(nth n l))
((< (nth n l) (nth (+ n 1) l))) (setq max 7) ;(nth n l))
(t (setq max n))
)
(incf n)
)
(cons min max)
)
)
When running the function without the SETQs before the min & max variables it compiles fine, but I'm getting the result (0 . 0) - the original values that were set in the LET. With the SETQs, it's giving me the error:
Error: Attempt to take the value of the unbound variable `SETQ'.
How else would I change the value of min and max as I loop through the list? Why is it assuming that SETQ is a variable when syntactically it is correct?
I believe you are grouping the forms in the cond body incorrectly. cond clauses should look like (CONDITION BODY); you have
(cond
((> (nth n l) (nth (+ n 1) l)))
(setq min 5)
;; etc
)
Whereas you want
(cond
((> (nth n l) (nth (+ n 1) l))
(setq min 5))
;; etc
)
If you're coming from a Clojure background, you'll find that the grouping for many Common Lisp forms differ from their Clojure analogues.
To expand on the reason for the precise error you're seeing, if you have something like
(cond
(setq x y))
cond will try and evaluate setq as a value, not as a functiony thing (recall that in Common Lisp, symbols can have both a function and a value binding); it's the same as writing (when setq x y), and if we bind a value to setq we no longer get an unbound variable error.
? (let ((setq t) (x :x) (y :y)) (cond (setq x y)))
:Y
In addition to the issue pointed out by Huw, your code has a serious efficiency problem: it uses nth, which needs to walk the whole list each time; in effect, you are writing an algorithm that is quadratic. As a general rule of thumb, you should not use nth with a variable argument except if you really know what you are doing.
In order to be efficient, you should walk the input list sequentially and never start from the beginning. If, like me, you're an old fart, you can do that using a do loop:
(defun min-max (l)
(let ((min (car l)) (max (car l)))
(do ((l (cdr l) (cdr l)))
((null l) (cons min max))
(when (< (car l) min) (setq min (car l)))
(when (> (car l) max) (setq max (car l))))))
If you prefer, you can use the fancy loop thingie:
(defun min-max (l)
(let ((min (car l)) (max (car l)))
(loop for e in (cdr l)
do (when (< e min) (setq min e))
do (when (> e max) (setq max e)))
(cons min max)))
Or, Scheme-style, you can use tail recursion (and ignore the old Common Lisp programmers who tell you that it's not portable):
(defun min-max-3 (l)
(let ((min (car l)) (max (car l)))
(labels
((mm (l)
(cond ((null l) (cons min max))
(t (when (< (car l) min) (setq min (car l)))
(when (> (car l) max) (setq max (car l)))
(mm (cdr l))))))
(mm (cdr l)))))

Summing vectors with common lisp 'loop' macro

I need to implement something like this:
(loop for i from 1 to N sum (f i))
except that accumulated values are represent lists of numbers like (1 2 3)
and they are added element-wise. In other words I would like to initialize summation
with (zerov N) and use (v+) to add subsequent elements:
(defun v+ (a b) (mapcar '+ a b))
(defun zerov (n) (loop for i from 1 to n collect 0))
Is it possible to do something like this with loop macro? I can implement it as a
separate function, but I would like to use loop or loop-like macro for expressiveness.
Perhaps there is a way to define simple loop-like macro just for this case?
LOOP as defined in the Common Lisp standard is not extensible.
I would write it with the normal LOOP functionality:
(let ((result (zerov n)))
(loop for i from 1 to N
do (setf result (v+ result (f i))))
result)
The I would write it as a function:
(defun sum (n f init sum)
(let ((result (funcall init n)))
(loop for i from 1 to n
do (setf result (funcall sum result (funcall f i))))
result))
If you want such a functionality as a direct language feature of a loopy macro, then an alternative would be the ITERATE macro, which is more powerful than the LOOP macro and it is also extensible.
(loop with accum = (make-list n :initial-element 0)
for i from 1 to n
do (setq accum (v+ accum (f i)))
finally (return accum))
(reduce #'v+ (loop for i from 1 to n collect (f i))
:initial-value (zerov n))
Note that Common Lisp has proper "vector" (i.e., sequence of elements of homogeneous type allowing more compact representation and efficient random access), so perhaps,
(defun v+ (a b) (map-into a #'+ a b))
(defun zerov (n) (make-array n :initial-element 0))
(defun fn (i n) (let ((v (zerov n))) (setf (aref v i) 1) v))
(defun gn (n)
(loop for v = (zerov n) then (v+ v (fn i n)) for i below n
finally (return v)))

common lisp let binding

I have a function calculate binomial expansion with optional parameters to specify the beginning and ending term:
(defun comb-index (s k)
(let ((combinations nil))
(labels ((rec (s k offset entry)
(cond ((equal s k)
(push (reverse (loop
for i from 1 to s
do (push (1- (+ i offset)) entry)
finally (return entry)))
combinations))
((equal k 0)
(push (reverse entry) combinations))
(t (rec (1- s) (1- k) (1+ offset) (cons offset entry))
(rec (1- s) k (1+ offset) entry)))))
(rec s k 0 nil))
(nreverse combinations)))
(defun binomial (k &key (start 1) end)
(let ((b start)
(e (if (null end) k end)))
(labels ((rec (i)
(cond ((equal i e)
(comb-index k e))
(t
(append (comb-index k i) (rec (1+ i)))))))
(rec b))
)
)
When I compile and run this code, it will yield the following run time error:
Unhandled memory fault at #x18.
[Condition of type SB-SYS:MEMORY-FAULT-ERROR]
This is caused by e, but I'm not sure why. I can avoid this problem by assigning 'e' with either 'k' or 'end', or simply using a (when ... ) to set 'end' to 'k' if it's nil, but I'm not sure why this doesn't work.
Looks like a memory overflow...
Ever thought about the memory efficiency of your code?
The problem in the code isn't obvious; it just seems to be a real overflow. Is there any way you can adjust the memory available to the underlying Lisp system? Command line flags or something?
Do you have the option of implementing this in a language like Clojure that can create lazy sequences? As you are probably aware, this type of calculation has the potential to create extremely large results. I seem to recall something in one of the Clojure/contrib libraries that did just this calculation.

Resources