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%.
Related
I am trying to understand how vector-set! is implemented. It looks to me like vector-set! is a special form - much like set! is. When I look at examples using vector-set! I see the following, desirable behavior (in guile).
(define test (lambda (v i) (vector-set! v i 0)))
(define v (make-vector 5 1))
v
$1 = #(1 1 1 1 1)
(test v 0)
v
$2 = #(0 1 1 1 1)
I can also do this (in guile)
(define test (lambda (v i) (vector-set! (eval v (interaction-environment)) i 0)))
(test (quote v) 3)
v
$21 = #(0 1 1 0 1)
Contrasting to the set! behavior:
(define a 1)
(define test2 (lambda b (begin (set! b 0) b)))
(test2 (quote a))
$26 = 0
a
$27 = 1
In this case, to my understanding the set! changes b to 0 (and not the 'evaluated" b (which should be a). The eval trick from above does not work here.
My question is: How is vector-set! implemented compared to set! (or set-variable-value!). Does vector-set! peak at it's first argument? Or something else? I have tried to look at some of scheme implementations but extracting the gist from the code is tricky. Perhaps someone has an explanation or a link to some (sicp style) scheme implementation.
The function vector-set! is a so-called primitive.
It is a function (not a special form), but it must be implemented within the runtime.
Note: A special form is a form that uses an evaluation order different from the order used in a normal application. Therefore if, cond, or and others are special forms.
Some implementations (I can't remember if Guile is one of them) has a function primitive? that can be used to test whether a function is a primitive or not.
> (primitive? vector-set!)
#t
In "some SICP-style Scheme implementation", where vector-set! would be handled by eval-vector-mutation, it could be
(define (eval-vector-mutation exp env)
; exp = (vector-set! vec idx val)
(let ((vec (eval (vector-mutation-vec exp) env))
(idx (eval (vector-mutation-idx exp) env))
(val (eval (vector-mutation-val exp) env)))
(begin
(set-car! (cddr (drop vec idx)) val) ; srfi-1 drop
vec)))
and make-vector handled by
(define (eval-vector-creation exp env)
; exp = (make-vector cnt val)
(let ((cnt (eval (vector-creation-cnt exp) env))
(val (eval (vector-creation-val exp) env)))
(cons 'vector ; tagged list
(cons cnt ; vector size
(make-list cnt val))))) ; srfi-1 make-list
Here vectors are represented by tagged lists in the underlying Scheme implementation (not the Scheme being defined), and its mutation primitives, like set-car!, are used to manipulate them. If your implementation language were C, say, you'd just use C arrays as your vectors representation, or perhaps a structure coupling an array with the additional pertinent info, like its size ,etc.
UPDATED: The code should compile now without errors or warnings. Sorry about the previous one. The problem I have now is that when a run (or with any other integer)
(NxNqueen-solver 10)
The function getqueencol will return nil because there are no queens on the board in the first place, hence there will be a (= number nil) in the queen-can-be-placed-here because tcol will be nil. I think this will happen everytime there is no queen in the row passed as argument to the queen-can-be-placed-here function.
Please share some advice on how to fix this problem. Thank you in advance.
Here is the code
(defvar *board* (make-array '(10 10) :initial-element nil))
(defun getqueencol (row n)
"Traverses through the columns of a certain row
and returns the column index of the queen."
(loop for i below n
do (if (aref *board* row i)
(return-from getqueencol i))))
(defun print-board (n)
"Prints out the solution, e.g. (1 4 2 5 3),
where 1 denotes that there is a queen at the first
column of the first row, and so on."
(let ((solutionlist (make-list n)))
(loop for row below n
do (loop for col below n
do (when (aref *board* row col)
(setf (nth row solutionlist) col))))
(print solutionlist)))
(defun queen-can-be-placed-here (row col n)
"Returns t if (row,col) is a possible place to put queen, otherwise nil."
(loop for i below n
do (let ((tcol (getqueencol i n)))
(if (or (= col tcol) (= (abs (- row i)) (abs (- col tcol))))
(return-from queen-can-be-placed-here nil)))))
(defun backtracking (row n)
"Solves the NxN-queen problem with backtracking"
(if (< row n)
(loop for i below n
do (when (queen-can-be-placed-here row i n)
(setf (aref *board* row i) 't)
(return-from backtracking (backtracking (+ row 1) n))
(setf (aref *board* row i) 'nil))
(print-board n))))
(defun NxNqueen-solver (k)
"Main program for the function call to the recursive solving of the problem"
(setf *board* (make-array '(k k) :initial-element nil))
(backtracking 0 k))
You say that you compiled your code. That can't be the case, since then you would have see the compiler complaining about errors. You want to make sure that you really compile the code and correct the code, such that it compiles without errors and warnings.
You might want to get rid of the errors/problems in the code (see Renzo's comment) and then look at the algorithmic problem. I makes very little sense to look into an algorithmic problem, when the code contains errors.
SETQ does not introduce a variable, the variable has to be defined somewhere
DEFVAR makes no sense inside a function.
Something like (let (x (sin a)) ...) definitely looks wrong. The syntax of LET requires a pair of parentheses around the bindings list.
RETURN-FROM takes as first argument the name of an existing block to return from. The optional second argument is a return value. Get the syntax right and return from the correct block.
in a call to MAKE-ARRAY specify the default value: (make-array ... :initial-element nil), otherwise it's not clear what it is.
The variable *board* is undefined
Style
in LOOP: for i to (1- n) is simpler for i below n
you don't need to quote NIL and T.
(if (eq foo t) ...) might be simpler written as (if foo ...). Especially if the value of foo is either NIL or T.
(if foo (progn ...)) is simply (when foo ...)
I'm not sure what you are doing to claim that your code compiles. It does not compile.
Every function has compiler warnings. You should check the compiler warnings and fix the problems.
(defun getqueencol (row)
"Traverses through the columns of a certain row
and returns the column index of the queen."
(loop for i below n
do (if (aref board row i)
(return-from getqueencol i))))
The compiler complains:
;;;*** Warning in GETQUEENCOL: N assumed special
;;;*** Warning in GETQUEENCOL: BOARD assumed special
Where is n defined? Where is board coming from?
(defun print-board (board)
"Prints out the solution, e.g. (1 4 2 5 3),
where 1 denotes that there is a queen at the first
column of the first row, and so on."
(let (solutionlist)
(setq solutionlist (make-list n)))
(loop for row below n
do (loop for col below n
do (when (aref board row col)
(setf (nth row solutionlist) col))))
(print solutionlist))
The LET makes no sense. (let (foo) (setq foo bar) ...) is (let ((foo bar)) ...).
Why is solutionlist not defined? Look at the LET... it does not make sense.
Where is n coming from?
(defun queen-can-be-placed-here (row col)
"Returns t if (row,col) is a possible place to put queen, otherwise nil."
(loop for i below n
do (let (tcol)
(setq tcol (getqueencol i)))
(if (or (= col tcol) (= (abs (- row i)) (abs (- col tcol))))
(return-from queen-can-be-placed-here nil))))
where is n coming from? The LET makes no sense.
(defun backtracking (row)
"Solves the NxN-queen problem with backtracking"
(if (< row n)
(loop for i below n
do (when (queen-can-be-placed-here row i)
(setf (aref board row i) 't)
(return-from backtracking (backtracking (+ row 1)))
(setf (aref board row i) 'nil))
(print-board board))))
Where is n coming from? Where is board defined?
(defun NxNqueen-solver (k)
"Main program for the function call to the recursive solving of the problem"
(let (n board)
(setq n k)
(setq board (make-array '(k k) :initial-element nil)))
(backtracking 0))
Why use setq when you have a let? The local variables n and board are unused.
MAKE-ARRAY expects a list of numbers, not a list of symbols.
I propose you use a basic Lisp introduction (Common Lisp: A Gentle Introduction to Symbolic Computation - free download) and a Lisp reference (CL Hyperspec).
I want to count the number of moves of the diskc. but Instead As a result I get something else.
(setq x 0)
(defun towersOfHanoi (n from to help)
(if (> n 0)
;progn evaluates multiple forms and returns the result from the last one.*/
(progn
(towersOfHanoi (- n 1) from help to)
(format t "~d ----> ~d~%" from to)
(towersOfHanoi (- n 1) help to from)
(+ 1 x)
)
))
;(towersOfHanoi 3 'A 'B 'C)
When I run it I get
(towersOfHanoi 3 'A 'B 'C)
A ----> B
A ----> C
B ----> C
A ----> B
C ----> A
C ----> B
A ----> B
1
why it is one instead of 7, I guess with every recursive call is resetting the value of x to 0 but, how can I get the number of moves of the disks. Thanks.
In lisp if takes at most three arguments; the condition, the form to evaluate when the condition is true, and the form to evaluate if it is false.
Se http://www.lispworks.com/documentation/HyperSpec/Body/s_if.htm for details.
In order to evaluate more than one form in a branch, you can use progn that evaluates multiple forms and returns the result from the last one.
Also, princ expects just one argument to be printed. In order to print several things at once, you may use format
In your case (remark also the placement of the parentheses):
(defun towersOfHanoi (n from to help)
(if (> n 0)
(progn
(towersOfHanoi (1- n) from to help)
(format t "~d ----> ~d~%" from to)
(towersOfHanoi (1- n) help to from))))
Having no false branch, you may also use when that can evaluate more than one form:
(defun towersOfHanoi (n from to help)
(when (> n 0)
(towersOfHanoi (1- n) from to help)
(format t "~d ----> ~d~%" from to)
(towersOfHanoi (1- n) help to from)))
In order to count the moves, you can use a local counting variable (introduced with let), and an inner working function (introduced with labels) that updates this variable:
(defun towers-of-hanoi (n &optional (from 1) (to 2) (help 3))
(let ((counter 0)) ; local variable
(labels ((towers-of-hanoi-core (n from to help) ; local function
(when (> n 0)
(towers-of-hanoi-core (1- n) from to help)
(incf counter)
(format t "~d ----> ~d~%" from to)
(towers-of-hanoi-core (1- n) help to from))))
(towers-of-hanoi-core n from to help)) ; leave work to inner function
(format t "Moves: ~d ~%" counter)))
Here, from, to, and help is made optional as well, defaulting to 1, 2, and 3.
Again: The details are found in the Hyperspec: http://www.lispworks.com/documentation/HyperSpec/Front/
I'm trying to solve this problem in a pure-functional way, without using set!.
I've written a function that calls a given lambda for each number in the fibonacci series, forever.
(define (each-fib fn)
(letrec
((next (lambda (a b)
(fn a)
(next b (+ a b)))))
(next 0 1)))
I think this is as succinct as it can be, but if I can shorten this, please enlighten me :)
With a definition like the above, is it possible to write another function that takes the first n numbers from the fibonacci series and gives me a list back, but without using variable mutation to track the state (which I understand is not really functional).
The function signature doesn't need to be the same as the following... any approach that will utilize each-fib without using set! is fine.
(take-n-fibs 7) ; (0 1 1 2 3 5 8)
I'm guessing there's some sort of continuations + currying trick I can use, but I keep coming back to wanting to use set!, which is what I'm trying to avoid (purely for learning purposes/shifting my thinking to purely functional).
Try this, implemented using lazy code by means of delayed evaluation:
(define (each-fib fn)
(letrec
((next (lambda (a b)
(fn a)
(delay (next b (+ a b))))))
(next 0 1)))
(define (take-n-fibs n fn)
(let loop ((i n)
(promise (each-fib fn)))
(when (positive? i)
(loop (sub1 i) (force promise)))))
As has been mentioned, each-fib can be further simplified by using a named let:
(define (each-fib fn)
(let next ((a 0) (b 1))
(fn a)
(delay (next b (+ a b)))))
Either way, it was necessary to modify each-fib a little for using the delay primitive, which creates a promise:
A promise encapsulates an expression to be evaluated on demand via force. After a promise has been forced, every later force of the promise produces the same result.
I can't think of a way to stop the original (unmodified) procedure from iterating indefinitely. But with the above change in place, take-n-fibs can keep forcing the lazy evaluation of as many values as needed, and no more.
Also, take-n-fibs now receives a function for printing or processing each value in turn, use it like this:
(take-n-fibs 10 (lambda (n) (printf "~a " n)))
> 0 1 1 2 3 5 8 13 21 34 55
You provide an iteration function over fibonacci elements. If you want, instead of iterating over each element, to accumulate a result, you should use a different primitive that would be a fold (or reduce) rather than an iter.
(It might be possible to use continuations to turn an iter into a fold, but that will probably be less readable and less efficient that a direct solution using either a fold or mutation.)
Note however that using an accumulator updated by mutation is also fine, as long as you understand what you are doing: you are using mutable state locally for convenience, but the function take-n-fibs is, seen from the outside, observationally pure, so you do not "contaminate" your program as a whole with side effects.
A quick prototype for fold-fib, adapted from your own code. I made an arbitrary choice as to "when stop folding": if the function returns null, we return the current accumulator instead of continuing folding.
(define (fold-fib init fn) (letrec ([next (lambda (acc a b)
(let ([acc2 (fn acc a)])
(if (null? acc2) acc
(next acc2 b (+ a b)))))])
(next init 0 1)))
(reverse (fold-fib '() (lambda (acc n) (if (> n 10) null (cons n acc)))))
It would be better to have a more robust convention to end folding.
I have written few variants. First you ask if
(define (each-fib fn)
(letrec
((next (lambda (a b)
(fn a)
(next b (+ a b)))))
(next 0 1)))
can be written any shorter. The pattern is used so often that special syntax called named let has been introduced. Your function looks like this using a named let:
(define (each-fib fn)
(let next ([a 0] [b 1])
(fn a)
(next b (+ a b))))
In order to get the control flowing from one function to another, one can in languages with supports TCO use continuation passing style. Each function gets an extra argument often called k (for continuation). The function k represents what-to-do-next.
Using this style, one can write your program as follows:
(define (generate-fibs k)
(let next ([a 0] [b 1] [k k])
(k a (lambda (k1)
(next b (+ a b) k1)))))
(define (count-down n k)
(let loop ([n n] [fibs '()] [next generate-fibs])
(if (zero? n)
(k fibs)
(next (λ (a next)
(loop (- n 1) (cons a fibs) next))))))
(count-down 5 values)
Now it is a bit annoying to write in style manually, so it could
be convenient to introduce the co-routines. Breaking your rule of not using set! I have chosen to use a shared variable fibs in which generate-fibs repeatedly conses new fibonacci numbers onto. The count-down routine merely read the values, when the count down is over.
(define (make-coroutine co-body)
(letrec ([state (lambda () (co-body resume))]
[resume (lambda (other)
(call/cc (lambda (here)
(set! state here)
(other))))])
(lambda ()
(state))))
(define fibs '())
(define generate-fib
(make-coroutine
(lambda (resume)
(let next ([a 0] [b 1])
(set! fibs (cons a fibs))
(resume count-down)
(next b (+ a b))))))
(define count-down
(make-coroutine
(lambda (resume)
(let loop ([n 10])
(if (zero? n)
fibs
(begin
(resume generate-fib)
(loop (- n 1))))))))
(count-down)
And a bonus you get a version with communicating threads:
#lang racket
(letrec ([result #f]
[count-down
(thread
(λ ()
(let loop ([n 10] [fibs '()])
(if (zero? n)
(set! result fibs)
(loop (- n 1) (cons (thread-receive) fibs))))))]
[produce-fibs
(thread
(λ ()
(let next ([a 0] [b 1])
(when (thread-running? count-down)
(thread-send count-down a)
(next b (+ a b))))))])
(thread-wait count-down)
result)
The thread version is Racket specific, the others ought to run anywhere.
Building a list would be hard. But displaying the results can still be done (in a very bad fashion)
#lang racket
(define (each-fib fn)
(letrec
((next (lambda (a b)
(fn a)
(next b (+ a b)))))
(next 0 1)))
(define (take-n-fibs n fn)
(let/cc k
(begin
(each-fib (lambda (x)
(if (= x (fib (+ n 1)))
(k (void))
(begin
(display (fn x))
(newline))))))))
(define fib
(lambda (n)
(letrec ((f
(lambda (i a b)
(if (<= n i)
a
(f (+ i 1) b (+ a b))))))
(f 1 0 1))))
Notice that i am using the regular fibonacci function as an escape (like i said, in a very bad fashion). I guess nobody will recommend programming like this.
Anyway
(take-n-fibs 7 (lambda (x) (* x x)))
0
1
1
4
9
25
64
Is it possible to write a Common Lisp macro that takes a list of dimensions and variables, a body (of iteration), and creates the code consisting of as many nested loops as specified by the list?
That is, something like:
(nested-loops '(2 5 3) '(i j k) whatever_loop_body)
should be expanded to
(loop for i from 0 below 2 do
(loop for j from 0 below 5 do
(loop for k from 0 below 3 do
whatever_loop_body)))
Follow up
As huaiyuan correctly pointed out, I have to know the parameters to pass to macro at compile time. If you actually need a function as I do, look below.
If you are ok with a macro, go for the recursive solution of 6502, is wonderful.
You don't need the quotes, since the dimensions and variables need to be known at compile time anyway.
(defmacro nested-loops (dimensions variables &body body)
(loop for range in (reverse dimensions)
for index in (reverse variables)
for x = body then (list y)
for y = `(loop for ,index from 0 to ,range do ,#x)
finally (return y)))
Edit:
If the dimensions cannot be decided at compile time, we'll need a function
(defun nested-map (fn dimensions)
(labels ((gn (args dimensions)
(if dimensions
(loop for i from 0 to (car dimensions) do
(gn (cons i args) (cdr dimensions)))
(apply fn (reverse args)))))
(gn nil dimensions)))
and to wrap the body in lambda when calling.
CL-USER> (nested-map (lambda (&rest indexes) (print indexes)) '(2 3 4))
(0 0 0)
(0 0 1)
(0 0 2)
(0 0 3)
(0 0 4)
(0 1 0)
(0 1 1)
(0 1 2)
(0 1 3)
(0 1 4)
(0 2 0)
(0 2 1)
...
Edit(2012-04-16):
The above version of nested-map was written to more closely reflect the original problem statement. As mmj said in the comments, it's probably more natural to make index range from 0 to n-1, and moving the reversing out of the inner loop should improve efficiency if we don't insist on row-major order of iterations. Also, it's probably more sensible to have the input function accept a tuple instead of individual indices, to be rank independent. Here is a new version with the stated changes:
(defun nested-map (fn dimensions)
(labels ((gn (args dimensions)
(if dimensions
(loop for i below (car dimensions) do
(gn (cons i args) (cdr dimensions)))
(funcall fn args))))
(gn nil (reverse dimensions))))
Then,
CL-USER> (nested-map #'print '(2 3 4))
Sometimes an approach that is useful is writing a recursive macro, i.e. a macro that generates code containing another invocation of the same macro unless the case is simple enough to be solved directly:
(defmacro nested-loops (max-values vars &rest body)
(if vars
`(loop for ,(first vars) from 0 to ,(first max-values) do
(nested-loops ,(rest max-values) ,(rest vars) ,#body))
`(progn ,#body)))
(nested-loops (2 3 4) (i j k)
(print (list i j k)))
In the above if the variable list is empty then the macro expands directly to the body forms, otherwise the generated code is a (loop...) on the first variable containing another (nested-loops ...) invocation in the do part.
The macro is not recursive in the normal sense used for functions (it's not calling itself directly) but the macroexpansion logic will call the same macro for the inner parts until the code generation has been completed.
Note that the max value forms used in the inner loops will be re-evaluated at each iteration of the outer loop. It doesn't make any difference if the forms are indeed numbers like in your test case, but it's different if they're for example function calls.
Hm. Here's an example of such a macro in common lisp. Note, though, that I am not sure, that this is actually a good idea. But we are all adults here, aren't we?
(defmacro nested-loop (control &body body)
(let ((variables ())
(lower-bounds ())
(upper-bounds ()))
(loop
:for ctl :in (reverse control)
:do (destructuring-bind (variable bound1 &optional (bound2 nil got-bound2)) ctl
(push variable variables)
(push (if got-bound2 bound1 0) lower-bounds)
(push (if got-bound2 bound2 bound1) upper-bounds)))
(labels ((recurr (vars lowers uppers)
(if (null vars)
`(progn ,#body)
`(loop
:for ,(car vars) :upfrom ,(car lowers) :to ,(car uppers)
:do ,(recurr (cdr vars) (cdr lowers) (cdr uppers))))))
(recurr variables lower-bounds upper-bounds))))
The syntax is slightly different from your proposal.
(nested-loop ((i 0 10) (j 15) (k 15 20))
(format t "~D ~D ~D~%" i j k))
expands into
(loop :for i :upfrom 0 :to 10
:do (loop :for j :upfrom 0 :to 15
:do (loop :for k :upfrom 15 :to 20
:do (progn (format t "~d ~d ~d~%" i j k)))))
The first argument to the macro is a list of list of the form
(variable upper-bound)
(with a lower bound of 0 implied) or
(variable lower-bound upper-bounds)
With a little more love applied, one could even have something like
(nested-loop ((i :upfrom 10 :below 20) (j :downfrom 100 :to 1)) ...)
but then, why bother, if loop has all these features already?