I've got a data structure that consists of two parts:
A hash table mapping symbols to indices
A vector of vectors containing data
For example:
(defparameter *h* (make-hash-table))
(setf (gethash 'a *h*) 0)
(setf (gethash 'b *h*) 1)
(setf (gethash 'c *h*) 2)
(defparameter *v-of-v* #(#(1 2 3 4) ;vector a
#(5 6 7 8) ;vector b
#(9 10 11 12))) ;vector c
I'd like to define a symbol macro to get at vector a without going through the hashmap. At the REPL:
(define-symbol-macro a (aref *v-of-v* 0))
works fine:
* a
#(1 2 3 4)
but there could be potentially many named vectors, and I don't know what the mappings will be ahead of time, so I need to automate this process:
(defun do-all-names ()
(maphash #'(lambda (key index)
(define-symbol-macro key (aref *v-of-v* index)))
*h*))
But that does nothing. And neither does any of the combinations I have tried of making do-all-names a macro, back-quote/comma templates, etc. I am beginning to wonder if this doesn't have something to do with the define-symbol-macro itself. It seems a little used feature, and On Lisp only mentions it twice. Not too many mentions here nor elsewhere either. In this case I'm using SBCL 2.1
Anyone have any ideas?
You need something like above to do it at runtime:
(defun do-all-names ()
(maphash #'(lambda (key index)
(eval `(define-symbol-macro ,key (aref *v-of-v* ,index)))
*h*))
DEFINE-SYMBOL-MACRO is a macro and does not evaluate all its arguments. So you need to generate a new macro form for each argument pair and evaluate it.
The other way to do it, usually at compile time, is to write a macro which generates these forms on the toplevel:
(progn
(define-symbol-macro a (aref *v-of-v* 0))
(define-symbol-macro b (aref *v-of-v* 1))
; ....
)
I'm not too sure on what you mean by "I don't know what the mappings will be ahead of time".
You could do something like:
(macrolet ((define-accessors ()
`(progn
,#(loop for key being the hash-keys of *h*
collect
`(define-symbol-macro ,key (aref *v-of-v* ,(gethash key *h*)))))))
(define-accessors))
If you know you do not require global access, then, you could do:
(defmacro with-named-vector-accessors (&body body) ; is that the name you want?
`(symbol-macrolet (,#(loop for key being the hash-keys of *h*
collect `(,key (aref *v-of-v* ,(gethash key *h*)))))
,#body))
;;; Example Usage:
(with-named-vector-accessors
(list a b c)) ;=> (#(1 2 3 4) #(5 6 7 8) #(9 10 11 12))
Also,
If you know *h* and the indices each symbol maps to at macroexpansion time, the above works.
If you know *h* at macroexpansion but the indices each symbol maps to will change after macroexpansion, you will want to collect (,key (aref *v-of-v* (gethash ,key *h*))).
PS: If you find loop ugly for hash-tables, you could use the iterate library with the syntax:
(iter (for (key value) in-hashtable *h*)
(collect `(,key (aref *v-of-v* ,value))))
I have created a Common Lisp library binding for libbladerf and can receive signals in Common Lisp. I have a function that demodulates an FM signal and is defined as follows:
(defun fm-demodulate-sc16-q11-samples (device frequency)
(configure-channel device (channel-rx 0) frequency 1000 40000000 30)
(init-sync device)
(enable-module device (channel-rx 0) t)
(with-foreign-objects ((rx-samples :uint16 8192)
(metadata :pointer))
(let ((status (bladerf_sync_rx (mem-ref device :pointer) rx-samples 4096 metadata 5000))
(samples-array (make-array 8192 :element-type 'float :initial-element 0.0 :fill-pointer 0)))
(if (< status 0)
(error "Failed to recieve IQ samples error: ~S" status)
(progn
(loop for i below 4096 by 4
do
(let* ((previous-i (mem-aref rx-samples :int16 (1+ i)))
(previous-q (mem-aref rx-samples :int16 i))
(current-i (mem-aref rx-samples :int16 (+ i 3)))
(current-q (mem-aref rx-samples :int16 (+ i 2)))
(previous-complex (complex previous-i previous-q))
(current-complex (complex current-i current-q))
(dif-complex (* (conjugate previous-complex) current-complex)))
(vector-push (atan-complex-number dif-complex) samples-array)))
samples-array)))))
I then pass this to cl-portaudio using the following code:
(defconstant +frames-per-buffer+ 1024)
(defconstant +sample-rate+ 44100d0)
(defconstant +sample-format+ :float)
(defconstant +num-channels+ 2)
(defun play-demodulated-fm ()
(with-audio
(with-default-audio-stream (astream +num-channels+ +num-channels+ :sample-format +sample-format+ :sample-rate +sample-rate+ :frames-per-buffer +frames-per-buffer+)
(dotimes (i 20)
(write-stream astream (fm-demodulate-sc16-q11-samples *dev* 863000000)))))
When I play this all I hear is a clipping sound and the following warning:
array is copied and/or coerced, lisp type is T, requested CFFI type is FLOAT
ALSA lib pcm.c:8432:(snd_pcm_recover) underrun occurred
What is the correct way of playing an FM demodulated signal with cl-portaudio?
I tried to play a simple tone with cl-portaudio and got the very same error as you reported:
array is copied and/or coerced, lisp type is T, requested CFFI type is FLOAT
After a long night of trying and digging the net I finally cooked the following piece of code making a sound. Probably not 'CleanCode', but should do as a start.
(eval-when (:compile-toplevel)
(ql:quickload "cl-portaudio"))
(defconstant +sample-rate+ 44100d0)
(defconstant +sample-format+ :float)
(defconstant +input-channels+ 0)
(defconstant +output-channels+ 1)
(defconstant +sound-frequency+ 800)
(defconstant +angle-per-tick+ (* 2d0 pi (/ +sound-frequency+ +sample-rate+)))
(defconstant +audio-buffer-size+ 4096
"The number of samples in the audio buffer.")
(defconstant +audio-buffer-time+ (* +audio-buffer-size+ (/ +sample-rate+))
"The total time the information in the audio buffer represents, in seconds.")
(defun make-audio-buffer ()
(make-array +audio-buffer-size+
:element-type 'single-float
:initial-element 0.0))
(defun make-sine-wave (&optional (angle 0d0))
(loop
with buffer = (make-audio-buffer)
for i from 0 below +audio-buffer-size+
for cur-angle = (+ angle (* i +angle-per-tick+))
do
(setf (aref buffer i) (coerce (sin cur-angle) 'single-float))
finally
(return-from make-sine-wave (values buffer (mod cur-angle (* 2 pi))))))
(defun play-note()
(portaudio:with-audio
(portaudio:with-default-audio-stream
(audio-stream +input-channels+ +output-channels+
:sample-format :float
:sample-rate +sample-rate+
:frames-per-buffer +audio-buffer-size+)
(loop
for i from 1 to 8
with angle = 0d0
do
(multiple-value-bind
(buffer new-angle)
(make-sine-wave angle)
(portaudio:write-stream audio-stream buffer)
(setf angle new-angle))))))
I tried implementing Brainf**k in Common Lisp, SBCL. I have encountered some problems.
(defparameter *tape* (make-array '(1) :adjustable t))
(defparameter *pointer* 0)
(defparameter *tape-size* 1)
(defparameter *output* (make-array '(0) :element-type 'base-char :fill-pointer 0 :adjustable t))
(defun move-pointer-right (a b)
(declare (ignore a))
(declare (ignore b))
'(progn
(incf *tape-size*)
(adjust-array *tape* (list *tape-size*))
(incf *pointer*)))
(defun move-pointer-left (a b)
(declare (ignore a))
(declare (ignore b))
'(progn (decf *pointer*)))
(defun increment-byte (a b)
(declare (ignore a))
(declare (ignore b))
'(incf (aref *tape* *pointer*)))
(defun decrement-byte (a b)
(declare (ignore a))
(declare (ignore b))
'(decf (aref *tape* *pointer*)))
(defun start-loop (stream ch)
(declare (ignore ch))
(let ((loop-body (read-delimited-list #\] stream t)))
`(loop :until (zerop (aref *tape* *pointer*))
:do ,#loop-body)))
(defun print-one-char (a b)
(declare (ignore a))
(declare (ignore b))
'(with-output-to-string (s *output*) (write-char (code-char (aref *tape* *pointer*)) s)))
(defun read-one-char (a b)
(declare (ignore a))
(declare (ignore b))
'(setf (aref *tape* *pointer*) (char-code (read-char *standard-input*))))
(defun flush-output (a b)
(declare (ignore a))
(declare (ignore b))
'(progn *output*))
(defun reset-me (a b)
(declare (ignore a))
(declare (ignore b))
'(progn
(setf *output* (make-array '(0) :element-type 'base-char :fill-pointer 0 :adjustable t))
(adjust-array *tape* '(1))
(setf (aref *tape* 0) 0)
(setf *pointer* 0)))
(set-macro-character #\< #'move-pointer-left)
(set-macro-character #\> #'move-pointer-right)
(set-macro-character #\+ #'increment-byte)
(set-macro-character #\[ #'start-loop)
(set-macro-character #\= #'flush-output)
(set-macro-character #\. #'print-one-char)
(set-macro-character #\, #'read-one-char)
(set-macro-character #\! #'reset-me)
(set-macro-character #\- #'decrement-byte)
input doesn't work
I am not sure whether nested loops would work because "[" reads to "]" and if you try "[/commands[/more]/dubious]" I don't how /dubious could be loaded with this methods.
I tried "++[->+>+<<]". As far as I know array should have: "0 2 2" but I got "0 2 0" instead. I conclude something is deeply wrong.
I am getting a lot of warnings from SBCL - it would be better to not have them:/
Is there a quick way to output all generated code (returned from functions such as "move-pointer-right") to file?
output is saved in one string to be printed at "=" command. I did it, because other operations were printing a lot of useless things to standard output. It is not a big problem for me - it seems easy to imagine just printing to file, instead of this workaround.
I am sorry for possible mistakes in my English.
Edit: I edited code (again - thank you for help, Sylwester). Everything but input seems to work.
As for input: I used read-char, but it doesn't work the way I want it. For example ,D inputs "D". I would like to redo it so it stops evaluation at each , and waits for user input.
Question: Is there an alternative to progn that does not return values (I want to just evaluate but not return)? For example (what-i-look-for (setf a 1) 1 2) sets a to 1 but does not return 2.
Without knowing too much about how you think its supposed to work you need to define tape, pointer and output as global variables, preferrably with *earmuffs* so that you can see they are globals.
(defparameter *tape* (make-array '(1) :adjustable t))
Then I noticed > extends the *tape* with a default element nil. Thus for every > you do you should set it to 0 if it's not true (every value is true except nil) It also seem to think that pointer is always at the end of the tape. When doing >>>++++<<< the element with 4 in it is long gone.
loop-body is a global variable. You should have used let here to not clobber package level variables. You use loopwrong. See examples in Loop for black belts. Eg.
(defun start-loop (stream ch)
(declare (ignore ch))
(let ((loop-body (read-delimited-list #\] stream t)))
`(loop :until (zerop (aref *tape* *pointer*))
:do ,#loop-body)))
Notice the declare there that tells Common Lisp to ignore ch not being used. The nesting is done automatically since read-deliited-list calls start-loop at a new [.
print-one-char doesn't add the char based on the ascii value but adds it as a number. Also usually it's common to print right away in BF so print-char might be better. You can print to a string input stream if you want to continue keeping it in memory until you press =.
read reads lisp data. Thus you would need to give it #\a instead of an a. Use read-char instead.
I guess you have enough to tacke at this point. Doing it with macros and reader-macros looked cool, but it is difficult to debug and extending since after the reader macros are added you have problems with code consisting those characters. Making one function for each operation except [ would simplify testing since you can test that and the macro would just expand to calling it.
(defun move-pointer-left ()
(assert (> *pointer* 0) (*pointer*) "Tape pointer out of bounds: ~a" *pointer*)
(decf *pointer*))
(set-macro-character #\< (constantly '(move-pointer-left)))
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%.
According to this document: http://cl-cookbook.sourceforge.net/functions.html
(defun adder (n)
(lambda (x) (+ x n)))
(funcall (adder 12) 1)
I have to use funcall to call (adder 12), And it is very ignoring to write funcall over and over, is there any way to write code like it in scheme:
((adder 12) 1)
No. There is none.
You can also see it as a feature: it makes calls of function objects explicit and improves understandability of source code.
However, you could use something like this (not sure why would you, but the number of characters typed would be the same as it is in Scheme):
(set-macro-character
#\[
#'(lambda (stream char)
(declare (ignore char))
(set-syntax-from-char #\] #\;)
(let ((forms (read-delimited-list #\] stream t)))
(set-syntax-from-char #\] #\x)
(append '(funcall) forms))))
(defun adder (n)
#'(lambda (x) (+ x n)))
(format t "sum: ~s~&" [(adder 12) #x128]) ;; 308
This may give you some problems if you will encounter a variable name with brackets in it. Sure, using it is up to you, consider yourself warned.