In scheme, it is possible to use set! to create two (or more) functions which share a private scope between them:
(define f1 #f) ; or any other "undefined" value
(define f2 #f)
(let ((private some-value) (another-private some-other-value))
(set! f1 (lambda ... <use of private variables> ...))
(set! f2 (lambda ... <use of private variables> ...)))
or by using a third variable:
(define functions
(let ((private some-value) (another-private some-other-value))
(list (lambda ... <use of private variables> ...)
(lambda ... <use of private variables> ...))))
(define f1 (car functions))
(define f2 (cadr functions))
However, both of these seem inelegant, due to the use of set! in the first and the left-over variable functions in the second. Is there a way to do this without either?
(define-values (f1 f2)
(let ((private values) ...)
(values (lambda ...)
(lambda ...))))
Not every scheme implementation provides define-values. There's a macro definition on the schemers wiki:
(define-syntax define-values
(syntax-rules ()
((define-values () exp)
(call-with-values (lambda () exp) (lambda () 'unspecified)))
((define-values (var . vars) exp)
(begin
(define var (call-with-values (lambda () exp) list))
(define-values vars (apply values (cdr var)))
(define var (car var))))
((define-values var exp)
(define var (call-with-values (lambda () exp) list)))))
http://community.schemewiki.org/?scheme-faq-macros
Related
I want to get a function argument value, using an argument name.
The following code don't works, because symbol-value working only with global variables:
(defun test1 (&key v1)
(format t "V1: ~A~%" (symbol-value (intern "V1"))))
Is there a portable way to do this in Common Lisp?
You can use a custom environment to map strings to functions:
(use-package :alexandria)
(defvar *env* nil)
(defun resolve (name &optional (env *env*))
(if-let (entry (assoc name env :test #'string=))
(cdr entry)
(error "~s not found in ~a" name env)))
(defmacro bind (bindings env &body body)
(assert (symbolp env))
(let ((env (or env '*env*)))
(loop
for (n v) in bindings
collect `(cons ,n ,v) into fresh-list
finally
(return
`(let ((,env (list* ,#fresh-list ,env)))
,#body)))))
(defmacro call (name &rest args)
`(funcall (resolve ,name) ,#args))
For example:
(bind (("a" (lambda (u) (+ 3 u)))
("b" (lambda (v) (* 5 v))))
nil
(call "a" (call "b" 10)))
Here is another version of an explicit named-binding hack. Note this isn't well (or at all) tested, and also note the performance is not going to be great.
(defun named-binding (n)
;; Get a binding by its name: this is an error outside
;; WITH-NAMED-BINDINGS
(declare (ignore n))
(error "out of scope"))
(defun (setf named-binding) (val n)
;; Set a binding by its name: this is an error outside
;; WITH-NAMED-BINDINGS
(declare (ignore val n))
(error "out of scope"))
(defmacro with-named-bindings ((&rest bindings) &body decls/forms)
;; establish a bunch of bindings (as LET) but allow access to them
;; by name
(let ((varnames (mapcar (lambda (b)
(cond
((symbolp b) b)
((and (consp b)
(= (length b) 2)
(symbolp (car b)))
(car b))
(t (error "bad binding ~S" b))))
bindings))
(decls (loop for df in decls/forms
while (and (consp df) (eql (car df) 'declare))
collect df))
(forms (loop for dft on decls/forms
for df = (first dft)
while (and (consp df) (eql (car df) 'declare))
finally (return dft)))
(btabn (make-symbol "BTAB")))
`(let (,#bindings)
,#decls
(let ((,btabn (list
,#(mapcar (lambda (v)
`(cons ',v (lambda (&optional (val nil valp))
(if valp
(setf ,v val)
,v))))
varnames))))
(flet ((named-binding (name)
(let ((found (assoc name ,btabn)))
(unless found
(error "no binding ~S" name))
(funcall (cdr found))))
((setf named-binding) (val name)
(let ((found (assoc name ,btabn)))
(unless found
(error "no binding ~S" name))
(funcall (cdr found) val))))
(declare (inline named-binding (setf named-binding)))
,#forms)))))
And now:
> (with-named-bindings ((x 1))
(setf (named-binding 'x) 2)
(named-binding 'x))
2
Even better:
(defun amusing (x y)
(with-named-bindings ((x x) (y y))
(values #'named-binding #'(setf named-binding))))
(multiple-value-bind (reader writer) (amusing 1 2)
(funcall writer 2 'x)
(funcall reader 'x))
will work.
I am trying to make a 'pseudo OO system':
(defun bank-account ()
(let ((balance))
(labels ((init (x)
(setf balance x))
(increment (x)
(setf balance (+ balance x)))
(get-balance ()
balance))
(lambda (func)
(case func (init #'init)
(increment #'increment)
(get-balance #'get-balance))))))
(defparameter bank-account-object (bank-account))
(funcall (funcall bank-account-object 'init) 42)
(funcall (funcall bank-account-object 'increment) 10)
(funcall (funcall bank-account-object 'get-balance))
Q: are there better ways to accomplish the same without using CLOS, defstruct, or defmacro?
The problem that I see with this is that it is closed for extension, and I see no simple way to add extensibility.
Minor nitpick: that's not a bank-system but a bank-account. When you think about that further, it seems to me that the interesting part about this example domain has not been touched: double accounting, i. e. ensuring the null-sum invariant.
There are two sayings: a closure is a poor man's object, and an object is a poor man's closure. I have the feeling that you are more in the realm of the former here. However, it might be a good learning experience to think about this—as long as you don't put it into production somewhere…
;; The "class"
(defun create-bank-account ()
(let ((balance))
(labels ((init (x)
(setf balance x))
(increment (x)
(setf balance (+ balance x)))
(get-balance ()
balance))
(lambda (func)
(case func (init #'init)
(increment #'increment)
(get-balance #'get-balance))))))
;; The "methods"
(defun init-balance (object amount)
(funcall (funcall object 'init) amount))
(defun increment-balance (object amount)
(funcall (funcall object 'increment) amount))
(defun get-balance (object)
(funcall (funcall object 'get-balance)))
;; Example usage
(defparameter bank-account (create-bank-account))
(init-balance bank-account 42) ; => 42
(increment-balance bank-account 10) ; => 52
(get-balance bank-account) ; => 52
As mentioned in other answers, the resulting object might be hard to extend. That could be a feature, but one possible way to improve on it is to let it be redefined dynamically. You can even switch from classes to protoypes.
(ql:quickload :optima)
(defpackage :obj (:use :cl :optima))
(in-package :obj)
(defun make-object (&optional prototype)
(let ((properties (make-hash-table :test #'eq))
(self))
(flet ((resolve (key)
(or (gethash key properties)
(and prototype (funcall prototype :get key)))))
(setf self
(lambda (&rest args)
(optima:ematch args
((list :get :prototype) prototype)
((list :get key) (resolve key))
((list :set :prototype p)
(cerror "Continue" "Changing prototype object, are you sure?")
(setf prototype p))
((list :set key value)
(if value
(setf (gethash key properties) value)
(remhash key properties)))
((list :invoke method args)
(let ((resolved (resolve method)))
(if resolved
(apply resolved self args)
(funcall (or (resolve :no-such-method)
(error "No such method: ~a in ~a"
method
self))
self
method))))))))))
Some helper symbols:
;; call built-in command
(defmacro $ (obj method &rest args)
`(funcall ,obj ,method ,#args))
;; access property
(declaim (inline # (setf #)))
(defun # (o k) ($ o :get k))
(defun (setf #) (v o k) ($ o :set k v))
;; invoke method
(defun % (o m &rest a)
($ o :invoke m a))
A simple test
(let ((a (make-object)))
;; set name property
(setf (# a :name) "a")
;; inherit
(let ((b (make-object a)))
(print (list (# b :name)
;; shadow name property
(setf (# b :name) "b")
(# a :name)))
;; define a method
(setf (# a :foo) (lambda (self) (print "FOO")))
;; invoke it
(% a :foo)))
Bank account
(defun create-bank-account (&optional parent)
(let ((account (make-object parent)))
(prog1 account
(setf (# account :init)
(lambda (self x)
(setf (# self :balance) x)))
(setf (# account :increment)
(lambda (self increment)
(incf (# self :balance) increment))))))
(let ((account (create-bank-account)))
(% account :init 0)
(% account :increment 100)
(# account :balance))
100
(defun lat
(lambda (l)
(cond ((null l) t)
((atom (car l))(lat (cdr l))
(t nil))))
The function takes a list as an argument. It is a recursive function that checks every element in the list. Whether it is atom or not. If every element is an atom, then it returns true else false.
Following is the error displayed
While compiling LAT :
Bad lambda list : (LAMBDA (L)
(COND ((NULL L) T) ((ATOM # #)) (T NIL)))
[Condition of type CCL::COMPILE-TIME-PROGRAM-ERROR]
Just like Hal Abelson called Scheme "lisp" in the SICP videos this book does the same, however the language in the book is a predecessor to Scheme and not Common Lisp. When you see:
(define name
(lambda (arg ...)
body ...)
This is the same as this in CL:
(defun name (arg ...)
body ...)
The reason is that in Scheme it's the same namespace for operator as well as operand bindings. A lisp-2 like Common Lisp can split it up like this:
(setf (fdefinition 'name)
(lambda (arg ...)
body ...))
This probably won't happen since you can always use defun, but in the event you return a function from a function you can do this or you must rely on funcall or apply to use the returned value:
;; This is a function that creates a function
(defun get-counter (from step)
(lambda ()
(let ((tmp from))
(incf from step)
tmp)))
When using this you might want to bind it globally:
(setf (fdefinition 'evens) (get-counter 0 2))
(evens) ; ==> 0
(evens) ; ==> 2
Or in functions you get it bound to normal variables and need to funcall or apply:
(defparameter *odds* (get-counter 1 2))
(funcall *odds*)
; ==> 1
Which one do you prefer?
(list (funcall *odds*) (evens))
; ==> (3 4)
The ? in lat? inidicated predicate and in CL a p in the end does the same. Your function latp is suppose to return nil or t so it should not return a function at all. Thus:
(defun latp (list)
(cond ((null list) t)
((atom (car list)) (latp (cdr list)))
(t nil)))
This of course is the same as:
(defun latp (list)
(or (null list)
(and (atom (car list))
(latp (cdr list)))))
Unlike Scheme using the name list as the argument does not affect the function call to list.
I want to write a function/macro
(defun apply-funcs (functions value) ...)
so that calling (apply-funcs (list #'f #'g #'h) x) will do the equivalent of (h (g (f x))). How can this be accomplished?
Looks like you want to reduce a list of functions over a value.
CL-USER> (defun apply-funcs (functions value)
(reduce (lambda (memo fn) (funcall fn memo))
functions :initial-value value))
CL-USER> (apply-funcs
(list (lambda (n) (+ 3 n))
(lambda (n) (- n 2))
(lambda (n) (* 2 n)))
6)
14
CL-USER>
You may know reduce as fold from other languages. I'm using funcall instead of apply because of what you've said you want above ((apply-funcs (list #'f #'g #'h) x) => (h (g (f x)))). You'd use apply if x were a list of values, each element of which you wanted to bind to a separate argument. For instance, if you wanted to do something like
(apply-funcs
(list (lambda (a b c)
(list (+ a c) (+ b c)))
(lambda (d e)
(+ d e)))
(list 1 2 3))
then you'd need apply rather than funcall in the definition of apply-funcs.
Depending on the situation, you might also take the macro route;
(defmacro ->> (value &body functions)
(reduce
(lambda (memo fn) `(funcall ,fn ,memo))
functions :initial-value value))
which will do essentially the same thing.
CL-USER> (->> 6
(lambda (n) (+ 3 n))
(lambda (n) (- n 2))
(lambda (n) (* 2 n)))
14
CL-USER> (macroexpand
'(->> 6
(lambda (n) (+ 3 n))
(lambda (n) (- n 2))
(lambda (n) (* 2 n))))
(FUNCALL (LAMBDA (N) (* 2 N))
(FUNCALL (LAMBDA (N) (- N 2))
(FUNCALL (LAMBDA (N) (+ 3 N)) 6)))
T
(defun apply-funcs (functions value)
(loop for f in functions
for result = (funcall f value) then (funcall f result)
finally (return result)))
From the Alexandria library comes the compose (and multiple-value-compose) function, including a compiler macro for compose. What you're describing seems analogous to
(funcall (alexandria:compose #'h #'g #'f) x)
such that
(defun apply-funcs (functions value)
(funcall (apply #'compose (reverse functions)) value))
would do what you intend — although I suspect that calling compose directly might be more effective for your purposes, depending on the context.
The library functions are:
(defun compose (function &rest more-functions)
"Returns a function composed of FUNCTION and MORE-FUNCTIONS that applies its
arguments to to each in turn, starting from the rightmost of MORE-FUNCTIONS,
and then calling the next one with the primary value of the last."
(declare (optimize (speed 3) (safety 1) (debug 1)))
(reduce (lambda (f g)
(let ((f (ensure-function f))
(g (ensure-function g)))
(lambda (&rest arguments)
(declare (dynamic-extent arguments))
(funcall f (apply g arguments)))))
more-functions
:initial-value function))
(define-compiler-macro compose (function &rest more-functions)
(labels ((compose-1 (funs)
(if (cdr funs)
`(funcall ,(car funs) ,(compose-1 (cdr funs)))
`(apply ,(car funs) arguments))))
(let* ((args (cons function more-functions))
(funs (make-gensym-list (length args) "COMPOSE")))
`(let ,(loop for f in funs for arg in args
collect `(,f (ensure-function ,arg)))
(declare (optimize (speed 3) (safety 1) (debug 1)))
(lambda (&rest arguments)
(declare (dynamic-extent arguments))
,(compose-1 funs))))))
Here is my attempt to implement Maybe monad in elisp. It it function composition that breaks on first nil. However value is always 13. Where is my error?
(defun .compose-maybe (&rest funcs)
"Monad Maybe function composition with nil as Nothing."
(lambda (arg)
(if funcs
(let ((value (funcall (apply #'.compose-maybe (cdr funcs)) arg)))
(message "%s" value)
(when value (funcall (car funcs) value))))
arg))
(funcall (.compose-maybe (lambda (x) (* x 5)) (lambda (x) (+ 100 x))) 13)
Your arg falls outside of the bouds of (if funcs ...), thus the inner lambda in .compose-maybe always returns arg instead of only when funcs is nil.
(defun .compose-maybe (&rest funcs)
"Monad Maybe function composition with nil as Nothing."
(lambda (arg)
(if funcs
(let ((value (funcall (apply #'.compose-maybe (cdr funcs)) arg)))
(message "%s" value)
(when value (funcall (car funcs) value)))
arg)))