; Demonstration of classes in XLISP by implementing various Smalltalk
; Collection classes.
; Author: Tom Almy
; Date: September 1996
; NOTE -- you should probably check out EXAMPLE.LSP, TURTLES.LSP, and
; BLOCKS.LSP first as they are somewhat simpler.
#-:classes (load "classes") ; We'll use these nice macros
; We will put everyting in a package to keep it out of the user name space
#+:packages (unless (find-package "CLASSES")
(make-package "CLASSES" :use '("XLISP")))
(in-package "CLASSES")
; List the symbols available on the outside -- in this case the class names.
; The message selectors are all in the keyword package so they don't need
; to be exported.
(export '(Collection Set Bag Dictionary SequenceableCollection
Array OrderedCollection SortedCollection Interval))
; Our basic Collection class is "abstract" -- it's just defined to
; subclass into useful types of collections. We'll define a single instance
; variable: "data" contains the collection's data, the format to be
; defined by the subclass. Various subclasses will define any additional
; instance variables.
; The actual collections used in applications will be created from subclasses
; of Collection. This demo will implement:
; Bag -- an unordered collection of objects
; Set -- like a bag, but no duplicate elements
; Dictionary -- access elements using symbolic keys
; SequenceableCollection -- Abstract class which is subclassed into:
; Array -- elements have a sequence. Collection has a fixed size
; OrderedCollection -- same as Array but no fixed size, can add/delete from
; either end.
; SortedCollection -- An Ordered collection with a colating sequence
; Interval -- contains a constant sequence
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; ;
; THE COLLECTION CLASS ;
; ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defclass Collection (data))
; The defclass macro defines a new class, which is bound to the symbol
; "Collection". The macro also defines several default methods for instance
; variable access (:data in this case), and instance initialization (:isnew).
; Unlike Smalltalk, XLISP has no class methods. In Smalltalk you create an
; instance of a class by sending a message to the class. In XLISP, the classes
; are members of class Class, and you create an instance by sending the class
; a message with the selector :new. i.e. (send MyClass :new <xxx>) where xxx
; are 0 or more arbitrary expressions. This executes the :new method in class
; Class which will create an object which is a member of the desired class
; (call it newobj) and then does a (send newobj :isnew <xxx>). The :isnew
; method gets the expressions, which it can then use to customize the
; initiation. So, basically, the :isnew method in a class takes the place of
; the class methods of Smalltalk. Not as functional, but it usually does all
; that is needed. The class Array demonstrates how two instance creation
; methods can be supported via the use of keyword arguments.
;;;;;;;;;
; The following group of methods are "private" methods in that they are not
; intended for use in applications, but just to aid in implementation.
; :notImplemented provides a nice error message for messages that aren't
; handled by our class. It's not really necessary to define these!
(defmethod Collection :notImplemented (msg)
(error "~s not handled in class ~a"
msg
(send (send self :class) :pname)))
; Here's the difference:
; >(send x :foo) :notImplemented USED
; error: no method for this message - :foo
; >(send x :foo) :notImplemented NOT USED
; error: :foo not handled in class Bag
; :map is a mapcar like mapping function for the collection.
; This version only works when data instance variable is sequence of
; collection elements. We will have to override the method for subclasses
; that maintain their data differently.
(defmethod Collection :map (fcn) (map 'cons fcn data))
; :addAll will add the elements in the argument collection to this
; collection. We'll extend this definition so it works with sequences as
; well. It won't work with Arrays (which are a fixed size), Intervals
; (which are not alterable), or Dictionaries (which require keys).
(defmethod Collection :addAll (arg)
(if (or (listp arg) (arrayp arg) (stringp arg))
; Use map when argument is a sequence
(map nil (lambda (x) (send self :add x)) arg)
; Otherwise, send :map to the argument collection
(send arg :map (lambda (x) (send self :add x))))
self)
; Override default "isnew" to disallow creating abstract collections.
; There is no reason for any program to create an instance of Collection.
(defmethod Collection :isnew (&rest dummy)
(error "Don't create collections of class \"Collection\""))
;;;;;;;;;
; Now we will define some "public" methods for Collection. Most will be
; overriden in a subclass. The rest we will provide with a common default
; functionality.
; :prin1 determines how an object is printed. The default is to print
; the objects class and unique ID. We want to do better than that if the
; collection is small enough to easily display, say 5 or fewer elements
(defmethod Collection :prin1 (&optional (stream *standard-output*))
(let ((contents (send self :asList)) ; get collection as a list
(cls(send(send self :class):pname))) ; and get our class' name
(cond ((null contents)
(format stream "#<An empty ~a>" cls))
((< (length contents) 6)
(format stream "#<~a:~{ ~s~}>" cls contents))
(t
(format stream "#<~a:~5{ ~s~} ...>" cls contents)))))
; :storeon is used to create an expression which, when executed, will create a
; copy of the object. The Default method, part of class Object, won't work
; for classes that override :isnew, and all Collection classes do.
(defmethod Collection :storeon ()
(list 'send
(list 'send
(intern (send (send self :class) :pname))
:new)
:addAll
(list
'quote
(send self :asList))))
; :at will fetch an element from an "sequenceable collection"
; Not all collections have the concept of sequencing.
(defmethod Collection :at (arg) (send self :notImplemented :at))
; :atput will store an element into a "sequenceable collection".
(defmethod Collection :atPut (arg1 arg2) (send self :notImplemented :atPut))
; :first will fetch the first element of the collection, where appropriate.
; :last does the same thing but for the last element.
(defmethod Collection :first () (send self :notImplemented :first))
(defmethod Collection :last () (send self :notImplemented :last))
; :add will store (one or more copies of) an element into a collection
; :addFirst will add to the start of a collection. These two are not
; implemented for all classes.
(defmethod Collection :add (arg &optional value)
(send self :notImplemented :add))
(defmethod Collection :addFirst (arg)
(send self :notImplemented :addFirst))
(defmethod Collection :addLast (arg)
(send self :notImplemented :addLast))
; Delete the specified, first, or last element
(defmethod Collection :remove (arg)
(send self :notImplemented :remove))
(defmethod Collection :removeFirst ()
(send self :notImplemented :removeFirst))
(defmethod Collection :removeLast ()
(send self :notImplemented :removeLast))
; :size -- Get the size of the the Collection. This will work for
; most subclasses.
(defmethod Collection :size () (length data))
; :empty -- Returns T if collection has no elements
(defmethod Collection :empty () (zerop (send self :size)))
; :includes tells us if a object is a member of the collection
; This version only works when data instance variable is sequence of
; collection elements
(defmethod Collection :includes (arg)
(if (position arg data) t nil))
; :species returns the class similar to the current class to create new
; objects
(defmethod Collection :species ()
(send self :class))
; :do is like :map but returns nothing
; :collect is like :map, but returns a new collection.
; :select returns a collection of elements for which the predicate function
; returns non-NIL.
; These are generic enough to work for any of the Collection subclasses
; except Array, which requires an argument to :new,
; however in many cases they could be overridden for speed.
; Smalltalk defines these and a number of similar functions.
(defmethod Collection :do (fcn) (send self :map fcn) nil)
(defmethod Collection :collect (fcn)
(send (send (send self :species) :new) :addAll (send self :map fcn)))
(defmethod Collection :select (fcn)
(let ((result
(mapcan (lambda (x)
(when (funcall fcn x)
(list x)))
(send self :asList))))
(send (send (send self :species) :new) :addAll result)))
; Our final assortment of Collection methods create copies of the object in
; one of several Collection subclasses or as an LISP list.
; :asList will return the collection as a LISP linked list.
(defmethod Collection :asList () (send self :map #'identity))
; :asBag will return the collection as a Bag
(defmethod Collection :asBag ()
(let ((result (send Bag :new)))
(send result :addAll self)
result))
; :asSet will return the collection as a Set
(defmethod Collection :asSet ()
(let ((result (send Set :new)))
(send result :addAll self)
result))
; :asArray will return the collection as an Array
(defmethod Collection :asArray ()
(send Array :new :initial (send self :asList)))
; :asOrderedCollection will return the collection as an OrderedCollection
(defmethod Collection :asOrderedCollection ()
(let ((result (send OrderedCollection :new)))
(send result :addAll self)
result))
; :asSortedCollection will return the collection as an OrderedCollection
(defmethod Collection :asSortedCollection (&optional (fcn '<))
(let ((result (send SortedCollection :new fcn)))
(send result :addAll self)
result))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; ;
; THE SET CLASS ;
; ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Our first collection will be "Set". Initialization doesn't have to do
; anything since instance variables are initialized to NIL.
; We will use "eql" as the equality test
;
(defclass Set () nil Collection)
(defmethod Set :isnew ())
; We will need :add. But we will ignore the count.
(defmethod Set :add (arg &optional (count 1))
(setq data (adjoin arg data))
; Methods typically return (or "answer" in Smalltalk)
; the object, which is bound to "self", if there is
; nothing more appropriate.
self)
; We also need to define :remove
(defmethod Set :remove (arg)
(let ((pos (position arg data))) ; Find (first) instance
(when pos ; Delete found element
(if (zerop pos)
(setq data (cdr data))
(setf (cdr (nthcdr (1- pos) data))
(nthcdr (1+ pos) data))))
self))
; All the other methods inherited from Collection will work fine
; At last we can test out some collections!
; > (setq x (send Set :new)) Create a new set
; #<An empty Set>
; Note that if your system says "#<An empty SET>" that means you have
; *readtable-case* set to :upcase. It's nothing to be concerned about, but
; if you want the output to match, start over with *readtable-case* set to
; :invert.
; > (send x :add 3) Add the element "3"
; #<Set: 3>
; > (send x :add 1) Add the element "1"
; #<Set: 1 3>
; > (send x :add 3) Add another 3 -- it's ignored!
; #<Set: 1 3>
; > (send x :addAll '(1 2 3 4 5)) Add five elements
; #<Set: 5 4 2 1 3>
; We see the order has changed! This doesn't matter because these collections
; are defined to have no order.
; > (send x :remove '3) Remove element "3"
; #<Set: 5 4 2 1>
; > (send x :select #'evenp) Create a set with even elements of x
; #<Set: 2 4>
; > (send x :collect #'1+) Create a set with incremented
; elements of x
; #<Set: 2 3 5 6>
; > (let ((cnt 0)) (send x :do (lambda (x) (incf cnt x))) cnt)
; 12 Summing all the elements in the set
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; ;
; THE BAG CLASS ;
; ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Our next Collection class will be "Bag" which is an unordered collection
; of objects that we will implement with a hash table. The table value will
; be the number of occurances of the object in the collection.
; It's difficult to calculate the number of elements in a Bag, so we will
; maintain a running total in a new instance variable, size. The defclass
; function will create a :size method for us!
;
; After we've defined this class, we can finally start testing things out.
(defclass Bag (size) nil Collection)
; Because the data in a Bag will be a hash table instead of a list, we
; need to have "isnew" allocate a hash table.
; The entry equality test will be "eql"
(defmethod Bag :isnew nil
(setf (send self :data) (make-hash-table)
(send self :size) 0))
; We could have done this with "(setf data (make-hash-table) size 0)"
; but this technique is more rigorous.
; The method :add will insert one or more copies of an object in the collection
; We need to adjust the size instance variable when we add objects
(defmethod Bag :add (arg &optional (count 1))
(setf (gethash arg data) (+ (gethash arg data 0) count)
size (+ size count))
self ; Most methods return Self if there isn't anything else
) ; that is reasonable
; The method :remove will delete an object from the collection
; We need to adjust the size instance variable when we delete objects
(defmethod Bag :remove (arg)
(let ((cnt (gethash arg data)))
(when cnt ; element found
(setq size (1- size))
(if (= cnt 1)
(remhash arg data) ; delete if count would be 0
(setf (gethash arg data) (1- cnt))))
self
))
; We have to override the definition of :includes since data is stored
; differently in a bag than as a linked list.
(defmethod Bag :includes (arg)
(if (gethash arg data) t nil))
; We have to override the definition of :map since data is stored
; differently in a bag than as a linked list.
; Even though :collect is similar, we don't need to redefine it since
; Collection :collect uses :map to do its work.
(defmethod Bag :map (fcn)
(if data ; If in the rare case data isn't set up, we abort
(let (result)
(maphash (lambda (arg count)
(dotimes (i count)
(push (funcall fcn arg) result)))
data)
(nreverse result))
nil))
; Now for some Bag examples:
; > (setq y (send Bag :new)) Create a new bag, y
; #<An empty Bag>
; > (send y :add 3) As with set, add 3, 1, 3
; #<Bag: 3>
; > (send y :add 1)
; #<Bag: 3 1>
; > (send y :add 3)
; #<Bag: 3 3 1> Now there can be multiple copies!
; > (send y :addAll x) Add all the elements of Set x
; #<Bag: 5 4 3 3 2 ...> Elipsis means too many to display
; > (send y :asList) Use :asList to see entire contents
; (5 4 3 3 2 1 1)
; > (send y :remove 4)
; #<Bag: 5 3 3 2 1 ...> Remove still works
; > (send y :select #'oddp) Try :select :collect and :do
; #<Bag: 5 3 3 1 1>
; > (send (send y :collect #'1+) :asList)
; (6 4 4 3 2 2)
; > (let ((cnt 0)) (send y :do (lambda (x) (incf cnt x))) cnt)
; 15
; > (send y :asSet) Converting a Bag to a Set
; #<Set: 1 2 3 5> will delete duplicates
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; ;
; THE DICTIONARY CLASS ;
; ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; The Dictionary class will be implemented using a hash table like a Bag.
; The hash table will use #'equal for comparisons, allowing string keys
;
(defclass Dictionary () nil Collection)
(defmethod Dictionary :isnew nil
(setf (send self :data) (make-hash-table :test #'equal)))
; Getting the size of a Dictionary is slightly different than the default
(defmethod Dictionary :size () (hash-table-count data))
; We need to define the :at and :atPut methods. :at will be extended
; to allow a keyword argument "ifAbsent" to supply the return value.
; It's a closure, just like in Smalltalk
(setq gened (gensym)) ; We need a unique symbol
(defmethod Dictionary :at (key &key ifAbsent)
(let ((value (gethash key data '#.gened)))
(if (eq value '#.gened)
(if ifAbsent
(funcall ifAbsent)
nil)
value)))
(defmethod Dictionary :atPut (key value)
(setf (gethash key data) value)
self)
; :addAll needs to be redefined, and requires a list of key-value pairs.
; This method makes :storeon much simpler.
(defmethod Dictionary :addAll (arg)
(if (or (listp arg) (arrayp arg) (stringp arg))
; Use map when argument is a sequence
(map nil
(lambda (x) (send self :atPut (first x) (second x)))
arg)
; Otherwise, send :map to the argument collection
(send arg
:map
(lambda (x)
(send self :atPut (first x) (second x)))))
self)
; :remove won't work for a Dictionary, since we want to remove key/value
; associations. Thus we have :removeKey, with an optional ifAbsent.
(defmethod Dictionary :removeKey (key &key ifAbsent)
(if (eq (gethash key data '#.gened) '#.gened)
(progn
(remhash key data)
(setq count (1- count)))
(when ifAbsent (funcall ifabsent)))
self)
(unintern gened) ; We don't need this symbol anymore
; :keys returns a set of the keys
(defmethod Dictionary :keys ()
(let (list)
(maphash (lambda (key value) (setq list (cons key list)))
data)
(send (send Set :new) :addAll list)))
; :values returns a bag of the values
(defmethod Dictionary :values ()
(let (list)
(maphash (lambda (key value) (setq list (cons value list)))
data)
(send (send Bag :new) :addAll list)))
; :map is defined to work over the values
(defmethod Dictionary :map (fcn)
(let (list)
(maphash (lambda (key value)
(setq list (cons (funcall fcn value) list)))
data)
list))
; We have to override the definition of :includes since data is stored
; differently in a Dictionary than as a linked list.
(defmethod Dictionary :includes (arg)
(if (position arg (send self :asList)) t nil))
; :collect, :select aren't appropriate
(defmethod Dictionary :collect (arg)
(send self :notImplemented :collect))
(defmethod Dictionary :select (arg)
(send self :notImplemented :select))
; :prin1 needs to be overridden to show both keys and data
(defmethod Dictionary :prin1 (&optional (stream *standard-output*))
(let (contents ; get collection as a list
; and get our class' name
; (it might not be "Dictionary")
(cls (send (send self :class) :pname)))
(maphash (lambda (x y)
(setq contents (cons (list x y) contents)))
data)
(cond ((null contents)
(format stream
"#<An empty ~a>" cls))
((< (length contents) 6)
(format stream
"#<~a:~{ ~s~}>" cls contents))
(t
(format stream
"#<~a:~5{ ~s~} ...>" cls contents)))))
; A different :storeon is needed as well
(defmethod Dictionary :storeon ()
(let (contents) ; get collection as a list
(maphash (lambda (x y)
(setq contents (cons (list x y) contents)))
data)
(list 'send
(list 'send 'Dictionary :new)
:addAll
(list
'quote
contents))))
; Class Dictionary examples
; > (setq z (send Dictionary :new)) Create a new dictionary
; #<An empty Dictionary>
; > (send z :addAll '((a 1) (b 2) (c 3) (d 4))) Quickly add 4 entries
; #<Dictionary: (a 1) (b 2) (c 3) (d 4)>
; > (send z :at 'b) Given a key, returns value
; 2
; > (send z :at 'e :ifAbsent (lambda () "Key Not Found")) Check ":ifAbsent"
; "Key Not Found"
; > (send z :atPut 'b 7) :atPut will change value
; #<Dictionary: (a 1) (b 7) (c 3) (d 4)>
; > (send z :atPut 'e 100) :atPut will create new entries
; #<Dictionary: (a 1) (b 7) (c 3) (d 4) (e 100)>
; > (send z :asBag) Converting to Bag just gives
; #<Bag: 7 100 4 3 1> values
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; ;
; THE SEQUENCEABLECOLLECTION CLASS ;
; ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; The class SequenceableCollection is, like Collection, an abstract class.
; This is a good thing since who would want to type "SequenceableCollection"
; very often?
;
(defclass SequenceableCollection () nil Collection)
; Some methods can be defined that will work for all subclasses of
; SequenceableCollection. The minimum index value is 0.
(defmethod SequenceableCollection :at (arg) (elt data arg))
(defmethod SequenceableCollection :atPut (arg value)
(setf (elt data arg) value)
self)
(defmethod SequenceableCollection :first () (self :at 0))
(defmethod SequenceableCollection :last () (self :at (1- (send self :size))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; ;
; THE ARRAY CLASS ;
; ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; The Array class -- implemented using an array.
; Because it has a fixed size, we have to allocate space for it when
; we create it. We will allow for initialization, since :addAll won't work.
; Either : (send Array :new :size 10) for example, to create an array of 10
; entries or (send Array :new :initial (1 2 3 4 5)) for an initialized array.
(defclass Array () nil SequenceableCollection)
(defmethod Array :isnew (&key size initial)
; Size must be specified when creating array
(if size
(setf (send self :data) (make-array size))
(setf (send self :data)
(make-array (length initial) :initial-contents initial))))
; We have to override :collect because (send Array :new) won't work.
; But we can optimize while we are at it.
(defmethod Array :collect (fcn)
(let ((result (send Array :new :size (send self :size))))
(map-into (send result :data) fcn data)
result))
; We also have to override :select, for the same reason
(defmethod Array :select (fcn)
(let ((result
(mapcan (lambda (x)
(when (funcall fcn x)
(list x)))
(coerce (send self :data) 'list))))
(send (send self :class) :new :initial result)))
; Finally, :storeon needs to be changed since :addAll doesn't work for
; arrays.
(defmethod Array :storeon ()
(list 'send
'Array
:new
:initial
(list
'quote
(send self :asList))))
; Test of the Array class:
; > (setq a (send x :asArray)) Make Array from Set x
; #<Array: 5 4 2 1>
; > (send a :atPut 1 10) Change an element
; #<Array: 5 10 2 1>
; > (send a :select #'evenp) Get array of even elements
; #<Array: 10 2>
; > (send a :collect #'1+) Make array with values 1 larger
; #<Array: 6 11 3 2>
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; ;
; THE ORDEREDCOLLECTION CLASS ;
; ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; The OrderedCollection class uses linked lists and doesn't have the
; allocation problems of Array.
; Adding or deleteing from the start alters the index numbers,
; so we need a new instance variable to hold the offset.
(defclass OrderedCollection (offset) nil SequenceableCollection)
(defmethod OrderedCollection :isnew (&optional (offset 0))
; Optional argument sets offset of first element.
; This is a "private" feature to aid storeon.
(setf (send self :offset) offset))
; :at, :atPut, :first, and :last need revision
(defmethod OrderedCollection :at (arg) (elt data (+ arg offset)))
(defmethod OrderedCollection :atPut (arg value)
(setf (elt data (+ arg offset)) value)
self)
(defmethod OrderedCollection :first () (car data))
(defmethod OrderedCollection :last () (car (last data)))
; We need to implement add and remove for both ends
; :add will be equivalent to :addLast
(defmethod OrderedCollection :add (arg)
(setq data (nconc data (list arg)))
self)
(defmethod OrderedCollection :addlast (arg) (send self :add arg))
(defmethod OrderedCollection :addFirst (arg)
(setq offset (1+ offset))
(setq data (cons arg data))
self)
(defmethod OrderedCollection :removeFirst ()
(unless (zerop (length data))
(setq offset (1- offset))
(prog1 (car data) (setq data (cdr data)))))
(defmethod OrderedCollection :removeLast ()
(prog1 (car (last data)) (setq data (nbutlast data))))
; Finally, storeon is modified so that offset will be set
(defmethod OrderedCollection :storeon ()
(list 'send
(if (zerop offset)
(list 'send
(intern (send (send self :class) :pname))
:new)
(list 'send
(intern (send (send self :class) :pname))
:new
offset))
:addAll
(list
'quote
(send self :asList))))
; Example of use of OrderedCollection:
; > (setq c (send a :asOrderedCollection)) Make one from Array a
; #<OrderedCollection: 5 10 2 1>
; > (send c :at 1) Value at index 1 is 10
; 10
; > (send c :addFirst 7) Add to front of collection
; #<OrderedCollection: 7 5 10 2 1>
; > (send c :at 1) Index 1 is same spot
; 10
; > (send c :removeLast) Remove from either end
; 1
; > (send c :last) Last element is now 2
; 2
; > (send c :asArray) Convert back to an array
; #<Array: 7 5 10 2>
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; ;
; THE SORTEDCOLLECTION CLASS ;
; ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; The SortedCollection class requires a sort function. The collection gets
; re-sorted whenever a new element is added. This is a subclass of
; OrderedCollection.
; Offset won't change for this class.
(defclass SortedCollection (sortfcn) nil OrderedCollection)
(defmethod SortedCollection :isnew (&optional (fcn '< ))
(setq sortfcn fcn)
(send-super :isnew))
(defmethod SortedCollection :selfSort ()
; "private" method that sorts the list
(setq data (sort data sortfcn))
self)
(defmethod SortedCollection :add (arg)
(send-super :add arg)
(send self :selfSort))
; Don't allow addFirst, addLast, removefirst, removelast, or atPut
(defmethod SortedCollection :addFirst (arg)
(send self :notImplemented :addFirst))
(defmethod SortedCollection :addLast (arg)
(send self :notImplemented :addLast))
(defmethod SortedCollection :removeFirst (arg)
(send self :notImplemented :removeFirst))
(defmethod SortedCollection :removeLast (arg)
(send self :notImplemented :removeLast))
(defmethod SortedCollection :atPut (arg1 arg2)
(send self :notImplemented :atPut))
; We need a way to remove elements from a Sorted Collection.
; :remove (specifying the element) will do just fine.
(defmethod SortedCollection :remove (arg)
(let ((pos (position arg data))) ; Find (first) instance
(when pos ; Delete found element
(if (zerop pos)
(setq data (cdr data))
(setf (cdr (nthcdr (1- pos) data))
(nthcdr (1+ pos) data))))
self))
; Finally, storeon is modified so that the sort function will be set
(defmethod SortedCollection :storeon ()
(list 'send
(list 'send
(intern (send (send self :class) :pname))
:new
(list
'quote
sortfcn))
:addAll
(list
'quote
(send self :asList))))
; Let's see how the SortedCollection works:
; > (setq s (send c :asSortedCollection)) Sorted when it is created
; #<SortedCollection: 2 5 7 10>
; > (send s :add 8) :add puts new element in order
; #<SortedCollection: 2 5 7 8 10>
; > (send s :asSortedCollection #'>) New collection with order reversed
; #<SortedCollection: 10 8 7 5 2>
; > (send (send (send Set :new) :addAll '(5 3 8 2 5 4 8)) :asSortedCollection)
; #<SortedCollection: 2 3 4 5 8> Eliminate duplicates and sort
; > (send * :asList)
; (2 3 4 5 8)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; ;
; THE INTERVAL CLASS ;
; ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; The Interval class is considerably different than the others in that it has
; no "data" but calculates each elements value. We'll use three new
; instance variables -- start end and step. The :new function will take two
; or three arguments to specify start, end and step, with the step size
; defaulting to 1 not defined. We will set the data instance
; variable to T if the range is valid, and to NIL if not (no elements)
(defclass Interval (start end step) nil SequenceableCollection)
(defmethod Interval :isnew (arg1 arg2 &optional arg3)
(if arg3
(setq data (or (and (<= arg1 arg2)(> arg3 0))
(and (>= arg1 arg2)(< arg3 0))))
(setq arg3 1
data (<= arg1 arg2)))
(setq start arg1 end arg2 step arg3)
; Correct End value if necessary
(unless (zerop (rem (- end start) step))
(setq end (- end (rem (- end start) step))))
)
; :at calculates value. We won't check for out of range.
(defmethod Interval :at (arg) (+ start (* step arg)))
; :atPut isn't allowed
(defmethod Interval :atPut (arg1 arg2) (send self :notImplemented :atPut))
; :size returns calculated size
(defmethod Interval :size () (if data (1+ (truncate (- end start) step)) 0))
; :includes must be calcuated
(defmethod Interval :includes (arg)
(cond
((null data) nil)
((> step 0) (and (>= arg start)
(<= arg end)
(zerop (rem (- arg start) step))))
(t (and (<= arg start)
(>= arg end)
(zerop (rem (- arg start) step))))))
; While Collection bases :asList on :map, we want to base :map on
; :asList
(defmethod Interval :map (fcn) (mapcar fcn (send self :asList)))
(defmethod Interval :asList ()
(let ((result nil))
(when data
(dotimes (i (send self :size))
(setq result (cons (+ start (* i step))
result))))
(nreverse result)))
; Since :do is used often with an Interval, and since the default method
; would create a list of values, it would make sense to reimplement :do
; here as an Interval method. That will be left as an exercise for the
; reader!
; :collect, :select will work because we will redefine :species to
; create an OrderedCollection rather than an Interval
(defmethod Interval :species () OrderedCollection)
; Override printing methods
(defmethod Interval :prin1 (&optional (stream *standard-output*))
(format stream
"#<~a from ~s to ~s by ~s>"
(send (send self :class) :pname)
start end step))
; Override :storeon -- this one becomes really easy
(defmethod Interval :storeon ()
(list 'send 'Interval :new start end step))
; A few examples of the use of the Interval class:
; > (setq i (send Interval :new 2 10 2)) Make an interval, i
; #<Interval from 2 to 10 by 2>
; > (send i :do (lambda (x) (format t "~s " x))) Demonstrate :do
; 2 4 6 8 10
; nil
; > (send i :at 3) Check operation of :at
; 8
; > (send i :size) Size of interval
; 5
; > (send i :asList) Convert to a list
; (2 4 6 8 10)
; > (send i :asSortedCollection #'>) Convert to a SortedCollection
; #<SortedCollection: 10 8 6 4 2> sequence changes!
(in-package "USER") ; revert to default package
(use-package "CLASSES") ; Make the classes package accessable
syntax highlighted by Code2HTML, v. 0.9.1