For an assignment I have to create Towers of Hanoi in Common LISP with named discs. I need to get output that looks something like this:
[1]> (hanoi '(Small Medium Large))
Moved SMALL from Peg 1 to Peg 3
Moved MEDIUM from Peg 1 to Peg 2
Moved SMALL from Peg 3 to Peg 2
Moved LARGE from Peg 1 to Peg 3
Moved SMALL from Peg 2 to Peg 1
Moved MEDIUM from Peg 2 to Peg 3
Moved SMALL from Peg 1 to Peg 3
NIL
[2]> peg1
NIL
[3]> peg2
NIL
[4]> peg3
(Small Medium Large)
Yet when I run the program I have created I get output like this:
[1]> (hanoi '(Small Medium Large))
Move SMALL from Peg 1 to Peg 2
Move SMALL from Peg 1 to Peg 2
Move NIL from Peg 2 to Peg 2
Move SMALL from Peg 1 to Peg 2
Move NIL from Peg 2 to Peg 1
Move NIL from Peg 2 to Peg 2
Move SMALL from Peg 1 to Peg 2
NIL
[2]> peg1
(Small Medium Large)
[3]> peg2
NIL
[4]> peg3
NIL
Here is my code:
(defvar *peg1* '())
(defvar *peg2* '())
(defvar *peg3* '())
(defun peg-name (peg)
(cond ((equal peg *peg1*) "Peg 1")
((equal peg *peg2*) "Peg 2")
((equal peg *peg3*) "Peg 3")))
(defun move-disk (from to)
(format t "Move ~a from ~a to ~a~%" (first from) (peg-name from) (peg-name to))
(push (pop from) to))
(defun transfer (n source aux dest)
(if (> n 0)
(progn
(transfer (1- n) source dest aux)
(move-disk source dest)
(transfer (1- n) aux source dest))))
(defun hanoi (disk-list)
(setq *peg1* disk-list)
(transfer (length disk-list) *peg1* *peg2* *peg3*))
The problem with the code is obviously the move-disk function, since it is just throwing away the result after it is called. But I am not sure how exactly I can determine which of the global variables I should be pushing and popping from. I've fiddled with using a large list to represent the tower and having the pegs be sublists in it, but I have the same problem of determining what part of the list to modify. Any help would be appreciated. I feel like I am at a complete dead end.
The code is easy to repair. But your solution is not the best style, since the pegs are global variables.
The main confusion in your code is between lists and variables. Macros like PUSH and POP are working over 'places', like symbol values, variables or object's slots. Using a list directly does not work as expected.
(defvar *peg1* '())
(defvar *peg2* '())
(defvar *peg3* '())
Make sure to compare the symbols, not the values.
(defun peg-name (peg)
(cond ((equal peg '*peg1*) "Peg 1")
((equal peg '*peg2*) "Peg 2")
((equal peg '*peg3*) "Peg 3")))
Since we pass symbols, we need to pop from and push to the symbol's values.
(defun move-disk (from to)
(let ((disc (pop (symbol-value from))))
(format t "Move ~a from ~a to ~a~%" disc (peg-name from) (peg-name to))
(push disc (symbol-value to))))
(defun transfer (n source aux dest)
(when (> n 0)
(transfer (1- n) source dest aux)
(move-disk source dest)
(transfer (1- n) aux source dest)))
Pass the symbols, not the lists. It is also useful to reset the other pegs.
(defun hanoi (disk-list)
(setq *peg1* disk-list)
(setq *peg2* '())
(setq *peg3* '())
(transfer (length disk-list) '*peg1* '*peg2* '*peg3*))
Test:
CL-USER 15 > (hanoi '(Small Medium Large))
Move SMALL from Peg 1 to Peg 3
Move MEDIUM from Peg 1 to Peg 2
Move SMALL from Peg 3 to Peg 2
Move LARGE from Peg 1 to Peg 3
Move SMALL from Peg 2 to Peg 1
Move MEDIUM from Peg 2 to Peg 3
Move SMALL from Peg 1 to Peg 3
NIL
CL-USER 16 > *peg3*
(SMALL MEDIUM LARGE)
CL-USER 17 > *peg1*
NIL
The "easy" fix is to use a vector of lists as your pegs, then pass the index of the peg you're manipulating.
That'd make your MOVE-DISK function something like:
(defun move-to (from to)
(push (pop (aref *pegs* from)) (aref *pegs* to))
The rest of the modifications should be pretty straight-forward with that as a base, I think.
The basic problem here is that all the functions are operating over the contents of the variables peg1 peg2 and peg3 instead of over the variables themselves. In the peg-name function we initially have peg2 and peg3 being both equals and eq since both are NIL so this kind of logic to give names doesn't work. Similarly, the push and pops are modifying the from and to variables inside move-disk but doing nothing to the global lists.
You need to find a different way to pass the list names around. Basically some sort of actual array or key->value map instead of the hardcoded variables so you can pass the keys around to modify the correct lists.
You could also consider a more purely functional solution that passes the name of the peg together with its contents (and using cons, car and cdr instead of push and pop). This would completely avoid the mutable assignment operators that are causing all the trouble.
First, if we just want to generate the movement sequence, we don't need to keep any internal state; the following is side-effect free:
(defun hanoi (disk-list)
(labels ((transfer (i source aux dest)
(when (< 0 i)
(transfer (1- i) source dest aux)
(move (1- i) source dest)
(transfer (1- i) aux source dest)))
(move (disk source dest)
(format t "Move ~A from Peg ~A to Peg ~A~%"
(elt disk-list disk) source dest)))
(transfer (length disk-list) 1 2 3)))
Example:
CL-USER> (hanoi '(small medium large))
Move SMALL from Peg 1 to Peg 3
Move MEDIUM from Peg 1 to Peg 2
Move SMALL from Peg 3 to Peg 2
Move LARGE from Peg 1 to Peg 3
Move SMALL from Peg 2 to Peg 1
Move MEDIUM from Peg 2 to Peg 3
Move SMALL from Peg 1 to Peg 3
Second, if we do want to keep track of the state changes, it's much preferable to keep the state in a single place instead of spreading it over many global variables:
(defun hanoi* (disk-list)
(let ((state (list disk-list nil nil)))
(labels ((transfer (i source aux dest)
(when (< 0 i)
(transfer (1- i) source dest aux)
(move (1- i) source dest)
(transfer (1- i) aux source dest)))
(move (disk source dest)
(format t "Move ~A from Peg ~A to Peg ~A~%"
(elt disk-list disk) (1+ source) (1+ dest))
(push (pop (elt state source)) (elt state dest))
(show state))
(show (state)
(format t "~{ |~{~A~}~%~}" (mapcar #'reverse state))))
(show state)
(transfer (length disk-list) 0 1 2))))
Example:
CL-USER> (hanoi* '(#\▂ #\▄ #\█))
|█▄▂
|
|
Move ▂ from Peg 1 to Peg 3
|█▄
|
|▂
Move ▄ from Peg 1 to Peg 2
|█
|▄
|▂
Move ▂ from Peg 3 to Peg 2
|█
|▄▂
|
Move █ from Peg 1 to Peg 3
|
|▄▂
|█
Move ▂ from Peg 2 to Peg 1
|▂
|▄
|█
Move ▄ from Peg 2 to Peg 3
|▂
|
|█▄
Move ▂ from Peg 1 to Peg 3
|
|
|█▄▂
Related
Simple program for binary search.
elements contain no. of elements
then array contains those elements
then q contains no. of queries
search contains element to be searched.
Why this error is coming about high and low has no value after some iterations.
Kindly help :)
My Code :-
(setf elements (parse-integer (read-line)))
(setf array (make-array elements :fill-pointer 0))
(dotimes (i elements) (vector-push (parse-integer (read-line)) array))
(setf q (parse-integer (read-line)))
(defvar *mid*)
(dotimes (i q)
(setf search (parse-integer (read-line)))
(do ((low 0)
(high (- elements 1))
(mid (floor (+ low high) 2)
(floor (+ low high) 2)))
((>= low high) (setf *mid* nil))
(cond
((eql (elt array mid) search) (setf *mid* mid))
((< (elt array mid) search) (setf high (- mid 1)))
(t (setf low (+ mid 1)))))
(format t "~a" *mid*))
Your code is a fine example of an old adage:
the determined Real Programmer can write FORTRAN programs in any language.
Unfortunately Lisp programmers are generally quiche-eating hippies: so here is one quiche-eater's solution to this problem, using notions not present when FORTRAN IV was handed down to us from above on punched stones. These notions are therefore clearly heretical, but nonetheless useful.
Assuming this is homework, you probably will not be able to submit this answer.
Reading the data
First of all we'll write some functions which read the specification of the problem from a stream or file. I have inferred what it is from your code.
(defun stream->search-spec (stream)
;; Read a search vector from a stream: return a vector to be searched
;; and a vector of elements to search for.
;;
;; This function defines what is in files: each line contains an
;; integer, and the file contains a count followed by that many
;; lines, which specifies first the vector to be searched, and then
;; the things to search for.
;;
;; This relies on PARSE-INTEGER & READ-LINE to puke appropriately.
(flet ((read-vector ()
(let* ((elts (parse-integer (read-line stream)))
(vec (make-array elts :element-type 'integer))) ;won't help
(dotimes (i elts vec)
(setf (aref vec i) (parse-integer (read-line stream)))))))
(values (read-vector) (read-vector))))
(defun file->search-spec (file)
;; Read a search vector from a file. This is unused below but is
;; useful to have.
(with-open-file (in file)
(stream->search-spec in)))
(defun validate-sorted-vector (v)
;; check that V is a sorted vector
(dotimes (i (- (length v) 1) v)
(unless (<= (aref v i) (aref v (1+ i)))
(return-from validate-sorted-vector nil))))
The last function is used below to sanity check the data, since the search algorithm assumes the vector is sorted.
The search function
This implements binary search in the same way yours tries to do. Rather than doing it with loops and explicit assignemnt it does it using a local recursive function, which is far easier to understand. There are also various sanity checks and optionally debugging output. In any implementation which optimises tail calls this will be optimised to a loop; in implementations which don't then there will be a few extra function calls but stack overflow problems are very unlikely (think about why: how big would the vector need to be?).
(defun search-sorted-vector-for (vector for &key (debug nil))
;; search a sorted vector for some value. If DEBUG is true then
;; print what we're doing. Return the index, or NIL if FOR is not
;; present.
(when debug
(format *debug-io* "~&* ~D:~%" for))
(labels ((search (low mid high)
(when debug
(format *debug-io* "~& ~10D ~10D ~10D~%" low mid high))
(if (<= low mid high)
;; more to do
(let ((candidate (aref vector mid)))
(cond ((= candidate for)
;; found it
mid)
((< candidate for)
;; look higher
(search (1+ mid) (floor (+ high mid 1) 2) high))
((> candidate for)
;; look lower
(search low (floor (+ low mid) 2) (1- mid)))
(t
;; can't happen
(error "mutant death"))))
;; low = high: failed
nil)))
(let ((high (1- (length vector))))
(search 0 (floor high 2) high))))
Putting the previous two things together.
search-sorted-vector-with-search-vector will repeatedly search using the two vectors that the *->search-spec functions return. stream->search-results uses stream->search-spec and then calls this on its values. file->search-results does it all from a file.
(defun search-sorted-vector-with-search-vector (vector searches &key (debug nil))
;; do a bunch of searches, returning a vector of results.
(let ((results (make-array (length searches))))
(dotimes (i (length searches) results)
(setf (aref results i) (search-sorted-vector vector (aref searches i)
:debug debug)))))
(defun stream->search-results (stream &key (debug nil))
;; Read search specs from a stream, and search according to them.
;; Return the vector of results, the vector being searched and the
;; vector of search specifications.
(multiple-value-bind (to-search search-specs) (stream->search-spec stream)
(when debug
(format *debug-io* "~&searching ~S~% for ~S~&" to-search search-specs))
(assert (validate-sorted-vector to-search) (to-search) "not sorted")
(values (search-sorted-vector-with-search-vector to-search search-specs
:debug debug)
to-search search-specs)))
(defun file->search-results (file &key (debug nil))
;; sort from a file
(with-open-file (in file)
(stream->search-results in :debug debug)))
Using it
Given a file /tmp/x.dat with:
9
1
10
100
101
102
103
200
201
400
6
10
102
200
1
400
99
then:
> (file->search-results "/tmp/x.dat" :debug t)
searching #(1 10 100 101 102 103 200 201 400)
for #(10 102 200 1 400 99)
* 10:
0 4 8
0 2 3
0 1 1
* 102:
0 4 8
* 200:
0 4 8
5 6 8
* 1:
0 4 8
0 2 3
0 1 1
0 0 0
* 400:
0 4 8
5 6 8
7 7 8
8 8 8
* 99:
0 4 8
0 2 3
0 1 1
2 1 1
#(1 4 6 0 8 nil)
#(1 10 100 101 102 103 200 201 400)
#(10 102 200 1 400 99)
You can see that the last search failed (99 is not in the vector).
I want to write a function in Racket which takes an amount of money and a list of specific bill-values, and then returns a list with the amount of bills used of every type to make the given amount in total. For example (calc 415 (list 100 10 5 2 1)) should return '(4 1 1 0 0).
I tried it this way but this doesn't work :/ I think I haven't fully understood what you can / can't do with set! in Racket, to be honest.
(define (calc n xs)
(cond ((null? xs) (list))
((not (pair? xs))
(define y n)
(begin (set! n (- n (* xs (floor (/ n xs)))))
(list (floor (/ y xs))) ))
(else (append (calc n (car xs))
(calc n (cdr xs))))))
Your procedure does too much and you use mutation which is uneccesary. If you split the problem up.
(define (calc-one-bill n bill)
...)
;; test
(calc-one-bill 450 100) ; ==> 4
(calc-one-bill 450 50) ; ==> 9
Then you can make:
(define (calc-new-n n bill amount)
...)
(calc-new-n 450 100 4) ; ==> 50
(calc-new-n 450 50 9) ; ==> 0
Then you can reduce your original implememntation like this:
(define (calc n bills)
(if (null? bills)
(if (zero? n)
'()
(error "The unit needs to be the last element in the bills list"))
(let* ((bill (car bills))
(amount (calc-one-bill n bill)))
(cons amount
(calc (calc-new-n n bill amount)
(cdr bills))))))
This will always choose the solution with fewest bills, just as your version seems to do. Both versions requires that the last element in the bill passed is the unit 1. For a more complex method, that works with (calc 406 (list 100 10 5 2)) and that potentially can find all combinations of solutions, see Will's answer.
This problem calls for some straightforward recursive non-deterministic programming.
We start with a given amount, and a given list of bill denominations, with unlimited amounts of each bill, apparently (otherwise, it'd be a different problem).
At each point in time, we can either use the biggest bill, or not.
If we use it, the total sum lessens by the bill's value.
If the total is 0, we've got our solution!
If the total is negative, it is invalid, so we should abandon this path.
The code here will follow another answer of mine, which finds out the total amount of solutions (which are more than one, for your example as well). We will just have to mind the solutions themselves as well, whereas the code mentioned above only counted them.
We can code this one as a recursive-backtracking procedure, calling a callback with each successfully found solution from inside the deepest level of recursion (tantamount to the most deeply nested loop in the nested loops structure created with recursion, which is the essence of recursive backtracking):
(define (change sum bills callback)
(let loop ([sum sum] [sol '()] [bills bills]) ; "sol" for "solution"
(cond
((zero? sum) (callback sol)) ; process a solution found
((< sum 0) #f)
((null? bills) #f)
(else
(apply
(lambda (b . bs) ; the "loop":
;; 1. ; either use the first
(loop (- sum b) (cons b sol) bills) ; denomination,
;; 2. ; or,
(loop sum sol bs)) ; after backtracking, don't!
bills)))))
It is to be called through e.g. one of
;; construct `the-callback` for `solve` and call
;; (solve ...params the-callback)
;; where `the-callback` is an exit continuation
(define (first-solution solve . params)
(call/cc (lambda (return)
(apply solve (append params ; use `return` as
(list return)))))) ; the callback
(define (n-solutions n solve . params) ; n assumed an integer
(let ([res '()]) ; n <= 0 gets ALL solutions
(call/cc (lambda (break)
(apply solve (append params
(list (lambda (sol)
(set! res (cons sol res))
(set! n (- n 1))
(cond ((zero? n) (break)))))))))
(reverse res)))
Testing,
> (first-solution change 406 (list 100 10 5 2))
'(2 2 2 100 100 100 100)
> (n-solutions 7 change 415 (list 100 10 5 2 1))
'((5 10 100 100 100 100)
(1 2 2 10 100 100 100 100)
(1 1 1 2 10 100 100 100 100)
(1 1 1 1 1 10 100 100 100 100)
(5 5 5 100 100 100 100)
(1 2 2 5 5 100 100 100 100)
(1 1 1 2 5 5 100 100 100 100))
Regarding how this code is structured, cf. How to generate all the permutations of elements in a list one at a time in Lisp? It creates nested loops with the solution being accessible in the innermost loop's body.
Regarding how to code up a non-deterministic algorithm (making all possible choices at once) in a proper functional way, see How to do a powerset in DrRacket? and How to find partitions of a list in Scheme.
I solved it this way now :)
(define (calc n xs)
(define (calcAssist n xs usedBills)
(cond ((null? xs) usedBills)
((pair? xs)
(calcAssist (- n (* (car xs) (floor (/ n (car xs)))))
(cdr xs)
(append usedBills
(list (floor (/ n (car xs)))))))
(else
(if ((= (- n (* xs (floor (/ n xs)))) 0))
(append usedBills (list (floor (/ n xs))))
(display "No solution")))))
(calcAssist n xs (list)))
Testing:
> (calc 415 (list 100 10 5 2 1))
'(4 1 1 0 0)
I think this is the first program I wrote when learning FORTRAN! Here is a version which makes no bones about using everything Racket has to offer (or, at least, everything I know about). As such it's probably a terrible homework solution, and it's certainly prettier than the FORTRAN I wrote in 1984.
Note that this version doesn't search, so it will get remainders even when it does not need to. It never gets a remainder if the lowest denomination is 1, of course.
(define/contract (denominations-of amount denominations)
;; split amount into units of denominations, returning the split
;; in descending order of denomination, and any remainder (if there is
;; no 1 denomination there will generally be a remainder).
(-> natural-number/c (listof (integer-in 1 #f))
(values (listof natural-number/c) natural-number/c))
(let handle-one-denomination ([current amount]
[remaining-denominations (sort denominations >)]
[so-far '()])
;; handle a single denomination: current is the balance,
;; remaining-denominations is the denominations left (descending order)
;; so-far is the list of amounts of each denomination we've accumulated
;; so far, which is in ascending order of denomination
(if (null? remaining-denominations)
;; we are done: return the reversed accumulator and anything left over
(values (reverse so-far) current)
(match-let ([(cons first-denomination rest-of-the-denominations)
remaining-denominations])
(if (> first-denomination current)
;; if the first denomination is more than the balance, just
;; accumulate a 0 for it and loop on the rest
(handle-one-denomination current rest-of-the-denominations
(cons 0 so-far))
;; otherwise work out how much of it we need and how much is left
(let-values ([(q r)
(quotient/remainder current first-denomination)])
;; and loop on the remainder accumulating the number of bills
;; we needed
(handle-one-denomination r rest-of-the-denominations
(cons q so-far))))))))
It's very simple program which just return the input as a list shuffled. I wrote this program in python. Now I want to convert this program to lisp code. but I couldn't. How do I write down this program in lisp?
def my_shuffle(a, b, c, d):
return [b, c, d, a]
I tried the following code but an error occur.
(defun my_shuffle (a b c d) (list b c d a))
Thee are several things here that I think that need to be pointing out. First the code that you presented is correct but do shuffle a list, present a new list of four algorithms that you pass, allways with the same order. First of all shuffle a sequence is:
generating a random permutation of a finite sequence
From wikipedia you can find several algorithms for that:
https://en.wikipedia.org/wiki/Fisher%E2%80%93Yates_shuffle
Also in the rosseta code there is an implementation of the knuth shuffle:
(defun nshuffle (sequence)
(loop for i from (length sequence) downto 2
do (rotatef (elt sequence (random i))
(elt sequence (1- i))))
sequence)
Then if you apply this in the repl:
CL-USER> (nshuffle (list 1 2 3 4))
(3 1 4 2)
CL-USER> (nshuffle (list 1 2 3 4))
(3 1 2 4)
Note Two different results on the same list!!! (also the same can happen, because is a random order)
In python there are build algorithms for that:
https://docs.python.org/3/library/random.html#random.shuffle
also in the Common lisp library Alexandria:
CL-USER> (ql:quickload :alexandria)
To load "alexandria":
Load 1 ASDF system:
alexandria
; Loading "alexandria"
(:ALEXANDRIA)
CL-USER> (alexandria:shuffle (list 1 2 3 4))
(3 2 4 1)
(defun my_shuffle (a b c d) (list b c d a))
The above code defines a function which will take 4 items and return a rearranged list of those 4 items. It can take input of 4 lists, 4 atoms, 4 numbers, 4 anything, but it cannot separate sublists present inside a single list.
What you can do is:
(defun my_shuffle (myList)
(list (second myList) (third myList) (fourth myList) (first myList)))
or
(defun my_shuffle (myList)
(list (cadr myList) (caddr myList) (cadddr myList) (car myList)))
or
(defun my_shuffle (myList)
(list (nth 1 myList) (nth 2 myList) (nth 3 myList) (nth 1 myList)))
car returns the first element of a list
cdr returns the tail of a list (part of the list following car of the list)
I have used combinations of car and cdr to extract the different elements of the list. Find that in your textbook.
first, second, third, fourth are relatively easy to use and do the same thing as car, cadr, caddr and cadddr
(nth x list) returns the (x+1)th item of the list, counting from zero.
So,
(nth 3 (list a b c d)) => d
(nth 0 (list a b c d)) => a
and so on.
In my little project I have two arrays, lets call them A and B. Their values are
#(1 2 3) and #(5 6 7). I also have two lists of symbols of identical length, lets call them C and D. They look like this: (num1 num2 num3) and (num2 num3 num4).
You could say that the symbols in lists C and D are textual labels for the values in the arrays A and B. So num1 in A is 1. num2 in A is 2. num2 in B is 5. There is no num1 in B, but there is a num3, which is 6.
My goal is to produce a function taking two arguments like so:
(defun row-join-function-factory (C D)
...body...)
I want it to return a function of two arguments:
(lambda (A B) ...body...)
such that this resulting function called with arguments A and B results in a kind of "join" that returns the new array: #(1 5 6 7)
The process taking place in this later function obtained values from the two arrays A and B such that it produces a new array whose members may be represented by (union C D). Note: I haven't actually run (union C D), as I don't actually care about the order of the symbols contained therein, but lets assume it returns (num1 num2 num3 num4). The important thing is that (num1 num2 num3 num4) corresponds as textual labels to the new array #(1 5 6 7). If num2, or any symbol, exists in both C and D, and subsequently represents values from A and B, then the value from B corresponding to that symbol is kept in the resulting array rather than the value from A.
I hope that gets the gist of the mechanical action here. Theoretically, I want row-join-function-factory to be able to do this with arrays and symbol-lists of any length/contents, but writing such a function is not beyond me, and not the question.
The thing is, I wish the returned function to be insanely efficient, which means that I'm not willing to have the function chase pointers down lists, or look up hash tables at run time. In this example, the function I require to be returned would be almost literally:
(lambda (A B)
(make-array 4
:initial-contents (list (aref A 0) (aref B 0) (aref B 1) (aref B 2))))
I do not want the array indexes calculated at run-time, or which array they are referencing. I want a compiled function that does this and this only, as fast as possible, which does as little work as possible. I do not care about the run-time work required to make such a function, only the run-time work required in applying it.
I have settled upon the use of (eval ) in row-join-function-factory to work on symbols representing the lisp code above to produce this function. I was wondering, however, if there is not some simpler method to pull off this trick that I am not thinking of, given one's general cautiousness about the use of eval...
By my reasoning, i cannot use macros by themselves, as they cannot know what all values and dimensions A, B, C, D could take at compile time, and while I can code up a function that returns a lambda which mechanically does what I want, I believe my versions will always be doing some kind of extra run-time work/close over variables/etc...compared to the hypothetical lambda function above
Thoughts, answers, recommendations and the like are welcome. Am I correct in my conclusion that this is one of those rare legitimate eval uses? Apologies ahead of time for my inability to express the problem as eloquently in english...
(or alternatively, if someone can explain where my reasoning is off, or how to dynamically produce the most efficient functions...)
From what I understand, you need to precompute the vector size and the aref args.
(defun row-join-function-factory (C D)
(flet ((add-indices (l n)
(loop for el in l and i from 0 collect (list el n i))))
(let* ((C-indices (add-indices C 0))
(D-indices (add-indices D 1))
(all-indices (append D-indices
(set-difference C-indices
D-indices
:key #'first)))
(ns (mapcar #'second all-indices))
(is (mapcar #'third all-indices))
(size (length all-indices)))
#'(lambda (A B)
(map-into (make-array size)
#'(lambda (n i)
(aref (if (zerop n) A B) i))
ns is)))))
Note that I used a number to know if either A or B should be used instead of capturing C and D, to allow them to be garbage collected.
EDIT: I advise you to profile against a generated function, and observe if the overhead of the runtime closure is higher than e.g. 5%, against a special-purpose function:
(defun row-join-function-factory (C D)
(flet ((add-indices (l n)
(loop for el in l and i from 0 collect (list el n i))))
(let* ((C-indices (add-indices C 0))
(D-indices (add-indices D 1))
(all-indices (append D-indices
(set-difference C-indices
D-indices
:key #'first)))
(ns (mapcar #'second all-indices))
(is (mapcar #'third all-indices))
(size (length all-indices))
(j 0))
(compile
nil
`(lambda (A B)
(let ((result (make-array ,size)))
,#(mapcar #'(lambda (n i)
`(setf (aref result ,(1- (incf j)))
(aref ,(if (zerop n) 'A 'B) ,i)))
ns is)
result))))))
And validate if the compilation overhead indeed pays off in your implementation.
I argue that if the runtime difference between the closure and the compiled lambda is really small, keep the closure, for:
A cleaner coding style
Depending on the implementation, it might be easier to debug
Depending on the implementation, the generated closures will share the function code (e.g. closure template function)
It won't require a runtime license that includes the compiler in some commercial implementations
I think the right approach is to have a macro which would compute the indexes at compile time:
(defmacro my-array-generator (syms-a syms-b)
(let ((table '((a 0) (b 0) (b 1) (b 2)))) ; compute this from syms-a and syms-b
`(lambda (a b)
(make-array ,(length table) :initial-contents
(list ,#(mapcar (lambda (ai) (cons 'aref ai)) table))))))
And it will produce what you want:
(macroexpand '(my-array-generator ...))
==>
#'(LAMBDA (A B)
(MAKE-ARRAY 4 :INITIAL-CONTENTS
(LIST (AREF A 0) (AREF B 0) (AREF B 1) (AREF B 2))))
So, all that is left is to write a function which will produce
((a 0) (b 0) (b 1) (b 2))
given
syms-a = (num1 num2 num3)
and
syms-b = (num2 num3 num4)
Depends on when you know the data. If all the data is known at compile time, you can use a macro (per sds's answer).
If the data is known at run-time, you should be looking at loading it into an 2D array from your existing arrays. This - using a properly optimizing compiler - should imply that a lookup is several muls, an add, and a dereference.
By the way, can you describe your project in a wee bit more detail? It sounds interesting. :-)
Given C and D you could create a closure like
(lambda (A B)
(do ((result (make-array n))
(i 0 (1+ i)))
((>= i n) result)
(setf (aref result i)
(aref (if (aref use-A i) A B)
(aref use-index i)))))
where n, use-A and use-index are precomputed values captured in the closure like
n --> 4
use-A --> #(T nil nil nil)
use-index --> #(0 0 1 2)
Checking with SBCL (speed 3) (safety 0) the execution time was basically identical to the make-array + initial-contents version, at least for this simple case.
Of course creating a closure with those precomputed data tables doesn't even require a macro.
Have you actually timed how much are you going to save (if anything) using an unrolled compiled version?
EDIT
Making an experiment with SBCL the closure generated by
(defun merger (clist1 clist2)
(let ((use1 (list))
(index (list))
(i1 0)
(i2 0))
(dolist (s1 clist1)
(if (find s1 clist2)
(progn
(push NIL use1)
(push (position s1 clist2) index))
(progn
(push T use1)
(push i1 index)))
(incf i1))
(dolist (s2 clist2)
(unless (find s2 clist1)
(push NIL use1)
(push i2 index))
(incf i2))
(let* ((n (length index))
(u1 (make-array n :initial-contents (nreverse use1)))
(ix (make-array n :initial-contents (nreverse index))))
(declare (type simple-vector ix)
(type simple-vector u1)
(type fixnum n))
(print (list u1 ix n))
(lambda (a b)
(declare (type simple-vector a)
(type simple-vector b))
(let ((result (make-array n)))
(dotimes (i n)
(setf (aref result i)
(aref (if (aref u1 i) a b)
(aref ix i))))
result)))))
runs about 13% slower than an hand-written version providing the same type declarations (2.878s instead of 2.529s for 100,000,000 calls for the (a b c d)(b d e f) case, a 6-elements output).
The inner loop for the data based closure version compiles to
; 470: L2: 4D8B540801 MOV R10, [R8+RCX+1] ; (aref u1 i)
; 475: 4C8BF7 MOV R14, RDI ; b
; 478: 4C8BEE MOV R13, RSI ; source to use (a for now)
; 47B: 4981FA17001020 CMP R10, 537919511 ; (null R10)?
; 482: 4D0F44EE CMOVEQ R13, R14 ; if true use b instead
; 486: 4D8B540901 MOV R10, [R9+RCX+1] ; (aref ix i)
; 48B: 4B8B441501 MOV RAX, [R13+R10+1] ; load (aref ?? i)
; 490: 4889440B01 MOV [RBX+RCX+1], RAX ; store (aref result i)
; 495: 4883C108 ADD RCX, 8 ; (incf i)
; 499: L3: 4839D1 CMP RCX, RDX ; done?
; 49C: 7CD2 JL L2 ; no, loop back
The conditional is not compiled to a jump but to a conditional assignment (CMOVEQ).
I see a little room for improvement (e.g. using CMOVEQ R13, RDI directly, saving an instruction and freeing a register) but I don't think this would shave off that 13%.
I have the following binary tree
A
/ \
B C
/ \
D E
represented as a list in Lisp (A 2 B 0 C 2 D 0 E 0) where the letters are node names and the numbers are the number of child nodes (0 for none, 1 one node, 2 two nodes). I need to find highest from root node to leaf depth of the tree (the depth of the binary tree that is) recursively. I'm pretty new to Lisp and I can't figure how to implement it. This is what I manage to come up with until now:
(defun depth (tree)
"Returns the depth of the argument tree."
(check-type tree list)
(if (= (second tree) 0)
0
(1+ (get-btree-max-depth (cddr tree)))))
(defun get-btree-max-depth (btree)
"Returns the maximum depth
of the argument tree."
(check-type btree list)
(if (= (second btree) 0)
0
(max (depth (cddr btree))
(get-btree-max-depth (cddr btree)))))
but it doesn't work properly. I also browsed similar postings but I didn't find anything useful that could help me. Could somebody give me a suggestion to help figure this out? Thank you!
P.S. This is part of a small project that I will present at University but also my own way of getting better in Lisp (I saw that many similar posts had questions asking if the posting is related to homework). :)
How about this one? No transformation of the tree needed.
(defun depth-rec (tree)
(labels ((depth-rec-aux (depth) ; self-recursive function
(if (null tree) ; no more nodes
depth ; -> return the current depth
(let ((n (second tree))) ; number of subnodes
(pop tree) (pop tree) ; remove the current node
(case n
(0 (1+ depth)) ; no subnode, 1+depth
(1 (depth-rec-aux (1+ depth))) ; one subnode, its depth+1
(2 (max (depth-rec-aux (1+ depth)) ; two subnodes, their max
(depth-rec-aux (1+ depth)))))))))
(depth-rec-aux 0))) ; start depth is 0
Another version:
(defun depth-rec (tree &aux (max 0))
(labels ((depth-rec-aux (depth)
(when tree
(pop tree)
(let ((n (pop tree)))
(if (zerop n)
(setf max (max max (1+ depth)))
(loop repeat n do (depth-rec-aux (1+ depth))))))))
(depth-rec-aux 0))
max)
I would first transform the list to a tree:
(defun tlist->tree (tlist)
"Transforms a tree represented as a kind of plist into a tree.
A tree like:
A
/ \
B C
/ / \
F D E
would have a tlist representation of (A 2 B 1 F 0 C 2 D 0 E 0).
The tree representation would be (A (B (F)) (C (D) (E)))"
(let (tree)
(push (pop tlist) tree)
(dotimes (i (pop tlist))
(multiple-value-bind (subnode rest-tlist) (tlist->tree tlist)
(push subnode tree)
(setf tlist rest-tlist)))
(values (nreverse tree) tlist)))
I wonder if you couldn't start with this tree representation to begin with.
Then, finding the depth of a tree in tree representation is a simple recursive one-liner.
Here's one in continuation-passing style:
(defun oddtree-height (oddtree)
(suboddtree-height oddtree
#'(lambda (h remainder)
(if (null remainder) h nil))))
(defun suboddtree-height (oddtree c)
(max-height-of-suboddtrees (cadr oddtree)
0
(cddr oddtree)
#'(lambda (h remainder)
(funcall c (+ h 1) remainder))))
(defun max-height-of-suboddtrees (n best oddtree c)
(if (= n 0)
(funcall c best oddtree)
(suboddtree-height oddtree
#'(lambda (h remainder)
(max-height-of-suboddtrees (- n 1) (max best h) remainder c)))))
Using Artelius's and Svante's answer I managed to solve the issue. Here is the code, perhaps it will be of some help to somebody else in need.
(defun btree-max-depth (btree)
"Returns the maximum depth
of the binary tree."
(check-type btree list)
(if (null btree)
0 ; the max depth of the members of ()
(max (depth (first btree))
(btree-max-depth (rest btree)))))
(defun depth (tree)
"Returns the depth of the argument TREE."
(if (atom tree)
0 ; an atomic tree has a depth of 0
(1+ (btree-max-depth tree))))
Thanks Artelius and Svante for your help!