Lisp: rudimentary object-oriented counter - object

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.

Related

Searching an item in a k-d tree

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))))

Top-down tree search & replace

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))

How to get the last element of a list and return nil if the element isn't in the list

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)))

Scheme list of strings

my function in scheme looks like this
(define (func1 input)
(let kloop ((x 6))
(let ((act (string-copy (func2 input2))))
(if (eq? act "") (display "null") (display act))
(if (> x 0) (kloop (- x 1)))))))
func2 return some string which is stored in act. Now I have to create a list of all strings returned by this function. Here above, I am just displaying those strings. I tried different approaches, but nothing is working out. I tried using append and cons.
Please suggest.
Your last if is missing the else case, which is where one would expect the return value of the function to be.
You don't mention how you've tried to use append and cons, but a common pattern is to pass an accumulating parameter around in the loop:
(define (five input)
(let loop ((x 5) (outputs '()))
(if (> x 0)
(loop (- x 1) (cons input outputs))
outputs)))
> (five "yes")
'("yes" "yes" "yes" "yes" "yes")
You are calling func2 on input six times. Does it return a different value each time? If not, this works:
(define (func1 input)
(make-list 6 (func2 input)))
The question is a bit confusing, you should provide a sample of the expected output for a given input. And why the empty string is treated differently in your code? apparently the recursion should advance on the value of x, not the value of the string returned by func2. Also, why are you copying the string? seems unnecessary.
Assuming that the named let is used just for keeping track of the number of iterations, this solution seems aligned with your intent, as this will return a 6-element list of all strings returned by func2
(define (func1 input)
(let kloop ((x 6))
(if (zero? x)
'()
(cons (func2 input)
(kloop (- x 1))))))
But we can be smarter and use the named let to give a tail-recursive solution, which is more efficient:
(define (func1 input)
(let kloop ((x 6)
(acc '()))
(if (zero? x)
acc
(kloop (- x 1)
(cons (func2 input)
acc)))))

LISP - Modify String

I have to write a program that changes a string's vowels, consonants and other symbols into C, V respectively 0. I've done this but I wonder if there is a more efficient and elegant way to do it. Would appreciate input.
(defun string-to-list (string)
(loop for char across string collect char))
(defun is-vowel (char) (find char "aeiou" :test #'char-equal))
(defun is-consonant (char) (find char "bcdfghjklmnpqrstvwxyz" :test #'char-equal))
(defun letter-type (char)
(if (is-vowel char) "V"
(if (is-consonant char) "C"
"0")))
(defun analyze-word (word-string)
(loop for char across word-string collect (letter-type char)))
Moreover, I would like to make it a string, how could I do that? Should I define a function that would iterate through the list and make it a string or is it an easier way to do it?
(defun letter-type (char)
(cond ((find char "aeiou" :test #'char-equal) #\V)
((alpha-char-p char) #\C)
(t #\0)))
CL-USER> (map 'string #'letter-type "analyze-word")
"VCVCCCV0CVCC"
Just for the sake of the idea:
(defun multi-replace-if (sequence function &rest more-functions)
(map (type-of sequence)
(lambda (x)
(loop for f in (cons function more-functions)
for result = (funcall f x)
while (eql x result)
finally (return result)))
sequence))
(multi-replace-if "bcdfghjklmnpqrstvwxyz"
(lambda (x) (if (find x "aeiouy") #\v x))
(lambda (y) (declare (ignore y)) #\c))
"cccccccccccccccccccvc"

Resources