My first LTK-application. Trying to execute function with argument from entry-field.
(defpackage :test
(:use :cl
:ltk))
(in-package :test)
(defun main()
(with-ltk ()
(let* ((f (make-instance 'frame
:height 200
:width 300))
(e (make-instance 'entry
:master f
))
(b (make-instance 'button
:master f
:text "Go"
:command (test (text e)))))
(wm-title *tk* "Test")
(pack f)
(pack e :side :left)
(pack b :side :left)
(configure f :borderwidth 3)
(configure f :relief :sunken))))
(defun test (str)
(format t "String: ~a" str))
Why function execute just once, when source is launched? And then - any actions.
If you want to pass a callback, use (lambda () ...), i.e. in your code:
...
(b (make-instance 'button
:master f
:text "Go"
:command (lambda () (test (text e))))))
Otherwise, your (test (text e)) is executed at the time of make-instance call, before the object is initialized.
It's easier to spot this problems, if you turn on debug output: (setf ltk:*debug-tk* t)
Related
I came across some strange behaviour when trying to customize the print-object function of a CLOS object. The function does generate the intended string, but it appears outside the object definition (i.e. <OBJECT-NAME > followed by the string I wanted after the > character). The skeleton code below reproduces the issue:
(defclass object () ;;; Define some object...
((element-count
:initarg :element-count
:accessor n)
(first-element
:initform nil
:accessor 1st)
(last-element
:initform nil
:accessor end)))
(defmethod print-object ((obj object) stream) ;;; ...and then its print-object method
(print-unreadable-object (obj stream :type t))
(with-accessors ((first 1st)
(last end)
(n n))
obj
(format stream " ~[empty~:;:elements ~:*~d :content ~:*(~[~;~a~;~a ~a~:;~a ... ~a~])~]"
n first last)))
The output strings appear thus:
(defvar o1 (make-instance 'object :element-count 0)) => #<OBJECT > empty
(defvar o2 (make-instance 'object :element-count 1)) => #<OBJECT > :elements 1 :content (NIL)
(defvar o3 (make-instance 'object :element-count 2)) => #<OBJECT > :elements 2 :content (NIL NIL)
(defvar o4 (make-instance 'object :element-count 10)) => #<OBJECT > :elements 10 :content (NIL ... NIL)
I don't understand this output. Per the docs, printing outside the space shouldn't ever happen. Or should it? Well, over to you! By the way, I'm using SBCL on Portacle in Windows.
You misplaced parens - print-unreadable-object creates an environment which should encompass the whole print-object body:
(defclass airplane () ((tail-number :initarg tail :accessor plane-tail)))
(defmethod print-object ((plane airplane) stream)
(print-unreadable-object (plane stream :type t)
(princ (plane-tail plane) stream)))
(make-instance 'airplane 'tail 1234)
==> #<AIRPLANE 1234>
I'm new to lisp (i'm experimenting with sbcl and ccl), i came across the use of car and cdr that can be chained arbitrarily within a single function call like (caddr).
I was wandering how one would write functions that behave like this...
Say for example i'd like my-eval to eval the input s-exp 3 times if i invoke it like (my-evaaal '(+ 2 1))
I've hacked my way around with a macro like
(my-ev $$$$ '(...)) where the behavior is dictated by the number of '$' in the first argument by transforming it into char sequence (coerce (symbol-name x) 'list) and the evaluate and recurse until the list is nil...
basic need:
;; if
(defvar *foo* 1)
(eval '*foo*) ;; => 1
(eval ''*foo*) ;; => *foo*
(eval '''*foo*) ;; => '*foo*
;; then
(eval (eval (eval '''*foo*))) ;; => 1
desired syntax
(my-eval '''*foo*) ;; => '*foo*
(my-evaal '''*foo*) ;; => *foo*
(my-evaaal '''foo) ;; => 1
Functions like CAAR, CADR are just regular functions; you can define a macro to help you define them easily if you want to.
Macros
(defpackage :so (:use :cl :ppcre))
(in-package :so)
(defmacro eval%% (count form)
(case count
(0 form)
(1 `(eval ,form))
(t (check-type count (integer 2))
`(eval%% ,(1- count) (eval ,form)))))
For example, the following :
(eval%% 3 '''most-positive-fixnum)
expands successively as:
(EVAL%% 2 (EVAL '''MOST-POSITIVE-FIXNUM))
(EVAL%% 1 (EVAL (EVAL '''MOST-POSITIVE-FIXNUM)))
(EVAL (EVAL (EVAL '''MOST-POSITIVE-FIXNUM)))
Then, you can define custom eval functions as follows, or even with another macro:
(defun evaal (x) (eval%% 2 x))
(defun evaaal (x) (eval%% 3 x))
Handler and restarts
Alternatively, note that you can catch calls to undefined functions:
(block nil
(handler-bind ((undefined-function
(lambda (e)
(return
(values (cell-error-name e)
(compute-restarts e))))))
(evaaaaaal 'a)))
=> EVAAAAAAL
(#<RESTART CONTINUE {7FD5F5F8CE43}> #<RESTART USE-VALUE {7FD5F5F8CE03}>
#<RESTART SB-KERNEL::RETURN-VALUE {7FD5F5F8CDC3}>
#<RESTART SB-KERNEL::RETURN-NOTHING {7FD5F5F8CD83}>
#<RESTART SWANK::RETRY {7FD5F5F8DA13}> #<RESTART ABORT {7FD5F5F8DEC3}>
#<RESTART ABORT {7FD5F5F8EB03}>)
You can also use the standard USE-VALUE restart to provide a different function to call:
(defun multi-eval-handler (condition)
(let ((name (cell-error-name condition)))
(when (eq (symbol-package name) (find-package :so))
(register-groups-bind ((#'length count)) ("EV\(A+\)L" (string name))
(invoke-restart 'use-value (make-repeated-evaluator count))))))
You need an auxiliary function that computes an evaluation N times:
(defun make-repeated-evaluator (count)
(case count
(0 #'identity)
(1 #'eval)
(t (check-type count (integer 2))
(lambda (form)
(loop
for value = form then (eval value)
repeat count
finally (return value))))))
For example:
(funcall (make-repeated-evaluator 3)
'''most-positive-fixnum)
=> 4611686018427387903
And then, you can have arbitrarily long eval functions:
(handler-bind ((undefined-function #'multi-eval-handler))
(evaaaaaaaaaaaaaal '''''''''''''0))
Now, if you compile the code, you'll have warnings at compile-time about the unknown function, when then you can muffle warnings.
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
I'd like to control the way the values are saved in slots and what is returned when I read a slot. Here is my class definition:
(defclass object ()
((name :accessor name-access
:initform 'noname
:initarg :name)
(value :accessor value-access
:initform 10
:initarg :value)))
I create the object this way:
(setf obj1 (make-instance 'object))
This is the way how I get the value of the slot name:
(name-access obj1)
And how I set a new value:
(setf (name-access obj1) 'realname)
What is the right way to override this accessor function (or method) in order to be able to make some changes to the object (on write) and to control the returned value?
Thank you.
You can just manually define the methods for getting and setting the slots:
(defclass foo ()
((name :initform 'noname
:initarg :name)))
(defgeneric name-access (foo)
(:method ((foo foo))
(format t "~&Getting name.~%")
(slot-value foo 'name)))
(defgeneric (setf name-access) (name foo)
(:method (name (foo foo))
(format t "~&Setting a new name.~%")
(setf (slot-value foo 'name) name)))
(defparameter *foo* (make-instance 'foo))
(name-access *foo*)
; Getting name.
;=> NONAME
(setf (name-access *foo*) 'some-name)
; Setting a new name.
;=> SOME-NAME
(name-access *foo*)
; Getting name.
;=> SOME-NAME
The book Practical Common Lisp goes through these in chapter 17. You should read that.
You can extend the accessor methods defined by DEFCLASS:
CL-USER 66 > (defclass object ()
((name :accessor name-access
:initform 'noname
:initarg :name)
(value :accessor value-access
:initform 10
:initarg :value)))
#<STANDARD-CLASS OBJECT 4220014953>
Writing, using a :before method:
CL-USER 67 > (defmethod (setf name-access) :before (new-value (o1 object))
(print "hi"))
#<STANDARD-METHOD (SETF NAME-ACCESS) (:BEFORE) (T OBJECT) 40202283BB>
Reading, with an :around method:
CL-USER 68 > (defmethod name-access :around ((o1 object))
(let ((name (call-next-method)))
(values name (length (symbol-name name)))))
#<STANDARD-METHOD NAME-ACCESS (:AROUND) (OBJECT) 4020061213>
Example:
CL-USER 69 > (let ((o1 (make-instance 'object)))
(setf (name-access o1) 'foobar)
(name-access o1))
"hi" ; side effect
FOOBAR ; return value 1
6 ; return value 2
I have this function scalar which is a wrapper of the 2 function definitions commented above it.
My ? is how do I mem-aref the output of (scalar 1 2 3 4), which is #<CV-SCALAR {10044559D3}>
I think #<CV-SCALAR {10044559D3}> is called a Meta-Object
;; Scalar* cv_create_Scalar(double val0, (double val1, double val2, double val3)
(defcfun ("cv_create_Scalar" %scalar) scalar
(val0 :double)
(val1 :double)
(val2 :double)
(val3 :double))
(define-foreign-type scalar ()
((garbage-collect :reader garbage-collect :initform nil :initarg
:garbage-collect))
(:actual-type :pointer)
(:simple-parser scalar))
(defclass cv-scalar ()
((c-pointer :reader c-pointer :initarg :c-pointer)))
(defmethod translate-to-foreign ((lisp-value cv-scalar) (c-type scalar))
(c-pointer lisp-value))
(defmethod translate-from-foreign (c-pointer (c-type scalar))
(let ((scalar (make-instance 'cv-scalar :c-pointer c-pointer)))
(when (garbage-collect c-type)
(tg:finalize scalar (lambda () (del-scalar c-pointer))))
scalar))
If you defclass and defmethods are defined as above you run (mem-aref (c-pointer a) :int 1) to mem-aref the return-value