I want to ask the user for input in LISP. I then want to see if this input is the key for a hashtable value and then retrieve the value corresponding to this key in the hashtable. I don't know how to do this and when I run the code that I am posting, it terminates before taking input from the user. Please help and thank you very much!!
(defparameter *KB* (make-hash-table))
(setf (gethash '(Robot Robbie) *KB*) T)
(setf (gethash '(Likes Robbie Samantha) *KB*) T)
(setf (gethash '(Dog Rover) *KB*) T)
(setf (gethash '(Bark Rover) *KB*) T)
(setf (gethash '(Likes Robbie Chocolate) *KB*) T)
(setf (gethash '(Lives Robbie California) *KB*) T)
(setf (gethash '(Likes Robbie ice-cream) *KB*) T)
(setf (gethash '(Eats Robbie petrol) *KB*) T)
(format t "Please enter a well formed function")
(terpri)
(defvar *apple* (read-line))
(terpri)
(format t "~a ~%"*apple*)
(terpri)
Related
I am trying to do the following: separate a function that gets values from some user input from the function that uses it.
I have tried the following code for the proof of concept initially (that worked):
(defun initialiser (bindings)
(cl-loop for (var) in bindings do
(set var (read-from-minibuffer "Input value: "))))
That i have tested with:
(let ((name))
(initialiser '((name)))
(message "name is %S" name))
The idea was to pass bindings to the function that handles input in the form like ((name "Name") (address "Post address") (code "County code")) or something similar, and in there assign the input.
After testing above i have come up with the following macro to do things:
(defmacro initialise-and-execute (bindings initialiser &rest callback-actions)
(let ((unwrapped-bindings (map 'list (lambda (binding) (car binding)) bindings)))
`(let ,unwrapped-bindings
(,initialiser (quote ,bindings)
(lambda () ,#callback-actions)))))
However, in the "real" scenario the assignments must happen in callbacks, like:
(defun initialiser(bindings)
(cl-loop for (var) in bindings collect
(lambda () (set var (read-from-minibuffer "Input value: ")))
into callbacks
return callbacks))
This fails to work. Code i have used to test was:
(defvar callbacks nil)
(let ((name))
(setq callbacks (initialiser '((name)))))
(funcall (car callbacks))
Edit: changed the code the following way:
(defmacro initialise-and-execute (bindings initialiser &rest callback-actions)
(let ((unwrapped-bindings (map 'list (lambda (binding) (car binding)) bindings)))
`(lexical-let ,unwrapped-bindings
(,initialiser
(quote ,(map 'list
(lambda (binding) (list (cadr binding)
`(lambda (val) (setq ,(car binding) val))))
bindings))
(lambda () ,#callback-actions)))))
What it must do: generate number of lambdas that share the same lexical environment - one that uses captured variables and the rest that modify them.
However, what i get is, regrettably, something else. Symbols used in callback-actions do not resolve into the values set.
For completeness, here is how i tested it:
(defun init-values (bindings callback)
(loop for (desc setter) in bindings
for idx = 0 then (incf idx)
do (print (format "Setting %s" desc))
(funcall setter idx))
(funcall callback))
(initialise-and-execute
((name "Name")
(surname "Surname"))
init-values
(message "name is %S" name))
Here, lambdas were not generated in a loop and values in the context of a lexical binding were assigned with setq.
To set the function value, use fset, not set.
(defun initialiser(bindings)
(cl-loop for (var) in bindings collect
(lambda () (fset var (read-from-minibuffer "Input value: ")))
into callbacks
return callbacks))
There are possible issues:
in a LOOP the VAR is possibly assigned on each iteration, not bound (that's in Common Lisp). so your callbacks set all the same VAR value.
in a lexical bound Lisp (new in GNU Emacs Lisp) one can't set the variable values with SET
Examples:
ELISP> (mapcar #'funcall
(cl-loop for i in '(1 2 3 4)
collect (lambda () i)))
(4 4 4 4)
all closures have the same value of i
ELISP> (let ((a 'foobar))
(set 'a 42)
a)
foobar
SET had no effect on the local variable
In Common Lisp I might write something like:
(defun initializer (bindings)
(loop for (what setter) in bindings
for new-value = (progn
(format t "Enter ~a: " what)
(finish-output)
(read-line))
do (funcall setter new-value)))
(defmacro call-with-bindings (name-sym-list fn)
(let ((value-sym (gensym "v")))
`(,fn
(list ,#(loop for (name sym) in name-sym-list
collect `(list ,name ,`(lambda (,value-sym)
(setf ,sym ,value-sym))))))))
CL-USER > (let (name age)
(call-with-bindings (("name" name) ("age" age))
initializer)
(format t "name is ~S~%" name)
(values name age))
Enter name: Lara
Enter age: 42
name is "Lara"
"Lara"
"42"
Where we can look at the macro expansion:
CL-USER > (pprint (macroexpand-1
'(call-with-bindings (("name" name) ("age" age))
initializer)))
(INITIALIZER (LIST (LIST "name"
(LAMBDA (#:|v1669|)
(SETF NAME #:|v1669|)))
(LIST "age"
(LAMBDA (#:|v1669|)
(SETF AGE #:|v1669|)))))
After some experimenting, i have been able to do it. The key was realising that lexical-let apparently had some restrictions on how the lambda should be placed for them to have the same closure context. After i have managed to generate set of closures that referred to the same variables, the rest was easy.
Here is the final code:
(defmacro make-lamba-set (bindings &rest callback-actions)
"Make set of closures with shared context
BINDINGS are a list of form (SYMBOL NAME), where SYMBOL is not defined yet
CALLBACK-ACTIONS are forms that use symbols from bindings
Return created captures a as a list of forms:
(do-callback-actions (set-symbol NAME) ...)"
(let ((unwrapped-bindings (map 'list
(lambda (binding)
(car binding))
bindings)))
`(lexical-let ,unwrapped-bindings
(list (lambda () ,#callback-actions)
,#(map 'list
(lambda (binding)
`(list
(lambda (val)
(setq ,(car binding) val))
,(cadr binding)))
bindings)))))
(defmacro initialise-and-execute (bindings initialiser &rest callback-actions)
"BINGINGS have form of ((BINDING-SYMBOL PROMPT) ...)
INITIALISER somehow assigns values to all of BINDING-SYMBOL
then it calls CALLBACK-ACTIONS with values of BINDING-SYMBOL set"
`(let ((closure-parts (make-lamba-set ,bindings ,#callback-actions)))
(,initialiser (cdr closure-parts)
(car closure-parts))))
Here is how i tested it:
(defun init-values (bindings callback)
(loop for (setter desc) in bindings
for idx = 0 then (incf idx)
do (message "Setting %s" desc)
(funcall setter idx))
(funcall callback))
(initialise-and-execute ((name "Name")
(surname "Surname"))
init-values
(insert (format "Name is %S and surname is %S"
name
surname)))
That gave me expected output of:
Name is 0 and surname is 1
I'm writing a macro to generate codes used by another macro in Common Lisp. But I'm new at this and have difficulty in constructing a macro that takes in a list (bar1 bar2 ... barn) and produces the following codes by a loop.
`(foo
,#bar1
,#bar2
...
,#barn)
I wonder whether this can be achieved not involving implement-dependent words such as SB-IMPL::UNQUOTE-SPLICE in sbcl.
Maybe I didn't give a clear description about my problem. In fact I want to write a macro gen-case such that
(gen-case
(simple-array simple-vector)
('(dotimes ($1 $5)
(when (and (= (aref $4 $2 $1) 1) (zerop (aref $3 $1)))
$0))
'(dolist ($1 (aref $4 $2))
(when (zerop (aref $3 $1))
$0)))
objname body)
produces something like
`(case (car (type-of ,objname))
(simple-array
,#(progn
(setf temp
'(dotimes ($1 $5)
(when (and (= (aref $4 $2 $1) 1) (zerop (aref $3 $1)))
$0)))
(code-gen body)))
(simple-vector
,#(progn
(setf temp
'(dolist ($1 (aref $4 $2))
(when (zerop (aref $3 $1))
$0)))
(code-gen body))))
In general cases, the lists taken in by gen-case may contain more than two items.
I have tried
``(case (car (type-of ,,objname))
,',#(#|Some codes that produce target codes|#))
but the target codes are inserted to the quote block and thus throw an exception in the macro who calls the macro gen-case. Moreover, I have no way to insert ,# to the target codes as a straightforward insertion will cause a "comma not inside a backquote" exception.
The codes generated are part of another macro
(defmacro DSI-Layer ((obj-name tag-name) &body body)
"Data Structure Independent Layer."
(let ((temp))
(defun code-gen (c)
(if (atom c) c
(if (eq (car c) tag-name)
(let ((args (cadr c)) (codes (code-gen (cddr c))) (flag nil))
(defun gen-code (c)
(if (atom c) c
(if (eq (car c) *arg*)
(let ((n (cadr c)))
(if (zerop n) (progn (setf flag t) codes)
(nth (1- n) args)))
(let ((h (gen-code (car c))))
(if flag
(progn
(setf flag nil)
(append h (gen-code (cdr c))))
(cons h (gen-code (cdr c))))))))
(gen-code temp))
(cons (code-gen (car c)) (code-gen (cdr c))))))
`(case (car (type-of ,obj-name))
(simple-array
,#(progn
(setf temp
'(dotimes ($1 $5)
(when (and (= (aref $4 $2 $1) 1) (zerop (aref $3 $1)))
$0)))
(code-gen body)))
(simple-vector
,#(progn
(setf temp
'(dolist ($1 (aref $4 $2))
(when (zerop (aref $3 $1))
$0)))
(code-gen body))))))
and I've set up a read-macro
(defvar *arg* (make-symbol "ARG"))
(set-macro-character #\$
#'(lambda (stream char)
(declare (ignore char))
(list *arg* (read stream t nil t))))
The intention of DSI-Layer is to add a piece of code to determine the type of input parameters. For example, the codes
(defun BFS (G v)
(let* ((n (car (array-dimensions G)))
(visited (make-array n :initial-element 0))
(queue (list v))
(vl nil))
(incf (aref visited v))
(DSI-Layer (G next-vertex)
(do nil ((null queue) nil)
(setf v (pop queue)) (push v vl)
(next-vertex (i v visited G n)
(setf queue (nconc queue (list i)))
(incf (aref visited i)))))
vl))
will be converted to
(defun BFS (G v)
(let* ((n (car (array-dimensions G)))
(visited (make-array n :initial-element 0))
(queue (list v))
(vl nil))
(incf (aref visited v))
(case (car (type-of G))
(simple-array
(do nil ((null queue) nil)
(setf v (pop queue))
(push v vl)
(dotimes (i n)
(when (and (= (aref G v i) 1) (zerop (aref visited i)))
(setf queue (nconc queue (list i)))
(incf (aref visited i))))))
(simple-vector
(do nil ((null queue) nil)
(setf v (pop queue))
(push v vl)
(dolist (i (aref G v))
(when (zerop (aref visited i))
(setf queue (nconc queue (list i)))
(incf (aref visited i)))))))))
Now I just wonder that whether the DSI-Layer can be generated from another macro gen-case by passing the type names and corresponding code templates to it or not.
By the way, I don't think the specific meaning of generated codes matters in my problem. They are just treated as data.
Don't be tempted to use internal details of backquote. If you have the lists you want to append in distinct variables, simply append them:
`(foo
,#(append b1 b2 ... bn))
If you have a list of them in some single variable (for instance if they've come from an &rest or &body argument) then do something like
`(foo
,#(loop for b in bs
appending b))
I see your problem - you need it not for a function call
but for a macro-call with case.
One cannot use dynamically macros - in a safe way.
One has to use eval but it is not safe for scoping.
#tfb as well as me answered in this question for type-case
lengthily.
previous answer (wrong for this case)
No need for a macro.
`(foo
,#bar1
,#bar2
...
,#barn)
with evaluation of its result
by pure functions would be:
(apply foo (loop for bar in '(bar1 bar2 ... barn)
nconc bar))
nconc or nconcing instead of collect fuses lists together and is very useful in loop. - Ah I see my previous answerer used append btw appending - nconc nconcing however is the "destructive" form of "append". Since the local variable bar is destructed here which we don't need outside of the loop form, using the "destructive" form is safe here - and comes with a performance advantage (less elements are copied than when using append). That is why I wired my brain always to use nconc instead of append inside a loop.
Of course, if you want to get the code construct, one could do
`(foo ,#(loop for bar in list-of-lists
nconc bar))
Try it out:
`(foo ,#(loop for bar in '((1 2 3) (a b c) (:a :b :c)) nconc bar))
;; => (FOO 1 2 3 A B C :A :B :C)
The answers of all of you inspired me, and I came up with a solution to my problem. The macro
(defmacro Layer-Generator (obj-name tag-name callback body)
(let ((temp (gensym)) (code-gen (gensym)))
`(let ((,temp))
(defun ,code-gen (c)
(if (atom c) c
(if (eq (car c) ,tag-name)
(let ((args (cadr c)) (codes (,code-gen (cddr c))) (flag nil))
(defun gen-code (c)
(if (atom c) c
(if (eq (car c) *arg*)
(let ((n (cadr c)))
(if (zerop n) (progn (setf flag t) codes)
(nth (1- n) args)))
(let ((h (gen-code (car c))))
(if flag
(progn
(setf flag nil)
(append h (gen-code (cdr c))))
(cons h (gen-code (cdr c))))))))
(gen-code ,temp))
(cons (,code-gen (car c)) (,code-gen (cdr c))))))
(list 'case `(car (type-of ,,obj-name))
,#(let ((codes nil))
(dolist (item callback)
(push
`(cons ',(car item)
(progn
(setf ,temp ,(cadr item))
(,code-gen ,body)))
codes))
(nreverse codes))))))
produces codes which are not the same as DSI-Layer but produce codes coincident with what the latter produces. Because the codes
`(case (car (type-of ,obj-name))
(tag1
,#(#|codes1|#))
(tag2
,#(#|codes2|#))
...)
are equivalent to
(list 'case `(car (type-of ,obj-name))
(cons 'tag1 (#|codes1|#))
(cons 'tag2 (#|codes2|#))
...)
And now we can use a loop to generate it just as what the Layer-Generator does.
I'm trying to define a macro that'll take a struct's name, a key, and the name of a hash table in the struct and define functions to access and modify the value under the key in the hash.
(defmacro make-hash-accessor (struct-name key hash)
(let ((key-accessor (gensym))
(hash-accessor (gensym)))
`(let ((,key-accessor (accessor-name ,struct-name ,key))
(,hash-accessor (accessor-name ,struct-name ,hash)))
(setf (fdefinition ,key-accessor) ; reads
(lambda (instance)
(gethash ',key
(funcall ,hash-accessor instance))))
(setf (fdefinition '(setf ,key-accessor)) ; modifies
(lambda (instance to-value)
(setf (gethash ',key
(funcall ,hash-accessor instance))
to-value))))))
;; Returns the symbol that would be the name of an accessor for a struct's slot
(defmacro accessor-name (struct-name slot)
`(intern
(concatenate 'string (symbol-name ',struct-name) "-" (symbol-name ',slot))))
To test this I have:
(defstruct tester
(hash (make-hash-table)))
(defvar too (make-tester))
(setf (gethash 'x (tester-hash too)) 3)
When I run
(make-hash-accessor tester x hash)
then
(tester-x too)
it returns 3 T, as it should, but
(setf (tester-x too) 5)
gives the error:
The function (COMMON-LISP:SETF COMMON-LISP-USER::TESTER-X) is undefined.
[Condition of type UNDEFINED-FUNCTION]
(macroexpand-1 '(make-hash-accessor tester x hash)) expands to
(LET ((#:G690 (ACCESSOR-NAME TESTER X)) (#:G691 (ACCESSOR-NAME TESTER HASH)))
(SETF (FDEFINITION #:G690)
(LAMBDA (INSTANCE) (GETHASH 'X (FUNCALL #:G691 INSTANCE))))
(SETF (FDEFINITION '(SETF #:G690))
(LAMBDA (INSTANCE TO-VALUE)
(SETF (GETHASH 'X (FUNCALL #:G691 INSTANCE)) TO-VALUE))))
T
I'm using SBCL. What am I doing wrong?
You should use defun whenever possible.
Specifically, here instead of defmacro for accessor-name and instead of (setf fdefinition) for your accessors:
(defmacro define-hash-accessor (struct-name key hash)
(flet ((concat-symbols (s1 s2)
(intern (concatenate 'string (symbol-name s1) "-" (symbol-name s2)))))
(let ((hash-key (concat-symbols struct-name key))
(get-hash (concat-symbols struct-name hash)))
`(progn
(defun ,hash-key (instance)
(gethash ',key (,get-hash instance)))
(defun (setf ,hash-key) (to-value instance)
(setf (gethash ',key (,get-hash instance)) to-value))
',hash-key))))
(defstruct tester
(hash (make-hash-table)))
(defvar too (make-tester))
(setf (gethash 'x (tester-hash too)) 3)
too
==> #S(TESTER :HASH #S(HASH-TABLE :TEST FASTHASH-EQL (X . 3)))
(define-hash-accessor tester x hash)
==> tester-x
(tester-x too)
==> 7; T
(setf (tester-x too) 5)
too
==> #S(TESTER :HASH #S(HASH-TABLE :TEST FASTHASH-EQL (X . 5)))
Note that I use a more conventional name for the macro: since it defines accessorts, it is common to name it define-... (cf. define-condition, defpackage).
make-... is usually used for functions returning objects (cf. make-package).
See also Is defun or setf preferred for creating function definitions in common lisp and why?
Remember, style is important, both in indentation and in naming variables, functions, and macros.
From reading a Lisp book I remember they showed an example of an OOP-style method dispatcher based on closures:
(defun create-object ()
(let ((val 0)
(get (lambda () val))
(set (lambda (new-val) (setq val new-val)))
(inc (lambda () (setq val (+ 1 val)))))
(lambda (method)
(cond ((eq method 'get)
get)
((eq method 'set)
set)
((eq method 'inc)
inc)))))
(let ((obj (create-object)))
(funcall (obj 'set) 1)
(funcall (obj 'inc))
(funcall (obj 'get))) ;; 2
Since it's just a function with a string symbol argument, I guess code intel won't be of much help here, not completing the method names or their signatures. (Compare with a similar JavaScript object.)
Is this problem generally solved? How do you program an object system in Scheme so that an editor (like Emacs) can be more intelligent with your code?
P.S. The example may be not a valid Scheme code, but you should get the idea.
I've made some starting code for you.
It's for Emacs Lisp, but it's should be very easily portable to Scheme.
Here's your usage example:
(defun create-object ()
(lexical-let* ((val 0)
(get (lambda() val))
(set (lambda(x) (setq val x))))
(generate-dispatch-table get set)))
(setq obj (create-object))
(funcall (funcall obj 'get))
;; => 0
(funcall (funcall obj 'set) 1)
;; => 1
(funcall (funcall obj 'get))
;; => 1
(scheme-completions obj)
;; => (get set)
And here's how it's implemented:
(defmacro generate-dispatch-table (&rest members)
`(lambda (method)
(cond ,#(mapcar
(lambda (x) `((eq method ',x) ,x)) members))))
(defun collect (pred x)
(when (and x (listp x))
(let ((y (funcall pred x))
(z (append
(collect pred (car x))
(collect pred (cdr x)))))
(if y
(append (list y) z)
z))))
(defun scheme-completions (obj)
(collect
(lambda(x) (and (eq (car x) 'eq)
(eq (cadr x) 'method)
(eq (caaddr x) 'quote)
(cadr (caddr x))))
obj))
And here's a simple visual interface for completions:
(require 'helm)
(defun scheme-completions-helm ()
(interactive)
(let ((y (and
(looking-back "(funcall \\([^ ]*\\) +")
(intern-soft (match-string 1)))))
(when y
(helm :sources
`((name . "members")
(candidates . ,(scheme-completions (eval y)))
(action . (lambda(x) (insert "'" x))))))))
I'm not a Emacs user, but use DrRacket and it does have an object system and do what an IDE should do, but I know Emacs is very customizable since it uses elisp so you can make support for your own syntax both in syntax highlighting and tab-completion. So you do:
Make your own object system
Edit your Emacs editor to do what you want
Many of my colleagues use it and they fix their Emacs in such ways.
Another thing, this question makes me think about the resources at schemewiki.org on the subject where the different approaches are mentioned and even a similar code to the one you posted is posted as example. It's a good read.
I would avoid double notion of symbols in create-object via an obarray.
Furthermore, the interface of the object are all functions. Therefore, use fset and avoid the double funcall.
(defun create-object ()
(lexical-let (val
(_oa (make-vector 11 0)))
(fset (intern "get" _oa) (lambda () val))
(fset (intern "inc" _oa) (lambda () (incf val)))
(fset (intern "set" _oa) (lambda (new-val) (setq val new-val)))
(lambda (method &rest args)
(apply 'funcall (intern (symbol-name method) _oa) args))))
(fset 'obj1 (create-object))
(fset 'obj2 (create-object))
(obj1 'set 1)
(obj2 'set 2)
(obj1 'inc)
(obj2 'inc)
(obj2 'inc)
(obj2 'get)
(obj1 'get)
Example for inheritance:
(defun create-object ()
(lexical-let (val
(_oa (make-vector 11 0)))
(fset (intern "get" _oa) (lambda () val))
(fset (intern "inc" _oa) (lambda () (incf val)))
(fset (intern "set" _oa) (lambda (new-val) (setq val new-val)))
(lambda (method &rest args)
(apply 'funcall (or (intern-soft (symbol-name method) _oa)
(error "Undefined function: %s" method))
args))))
(defun create-object-add10 ()
(lexical-let ((base (create-object))
(_oa (make-vector 11 0)))
(fset (intern "inc" _oa) (lambda () (funcall base 'set (+ (funcall base 'get) 10))))
(lambda (method &rest args)
(let ((call (intern-soft (symbol-name method) _oa)))
(if call
(apply 'funcall call args)
(apply 'funcall base method args))))))
(fset 'obj1 (create-object))
(fset 'obj2 (create-object-add10))
(obj1 'set 1)
(obj2 'set 2)
(obj1 'inc)
(obj2 'inc)
(obj2 'inc)
(obj2 'get)
(obj1 'get)
The definition of create-object-like methods should additionally be supported through macros. That is not done here.
For more features, note, there is a CLOS-compatible object oriented system in emacs:
https://www.gnu.org/software/emacs/manual/html_node/eieio/index.html
I'm working on actually writing something on my own in Common Lisp for once, implementing the Shunting-yard Algorithm. I thought it went okay, even if it came out rather ugly and if I doubt its Lispy-ness, but upon testing out the function in the REPL, I get the error in the title.
The code is as follows, with the test case being (shunting-yard '(3 + 5)).
(defparameter *output-queue* nil)
(defparameter *operator-stack* nil)
(defun determine-precedence (operator)
(case operator
(('+ '-) 2)
(('* '/) 3)
('^ 4)))
(defun shunting-yard (stmt)
(loop until (null stmt) do
(let ((token (car stmt)))
(cond ((or (numberp token)
(eq token '\())
(setf *output-queue* (cons token *output-queue*)))
((mapcar #'(lambda (x) (eq token x)) '(+ - * / ^))
(let* ((token-precedence (determine-precedence token))
(stack-topmost (car *operator-stack*))
(stack-precedence (determine-precedence stack-topmost)))
(when (< token-precedence stack-precedence)
(setf *output-queue* (cons stack-topmost *output-queue*))
(setf *operator-stack* (cdr *operator-stack*)))
(setf *operator-stack* (cons token *operator-stack*))))
((eq token '\))
(loop for stack-topmost in *operator-stack*
until (eq stack-topmost '\()
do (progn
(setf *output-queue* (cons stack-topmost *output-queue*))
(setf *operator-stack* (cdr *operator-stack*)))
finally (setf *operator-stack* (cdr *operator-stack*)))))
(setf stmt (cdr stmt))))
(loop while (not (null *operator-stack*))
do (progn
(setf *output-queue* (cons (car *operator-stack*) *output-queue*))
(setf *operator-stack* (cdr *operator-stack*))))
(nreverse *output-queue*))
Is the error in the code itself (my guess) or is it in my test case?
Thanks so much in advance, this was REALLY fun to write and I can't wait to work on something else, but only after I get this working.
There are several errors:
First:
(defun determine-precedence (operator)
(case operator
(('+ '-) 2)
(('* '/) 3)
('^ 4)))
The quotes need to go. All.
Second:
(mapcar #'(lambda (x) (eq token x)) '(+ - * / ^))
Above is not doing what you think. Replace it with a call to MEMBER.
Third:
(when (< token-precedence stack-precedence)
You need to make sure that the variables are really bound to numbers.
Use something like
(check-type token-precedence number)
(check-type stack-precedence number)
before as a check.
Happy further debugging...