I'm learning Common Lisp from Practical Common Lisp. It has an example of helper functions for reading and writing binary files in Chapter 24. Here's one example:
(defun read-u2 (in)
(+ (* (read-byte in) 256) (read-byte in)))
I can write functions for reading other kinds of binary numbers likewise. But I thought that doing so violates the DRY principle. Besides, these functions are going to be similar, so I tried to generate the functions with macros.
(defmacro make-read (n be)
`(defun ,(intern (format nil "READ~d~:[L~;B~]E" n be))
(&optional (stream *standard-input*))
(logior ,#(loop for i from 0 below n collect
`(ash (read-byte stream)
,(* 8 (if be (- n 1 i) i)))))))
(defmacro make-read-s (n be)
`(defun ,(intern (format nil "READ~d~:[L~;B~]E-S" n be))
(&optional (stream *standard-input*))
(let ((a (,(intern (format nil "READ~d~:[L~;B~]E" n be)) stream)))
(if (zerop (logand a ,(ash 1 (1- (* 8 n)))))
a
(logior a ,(ash -1 (* 8 n)))))))
(defmacro make-write (n be)
`(defun ,(intern (format nil "WRITE~d~:[L~;B~]E" n be))
(n &optional (stream *standard-output*))
(setf n (logand n ,(1- (ash 1 (* 8 n)))))
,#(loop for i from 0 below n collect
`(write-byte (ldb (byte 8 ,(* 8 (if be (- n 1 i) i))) n)
stream))))
(eval-when (:compile-toplevel :load-toplevel :execute)
(dolist (cat '("READ" "READ-S" "WRITE"))
(dolist (be '(nil t))
(dolist (n '(1 2 4 8))
(eval `(,(intern (format nil "MAKE-~a" cat)) ,n ,be))))))
It works. It generates functions for reading and writing unsigned and signed integers in sizes of 1, 2, 4, and 8. SLIME understands it. But I wonder if there are better ways.
What's the best way to write a bunch of similar functions in Common Lisp?
There are some issues with this code, though the general approach to have macros generating functions is fine.
Naming
The macros should not be named make-..., because they are not functions which make something, but macros which define a function.
Code generation
The EVAL-WHEN ... EVAL code is really bad and should not be used this way.
The better way is to write macro which expands into a progn with the function definitions.
If I wanted to use EVAL, then I would not need to write code generating macros, but simply code generating functions. But I don't want to use EVAL, I want to create code for the compiler directly. If I have code generating macros, then I don't need EVAL.
EVAL is not a good idea, because it is not clear that the code would be compiled - which would be implementation dependent. Also the evaluation would take place at compile time and load time. It would be better to compile the functions at compile time and only load them at load time. A file compiler also might miss possible optimizations for the evaluated functions.
(defmacro def-read-fun (n be)
`(defun ,(intern (format nil "READ~d~:[L~;B~]E" n be))
(&optional (stream *standard-input*))
(logior ,#(loop for i from 0 below n collect
`(ash (read-byte stream)
,(* 8 (if be (- n 1 i) i)))))))
(defmacro def-read-s-fun (n be)
`(defun ,(intern (format nil "READ~d~:[L~;B~]E-S" n be))
(&optional (stream *standard-input*))
(let ((a (,(intern (format nil "READ~d~:[L~;B~]E" n be)) stream)))
(if (zerop (logand a ,(ash 1 (1- (* 8 n)))))
a
(logior a ,(ash -1 (* 8 n)) )))))
(defmacro def-write-fun (n be)
`(defun ,(intern (format nil "WRITE~d~:[L~;B~]E" n be))
(n &optional (stream *standard-output*))
(setf n (logand n ,(1- (ash 1 (* 8 n)))))
,#(loop for i from 0 below n collect
`(write-byte (ldb (byte 8 ,(* 8 (if be (- n 1 i) i))) n)
stream))))
Instead of the EVAL-WHEN ... EVAL we define another macro and then we use it later:
(defmacro def-reader/writer-functions (cat-list be-list n-list)
`(progn
,#(loop for cat in cat-list append
(loop for be in be-list append
(loop for n in n-list
collect `(,(intern (format nil "DEF-~a-FUN" cat))
,n
,be))))))
Now we can use above macro to generate all the functions:
(def-reader/writer-functions
("READ" "READ-S" "WRITE")
(nil t)
(1 2 4 8))
You can see the expansion here:
CL-USER 173 > (pprint (macroexpand-1 '(def-reader/writer-functions
("READ" "READ-S" "WRITE")
(nil t)
(1 2 4 8))))
(PROGN
(DEF-READ-FUN 1 NIL)
(DEF-READ-FUN 2 NIL)
(DEF-READ-FUN 4 NIL)
(DEF-READ-FUN 8 NIL)
(DEF-READ-FUN 1 T)
(DEF-READ-FUN 2 T)
(DEF-READ-FUN 4 T)
(DEF-READ-FUN 8 T)
(DEF-READ-S-FUN 1 NIL)
(DEF-READ-S-FUN 2 NIL)
(DEF-READ-S-FUN 4 NIL)
(DEF-READ-S-FUN 8 NIL)
(DEF-READ-S-FUN 1 T)
(DEF-READ-S-FUN 2 T)
(DEF-READ-S-FUN 4 T)
(DEF-READ-S-FUN 8 T)
(DEF-WRITE-FUN 1 NIL)
(DEF-WRITE-FUN 2 NIL)
(DEF-WRITE-FUN 4 NIL)
(DEF-WRITE-FUN 8 NIL)
(DEF-WRITE-FUN 1 T)
(DEF-WRITE-FUN 2 T)
(DEF-WRITE-FUN 4 T)
(DEF-WRITE-FUN 8 T))
Each of the subforms then will be expanded into the function definitions.
This way the compiler runs the macros to generate all the code at compile time and the compiler can then generate code for all the functions.
Efficiency / Defaults
In a lowest-level function I may not want to use an &optional parameter. The default call would get the value from a dynamic binding and, worse, *standard-input* / *standard-output* may not be a stream for which READ-BYTE or WRITE-BYTE works. Not in every implementation you can use a standard input/output stream as a binary stream.
LispWorks:
CL-USER 1 > (write-byte 13 *standard-output*)
Error: STREAM:STREAM-WRITE-BYTE is not implemented for this stream type: #<SYSTEM::TERMINAL-STREAM 40E01D110B>
1 (abort) Return to level 0.
2 Restart top-level loop.
I also may want to declare all generated functions to be inlined.
Type declarations would be another thing to think about.
Summmary: don't use EVAL.
Generally, I'd prefer to just add the number of bytes to read as another parameter to the function:
(defun read-integer (stream bytes)
(check-type bytes (integer 1 *))
(loop :repeat bytes
:for b := (read-byte stream)
:for n := b :then (+ (* n 256) b)
:finally (return n)))
Signedness and endianness could be added as keyword arguments. This way of programming is good for understandable code that is also easily navigated through tools like SLIME.
Unrolling this through macros is a valid optimization strategy, and I defer to Rainer's answer.
In the specific case of reading numbers from a stream, optimization is likely a valid goal from the start, since this tends to get used a lot in tight loops.
If you do this, however, you should also thoroughly document what gets generated. If a reader of the code sees an operator read8bes, he cannot easily find out where it was defined. You need to help him.
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).
Why is it not possible to push directly on a list like '(1 2 3) or NIL?
Specifically:
Why is possible to do
> (let ((some-list nil))
(push 42 some-list))
(42)
but not to do something like
(push 42 nil)
or
(push 42 '(1 2 3))
What is the reasoning behind this implementation?
With macro push the second argument needs to be a place to be modified. Here are some examples:
Lets make two variables:
(defparameter *v* (list 2 4))
(defparameter *v-copy* *v*)
Then we push 0
(push 1 *v*) ; ==> (1 2 4)
*v-copy* ; ==> (2 4) (unaltered)
; the reason is that the variable is changed, not its value
(macroexpand '(push 1 v))
; ==> (setq v (cons 1 v))
push can use other things as second argument. Lets try a cons
(push 3 (cdr *v-copy*))
*v-copy* ; ==> (2 3 4)
; since the tail of *v* is the *v-copy* *v* is changed too
*v* ; ==> (1 2 3 4)
(macroexpand-1 '(push 2 (cdr *v-copy*)))
; ==> (rplacd v (cons 2 (cdr *v-copy*)))
If your examples were valid, what should it really have done? Lets do the nil first:
(macroexpand '(push 42 nil))
; ==> (setq nil (cons 42 nil))
This treats nil just as any other variable and if this worked nil would never be the empty list again. It would have been a list with one element, 42 and a different value than (). In Common Lisp nil is a constant and cannot be mutated. I've created a lisp once where nil was a variable like any other and a small typo redefined nil making the programs behave strange with no apparent reason.
Lets try your literal quoted list.
(macroexpand '(push 42 (quote (1 2 3))))
; ==> (let ((tmp (1 2 3)))
; (funcall #'(setf quote) (cons 42 'tmp) tmp))
It doesn't seem the push macro differentiates between special form quote and those types that has set their setf function. It won't work and it doesn't make sense. Anyway in the same manner as mutating the binding nil if this changed the literal data '(1 2 3) to '(43 1 2 3) would you then expect to get (43 1 2 3) every time you evaluated (1 2 3) from there on? I imagine that would be the only true effect of mutating a constant. If this was allowed you should be allowed to redefine 4 to be 5 so that evaluating 4 or (+ 2 2) shows the result 5.
I am working on program related to the different of dealing with even numbers in C and lisp , finished my c program but still having troubles with lisp
isprime function is defined and I need help in:
define function primesinlist that returns unique prime numbers in a lis
here what i got so far ,
any help with that please?
(defun comprimento (lista)
(if (null lista)
0
(1+ (comprimento (rest lista)))))
(defun primesinlist (number-list)
(let ((result ()))
(dolist (number number-list)
(when (isprime number)
( number result)))
(nreverse result)))
You need to either flatten the argument before processing:
(defun primesinlist (number-list)
(let ((result ()))
(dolist (number (flatten number-list))
(when (isprime number)
(push number result)))
(delete-duplicates (nreverse result))))
or, if you want to avoid consing up a fresh list, flatten it as you go:
(defun primesinlist (number-list)
(let ((result ()))
(labels ((f (l)
(dolist (x l)
(etypecase x
(integer (when (isprime x)
(push x result)))
(list (f x))))))
(f number-list))
(delete-duplicates (nreverse result))))
To count distinct primes, take the length of the list returned by primesinlist.
Alternatively, you can use count-if:
(count-if #'isprime (delete-duplicates (flatten number-list)))
It sounds like you've already got a primality test implemented, but for sake of completeness, lets add a very simple one that just tries to divide a number by the numbers less than it up to its square root:
(defun primep (x)
"Very simple implementation of a primality test. Checks
for each n above 1 and below (sqrt x) whether n divides x.
Example:
(mapcar 'primep '(2 3 4 5 6 7 8 9 10 11 12 13))
;=> (T T NIL T NIL T NIL NIL NIL T NIL T)
"
(do ((sqrt-x (sqrt x))
(i 2 (1+ i)))
((> i sqrt-x) t)
(when (zerop (mod x i))
(return nil))))
Now, you need a way to flatten a potentially nested list of lists into a single list. When approaching this problem, I usually find it a bit easier to think in terms of trees built of cons-cells. Here's an efficient flattening function that returns a completely new list. That is, it doesn't share any structure with the original tree. That can be useful, especially if we want to modify the resulting structure later, without modifying the original input.
(defun flatten-tree (x &optional (tail '()))
"Efficiently flatten a tree of cons cells into
a list of all the non-NIL leafs of the tree. A completely
fresh list is returned.
Examples:
(flatten-tree nil) ;=> ()
(flatten-tree 1) ;=> (1)
(flatten-tree '(1 (2 (3)) (4) 5)) ;=> (1 2 3 4 5)
(flatten-tree '(1 () () 5)) ;=> (1 5)
"
(cond
((null x) tail)
((atom x) (list* x tail))
((consp x) (flatten-tree (car x)
(flatten-tree (cdr x) tail)))))
Now it's just a matter of flatting a list, removing the number that are not prime, and removing duplicates from that list. Common Lisp includes functions for doing these things, namely remove-if-not and remove-duplicates. Those are the "safe" versions that don't modify their input arguments. Since we know that the flattened list is freshly generated, we can use their (potentially) destructive counterparts, delete-if-not and delete-duplicates.
There's a caveat when you're removing duplicate elements, though. If you have a list like (1 3 5 3), there are two possible results that could be returned (assuming you keep all the other elements in order): (1 3 5) and (1 5 3). That is, you can either remove the the later duplicate or the earlier duplicate. In general, you have the question of "which one should be left behind?" Common Lisp, by default, removes the earlier duplicate and leaves the last occurrence. That behavior can be customized by the :from-end keyword argument. It can be nice to duplicate that behavior in your own API.
So, here's a function that puts all those considerations together.
(defun primes-in-tree (tree &key from-end)
"Flatten the tree, remove elements which are not prime numbers,
using FROM-END to determine whether earlier or later occurrences
are kept in the list.
Examples:
(primes-in-list '(2 (7 4) ((3 3) 5) 6 7))
;;=> (2 3 5 7)
(primes-in-list '(2 (7 4) ((3 3) 5) 6 7) :from-end t)
;;=> (2 7 3 5)"
;; Because FLATTEN-TREE returns a fresh list, it's OK
;; to use the destructive functions DELETE-IF-NOT and
;; DELETE-DUPLICATES.
(delete-duplicates
(delete-if-not 'primep (flatten-tree list))
:from-end from-end))
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%.
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?