new file mode 100644

@@ -0,0 +1,3 @@

+# Docs:

+

+See example.lisp for a simple usage

new file mode 100644

@@ -0,0 +1,18 @@

+;;;; collection-classes.asd

+

+(asdf:defsystem #:collection-class

+  :description "Defines a macro for declaring a class that is a collection of another class"

+  :author "Edward Langley <el@elangley.org>"

+  :license "MIT"

+  :depends-on (#:alexandria

+               #:for

+               #:serapeum

+               )

+  :serial t

+  :components ((:file "package")

+               (:file "collections")

+               (:file "collections-for")

+               #+sbcl

+               (:file "collections-sbcl-iterators")

+               ))

+

new file mode 100644

@@ -0,0 +1,22 @@

+(in-package :collection-class)

+

+(defclass collection-iterator (for:iterator)

+  ())

+

+(defmethod initialize-instance :after ((iterator collection-iterator) &key object)

+  (setf (for:object iterator)

+        (items object)))

+

+(defmethod for:has-more ((iterator collection-iterator))

+  (not (null (for:object iterator))))

+

+(defmethod for:next ((iterator collection-iterator))

+  (let ((collection-items (for:object iterator)))

+    (prog1 (car collection-items)

+      (setf (for:object iterator)

+            (cdr collection-items)))))

+

+(defmethod for:make-iterator ((collection collection) &key)

+  (make-instance 'collection-iterator :object collection))

+

+

new file mode 100644

@@ -0,0 +1,28 @@

+(in-package :collection-class)

+

+(defmethod sb-sequence:length ((sequence collection))

+  (length (items sequence)))

+

+(defmethod sb-sequence:elt ((sequence collection) index)

+  (elt (items sequence) index))

+

+(defmethod (setf sb-sequence:elt) (new-value (sequence collection) index)

+  (setf (elt (items sequence) index) new-value))

+

+(defmethod sb-sequence:adjust-sequence ((sequence collection) length &key initial-element initial-contents)

+  (let ((result (duplicate-collection sequence)))

+    (when (or initial-element initial-contents)

+      (setf (items result)

+            (sb-sequence:adjust-sequence (items result) length

+                                         :initial-element initial-element

+                                         :initial-contents initial-contents)))

+    result))

+

+(defmethod sb-sequence:make-sequence-like ((sequence collection) length &key initial-element initial-contents)

+  (let ((result (duplicate-collection sequence)))

+    (setf (items result)

+          (sb-sequence:make-sequence-like (items result) length

+                                          :initial-element initial-element

+                                          :initial-contents initial-contents))

+    result))

+

new file mode 100644

@@ -0,0 +1,61 @@

+(in-package :collection-class)

+

+(defclass collection (standard-object #+sbcl sequence)

+  ())

+

+(define-condition value-error ()

+  ((value :initarg :value :accessor value)))

+

+(defgeneric push-item (item collection)

+  (:documentation "Push item onto the beginning of the collection"))

+

+(defgeneric items (collection)

+  (:documentation "Get the items from a collection"))

+

+(defgeneric duplicate-collection (collection))

+

+(defgeneric copy-instance (object &rest initargs &key &allow-other-keys)

+  (:documentation "Makes and returns a shallow copy of OBJECT.

+

+                   An uninitialized object of the same class as OBJECT is allocated by

+                   calling ALLOCATE-INSTANCE.  For all slots returned by

+                   CLASS-SLOTS, the returned object has the

+                   same slot values and slot-unbound status as OBJECT.

+

+                   REINITIALIZE-INSTANCE is called to update the copy with INITARGS.")

+  (:method ((object standard-object) &rest initargs &key &allow-other-keys)

+   (let* ((class (class-of object))

+          (copy (allocate-instance class)))

+     (dolist (slot-name (mapcar #'closer-mop:slot-definition-name (closer-mop:class-slots class)))

+       (when (slot-boundp object slot-name)

+         (setf (slot-value copy slot-name)

+               (slot-value object slot-name))))

+     (apply #'reinitialize-instance copy initargs))))

+

+

+; TODO: actually use item-class...

+; TODO: finish initform handling.  Have to figure out how to make initform work with push-item

+(defmacro define-collection ((name item-class &key (initform '(list))) (&rest supers) &body ((&rest slots) &rest other-stuff))

+  (with-gensyms (item-slot-sym)

+    `(progn (defclass ,name (,@supers collection)

+              ((,item-slot-sym :initform ,initform :accessor items)

+               ,@slots)

+              ,@other-stuff)

+            (defmethod duplicate-collection ((collection ,name))

+              (let ((result (copy-instance collection)))

+                (setf (items result)

+                      (copy-seq (items result)))

+                result))

+            (defmethod push-item ((item ,item-class) (collection ,name))

+              (push item (items collection))))))

+

+(defmethod random-item ((collection collection) &optional (random-state *random-state*))

+  (let* ((length (length (items collection)))

+         (selected-index (random length random-state)))

+    (elt (items collection)

+         selected-index)))

+

+(defmethod nth-item ((collection collection) (index integer))

+  (if (>= index 0)

+    (elt (items collection) index)

+    (error 'value-error :value index)))

new file mode 100644

@@ -0,0 +1,31 @@

+(defpackage #:collection-class.example

+  (:use #:cl #:collection-class #:alexandria #:serapeum))

+

+(in-package :collection-class.example)

+

+; Define the class to be contained in the collection

+(defclass foo ()

+  ((%slot1 :initarg :slot1 :accessor slot1)

+   (%slot2 :initarg :slot2 :reader slot2)))

+

+; Define the collection: it's basically a class form, with the name being a list

+; of (collection-name collected-class)

+(define-collection (collected-foos foo) ()

+  ((%collection-slot :initarg :collection-slot :reader collection-slot)))

+

+

+; Define a collection

+(defparameter *collection* (make-instance 'collected-foos :collection-slot "howdy?"))

+

+(push-item (make-instance 'foo :slot1 1 :slot2 2) *collection*)

+(push-item (make-instance 'foo :slot1 2 :slot2 2) *collection*)

+(push-item (make-instance 'foo :slot1 2 :slot2 3) *collection*)

+

+; On sbcl, we implement the iterator protocol, so we can

+; use the builtin sequence functions on the collection.

+#+sbcl

+(progn

+  (collection-slot *collection*)   #| --> "howdy?" |#

+  (map 'list #'slot1 *collection*) #| --> (1 2 2)  |#

+  (map 'list #'slot2 *collection*) #| --> (2 2 3)  |# 

+  )

new file mode 100644

@@ -0,0 +1,6 @@

+;;;; package.lisp

+

+(defpackage #:collection-class

+  (:use #:cl #:alexandria #:serapeum)

+  (:export collection value-error push-item define-collection random-item nth-item items))

+