After quite a while of studying CL and practising as a hobby in different small projects, I still have some blank areas on my personal CL map. Recently, I had a number of functions using all the same let construct and I thought of writing a macro which makes the code more concise:
(defmacro with-context (&body body)
`(let ((context (make-array 4 :element-type 'fixnum
:initial-contents '(0 1 2 3))))
,#body))
So that I can later define functions like (just as a minimal example):
(defun test-a ()
(with-context
(setf (aref context 3)
(+ (aref context 0) (aref context 1)))
context))
Now I was wondering if I could shorten the (aref context n) expressions with a macro/function like (context n).
(defun context (n)
(aref context n))
But the variable context is unknown at compile time, of course. I just don't know if I have a case of basic misunderstanding here or how I could tell lisp what I actually want. So, my question is basically if it is possible and if it is a good idea.
What's wrong with a local function?
(defmacro with-context (&body body)
`(let ((context (make-array 4 :initial-contents '(0 1 2 3))))
(flet ((context (n)
(aref context n)))
,#body)))
Setting, too:
(defmacro with-context (&body body)
`(let ((context (make-array 4 :initial-contents '(0 1 2 3))))
(flet ((context (n)
(aref context n))
((setf context) (new n)
(setf (aref context n) new)))
,#body)))
You could put a macrolet into your macro expansion:
(defmacro with-context (&body body)
(with-gensyms (i)
`(let ((context (make-array 4 …)))
(macrolet ((context (,i)
`(aref context ,,i)))
,#body))))
Some personal notes:
I dislike anaphoric macros, so I'd generally let the user define the name for the context. That would feel strange with the context macrolet though. I'd then maybe come to the conclusion that all I want is a make-standard-context function and keep using let. I think this is in line with the general guideline “be conventional”.
Related
Let's say I have a list:
((1 2 3) (8 4 7) (41 79 30) (0 8 5))
I want to do this:
(1+8+41+0 2+4+79+8 3+7+30+5) = (50 93 45)
I've found an ugly solution:
(defun nested+ (lst)
(let ((acc nil))
(dotimes (i (length (first lst)))
(push (apply #'+ (mapcar #'(lambda (a) (nth i a)) lst)) acc))
(reverse acc)))
It seems to work for my purposes, but I guess it is slow and un-lispy. What's the proper way?
One option is (apply #'mapcar #'+ list). Mapcar will consume as many lists as you give it and stop when it reaches the end of the shortest list.
The naive solution would be
(apply #'mapcar #'+ list)
However, as already pointed out e.g. here by stackoverflow and here by LispWorks, the call-arguments-limit of (in the worst case) 50 arguments applies to functions called by apply. And reduce is suggested instead.
Thus, I suggest:
(defun sum-all (lists)
(reduce #'(lambda (l1 l2) (mapcar #'+ l1 l2)) lists))
And indeed
(sum-all '((1 2 3) (8 4 7) (41 79 30) (0 8 5)))
;; (50 93 45)
Another option is to loop over your list of lists:
(defun sum-all (lists)
(loop
for list in lists
for result = (copy-list list) then (map-into result #'+ result list)
finally (return result)))
During the first iteration, the first list is copied. The resulting list is then used in successive iterations to hold the respective sums. At the end of the iteration, that result list is returned.
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'm new here, and I need help with a function that I'm writing in scheme.
Basically, it involves a search function that can work for either Breadth-First search or Depth-First Search. I think I got the Depth-First-Merge and Breadth-First Merge to work.
However, the problem is to modify the main Search to work as a "currying function" so that when algorithm-specific merge procedures (such as the depth-first-merge or the breadth-first-merge) are passed in as arguments, the search uses that specific type of search. The return
There's two files I have with it. Coins is okay, but search needs fixed. How do I modify the search function here to work as a curried version?
Here's my codes below. first one for search.ss. I made a search2 as an early attempt, but it didn't work. I need to make either search or search2 work as the curried search, (then delete the other). I'm not sure, but I think the merges and two searches are working.
;;;
;;; SEARCH:
;;; -- Non-curried version of generic search algorithm
;;; -- Can be customized for depth-first and breadth-first search
;;; -- You must convert it to a curried version so that
;;; - the function accepts 1 algorithm specific parameter and returns a function
;;; - that accepts 3 problem-specific parameters and returns a function
;;; - that accepths 1 instance specific parameter and performs the search
;;; -- The 5 parameters are described below
;;;
;;; Input:
;;; merge-queue
;;; -- algorithm specific
;;; -- procedure that takes a list of new paths and a queue
;;; and returns a new queue
;;; extend
;;; -- problem-specific
;;; -- procedure that takes a state and a list of visited states,
;;; and returns a list of states that are reachable in one move
;;; from the given state
;;; goal?
;;; -- problem-specific
;;; -- predicate that takes a state and returns true if the
;;; state is a goal state, false otherwise
;;; print-path
;;; -- problem-specific
;;; -- procedure that takes a state and prints out a state nicely
;;; init-state
;;; -- problem instance-specific
;;; -- an initial state to start the search from
;;;
;;; OUTPUT:
;;; -- When succeeded, a path from the initial state to a goal state
;;; -- When failed, #f
;;;
;;Either this or search2 needs to be rewritten into a curried version
;;To accept either depth-first-merge or breadth-first merge as merge procedures into merge-queue
(define search
(lambda (merge-queue init-config extend goal? print-state)
(letrec
((helper
(lambda (queue)
(newline)
(for-each
(lambda (p) (print-path p print-state))
queue)
(cond ((null? queue) #f)
((goal? (caar queue))
(print-state (caar queue))
(newline)
(let ((ans (reverse (car queue))))
(for-each (lambda (x) (print-state x) (newline)) ans)
ans))
(else
(let ((successors (extend (caar queue))))
(print-state (caar queue)) (newline)
(cond ((null? successors)
(helper (cdr queue)))
(else
(for-each (lambda (x) (print-state x) (newline))
successors)
(helper
(merge-queue (cdr queue)
(extend-path successors (car queue))))))))))))
(helper
(list (list (config->state init-config ))))))
(define search2
(lambda (merge-queue extend goal? print-path init-state)
(letrec
((search-helper
(lambda (queue visited)
(cond
((null? queue) #f)
((goal? (caar queue))
(begin
(print-path (car queue))
(car queue)))
(else
(let ((successors (extend (caar queue) visited)))
(cond
((null? successors)
(search-helper (cdr queue) visited))
(else
(let ((new-paths (extend-path successors (car queue))))
(search-helper
(merge-queue queue new-paths)
(cond
(merge-queue))
(append successors visited)))))))))))
(search-helper
(list (list init-state)) ; initial queue
(list init-state))))) ; initial visited
(define extend-path
(lambda (successors path)
(if (null? successors)
'()
(cons (cons (car successors) path)
(extend-path (cdr successors) path)))))
;; merge new extended paths to queue for depth first search
;; - uncomment and define your merge for depth first search
(define depth-first-merge
(lambda (queue paths)
(append! paths queue)))
;; merge new extended paths to queue for breadth first search
;; - uncomment and define your merge for breadth first search
(define breadth-first-merge
(lambda (queue paths)
(append! queue paths)))
;; customize the generic search for depth first search
;; - uncomment and define your depth-first-search in terms of your
;; curried version of search and depth-first-merge
;; Curry Methods are helpful to this.
(define depth-first-search (search depth-first-merge))
(lambda (extend goal? print-path)
(search (depth-first-merge extend goal? print-path))))
;; customize the generic search for breadth first search
;; - uncomment and define your breadth-first-search in terms of your
;; curried version of search and breadth-first-merge
(define breadth-first-search (search breadth-first-merge))
(lambda (extend goal? print-path)
(search (breadth-first-merge extend goal? print-path))))
And this is the Coins file code that is used to compliment the search code. They are in separate files and it loads search.ss (the above one) to work.
;; load algorithm specific code for search
(load "search.ss")
;;; Problem specific code for solving the old British coin problems
;;; using the curried version of the simple search procedure.
;;; The old British coin problem was discussed in the lecture.
;;;
;;; To solve the problem, load this file and run
;;; (coin-depth-first amount)
;;; or
;;; (coin-breadth-first amount)
;;; where, amount is replaced with some number, e.g., 48.
;;;
;;; Here, a state is represented as follows:
;;; (amount (coin1 coin2 ...))
;;;
;;; The car of the state represents how much change you need to pay further.
;;; The cadr of the state represents the combination of coins you used
;;; to pay so far. For example,
;;; (48 ())
;;; is the initial state for the amount of 48 cents and
;;; (0 (24 24)
;;; can be one of the goal states using two 24-cent coins.
;; There are 7 kinds of old British coins
(define old-british-coins '(120 30 24 12 6 3 1))
;; Or, you can do the same for US coins
(define us-coins '(100 50 25 10 5 1))
;; Here, we will do the old British coins
(define *coins* old-british-coins)
;; Is a state the goal state?
(define goal?
(lambda (state)
(zero? (car state))))
;; returns children of a state
(define extend
(lambda (state visited)
(let ((coins (applicable-coins state visited *coins*)))
(map
(lambda (coin)
(list (- (car state) coin)
(append (cadr state) (list coin))))
coins))))
;; find all applicable coins from a state
(define applicable-coins
(lambda (state visited coins)
(cond
((null? coins) '())
((<= (car coins) (car state))
(if (visited? state visited (car coins))
(applicable-coins state visited (cdr coins))
(cons (car coins) (applicable-coins state visited (cdr coins)))))
(else (applicable-coins state visited (cdr coins))))))
;; see if a state has been visited before
(define visited?
(lambda (state visited coin)
(cond
((null? visited) #f)
((= (- (car state) coin) (caar visited)) #t)
(else (visited? state (cdr visited) coin)))))
;; pretty-print a state
(define pretty-print-path
(lambda (path)
(pretty-print-state (car path))))
(define pretty-print-state
(lambda (state)
(let ((change (car state))
(coins (cadr state))
(total (apply + (cadr state))))
(printf
"===> Total of ~a paid with ~a, with remainder of ~a <===~%"
total coins change))))
;; customize the generic depth-first-search for coin problem
(define coin-depth-first-search
(depth-first-search extend goal? pretty-print-path))
;; instance of a coin problem using depth-first search
(define coin-depth-first
(lambda (amount)
(coin-depth-first-search (list amount '()))))
;; customize the generic breadth-first-search for coin problem
(define coin-breadth-first-search
(breadth-first-search extend goal? pretty-print-path))
;; instance of a coin problem with breadth-first search
(define coin-breadth-first
(lambda (amount)
(coin-breadth-first-search (list amount '()))))
Can someone please help me? I think all I need to get it to work is to find out how to make the search or search2 code become a curried version.
To curry a function means to redefine it in such a way that it takes a number of parameters less than the current definition and returns a new function that takes the rest of the parameters and perform the work of the first one. For instance, you can curry the following two-parameters summing function:
(define add
(lambda (a b)
(+ a b)))
(add 7 10) ;; => 17
in the following way:
(define add-to
(lambda (a)
(lambda (b)
(+ a b))))
((add-to 7) 10) ;; => 17
(define add-to-7 (add-to 7)) ;; we give a name to the function that add 7 to its argument
(add-to-7 8) ;; => 15
(add-to-7 9) ;; => 16
So, to transform the search2 function (you must extend that function since its last parameter is the problem instance specific one):
(define search2
(lambda (merge-queue extend goal? print-path init-state)
...body of search2...
as required, you could simply write something like this:
(define search2
(lambda (merge-queue)
(lambda (extend goal? print-path)
(lambda (init-state)
...body of search2...
and then, calling it with the correct number of parameters, you could obtain “partial” functions to be called later. For instance you can define a generic depth first search as:
(define depth-first-search (search2 depth-first-merge))
then you can define the depth first search specialized for the coin problem, given appropriate definitions for the coin functions:
(define coin-depth-first (depth-first-search coin-extend coin-goal? coin-print-path))
and finally you can call it with a certain amount to solve the problem:
(coin-depth-first 100)
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.
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)))))