;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp -*- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; File		     - iterators-in-lisp-answers.lisp
;; Description	     - Sample Iterator Design Pattern in Lisp
;; Author	     - Tim Bradshaw (tfb at lostwithiel.tfeb.org)
;; Created On	     - Thu Jun 29 12:35:14 2000
;; Last Modified On  - Sat Jan 27 10:14:09 2001
;; Last Modified By  - Gail Anderson (ga at lostwithiel)
;; Update Count	     - 4
;; Status	     - Unknown
;; 
;; $Id: iterators-in-lisp-answers.lisp,v 1.1.1.1 2002/12/12 02:15:47 colin Exp $
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; Copyright 1999-2001 Cley Limited

;;;; Note: this is not the only way to implement these patterns in Lisp,
;;;; nor even the best - the purpose of the exercise is twofold: to show how
;;;; Lisp could be used to implement design patterns in an object-oriented way,
;;;; and to practise using CLOS.

;;;; * Iterators and Collections
;;;

;;;; ** Internal iterators
;;;
;;; Internal iterators are a way of mapping a function over the
;;; elements of a collection.  Internal iterators are rather more
;;; useful in Lisp than in many other languages because we have
;;; anonymous functions.
;;;
;;; To use an internal iterator we simply need to define a name for
;;; the mapping function.
;;;

(defgeneric map-over (f collection)
  ;; Note that this GF would typically specialise on its second
  ;; argument.
  (:documentation
   "Map F over COLLECTION.  Return COLLECTION"))

;;;; ** External iterators.
;;;
;;; External iterators, here called CURSORs, provide a way of creating
;;; an object which `points into' a collection of some kind, and can
;;; then be repeatedly asked for the next element.  As we will see,
;;; cursors have a delightfully simple implementation in Lisp.
;;;
;;; The protocol for cursors is slightly more complex.  We need to be
;;; able to create them, ask them for the next element, and ask them
;;; if they are finished.  There are some additional possible
;;; operations -- resetting a cursor for instance -- which we do not
;;; implement.
;;;

(defgeneric make-cursor-for (collection)
  (:documentation
   "Return a cursor for COLLECTION"))

(defgeneric cursor-next (cursor)
  (:documentation
   "Get the next element in CURSOR's collection.
Second value is T if the cursor is now finished.  If the cursor is already
finished, the result is NIL,T"))

(defgeneric cursor-finished-p (cursor)
  (:documentation
   "Return T if CURSOR is finished"))

#||
;;; These are not implemented; you could define them if you wished.
;;;

(defgeneric cursor-reset (cursor)
  (:documentation
   "Reset cursor"))
(defgeneric cursor-current (cursor)
  (:documentation
   "Return the current element"))
||#


;;;; ** Iterators for lists
;;;
;;; Lisp already has a very well-known collection type -- lists!  Here
;;; is an implementation of the above protocols for lists.
;;;

;;; Internal iterator
;;;

(defmethod map-over (f (collection list))
  (mapc f collection))

;;; External iterator.  In Lisp, *functions* are powerful enough to
;;; serve as cursors, as they `close over' bindings.  This saves us
;;; having to define a new class for every different collection class
;;; we might want to iterate over.  However, because the above
;;; protocol was defined with generic functions, we can still do that
;;; if we want to.

(defmethod make-cursor-for ((collection list))
  #'(lambda (message)
      (case message
	(:next
	 (let ((r (first collection)))
	   (setf collection (cdr collection))
	   (values r (null collection))))
	(:finished-p
	 (null collection)))))

(defmethod cursor-next ((cursor function))
  (funcall cursor ':next))

(defmethod cursor-finished-p ((cursor function))
  (funcall cursor ':finished-p))


;;;; ** A more opaque collection class
;;;
;;; Here we define a class which encapsulates the concept of `thing
;;; with children' and then define the iterators for it.  For this
;;; class the order of the children is not important, so the
;;; implementation is simplified. Note that these objects are not
;;; intended to support duplicate children.
;;;
;;; As before, we first define the protocol, and then a class which
;;; implements it.  This protocol does not support the various TEST &
;;; KEY arguments which are in the standard PUSHNEW / DELETE: in our
;;; approach these functions are considered a property of the class
;;; (see below).  This protocol is not that satisfactory.
;;;

(defgeneric add-child (childed-thing new-child)
  (:documentation
   "Add NEW-CHILD to CHILDED-THING, if it is not there already.
Return CHILDED-THING"))

(defgeneric delete-child (childed-thing child)
  (:documentation
   "Delete CHILD from CHILDED-THING.  Return CHLDED-THING."))

(defgeneric delete-children-if (childed-thing test)
  (:documentation
   "Delete the children of CHILDED-THING which pass TEST.  Return CHILDED-THING.
We need this function because you are not allowed to delete children found
with MAP-OVER"))

;;; The class
;;;
;;; This class uses EQL as a test and IDENTITY as a key, and is not
;;; really extensible.  It could be made extensible by defining
;;; generic functions which returned the test and key functions and
;;; then defining them differently for various subclasses of an
;;; abstract class.  We don't do that here because it makes the code
;;; somewhat larger.
;;;
;;; Note that the CHILDREN slot is not revealed to the world.  This is
;;; intentional -- allowing unrestricted access to it brings up a lot
;;; of problems of `ownership' of the list, and constrains the
;;; implementation.

(defclass simple-childed-mixin ()
    ((children :initform '())))

(defmethod add-child ((childed-thing simple-childed-mixin) child)
  (pushnew child (slot-value childed-thing 'children))
  childed-thing)

(defmethod delete-child ((childed-thing simple-childed-mixin) child)
  (with-slots (children) childed-thing
    (setf children (delete child children)))
  childed-thing)

(defmethod delete-children-if ((childed-thing simple-childed-mixin) test)
  (with-slots (children) childed-thing
    (setf children (delete-if test children)))
  childed-thing)

;;; The iterator interface.
;;;
;;; This is very trivial -- we just punt to the listy one.
;;;

(defmethod map-over (f (collection simple-childed-mixin))
  (map-over f (slot-value collection 'children))
  collection)

(defmethod make-cursor-for ((collection simple-childed-mixin))
  (make-cursor-for (slot-value collection 'children)))