[mcclim-cvs] CVS mcclim/ESA

[thenriksen]

Update of /project/mcclim/cvsroot/mcclim/ESA
In directory clnet:/tmp/cvs-serv13736/ESA

Modified Files:
	utils.lisp packages.lisp esa.lisp esa-buffer.lisp 
Log Message:
Changed Drei to use a view-based paradigm, didn't make any significant
changes to ESA just yet.


--- /project/mcclim/cvsroot/mcclim/ESA/utils.lisp	2007/08/13 21:56:04	1.3
+++ /project/mcclim/cvsroot/mcclim/ESA/utils.lisp	2007/12/08 08:53:48	1.4
@@ -18,7 +18,7 @@
 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
 ;;; Boston, MA  02111-1307  USA.
 
-;;; Miscellaneous utilities used in Climacs.
+;;; Miscellaneous utilities used in ESA.
 
 (in-package :esa-utils)
 
@@ -212,3 +212,99 @@
 specifiers."
   (some (lambda (x)
           (subtypep x `(and , at types))) types))
+
+(defclass observable-mixin ()
+  ((%observers :accessor observers
+               :initform '()))
+  (:documentation "A mixin class that adds the capability for a
+subclass to have a list of \"event subscribers\" (observers) that
+can be informed via callback (the function `observer-notified')
+whenever the state of the object changes. The order in which
+observers will be notified is undefined."))
+
+(defgeneric add-observer (observable observer)
+  (:documentation "Add an observer to an observable object. If
+the observer is already observing `observable', it will not be
+added again."))
+
+(defmethod add-observer ((observable observable-mixin) observer)
+  ;; Linear in complexity, perhaps a transparent switch to a hash
+  ;; table would be a good idea for large amounts of observers.
+  (pushnew observer (observers observable)))
+
+(defgeneric remove-observer (observable observer)
+  (:documentation "Remove an observer from an observable
+object. If observer is not in the list of observers of
+`observable', nothing will happen."))
+
+(defmethod remove-observer ((observable observable-mixin) observer)
+  (setf (observers observable)
+        (delete observer (observers observable))))
+
+(defgeneric observer-notified (observer observable data)
+  (:documentation "This function is called by `observable' when
+its state changes on each observer that is observing
+it. `Observer' is the observing object, `observable' is the
+observed object. `Data' is arbitrary data that might be of
+interest to `observer', it is recommended that subclasses of
+`observable-mixin' specify exactly which form this data will
+take, the observer protocol does not guarantee anything. It is
+non-&optional so that methods may be specialised on it, if
+applicable. The default method on this function is a no-op, so it
+is never an error to not define a method on this generic function
+for an observer.")
+  (:method (observer (observable observable-mixin) data)
+    ;; Never a no-applicable-method error.
+    nil))
+
+(defgeneric notify-observers (observable &optional data-fn)
+  (:documentation "Notify each observer of `observable' by
+calling `observer-notified' on them. `Data-fn' will be called,
+with the observer as the single argument, to obtain the `data'
+argument to `observer-notified'. The default value of `data-fn'
+should cause the `data' argument to be NIL."))
+
+(defmethod notify-observers ((observable observable-mixin)
+                             &optional (data-fn (constantly nil)))
+  (dolist (observer (observers observable))
+    (observer-notified observer observable
+                       (funcall data-fn observer))))
+
+(defclass name-mixin ()
+  ((%name :accessor name
+          :initarg :name
+          :type string
+          :documentation "The name of the named object."))
+  (:documentation "A class used for defining named objects."))
+
+(defclass subscriptable-name-mixin (name-mixin)
+  ((%subscript :accessor subscript
+               :documentation "The subscript of the named object.")
+   (%subscript-generator :accessor subscript-generator
+                         :initarg :subscript-generator
+                         :initform (constantly 1)
+                         :documentation "A function used for
+finding the subscript of a `name-mixin' whenever the name is
+set (including during object initialization). This function will
+be called with the name as the single argument."))
+  (:documentation "A class used for defining named objects. A
+facility is provided for assigning a named object a \"subscript\"
+uniquely identifying the object if there are other objects of the
+same name in its collection (in particular, if an editor has two
+buffers with the same name)."))
+
+(defmethod initialize-instance :after ((name-mixin subscriptable-name-mixin)
+                                       &rest initargs)
+  (declare (ignore initargs))
+  (setf (subscript name-mixin)
+        (funcall (subscript-generator name-mixin) (name name-mixin))))
+
+(defmethod subscripted-name ((name-mixin subscriptable-name-mixin))
+  ;; Perhaps this could be written as a single format statement?
+  (if (/= (subscript name-mixin) 1)
+      (format nil "~A <~D>" (name name-mixin) (subscript name-mixin))
+      (name name-mixin)))
+
+(defmethod (setf name) :after (new-name (name-mixin subscriptable-name-mixin))
+  (setf (subscript name-mixin)
+        (funcall (subscript-generator name-mixin) new-name)))
--- /project/mcclim/cvsroot/mcclim/ESA/packages.lisp	2007/11/19 20:34:10	1.5
+++ /project/mcclim/cvsroot/mcclim/ESA/packages.lisp	2007/12/08 08:53:48	1.6
@@ -41,7 +41,12 @@
            #:invoke-with-dynamic-bindings-1
            #:invoke-with-dynamic-bindings
            #:maptree
-           #:subtype-compatible-p))
+           #:subtype-compatible-p
+           #:observable-mixin
+           #:add-observer #:remove-observer
+           #:observer-notified #:notify-observers
+           #:name-mixin #:name
+           #:subscriptable-name-mixin #:subscripted-name #:subscript #:subscript-generator))
 
 (defpackage :esa
   (:use :clim-lisp :clim :esa-utils)
--- /project/mcclim/cvsroot/mcclim/ESA/esa.lisp	2007/11/19 20:28:43	1.11
+++ /project/mcclim/cvsroot/mcclim/ESA/esa.lisp	2007/12/08 08:53:48	1.12
@@ -41,10 +41,18 @@
 (defgeneric esa-current-buffer (esa)
   (:documentation "Return the current buffer of APPLICATION-FRAME."))
 
+(defgeneric (setf esa-current-buffer) (new-buffer esa)
+  (:documentation "Replace the current buffer of
+APPLICATION-FRAME with NEW-BUFFER."))
+
 (defun current-buffer ()
   "Return the currently active buffer of the running ESA."
   (esa-current-buffer *esa-instance*))
 
+(defun (setf current-buffer) (new-buffer)
+  "Return the currently active buffer of the running ESA."
+  (setf (esa-current-buffer *esa-instance*) new-buffer))
+
 (defgeneric windows (esa)
   (:documentation "Return a list of all the windows of the ESA.")
   (:method ((esa application-frame))
--- /project/mcclim/cvsroot/mcclim/ESA/esa-buffer.lisp	2007/11/13 13:05:38	1.2
+++ /project/mcclim/cvsroot/mcclim/ESA/esa-buffer.lisp	2007/12/08 08:53:48	1.3
@@ -45,10 +45,10 @@
 representation"
   (frame-save-buffer-to-stream *application-frame* buffer stream))
 
-(defclass esa-buffer-mixin ()
+(defclass esa-buffer-mixin (name-mixin)
   ((%filepath :initform nil :accessor filepath)
-   (%name :initarg :name :initform "*scratch*" :accessor name)
    (%needs-saving :initform nil :accessor needs-saving)
    (%file-write-time :initform nil :accessor file-write-time)
    (%file-saved-p :initform nil :accessor file-saved-p)
-   (%read-only-p :initform nil :accessor read-only-p)))
+   (%read-only-p :initform nil :accessor read-only-p))
+  (:default-initargs :name "*scratch*"))