I have the following classes, and more like them:
(defclass weapon ()
((base-slice-damage
:documentation "Base slice damage dealt by weapon"
:reader base-slice-damage
:initform 0
:initarg :base-slice-damage)
(base-blunt-damage
:reader base-blunt-damage
:initform 0
:initarg :base-blunt-damage)
(base-pierce-damage
:reader base-pierce-damage
:initform 0
:initarg :base-pierce-damage)))
(defclass dagger (weapon)
((base-slice-damage
:initform 3)
(base-pierce-damage
:initform 6)))
(defclass attack ()
((slice-damage-dealt
:initarg :slice-damage-dealt
:reader slice-damage-dealt)
(blunt-damage-dealt
:initarg :blunt-damage-dealt
:reader blunt-damage-dealt)
(pierce-damage-dealth
:initarg :pierce-damage-dealt
:reader pierce-damage-dealt)))
As you can see, there is a lot of repetition. For two of the classes, my slots all have the same option and vary only by whether they're slice, blunt, or pierce.
I've thought about using a macro to define attribute classes and then just mixing those in. This is what I have so far:
(defmacro defattrclass (attr-name &body class-options)
`(defclass ,(symb attr-name '-attr) ()
((,attr-name
,#class-options))))
But this really doesn't go far enough.
Edit:
I've come up with this, though I'm not completely happy with it:
(defmacro defattrclass (attr-name &body class-options)
`(defclass ,(symb attr-name '-attr) ()
((,attr-name
,#class-options))))
(defmacro defattrclasses (attr-names &body class-options)
`(progn
,#(loop for attr-name in attr-names collect
`(defattrclass ,attr-name ,#class-options))))
Not quite 100% coverage of the features you want, but I've been using this macro for a while:
(defmacro defclass-default (class-name superclasses slots &rest class-options)
"Shorthand defclass syntax; structure similar to defclass
Pass three values: slot-name, :initform, and :documentation
Everything else gets filled in to standard defaults"
`(defclass
,class-name
,superclasses
,(mapcar (lambda (x) `( ,(first x)
:accessor ,(first x)
:initarg ,(intern (symbol-name (first x)) "KEYWORD")
:initform ,(second x)
:documentation ,(third x)))
slots)
,#class-options))
To use:
CL-USER>
(defclass-default weapon ()
((base-slice-damage 0 "Base slice damage dealt by a weapon")
(base-blunt-damage 0 "Needs a doc")
(base-pierce-damage 0 "Needs a doc")))
#<STANDARD-CLASS WEAPON>
CL-USER>
IMHO it looks like you need a class damage with three fields (slice, blunt, pierce). You can use that class inside weapon, attack etc.
Related
Suppose I have a class class with slots first and second. Inside my function I can bind a variable to one of those slots like
(symbol-macrolet ((var (first cls)))
....)
Obviously I can also bind the second slot to smth.
Questions is, let's say that first and second are either some number or nil. Let's also say that if second is non-nil, first is always nil. Now, can I bind my var to a non-nil one with just one macro? So it just looks at instance of the class given and then check if second is nil. If no, it binds var to second, otherwise to first.
Seems complicated, but I'm pretty sure it can be done, just don't know where to start.
To further generalize -- is it possible to bond a variable not to a single place, but to one of a specific set, depending on some state?
I think this is not quite simple. You could do something like this which works for reading only (I've used a fake toy structure so my code works, which is given here):
(defstruct toy
(first nil)
(second nil))
(defun foo (a-toy)
(symbol-macrolet ((x (or (toy-first a-toy) (toy-second a-toy))))
...))
But now (setf x ...) is horribly illegal. You can get around this, once you've decided what (setf x ...) should do, by defining some local functions. I've decided here that it should set the non-nil slot, as that makes sense to me.
(defun bar (a-toy)
(flet ((toy-slot (the-toy)
(or (toy-first the-toy) (toy-second the-toy)))
((setf toy-slot) (new the-toy)
(if (toy-first the-toy)
(setf (toy-first the-toy) new)
(setf (toy-second the-toy) new))))
(symbol-macrolet ((x (toy-slot a-toy)))
(setf x 2)
a-toy)))
And now you can wrap this all in a single macro:
(defmacro binding-toy-slot ((x toy) &body forms)
(let ((tsn (make-symbol "TOY-SLOT")))
`(flet ((,tsn (the-toy)
(or (toy-first the-toy) (toy-second the-toy)))
((setf ,tsn) (new the-toy)
(if (toy-first the-toy)
(setf (toy-first the-toy) new)
(setf (toy-second the-toy) new))))
(symbol-macrolet ((,x (,tsn ,toy)))
,#forms))))
(defun bar (a-toy)
(binding-toy-slot (x a-toy)
(setf x 3)
a-toy))
Obviously you might want to generalise binding-toy-slot, so it, for instance, takes a list of slot accessor names or something like that.
There may also be better ways of doing this I haven't thought of: there might be clever tricks with setf-expansions that let you do it without the little helper functions. You could also have global helper functions which get passed an object and a list of accessors to try which would make the code slightly smaller (although you can probably achieve similarly small code in any serious implementation by declaring the helpers inline which should cause them to be completely compiled away).
An alternative, and perhaps better, approach, is to define the protocol you want to achieve using generic functions. This means things are defined globally, and it's related to but not quite the same as Kaz's answer.
So again, let's say I have some class (this can be a structure, but making it a fully-fledged standard-class lets us have unbound slots, which is nice):
(defclass toy ()
((first :initarg :first)
(second :initarg :second)))
Now you could either define generic functions with names like appropriate-slot-value & (setf appropriate-slot-value), or you could define GF which returns the name of the appropriate slot, like so:
(define-condition no-appropriate-slot (unbound-slot)
;; this is not the right place in the condition heirarchy probably
()
(:report "no appropriate slot was bound"))
(defgeneric appropriate-slot-name (object &key for)
(:method :around (object &key (for ':read))
(call-next-method object :for for)))
(defmethod appropriate-slot-name ((object toy) &key for)
(let ((found (find-if (lambda (slot)
(slot-boundp object slot))
'(first second))))
(ecase for
((:read)
(unless found
(error 'no-appropriate-slot :name '(first second) :instance object))
found)
((:write)
(or found 'first)))))
And now the accessor function pair can be plain functions which will work for any class where there is a method for appropriate-slot-name:
(defun appropriate-slot-value (object)
(slot-value object (appropriate-slot-name object :for ':read)))
(defun (setf appropriate-slot-value) (new object)
;; set the bound slot, or the first slot
(setf (slot-value object (appropriate-slot-name object :for ':write)) new))
Finally, we can now have functions which just use symbol-macrolet in the obvious way:
(defun foo (something)
(symbol-macrolet ((s (appropriate-slot-value something)))
... s ... (setf s ...) ...))
So, that's another approach.
Simple, inefficient way with defsetf:
(defun second-or-first (list)
(or (second list) (first list)))
(defun set-second-or-first (list val)
(if (second list)
(setf (second list) val)
(setf (first list) val)))
(defsetf second-or-first set-second-or-first)
(defun test ()
(let ((list (list nil nil)))
(symbol-macrolet ((sof (second-or-first list)))
(flet ((prn ()
(prin1 list) (terpri)
(prin1 sof) (terpri)))
(prn)
(setf sof 0)
(prn)
(setf sof 1)
(prn)
(setf (second list) 3)
(prn)
(setf sof nil)
(prn)
(setf sof nil)
(prn)))))
If it is okay that update expressions like (incf sof) wastefully traverse the structure twice, this is adequate.
Otherwise a more sophisticated implementation is required using define-setf-expander. The gist of such a solution is that the generated code has to calculate which of the two cons cells of the list holds the current place, storing that cons cell in a temporary variable #:temp. Then the place we are interested in is denoted by (car #:temp). If #:temp is the second cell, avoiding two accesses to are tricky (one access to determine it's the one we want, then the other to get the prior value). Basically what we can do is have another temp variable which holds the value of the place that we obtained as a side effect of checking whether it is not nil. Then designate that temporary variable as the access form for getting the prior value.
Here’s how you might not use symbol macros without any huge loss:
(defgeneric firsty-secondy (thing))
(defgeneric (setf firsty-secondy) (newval thing))
(defmethod firsty-secondy ((x my-class))
(or (secondy x) (firsty x)))
(defmethod (setf firsty-secondy) (nv (x my-class))
(if (secondy x)
(setf (secondy x) nv)
(setf (firsty x) nv)))
You may find that the compiler does better with these because within the methods it can be more sure about where the slots for the fields are in memory.
Here is a way to structure your object to not need to do this and enforce your invariant a bit better:
(defclass my-class
((is-first :initform nil)
(thingy :initform nil)))
Here is a comparison:
first=nil,second=nil : is-first=nil,thingy=nil
first=123,second=nil : is-first=t ,thingy=123
first=nil,second=123 : is-first=nil,thingy=123
first=123,second=456 : unrepresentable
I'm trying to learn about CLOS, and have written an example class. It has 4 slots, named slot1-4. slot2 has an initform, yet none the less I am getting this error: "The slot COMMON-LISP-USER::SLOT2 is unbound in the object". I am failing to see how this is possible. I am using SBCL and my code is as follows:
;;;; The following is meant to demonstrate some concepts of object initialisation
(defclass example ()
((slot1
:initarg :slot1-arg
:initform (error "must supply a slot1"))
(slot2
:initform "This is the initform"
:reader slot2-reader
:writer (setf slot2-writer))
(slot3
:accessor slot3-accessor
:documentation "The third slot")
(slot4)))
(defmethod initialize-instance :after ((instance example) &key)
(setf (slot-value instance 'slot4)
"this was set in INITIALIZE-INSTANCE"))
(let ((xampl (make-instance 'example
:slot1-arg "Must provide this or there will be an error")))
(setf (slot3-accessor xampl)
"it is necessary to initialize this slot, as there is not initform or initarg")
(print (slot3-accessor xampl))
(setf (slot-value xampl 'slot3) "this also works")
(print (slot-value xampl 'slot3))
(print (slot2-reader xampl)))
I have a list of the names of slots of a CLOS object:
(DEFCLASS TRIAL-DATA (STANDARD-OBJECT)
((A-DATUM :ACCESSOR A-DATUM :INITARG :A-DATUM :INITFORM NIL)
(BOTH-DATA :ACCESSOR BOTH-DATA :INITARG :BOTH-DATA :INITFORM 0)
(CUMULATIVE-DATA :ACCESSOR CUMULATIVE-DATA :INITARG :CUMULATIVE-DATA :INITFORM NIL)
(NAME :ACCESSOR NAME :INITARG :NAME :INITFORM VALUE)))
(let* ((td (make-instance 'trial-data))
(slot-lst (mapcar #'slot-definition-name (class-slots (class-of td)))))
I can read the values of these slots:
(let* ((td (make-instance 'trial-data))
(slot-lst (mapcar #'slot-definition-name (class-slots (class-of td)))))
(funcall (symbol-function (nth 0 slot-lst)) td))
==> NIL
But why can I not write new values to these slots? Shouldn't my class definition of trial-data have created an accessor function for each slot?
;; Should set the first slot, a-datum's, value to 42
(let* ((td (make-instance 'trial-data))
(slot-lst (mapcar #'slot-definition-name (class-slots (class-of td)))))
(setf (funcall (symbol-function (nth 0 slot-lst)) td) 42))
==>
;Compiler warnings for "/Users/frank/Documents/NRL/Error/Patrolbot/Patrol Construction Notes & Testing.lisp" :
; In an anonymous lambda form at position 123: Undefined function (SETF FUNCALL)
> Error: Undefined function (SETF FUNCALL) called with arguments (42 #<STANDARD-GENERIC-FUNCTION A-DATUM #x302001D1C5DF> #<TRIAL-DATA #x30200200D95D>) .
> While executing: #<Anonymous Function #x30200200EB7F>, in process Listener-2(5).
The accessor is called a-datum.
The reader:
CL-USER 9 > #'a-datum
#<STANDARD-GENERIC-FUNCTION A-DATUM 406000091C>
The writer:
CL-USER 10 > #'(setf a-datum)
#<STANDARD-GENERIC-FUNCTION (SETF A-DATUM) 422000958C>
If you want to call via funcall the writer, you need to call above function.
If you have a plain form (setf (a-datum foo) 'bar)) then this needs to be resolved at macro expansion time.
The error message says that #'(setf funcall) is undefined. Thus (setf (funcall ...) ...) does not exist.
How do you get the writer function in your case?
CL-USER 11 > (fdefinition '(setf a-datum))
#<STANDARD-GENERIC-FUNCTION (SETF A-DATUM) 422000958C>
CL-USER 12 > (let ((name 'a-datum)) (fdefinition `(setf ,name)))
#<STANDARD-GENERIC-FUNCTION (SETF A-DATUM) 422000958C>
Task for you: what are the correct arguments for above function?
Rainer Joswigs's answer addresses the issue of why you can't set with the code that you have now. However, it's also important to note that there's no reason that reader, writer, or accessor name has to be the same as the slot name, so if what you've actually got is the slot name, then you should use (setf slot-value) with it. E.g.,
(defclass foo ()
((bar :accessor getbar :initform 42)))
(defparameter *foo* (make-instance 'foo))
;; neither of these work
(setf (bar *foo*) 34)
(funcall #'(setf bar) 34 *foo*)
(slot-value *foo* 'bar)
;=> 42
(setf (slot-value *foo* 'bar) 36)
;=> 26
(slot-value *foo* 'bar)
;=> 36
Ok here is How i instantiate my Defclass and related Defmethod and Defparameter
(defvar *account-numbers* 0)
(defclass bank-account ()
((customer-name
:initarg :customer-name
:initform (error "Must supply a customer name.")
:accessor customer-name
:documentation "Customer's name")
(balance
:initarg :balance
:initform 0
:reader balance
:documentation "Current account balance")
(account-number
:initform (incf *account-numbers*)
:reader account-number
:documentation "Account number, unique within a bank.")
(account-type
:reader account-type
:documentation "Type of account, one of :gold, :silver, or :bronze.")))
(defmethod initialize-instance :after ((account bank-account)
&key opening-bonus-percentage)
(when opening-bonus-percentage
(incf (slot-value account 'balance)
(* (slot-value account 'balance) (/ opening-bonus-percentage 100)))))
(defparameter *account* (make-instance
'bank-account
:customer-name "Ed Monney"
:balance 1000000000
:opening-bonus-percentage 5))
I'm trying to access the :documentation slot-value of any said slot but have not been able to find info in the book i'm reading nor google....
My attempts include
(documentation *account* 'balance)
got this error
WARNING:
unsupported DOCUMENTATION: type BALANCE for object of type BANK-ACCOUNT
I tried
(slot-value bank-account ('balance :documentation))
I got
The variable BANK-ACCOUNT is unbound.
[Condition of type UNBOUND-VARIABLE]
I tried every other variation I could think of slot-value 'balance :documentation 'documentation bank-account and *account* I can think of but just got a lot of different errors any help on learning how to access the :documentation of a defclass slot
is much appreciated
Edit:
#Rainer Joswig that seems to work only right after i entered the defclass at the repl...I was hoping for a way that , if I had a set defclass in a library or something I could just run a command and access the doc. . They way you posted though if i run something else at the repl after the defclass ....I get an error when i run those 4 lines of code....I tried something like (documentation (slot-value account 'balance) t) after i've run my initialize-instance and my defparam account as in my post but get error....could you suggest a way to make the documentation easier to access.
This is not defined in the Common Lisp standard. Unfortunately this is also not beginners territory.
Implementations may provide a way to access the documentation string of a slot.
LispWorks example:
CL-USER 23 > (defclass foo ()
((bar :documentation "this is slot bar in class foo")))
#<STANDARD-CLASS FOO 40200032C3>
CL-USER 24 > (class-slots *)
(#<STANDARD-EFFECTIVE-SLOT-DEFINITION BAR 4020004803>)
CL-USER 25 > (first *)
#<STANDARD-EFFECTIVE-SLOT-DEFINITION BAR 4020004803>
CL-USER 26 > (documentation * 'slot-definition)
"this is slot bar in class foo"
It also works in Clozure CL.
For SBCL it works slightly different.
* (defclass foo ()
((bar :documentation "this is slot bar in class foo")))
#<STANDARD-CLASS FOO>
* (sb-mop:finalize-inheritance *)
NIL
* (sb-mop::class-slots **)
(#<SB-MOP:STANDARD-EFFECTIVE-SLOT-DEFINITION BAR>)
* (first *)
#<SB-MOP:STANDARD-EFFECTIVE-SLOT-DEFINITION BAR>
* (documentation * t)
"this is slot bar in class foo"
I was working with common lisp, and found myself typing up slot definitions of the following form quite a lot:
(name :initarg :name :accessor name)
And so I thought to concoct a macro to speed up this. I came up with the following:
(defmacro quickslot (name)
`(,name :initarg ,(intern (string-upcase name) "KEYWORD") :accessor ,name))
A dirty hack, no doubt, but functional. Or so I thought. When I tried to run my code, I cam across a snag: since defclass is a macro, the arguments are passed to it unevaluated. That means, instead of seeing
(x :initarg :x :accessor x)
It sees
(quickslot x)
Which, of course, signals an error.
The answer, it seems to me, would be to somehow control the order of macro expansion in order to make sure quickslot is expanded before defclass. Which brings me to my question: how would one accomplish this? Or, if you have a different solution to my initial conundrum, that would not go unappreciated either.
That's not really worthy of a macro. Macros typically take literal Lisp source code as their input.
Instead you could just use a function. From Practical Common Lisp, Ch.24:
(defun as-keyword (sym) (intern (string sym) :keyword))
(defun slot->defclass-slot (spec)
(let ((name (first spec)))
`(,name :initarg ,(as-keyword name) :accessor ,name)))
Then you could do something like (again adapted from PCL):
(defmacro my-defclass (name slots)
`(defclass ,name ()
,(mapcar #'slot->defclass-slot slots)))
No, you can't do it. You could write a macro around defclass instead though (that has some special syntax for your quickslots).
You could approach the problem entirely differently and come up with a reader-macro that instructs the reader to call macroexpand on the code that follows it, that would be more generic then just the one purpose for slots declaration in the class. But the complete solution would be somewhat involved, because you'd had to account for many peculiarities and demands of the reader, however, even something as ugly as this would do the job:
(defmacro quickslot (name)
`(,name :initarg ,(intern (string-upcase name) "KEYWORD") :accessor ,name))
(macroexpand '(defclass test-class ()
(#.(macroexpand '(quickslot some-slot)))))
So, what you'd have to do would be something like an alias to #.(macroexpand ...)
And... here you go:
(set-macro-character
#\{
#'(lambda (str char)
(declare (ignore char))
(let ((*readtable* (copy-readtable *readtable* nil))
(reading-p t))
(set-macro-character
#\}
#'(lambda (stream char)
(declare (ignore char stream))
(setf reading-p nil)))
(loop for exp = (read str nil nil t)
while reading-p
collect (macroexpand exp)))))
(read-from-string "'(defclass test-class ()
{(quickslot some-slot)
(quickslot some-other-slot)})")
'(DEFCLASS TEST-CLASS NIL
((SOME-SLOT :INITARG :SOME-SLOT :ACCESSOR SOME-SLOT)
(SOME-OTHER-SLOT :INITARG :SOME-OTHER-SLOT :ACCESSOR
SOME-OTHER-SLOT)))
:)