I am developing a k-d tree in Lisp. I am writing a function that allows me to search a node in the k-d tree. This function is defined as follows:
(defmethod find-node ((kdt kdtree) target &key (key #'value) (test #'equal))
(unless (null (root kdt))
(find-node (root kdt) target :key key :test test)))
(defmethod find-node ((node kdnode) target &key (key #'value) (test #'equal))
(format t "Testing node ~a~%" (value node))
(format t "Result is ~a~%" (funcall test (funcall key node) target))
(if (funcall test (funcall key node) target)
node
(progn
(unless (null (left node))
(find-node (left node) target :key key :test test))
(unless (null (right node))
(find-node (right node) target :key key :test test)))))
I build up a tree with the following data: '((2 3) (5 4) (9 6) (4 7) (8 1) (7 2)). So now, I am using this function to find the node '(2 3).
(find-node kdt '(2 3))
With the format statements, I get this output:
Testing node (7 2)
Result is NIL
Testing node (5 4)
Result is NIL
Testing node (2 3)
Result is T
Testing node (4 7)
Result is NIL
Testing node (9 6)
Result is NIL
Testing node (8 1)
Result is NIL
NIL
So, as you can see, the node is found since the result of the test is T, however, the search continues and the result is NIL. Why doesn't this function return the node?
You might want to directly return a result, when you find something.
Use the following example to improve your code:
(defun find-it (item list)
(labels ((find-it-aux (item list)
(when list
(if (eql item (first list))
(return-from find-it (first list))
(find-it-aux item (rest list))))))
(find-it-aux item list)))
CL-USER 89 > (find-it 1 '(2 3 1 5))
1
CL-USER 90 > (find-it 1 '(2 3 5))
NIL
or
(defun find-it (item list)
(catch 'found-it
(find-it-aux item list)))
(defun find-it-aux (item list)
(when list
(if (eql item (first list))
(throw 'found-it (first list))
(find-it-aux item (rest list)))))
CL-USER 91 > (find-it 1 '(2 3 1 5))
1
CL-USER 92 > (find-it 1 '(2 3 5))
NIL
You can simplify things a little, and stop searching once you find an item, by defining a method for nil nodes and using or:
(defmethod find-node ((empty null) target &key &allow-other-keys)
nil)
(defmethod find-node ((node kdnode) target &key (key #'value) (test #'equal))
(if (funcall test (funcall key node) target)
node
(or (find-node (left node) target :key key :test test)
(find-node (right node) target :key key :test test))))
You could combine this with Rainer Joswig's answer, of course. For example, you could define an :around method for kdnode:
(defvar *searching* nil)
(defmethod find-node :around ((x kdnode) target &key &allow-other-keys)
(if *searching*
(let ((result (call-next-method)))
(when result
(throw 'found result)))
(let ((*searching* t))
(catch 'found
(call-next-method)))))
You could also place the catch block explicitly in the code. If you are sure you never initiate a search on a kdnode but always on kdtree instances, then you can put the catch around kdtree instead and get rid of the special variable *searching*.
Note that this example is only here to demonstrate methods. It makes the code a little bit "too clever"; I would probably implement the throw/catch behavior explicitly in practice.
The function keeps on testing nodes because it is recursive. If you descend left (find-node (left node) ...), than the search in the right branch is put on the stack (find-node (right node) ...). So, the nodes being tested are all because of the recursion. One way to solve this is to rewrite the function like this:
(defmethod find-node ((node kdnode) target &key (key #'value) (test #'equal))
(let ((left (unless (null (left node))
(find-node (left node) target :key key :test test)))
(right (unless (null (right node))
(find-node (right node) target :key key :test test)))
(this (funcall test (funcall key node) target)))
(if this
node
(if left
left
right))))
Related
I am studying NLP with Racket and Dr. Racket.
I am working with this code:
#lang racket
(define english-1
'((Initial (1))
(Final (9))
(From 1 to 3 by NP)
(From 1 to 2 by DET)
(From 2 to 3 by N)
(From 3 to 4 by BV)
(From 4 to 5 by ADV)
(From 4 to 5 by |#|)
(From 5 to 6 by DET)
(From 5 to 7 by DET)
(From 5 to 8 by |#|)
(From 6 to 7 by ADJ)
(From 6 to 6 by MOD)
(From 7 to 9 by N)
(From 8 to 8 by MOD)
(From 8 to 9 by ADJ)
(From 9 to 4 by CNJ)
(From 9 to 1 by CNJ)))
(define (getf x y)
(if (eq? (car x) y)
(cadr x)
(getf (cdr x) y)))
(define (initial-nodes network)
(list-ref (assoc 'Initial network) 1))
(define (final-nodes network)
(list-ref (assoc 'Final network) 1))
(define (transitions network)
(filter (lambda (x) (eq? (car x) 'From)) network))
(define (trans-node transition)
(getf transition 'From))
(define(trans-newnode transition)
(getf transition 'to))
(define (trans-label transition)
(getf transition 'by))
(define abbreviations
'((NP kim sandy lee)
(DET a the her)
(N consumer man woman)
(BV is was)
(CNJ and or)
(ADJ happy stupid)
(MOD very)
(ADV often always sometimes)))
(define (recognize network tape)
;; returns t if sucessfully recognizes tape - nil otherwise
(call/cc (lambda (return)
(define (recognize-next node tape network)
(if (and (null? tape) (member node (final-nodes network)))
(return #t) ; success
(for ([transition (transitions network)])
;; try each transition of the network
(when (equal? node (trans-node transition)) ; if it starts at the right node
(for ([newtape (recognize-move (trans-label transition) tape)])
;; try each possible new value of tape
(recognize-next (trans-newnode transition) newtape network))))))
(for ([initialnode (initial-nodes network)])
(recognize-next initialnode tape network))
null))) ; failed to recognize
(define (recognize-move label tape)
(if (or (eq? label (car tape))
(member (car tape) (assoc label abbreviations)))
(list (cdr tape))
(if (eq? label '|#|)
(list tape)
null)))
(require racket/trace)
(trace recognize-move)
(recognize-move english-1 '(hahaha))
The code seems to be mostly fine. However, I keep getting a error messaging related to the recognize-move function:
member: not a proper list: #f
And I thought I was dealing with lists... How can I solve this?
The problem is with this form:
(member (car tape) (assoc label abbreviations))
If assoc does not find anything the result is #f. (member 'anything #f) will not work. In Common Lisp false is the same as an empty list so member on false will work, but not in Scheme. You can perhaps make sure it's a list like this:
(member (car tape) (or (assoc label abbreviations) '()))
This is code translated from Common Lisp. In CL, nil is false and is also the empty list, (). In Racket, #f is false and is not the same as (). assoc wants to return false if it does not find a match: because of the way CL puns on false and the empty list, this means that (member ... (assoc ...)) will always work. In Racket it won't: you need to check to see if assoc failed to find a match.
I'm having trouble coding a tree search & replace algorithm. The input tree contains arbitrarily nested data items--eg, tree = (1 (2 3 (4 (5)) 6)), where 1 is the root, and each level down is embedded in parentheses. So 1 is at level#1; 2, 3, 4, 6 are at level#2 (under 1), and 5 is at level#3 (under 4). The entire tree is structured such that the car of any list is always a data item, which can be followed by other data items or subtrees. The problem is to find a data item in the tree matching (#'equal in my specific case) an input item, and replace the existing old item with a given new subtree--eg, (exchange subtree olditem tree ...). The tree therefore grows with each replacement. However, the search must proceed top-down in the tree, exchanging only the first such olditem found, and then exit.
Some observations?: 1) For binary trees, the search order (top-down visitation) is normally called level-order, the other possible search orders being preorder, inorder, and postorder, but my trees are not necessarily binary. 2) Something like a breadth-first-search algorithm might work, but the nodes are selected by tree traversal, rather than being generated. 3) The standard "substitute" function works only for sequences, not trees. 4) The "subst" function works for trees, but seems to traverse in a depth-first manner replacing all matching items, and has no :count keyword (like "substitute" does) to stop after the first replacement.
Any help coding or even framing a good approach would be appreciated. (Also curious why common-lisp does not have more "tree" functions for both lists and vectors.)
Maybe I shouldn't be doing this, cause you are supposed to do your homework yourself, but it would take me longer to explain what to do, than to show it.
Here is a breadth-first search and replace version:
(defun search-replace (item new-item lst)
(when (listp lst)
(let ((found-item (member item lst)))
(if found-item
(rplaca found-item new-item)
(some #'(lambda (sublst) (search-replace item new-item sublst)) lst) ))))
This function is destructive, i.e., it will modify the original list, because it uses rplaca, and it won't return the resulting list (you can add it at the end). You can also add other nice features, such as a test function (equal or whichever you need). It will work also with lists whose car is a sublist (in your example it's always an atom).
I hope it helps you get started.
#Leo. Like your concise solution--will have to study it for understanding. In the meantime here is another preliminary breadth-first search attempt:
(defun add-tree (newsubtree tree)
(let ((queue (make-array 0 :adjustable t :fill-pointer t))
(data (first newsubtree))
(index 0))
(vector-push-extend tree queue)
(loop until (= index (fill-pointer queue))
do (let ((current-node (elt queue index)))
(incf index)
(loop for child in (second current-node)
for i from 0
if (and (numberp child) (= child data))
do (setf (elt (second current-node) i) newsubtree)
(return-from add-tree tree)
else do (vector-push-extend child queue))))))
(add-tree '(2 (5 6)) '(0 ((1 (3 2 4)) 2)))
(0 ((1 (3 2 4)) (2 (5 6))))
Thanks for confirming my intuition that breadth-first was the way to approach this. (ps: this is not homework)
Here's a real breadth first search that actually does replace the shallowest leftmost occurrence. (Unfortunately #Leo's code, albeit slick, doesn't do that.)
For fun used a circular list as a queue:
(setf *print-circle* t)
(defun one-element-queue (item)
(let ((link (list item)))
(setf (cdr link) link)))
(defun enqueue (item &optional queue)
(cond ((null queue) (one-element-queue item))
(t (let ((new-link (cons item (cdr queue))))
(setf (cdr queue) new-link)))))
(defun enqueue-all (items &optional queue)
(dolist (item items queue) (setq queue (enqueue item queue))))
(defun dequeue (queue)
(cond ((eq queue (cdr queue)) (values (car queue) nil))
(t (let ((item (cadr queue)))
(setf (cdr queue) (cddr queue))
(values item queue)))))
(defun node-replace (new-item old-item node)
(let ((position (position old-item node :test #'equal)))
(when position (setf (nth position node) new-item))
position))
(defun tree-replace (new-item old-item tree)
(loop with queue = (enqueue tree) and node
while queue
do (multiple-value-setq (node queue) (dequeue queue))
until (node-replace new-item old-item node)
do (setq queue (enqueue-all (remove-if-not #'listp node) queue)))
tree)
(setq tree '(1 ((5 ((41))) 3 (4 (5)) 5)))
(print (tree-replace 42 5 tree))
I would like to get the position of any element in the list and get nil if the element isn't in the list. I did:
(defun myposition (letter list)
(cond
((atom list) nil)
((equal (car list) letter) 0)
((null (car list)) (myposition letter))
(t (1+ (myposition letter (cdr list)))) ) )
(myposition 'k '(g h i j k l)
4
(myposition 'p '(g h i j k l)
nil is not a number
When I replace ((atom list) nil) par ((atom list) 0), I get 6 instead nil
(myposition 'p '(g h i j k l)
6
In your first example, your function will recursively compute 1+1+1+1+0 = 4 to find the correct result.
In your second example, it will run through the whole list, add 1 per (non-matching) element, and finally add nil. So it actually computes 1+1+1+1+1+1+nil, which is incorrect since nil is not a number, hence the error message. If you replace nil by zero, it computes 1+1+1+1+1+1+0 which is wrong.
So your basic problem is that you recursively add 1 and, reaching the end of the list, you would like to throw away what you computed until then. But you have an addition pending which you cannot escape.
The easiest way is to change from a recursive to a tail-recursive solution, which is technically a plain goto. Here the addition is done by incrementing a variable, not by unwinding the call stack, which makes it easy to throw away the result from the previous additions and just return nil because there is no addition pending.
A (tail-)recursive solution could be:
(defun myposition (letter lst)
(labels ((sub (lst pos)
(cond
((null lst) nil)
((equal (car lst) letter) pos)
(t (sub (cdr lst) (1+ pos))))))
(if (atom lst) nil (sub lst 0))))
This will work in Common Lisp, but technically, if your implementation does no tail call optimisation, it might still blow the stack for large lists. That's why Common Lisp prefers iterative solutions, such as using the loop macro:
(defun myposition (letter lst)
(when (consp lst)
(loop for c in lst for i from 0
when (equal c letter) return i)))
I've been trying to build something similar to a breadth-first tree-like structure for a graph, which contains all possible paths from a given node. I didn't have problem with the algorithm as much as I do with some sort of error that pops up. Here's the relevant code below:
(set 'my-graph '((A (B C))
(B (D E))
(C (F G))
(D (E))
(E (H))
(F (H I))
(G (I))
(H (J))
(I (J))
(J ())))
(defun search-tree(graph traversed visited)
(cond
((null traversed) NIL)
(:else (let*
((new-visited (append visited (list (car traversed))))
(children (add-children graph (car traversed)
(append (cdr traversed) new-visited))))
(cond
((null children) (list (car traversed)))
(:else
(cons (car traversed)
(mapcar (lambda(x) (search-tree graph (list x) new-visited)) children)))
)
)
)
)
)
;;; Selects the node to pick returned children from
(defun add-children(graph node visited)
(cond
((null graph) NIL)
((equal (caar graph) node) (new-nodes (cadar graph) visited))
(:else (add-children (cdr graph) node visited))
)
)
;;; Returns new, unvisited nodes from the children of a node
(defun new-nodes(children visited)
(cond
((null children) NIL)
((member (car children) visited) (new-nodes (cdr children) visited))
(:else (cons (car children) (new-nodes (cdr children) visited)))
)
)
Function search tree is called as (search-tree my-graph '(A) '()) and it returns almost everything as I want correctly, but the first terminal node which is replaced with a # symbol (it should be (J)). What could be the problem in here? That's the returned value.
(A (B (D (E (H #))) (E (H (J)))) (C (F (H (J)) (I (J))) (G (I (J)))))
I've tried tracing the code, but I still don't understand why is the (J) list swapped in mid-recursion with a # symbol.
Usually I would guess that it has something to do with *print-level*.
This variable controls how deep nested lists are printed. Set it to a number for the level. Lists in a deeper level are replaced with a # character.
If setting that to NIL does not help, then you might also want to consult the Allegro CL manual - I can remotely remember that the IDE also has its own settings.
I have to program an object-oriented counter. First the function make-object should instantiate the objects a and b with internal state 0. Then the 'methods' :inc, :dec and :res (increase, decrease, reset) are called. It should look like this:
> (setq a (make-object) b (make-object))
...
> (funcall a :inc)
1
> (funcall a :inc)
2
> (funcall a :res)
0
> (funcall a :dec)
-1
> (funcall b :inc)
1
My solution so far looks like this:
(defun make-object ()
(let ((counter 0))
(list #'(lambda () (incf counter))
#'(lambda () (setf counter 0))
#'(lambda () (decf counter)))))
With
(setq a (make-object) b (make-object))
I can instantiate a and b and the methods are called with
(funcall (first a))
(funcall (second b))
(funcall (third a))
I tried the following to call the methods with ":inc" instead of "first":
(defun myfuncall (var fun)
(funcall ((cond ((equal fun ":inc") first)
((equal fun ":res") second)
((equal fun ":dec") third))
var)))
but there's the error
While compiling MYFUNCALL :
In the form (#1=(COND ((EQUAL FUN ":inc") FIRST)
((EQUAL FUN ":res") SECOND)
((EQUAL FUN ":dec") THIRD))
VAR), #1# is not a symbol or lambda expression.
[Condition of type CCL::COMPILE-TIME-PROGRAM-ERROR]
Can anyone help me please? How do I make funcall do the right thing for me?
Found the solution.
(defun make-object ()
(let ((count 0))
(lambda (msg)
(case msg
((:inc) (incf count))
((:dec) (decf count))
((:res) (setq count 0))))))
This does what I wanted.
That's almost working.
(defun myfuncall (var fun)
(funcall ((cond ((equal fun ":inc") first)
((equal fun ":res") second)
((equal fun ":dec") third))
var)))
There is an extra ( ... ) around the COND and the var form. You need to remove that.
Also first (etc) would be a variable reference. You need to call (first var).
Once you got that working, you may want to write your code differently. What if MAKE-OBJECT would return a single function and not a list of three functions. How could that work?
Next problem
((equal fun ":inc") 'first var)
Above makes no sense. You want to call the function FIRST on the result of var. This then would return a function, which then gets called via FUNCALL.