I've written an iterative deepening algorithm, it works except when I add cycle checking, the algorithm returns a deeper solution than it should. But when I don't check for cycles it does work correctly, but it takes too long. Can anyone please spot the bug?
(defun rec-depth-limited (problem node cutoff closed)
(if (= cutoff 0)
(if (funcall (problem-goalp problem) node)
node)
(if (visited-p node closed)
nil
(progn
;; when i remove the next line, it works correctly
(setf (gethash (node-state node) closed) t)
(loop for child in (expand node (problem-actions problem)) do
(let ((result (rec-depth-limited problem child (1- cutoff) closed)))
(if result
(return result))))))))
(defun iterative-deepening (problem)
"Iterative deepening search"
(let ((cutoff 0))
(loop
(format t "~%cut-off: ~A" cutoff)
(let ((solution (rec-depth-limited
problem
(make-node :state (problem-state problem))
cutoff
(make-hash-table :test #'equalp)))) ;solve problem up to cutoff
(if (null solution)
(incf cutoff);if solution is not found, increment the depth
(return solution))))))
(defun visited-p (node table)
"Checks if state in node was visited before by checking
if it exists in the table"
(nth-value 1 (gethash (node-state node) table)))
Edit: here is the expand function
(defun expand (node actions)
"Expands a node, returns a list of the new nodes"
(remove-if #'null (apply-actions node actions)));apply all actions on all nodes
(defun apply-actions (node actions)
"Applies all actions to a state, returns a list of new states"
(mapcan #'(lambda (action)
(mapcar #'(lambda (tile) (funcall action tile node))
(node-state node)))
actions))
This is one of the actions, they are all the same except for minor changes
(defun slide-right (tile node)
"slide the tile one cell to the right. returns nil if not possible,
otherwise returns a node with the new state"
(when (can-slide-right-p tile (node-state node));if can slide right
(and visualize (format t "~%slide ~A to the right" (tile-label tile)))
(let* ((newstate (mapcar #'copy-tile (node-state node)));copy the current state
(depth (node-depth node))
(newcol (incf (tile-col (find tile newstate :test #'equalp))));update state
(cost (1+ (node-cost node))))
(make-node :state newstate ;create new node with the new state
:parent node
:depth (1+ depth)
:action (concatenate 'string
"slide "
(tile-label tile)
" right" )
:cost cost))))
Predicates
(defun can-slide-right-p (tile state)
"returns T if the specified tile can be sled one cell to the right"
(let ((row (tile-row tile))
(end (+ (tile-col tile) (tile-length tile))) ;col at which tile ends after being sled
(orient (tile-orientation tile)))
(and (equal orient 'H)
(or (tile-is-mouse tile) (< end *board-w*))
(empty-cell-p row end state))))
(defun spans-cell-p (row col tile)
"returns T if the specified tile spans the specified cell"
(if (equal (tile-orientation tile) 'H)
(horizontally-spans-cell-p row col tile)
(vertically-spans-cell-p row col tile)))
(defun horizontally-spans-cell-p (row col tile)
"Tests if the specified horizontal tile spans the specified cell"
(let ((tile-col (tile-col tile))
(tile-row (tile-row tile))
(tile-len (tile-length tile)))
(and (= tile-row row) (>= col tile-col) (< col (+ tile-col tile-len)))))
(defun vertically-spans-cell-p (row col tile)
"Tests if the specified vertical tile spans the specified cell"
(let ((tile-col (tile-col tile))
(tile-row (tile-row tile))
(tile-len (tile-length tile)))
(and (= tile-col col) (>= row tile-row) (< row (+ tile-row tile-len)))))
A limited depth-first search with cycle detection may return a longer path when the first path that leads to the goal is longer than any other shorter path that includes the same state.
Let D be a goal state:
A -- B -- C -- D
\
C -- D
With a depth limit of 2, if the top branch is visited first, B and C will be visited and saved in the hash table. When the bottom branch is visited, it won't expand past C, because it was marked as visited.
A possible solution is to set the hash value to the minimum depth where the state was found. This makes the state known as visited for a certain depth and beyond, but it'll be possible to expand it again if visited with less depth.
(defun visited-p (node table)
(let ((visited-depth (gethash (node-state node) table)))
(and visited-depth
(>= (node-depth node) visited-depth))))
(defun set-visited (node table)
(let ((visited-depth (gethash (node-state node) table)))
(setf (gethash (node-state node) table)
(if visited-depth
(min visited-depth (node-depth node))
(node-depth node)))))
Related
I'm learning (common) Lisp, and as exercise, I want to implement 'xond', a cond macro, that transform this silly example:
(xond (= n 1) (setq x 2) (= n 2) (setq x 1))
into a if-else chain:
(if (= n 1) (setq x 2) (if (= n 2) (setq x 1)))
Currently, I have this macro:
(defmacro xond (&rest x) (if x (list 'progn (list 'if (pop x) (pop x)))))
that just expand the first two items in x:
(macroexpand '(xond (= x 1) (setq y 2)))
produce
(PROGN (IF (= X 1) (SETQ Y 2))) ;
Now I want to process all items in x, so I add a loop to produce a if-serie (a step toward if-else-version):
(defmacro xond (&rest x)
(loop (if x
(list 'progn (list 'if (pop x) (pop x)))
(return t))))
but then macro seems to stop working:
(macroexpand '(xond (= x 1) (setq y 2)))
T ;
What I'm missing here?
Edition
verdammelt's answer put me in the right track, and coredump's made me change my approach to an iterative one.
Now I'll implement (xond test1 exp1 test2 exp2) as:
(block nil
test1 (return exp1)
test2 (return exp2)
)
which can be done by iteration.
I'm writing this for my minimal Lisp interpreter; I have only implemented the most basic functions.
This is what I wrote. I'm using la to accumulate the parts of the output.
(defmacro xond (&rest x)
(let ((la '()))
(loop
(if x (push (list 'if (pop x) (list 'return (pop x))) la)
(progn (push 'nil la)
(push 'block la)
(return la)
)))))
with
(macroexpand '(xond (= x 1) (setq y 2) (= X 2) (setq y 1)))
result:
(BLOCK NIL
(IF (= X 2) (RETURN (SETQ Y 1)))
(IF (= X 1) (RETURN (SETQ Y 2)))
) ;
Second edition
Add a label to block and change return to return-from, to avoid conflict with other return inside arguments. Also changed push for append to generate code in the same orden as the parameters.
(defmacro xond (&rest x)
(let ((label (gensym)) (la '()) (condition nil) (expresion nil))
(setq la (append la (list 'block label)))
(loop
(if x
(setq la (append la (list
(list 'if (pop x) (list 'return-from label (pop x))))))
(return la)))))
So
(macroexpand '(xond (= x 1) (setq y 2) (= X 2) (setq y 1)))
now gives
(BLOCK #:G3187 (IF (= X 1) (RETURN-FROM #:G3187 (SETQ Y 2))) (IF (= X 2) (RETURN-FROM #:G3187 (SETQ Y 1))))
Some remarks
You do not need a progn when you only expand into a single if
The use of pop might be confusing for the reader (and the programmer too) since it mutates a place, maybe you want to start with a less imperative approach
Also, in that case I don't think a loop approach is helpful, because you need to nest the expressions that come after in the body inside a previously built form, and even though it can be done, it is a bit more complex to do that simply a recursive function or a "recursive" macro.
Here I explain both approach, starting with "recursive" macro (the quote here is because the macro does not call itself, but expands as call to itself).
Macro expansion fixpoint
If I had to implement xond, I would write a macro that expands into other calls to xond, until macroexpansion reaches a base case where there are no more xond:
(defmacro xond (&rest body)
(if (rest body)
(destructuring-bind (test if-action . rest) body
`(if ,test ,if-action (xond ,#rest)))
(first body)))
For example, this expression:
(xond (= n 1) (setq x 2) (= n 2) (setq x 1))
First macroexpands into:
(if (= n 1)
(setq x 2)
(xond (= n 2) (setq x 1)))
And eventually reaches a fixpoint with:
(if (= n 1)
(setq x 2)
(if (= n 2)
(setq x 1)
nil))
Be careful, you cannot directly use xond inside the definition of xond, what happens is that the macro expands as a call to xond, which Lisp then expands again. If you are not careful, you may end up with an infinite macroexpansion, that's why you need a base case where the macro does not expand into xond.
Macro calling a recursive function
Alternatively, you can call a recursive function inside your macro, and expand all the inner forms at once.
With LABELS, you bind xond-expand to a recursive function. Here this is an actual recursive approach:
(labels ((xond-expand (body)
(if body
(list 'if
(pop body)
(pop body)
(xond-expand body))
nil)))
(xond-expand '((= n 1) (setq x 2) (= n 2) (setq x 1))))
; => (IF (= N 1)
; (SETQ X 2)
; (IF (= N 2)
; (SETQ X 1)
; NIL))
Your xond macro ends with (return t) so it evaluates to t rather than your accumulated if expressions.
You could use loop's collect clause to accumulate the code you wish to return. For example: (loop for x in '(1 2 3) collect (* 2 x)) would evaluate to (2 4 6).
How about
(ql:quickload :alexandria)
(defun as-last (l1 l2)
`(,#l1 ,l2))
(defmacro xond (&rest args)
(reduce #'as-last
(loop for (condition . branch) in (alexandria:plist-alist args)
collect `(if ,condition ,branch))
:from-end t))
(macroexpand-1 '(xond c1 b1 c2 b2 c3 b3))
;; (IF C1 B1 (IF C2 B2 (IF C3 B3))) ;
;; T
alexandria's plist-alist was used to pair the arguments,
the intrinsic destructuring in loop used to extract conditions and branches.
The helper function as-last stacks lists together in the kind of
(a b c) (d e f) => (a b c (d e f)).
(reduce ... :from-end t) right-folds the sequence of the collected (if condition branch) clauses stacking them into each other using #'as-last.
Without any dependencies
('though, does alexandria even count as a dependency? ;) )
(defun pairs (l &key (acc '()) (fill-with-nil-p nil))
(cond ((null l) (nreverse acc))
((null (cdr l)) (pairs (cdr l)
:acc (cons (if fill-with-nil-p
(list (car l) nil)
l)
acc)
:fill-with-nil-p fill-with-nil-p))
(t (pairs (cdr (cdr l))
:acc (cons (list (car l) (cadr l)) acc)
:fill-with-nil-p fill-with-nil-p))))
(defun as-last (l1 l2)
`(,#l1 ,l2))
(defmacro xond (&rest args)
(reduce #'as-last
(loop for (condition branch) in (pairs args)
collect `(if ,condition ,branch))
:from-end t))
(macroexpand-1 '(xond c1 b1 c2 b2 c3 b3))
;; (IF C1 B1 (IF C2 B2 (IF C3 B3))) ;
;; T
The helper function pairs makes out of (a b c d e f) => ((a b) (c d) (e f)).
(:fill-with-nil-p determines in case of odd number of list elements, whether the last element would be listed (last-el) or (last-el nil) - in the latter case filled with nil).
I expanded the macro below to see how it worked and found myself a little confused.
(loop for i below 4 collect i)
expands to (I have cleaned it up a little for readability)
(block nil
(let ((i 0))
(declare (type (and number real) i))
(let* ((list-head (list nil))
(list-tail list-head))
(tagbody
sb-loop::next-loop
(when (>= i 4) (go sb-loop::end-loop))
(rplacd list-tail (setq list-tail (list i)))
(setq i (1+ i))
(print "-------") ;; added so I could see the lists grow
(print list-head)
(print list-tail)
(print "-------")
(go sb-loop::next-loop)
sb-loop::end-loop
(return-from nil (cdr list-head))))))
..and here is the output from running the above..
;; "-------"
;; (NIL 0)
;; (0)
;; "-------"
;; "-------"
;; (NIL 0 1)
;; (1)
;; "-------"
;; "-------"
;; (NIL 0 1 2)
;; (2)
;; "-------"
;; "-------"
;; (NIL 0 1 2 3)
;; (3)
;; "-------"
I just can't see where list-head is modified, I have to assume head and tail are eq and thus modifying one is modifying the other but could someone please break down what is happening on the rplacd line?
list-head and list-tail are initially the same (in the eq sense). list-head is a cons which cdr is the list being collected. list-tail points to the last cons in the list (except initially, see below).
To add an element to the end of the list, replacd modifies the cdr of list-tail to add a new cons, and list-tail is updated to point to the new cons.
When the loop terminates, the result is the cdr of list-head.
Why this complicated business with an extra cons? Because the list appending algorithm becomes easier when list-tail is always a pointer to the last cons of the list. But in the beginning, the empty list has no cons. So the trick is to make the list one cons longer.
Is there any simplier way to find the last element of an array in clojure except this function?
(fn [l] (if (empty? (rest l)) (first l) (recur (rest l))))
For vectors, use peek for constant time
user=> (peek [1 2 3 4 5])
5
For Java arrays,
user=> (let [a (to-array [1 2 3 4 5])] (aget a (dec (alength a))))
5
For a general collection, you can get the last item in linear time with last. It is defined similarly to what you have done.
user=> (source last)
(def
^{:arglists '([coll])
:doc "Return the last item in coll, in linear time"
:added "1.0"
:static true}
last (fn ^:static last [s]
(if (next s)
(recur (next s))
(first s))))
The simplest way is to use (last l) that works in linear time (http://clojure.github.io/clojure/clojure.core-api.html#clojure.core/last)
Another possibility is to reverse your collection and take the first element: ((comp first reverse) l). But that's rather slow as reverse returns a non-lazy sequence. Note: comp returns a composition of its arguments (functions) (http://clojure.github.io/clojure/clojure.core-api.html#clojure.core/comp)
You can also convert the collection to a vector first and then apply peek: ((comp peek vec) l). This should have a better performance.
Another one: determine the length of your collection and take the last element (#(nth % (dec (count %))) l).
These functions work for all collection types (e.g. vectors, lists, ...). There are no arrays per se in Clojure (except you want to use Java arrays).
I have a list of elements. Each element is structured as followed:
('symbol "string" int-score)
An example list:
(list (list 'object1 "wabadu" 0.5)
(list 'object2 "xezulu" 0.6)
(list 'object1 "yebasi" 0.5)
(list 'object1 "tesora" 0.2))
I want to retrieve the maximum values for a specific symbol. When I search with the symbol object2, I should get back:
('object2 "xezulu" 0.6)
If I search with object1, I should get back:
(('object1 "wabadu" 0.5) ('object1 "yebasi" 0.5))
I want to collect all the highest elements of a specific object. What I can do is this: assume that the above list is the list used below and that I'm searching for object1. I can retrieve all elements of a specific object:
(loop for element in list
when (equal 'object1 (first element))
collect element)
I can also retrieve one highest element of the list:
(loop for element in list
when (equal 'object1 (first element))
maximize (third element))
However, this will only return one element. What I want is all maximum elements. I've tried some combinations with collect and maximize, but my knowledge on the syntax is little. Is there a way to collect all the highest elements in a ‘simple’ function?
A sketch of a LOOP-based version:
(defun mymax (target list &aux result max)
(loop for (item name value) in list
when (eql item target)
do (cond ((or (null result)
(> value max))
(setf result (list (list item name value))
max value))
((= value max)
(push (list item name value) result))))
result)
This will create a hash-table with the keys being the symbols and the values being arranged in the way (maximum . (list of strings corresponding to maximum))
(let ((data (list (list 'object1 "wabadu" 0.5)
(list 'object2 "xezulu" 0.6)
(list 'object1 "yebasi" 0.5)
(list 'object1 "tesora" 0.2))))
(loop
:with table := (make-hash-table)
:for (item string num) :in data :do
(destructuring-bind (&optional max strings)
(gethash item table)
(cond
((or (null max) (< max num))
(setf (gethash item table) (list num (list string))))
((= max num)
(setf (cdr strings) (cons string (cdr strings))))))
:finally (return table)))
;; #<HASH-TABLE {1005C6BE93}>
;; --------------------
;; Count: 2
;; Size: 16
;; Test: EQL
;; Rehash size: 1.5
;; Rehash threshold: 1.0
;; [clear hashtable]
;; Contents:
;; OBJECT1 = (0.5 ("wabadu" "yebasi")) [remove entry]
;; OBJECT2 = (0.6 ("xezulu")) [remove entry]
I think your life would be later easier with this hash table then with the data structure you currently have.
You can do that by looping through the list once for selecting all the sublists with the right first elements and determining the maximum (you can use into to let loop accumulate multiple values), and then a second loop in the finally clause go through the selection and now select only those with the maximum score:
(loop for triple in *l*
for (key nil score) = triple
when (eq key 'object1)
collect triple into selection
and maximize score into max-score
finally (return (loop for triple in selection
when (eql (third triple) max-score)
collect triple)))
Edit: Alternatively, instead of a second loop, the delete function can be used here quite concisely:
(loop for triple in *l*
for (key name score) = triple
when (eq key 'object1)
collect triple into selection
and maximize score into max-score
finally (return (delete max-score selection
:test #'/=
:key #'third)))
The maximize returns only one element. You can sort all the list by the 3rd component and then gets the front one(s). Like this:
;;; suppose a copy of the data is stored in l
;; get all 'object1 and sort them
(setf l (sort (remove-if-not
(lambda (x) (equal (first x) 'object1)) l)
#'> :key #'third))
;; remove the ones with smaller value than the first one
(setf l (remove-if
(lambda (x) (< (third x) (third (first l)))) l))
Abstract your data to create basic building blocks; combine building blocks into your needed functionality:
(defun make-foo (type name score)
(list type name score))
(defun foo-type (foo) (elt foo 0))
;; ...
(defun make-foos (&rest foos)
foos)
(defun foos-find-if (foos predicate)
;; return all foos satisfying predicate
)
(defun foos-maximize (foos orderer)
;; return the maximum foo (any one)
)
(defun foos-find-if-maximized (foos)
(foos-find-if foos
(let ((max (foos-maximize foos #'foo-score)))
(lambda (foo)
(= (foo-score max) (foo-score foo))))))
Here is an approach by first saving symbol-list that only contains the lists with the search object. Then we can easily get the maximum value and remove those lists with a smaller value.
(defun foo (symbol list)
(let* ((symbol-list (remove-if-not #'(lambda (l) (eq (first l) symbol))
list))
(max (apply #'max (mapcar #'third symbol-list))))
(remove-if-not #'(lambda (l) (= (third l) max))
symbol-list)))
We can call it: (foo 'object1 l)
As a rule of thumb, if you are really wanting to boil down a list of things into a single result, there should be a nice way to do this with reduce.
And there is:
(defun collect-maxima-by-third (list)
(reduce
#'(lambda (max-list next-element)
(let ((max-value (third (first max-list)))
(next-value (third next-element)))
(cond ((< max-value next-value)
(list next-element))
((= max-value next-value)
(cons next-element max-list))
(t max-list)))) ; the greater-than case
(rest list)
:initial-value (list (first list))))
It's not perfect, as if you give it an empty list it will give you a list containing an empty list instead of just an empty list, but you can easily add a case for this if you think that will happen often.
This type of technique (maybe not this exact example) is detailed in various texts on functional programming; some Haskell texts do a particularly good job (Learn You a Haskell comes to mind).
Is it possible to generate n-sized permutations of a list using only the basic scheme constructs?
With define you can do it like this (without define the answer would be no, because you'll need to use recursion):
First define a function that takes a list of lists and a value and returns a list of lists where the given item has been prepended to each list in the original list of lists.
This can be done by writing a simple recursive function that uses cons to prepend the item to the first list (using car to get the first list) and then uses cons again to prepend the extended list to the result of calling the function on the other lists (i.e. on the cdr of the list of lists). If the list is empty (and thus doesn't have a car and cdr), return the empty list.
You'll also need a function that removes a given item from a list. This can also be done by defining a simple recursive function that takes an item and a list. At each step the `car´ of the given list should be prepended to the result of the recursive call if it is not equal to the item that is to be deleted. If it is equal, the result of the recursive call should be returned directly.
Further you'll need a function to concatenate lists. This can also be implemented recursively without too much trouble.
Then define a function that given a list of lists and an item calls the previous function with the item and each sublist as its argument.
Now define the a function that creates n-sized permutations. This function should take the number n and a list. If n is 0, it should return the empty list. Otherwise it should call itself recursively for each item x in the list with (- n 1) as the new value for n and the result of removing x from the list as the new value for the list. Then the results of the recursive calls should be concatenated.
This is an explanation of the code found in Rosetta, although, I have changed the variable names to help make it more readable, and added my explanation of the code below. I did check to see if the code works in DrRacket, and it does.
Before defining permute, two helper functions are required namely, seq and insert.
seq builds a list containing a sequence of numbers. For example (seq 0 3) -> (0 1 2 3).
The elements (numbers) in the list are used in the insert function to insert the carItem at various positions in the 'cdr' list.
(define (seq start end)
(if (= start end)
(list end) ; if start and end are the same number, we are done
(cons start (seq (+ start 1) end))
)
)
insert generates a list with the carItem inserted in the "n"th position of the cdrList. For example, (insert '(b c) 0 'a) -> '(a b c) and (insert '(b c) 2 'a) -> '(b c a).
(define (insert cdrList n carItem)
(if (= 0 n)
(cons carItem cdrList) ; if n is 0, prepend carItem to cdrList
(cons (car cdrList)
(insert (cdr cdrList) (- n 1) carItem))))
Finally, as for the main function permute, it uses insert and seq in a recursive manner.
For example, when plist = '(b,c) the lambda evals to the following:
; (map (lambda (n)
; (insert '(b c) n 'a))
; '(0 1 2)) -> output of seq function given n = 2, which is length of '(b c)
; '((a b c) (b a c) (b c a)) ---> will be the output
(define (permute mylist)
(if (null? mylist)
'(())
(apply append (map (lambda (plist)
(map (lambda (n)
(insert plist n (car mylist)))
(seq 0 (length plist))))
(permute (cdr mylist))))))
(permute '(a b c))
If the above nested lambdas makes your head spin (it did for me), find below, IMHO, a more readable "define" version, thanks to Matthias Felleisen:
(define (permute mylist)
(cond
[(null? mylist) '(())]
[else
(define (genCombinationsFor plist)
(define (combineAt n) (insert plist n (car mylist)))
(map combineAt (seq 0 (length plist))))
(apply append (map genCombinationsFor (permute (cdr mylist))))]))