[rjain-utils-cvs] CVS formulate/src
rjain
rjain at common-lisp.net
Wed Nov 11 08:56:27 UTC 2009
Update of /project/rjain-utils/cvsroot/formulate/src
In directory cl-net:/tmp/cvs-serv9463/src
Modified Files:
clim-ui.lisp
Log Message:
get variables working
get class instantiation and instance display and slot setting working
class definition doesn't work in mcclim due to accepting of deep structure being hairy
clicking on slots to use an instance's slot value does not work, either -- sends DREI off a cliff
--- /project/rjain-utils/cvsroot/formulate/src/clim-ui.lisp 2007/11/02 20:45:39 1.1.1.1
+++ /project/rjain-utils/cvsroot/formulate/src/clim-ui.lisp 2009/11/11 08:56:26 1.2
@@ -1,27 +1,75 @@
(defpackage :formulate.clim-ui
(:export #:formulate)
- (:use :clim-lisp :formulate :clim))
+ (:use :clim-lisp :formulate :clim #.(first (list #+sbcl :sb-mop :mop))))
(in-package :formulate.clim-ui)
(define-application-frame formulate ()
- ()
+ ((monitored-values :initform (make-array 5 :fill-pointer 0 :adjustable t)
+ :accessor monitored-values))
(:panes (interactor :interactor
- :scroll-bars t))
+ :scroll-bars t)
+ (monitor :application
+ :scroll-bars t
+ :incremental-redisplay t
+ :display-function 'display-monitor
+ :display-time :command-loop))
(:pointer-documentation t)
(:layouts (default
- interactor)))
+ monitor
+ interactor)))
-(define-formulate-command (com-define-formulated-variable :name "Define Formulated Variable")
- ((name 'symbol) (formula 'expression)
- (declarations 'expression :default '())
- (documentation '(or string null) :default nil))
- (funcall (compile nil (lambda () `(define-formulated-variable ,name ,formula
- :declare ,declarations :documentation ,documentation)))))
-
-(define-formulate-command (com-define-formulated-class :name "Define Formulated Class")
- ((name 'symbol) (superclasses '(sequence class) :default '()) (slots '(sequence slot-specification)))
+(defun display-monitor (*application-frame* *standard-output*)
+ (updating-output (t :unique-id (monitored-values *application-frame*))
+ (map nil (lambda (item) (display-monitored-value item))
+ (monitored-values *application-frame*))))
+
+(defmethod display-monitored-value (item)
+ (updating-output (t :unique-id item)
+ (call-next-method)))
+
+(defmethod frame-standard-output ((frame formulate))
+ (get-frame-pane frame 'interactor))
+
+
+;;;
+;;; VARIABLES
+;;;
+
+(define-formulate-command (com-define-formulated-variable :name "Define Variable")
+ ((name 'symbol :prompt "Name")
+ (formula-p 'boolean :prompt "Formula?")
+ (formula 'expression :prompt (if formula-p "Formula" "Initial value"))
+ (monitor-p 'boolean :default t :prompt "Show in monitor pane?")
+ (declarations 'expression :default '() :prompt "Declarations")
+ (documentation '(or string null) :default nil :prompt "Documentation"))
+ (eval `(define-formulated-variable ,name ,formula
+ :formula-p ,formula-p
+ :declare ,declarations :documentation ,documentation))
+ (when monitor-p
+ (let ((*standard-output* (get-frame-pane *application-frame* 'monitor)))
+ (vector-push-extend name (monitored-values *application-frame*)))))
+
+(defmethod display-monitored-value ((name symbol))
+ (let ((value (eval name)))
+ (fresh-line)
+ (present name 'symbol)
+ (write-string " = ")
+ (present value (presentation-type-of value))))
+
+(define-formulate-command (com-set-variable :name "Set Variable")
+ ((name 'symbol) (value 'expression))
+ (eval `(setf ,name ,value)))
+
+;;;
+;;; CLASSES
+;;;
+
+(define-formulate-command (com-define-formulated-class :name "Define Class")
+ ((name 'symbol :prompt "Name")
+ (superclasses '(sequence symbol) :default () :prompt "Superclasses")
+ (slots '(sequence slot-specification) :prompt "Slots"))
(eval `(defclass ,name ,(coerce superclasses 'list)
(,@(coerce slots 'list))
(:metaclass formulated-class))))
@@ -29,11 +77,78 @@
(define-presentation-type slot-specification ()
:inherit-from 'expression)
-(define-presentation-method accept ((type slot-specification) stream view &key default default-type)
+(define-presentation-method accept ((type slot-specification) stream view
+ &key default)
(let* ((name (if default
(accept 'symbol :prompt "Name" :default (first default))
- (accept 'symbol :prompt "Name")))
- (formulated-p (accept 'boolean :prompt "Formulated?"
- :default (getf default 'formulated-p t) :default-type 'boolean))
- (initform (accept 'expression :prompt (if formulated-p "Formula" "Initial value"))))
- `(,name formulated-p ,formulated-p :initform ,initform)))
+ (accept 'symbol :prompt "Name")))
+ (formula-p (accept 'boolean
+ :prompt "Formula?"
+ :default (getf default 'formula-p t)
+ :default-type 'boolean))
+ (initform (accept 'expression :prompt (if formula-p "Formula" "Initial value"))))
+ `(,name formula-p ,formula-p :initform ,initform)))
+
+(define-formulate-command (com-create-instance :name "Create Instance")
+ ((class 'symbol))
+ (vector-push-extend (make-instance class)
+ (monitored-values *application-frame*)))
+
+(defmethod display-monitored-value ((object standard-object))
+ (fresh-line)
+ (present object 'formulated-object))
+
+(define-presentation-type formulated-object ()
+ :inherit-from t)
+
+(define-presentation-method presentation-typep (object (type formulated-object))
+ (some (lambda (super) (typep super 'formulated-class))
+ (class-precedence-list object)))
+
+(define-presentation-method present (object (type formulated-object) stream view
+ &key acceptably for-context-type)
+ (prin1 (class-name (class-of object)))
+ (fresh-line)
+ (formatting-table (stream)
+ (dolist (slot (class-slots (class-of object)))
+ (present `(slot-value ,object ,(slot-definition-name slot))
+ 'formulated-slot
+ :stream stream :view view
+ :acceptably acceptably :for-context-type for-context-type))))
+
+(define-presentation-type formulated-slot ()
+ ;; 3 element list: (slot-value <object> <slot-name>)
+ :inherit-from '(sequence t))
+
+(define-presentation-method presentation-typep ((expression cons) (type formulated-slot))
+ (and (= 3 (length expression))
+ (destructuring-bind (slot-value object slot) expression
+ (and (eq 'slot-value slot-value)
+ (typep slot 'symbol)
+ (some (lambda (super) (typep super 'formulated-class))
+ (class-precedence-list object))))))
+
+(define-presentation-method present (expression (type formulated-slot) stream view
+ &key acceptably for-context-type)
+ (when (and (consp (first expression))
+ (eq 'quote (first (first expression))))
+ (setf expression (second (first expression))))
+ (destructuring-bind (s-v object slot) expression
+ (formatting-row (stream)
+ (formatting-cell (stream)
+ (present slot 'symbol
+ :stream stream :view view :sensitive nil))
+ (formatting-cell (stream)
+ (let ((slot-value (slot-value object slot)))
+ (present slot-value `(and ,(presentation-type-of slot-value)
+ formulated-value)
+ :stream stream :view view :sensitive t))))))
+
+(define-formulate-command (com-set-slot-value :name "Set Slot Value")
+ ((object.slot 'formulated-slot :prompt "Slot")
+ (new-value 'expression :prompt "New value"))
+ ;; not sure why object.slot has other crap around it, but hacking
+ ;; around it.
+ (destructuring-bind (s-v object slot) (second (first object.slot))
+ (setf (slot-value object slot) (eval new-value))))
+
More information about the Rjain-utils-cvs
mailing list