- rjain-utils-cvs@common-lisp.net - mailman3.common-lisp.net

[rjain-utils-cvs] CVS prototypes
by rjain 24 Nov '09

24 Nov '09

Update of /project/rjain-utils/cvsroot/prototypes In directory cl-net:/tmp/cvs-serv6398 Log Message: initial version Status: Vendor Tag: rjain Release Tags: INITIAL_IMPORT N prototypes/prototypes.lisp No conflicts created by this import

1 0

[rjain-utils-cvs] CVS formulate/src/clim-ui
by rjain 24 Nov '09

24 Nov '09

Update of /project/rjain-utils/cvsroot/formulate/src/clim-ui In directory cl-net:/tmp/cvs-serv899/src/clim-ui Modified Files: application.lisp objects.lisp variables.lisp Log Message: add remove from monitor command simplify and fix other commands --- /project/rjain-utils/cvsroot/formulate/src/clim-ui/application.lisp 2009/11/19 01:17:18 1.1 +++ /project/rjain-utils/cvsroot/formulate/src/clim-ui/application.lisp 2009/11/24 10:06:47 1.2 @@ -21,10 +21,13 @@ (map nil (lambda (item) (display-monitored-value item)) (monitored-values *application-frame*)))) -(defmethod display-monitored-value (item) +(defmethod display-monitored-value :around (item) (updating-output (t :unique-id item) (call-next-method))) +(defun remove-from-monitor (value *application-frame*) + (delete value (monitored-values *application-frame*))) + (defvar *error-formulator* nil) (defmacro display-formula-value (location) --- /project/rjain-utils/cvsroot/formulate/src/clim-ui/objects.lisp 2009/11/19 01:17:18 1.1 +++ /project/rjain-utils/cvsroot/formulate/src/clim-ui/objects.lisp 2009/11/24 10:06:47 1.2 @@ -28,13 +28,13 @@ (vector-push-extend (make-instance class) (monitored-values *application-frame*))) +(define-presentation-type formulated-object () + :inherit-from t) + (defmethod display-monitored-value ((object standard-object)) (fresh-line) (present object 'formulated-object)) -(define-presentation-type formulated-object () - :inherit-from t) - (define-presentation-type formulated-slot () ;; 3 element list: (slot-value <object> <slot-name>) :inherit-from t) @@ -71,20 +71,17 @@ (format t "translating slot to expression") (values object 'expression t)) +(define-formulate-command (com-remove-object :name "Remove Object From Monitor") + ((object 'formulated-object :prompt "Object" :gesture :menu)) + (remove-from-monitor object *application-frame*)) + (define-formulate-command (com-set-slot-value :name "Set Slot Value") - ((expression 'formulated-slot :prompt "Slot") - (new-value 'form :prompt "New value")) + ((expression 'formulated-slot :prompt "Slot" :gesture :select) + (new-value 'form :prompt "New value" :default *unsupplied-argument-marker*)) (destructuring-bind (s-v object (q slot)) expression (declare (ignore s-v q)) (setf (slot-value object slot) (eval new-value)))) -(define-presentation-to-command-translator set-slot-value - (formulated-slot com-set-slot-value formulate :gesture :select) - (object) - (list object - (accept 'form - :prompt (format nil "Set Slot Value (Slot) ~a (New value)" object)))) - (define-formulate-command (com-describe-slot :name "Describe Slot") ((expression 'formulated-slot :prompt "Slot" :gesture :describe)) (destructuring-bind (s-v object (q slot)) expression --- /project/rjain-utils/cvsroot/formulate/src/clim-ui/variables.lisp 2009/11/19 01:17:18 1.1 +++ /project/rjain-utils/cvsroot/formulate/src/clim-ui/variables.lisp 2009/11/24 10:06:47 1.2 @@ -14,27 +14,28 @@ (let ((*standard-output* (get-frame-pane *application-frame* 'monitor))) (vector-push-extend name (monitored-values *application-frame*))))) +(define-presentation-type formulated-variable () + :inherit-from t) + (defmethod display-monitored-value ((name symbol)) (fresh-line) - (with-text-face (t :bold) - (present name 'symbol)) - (write-string " = ") - (display-formula-value (eval name))) + (with-output-as-presentation (t name 'formulated-variable) + (with-text-face (t :bold) + (present name 'symbol)) + (write-string " = ") + (display-formula-value (eval name)))) -(define-formulate-command (com-set-variable :name "Set Variable") - ((name 'symbol) (new-value 'form)) - (eval `(setf ,name ',value))) +(define-formulate-command (com-remove-variable :name "Remove Variable From Monitor") + ((name 'formulated-variable :prompt "Variable" :gesture :menu)) + (remove-from-monitor name *application-frame*)) -(define-presentation-to-command-translator set-variable - (symbol com-set-variable formulate :gesture :select) - (name) - (list name - (let ((stream t)) - (format stream " Set Variable (Name) ~a (New value) " name) - (accept 'form :prompt nil :stream stream)))) +(define-formulate-command (com-set-variable :name "Set Variable") + ((name 'formulated-variable :gesture :select) + (new-value 'form)) + (eval `(setf ,name ',new-value))) (define-formulate-command (com-describe-variable :name "Describe Variable") - ((name 'symbol :prompt "Name" :gesture :describe)) + ((name 'formulated-variable :prompt "Name" :gesture :describe)) (let ((formulator (let ((formulate::*get-formulator* t)) (eval name)))) (format t "Variable ~A is computed by ~A~%using formula ~A"

1 0

[rjain-utils-cvs] CVS formulate/src/clim-ui
by rjain 19 Nov '09

19 Nov '09

Update of /project/rjain-utils/cvsroot/formulate/src/clim-ui In directory cl-net:/tmp/cvs-serv2325/src/clim-ui Added Files: application.lisp formulate.clim-ui.asd objects.lisp package.lisp variables.lisp Log Message: move the CLIM UI to a separate directory add lots of functionality slot setting now works --- /project/rjain-utils/cvsroot/formulate/src/clim-ui/application.lisp 2009/11/19 01:17:18 NONE +++ /project/rjain-utils/cvsroot/formulate/src/clim-ui/application.lisp 2009/11/19 01:17:18 1.1 (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) (monitor :application :scroll-bars t :incremental-redisplay t :display-function 'display-monitor :display-time :command-loop)) (:pointer-documentation t) (:layouts (default monitor interactor))) (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))) (defvar *error-formulator* nil) (defmacro display-formula-value (location) `(catch 'formula-value-fail (handler-bind ((error #'(lambda (error) (display-formula-error error formulate::*formulating*) (throw 'formula-value-fail nil)))) (let ((error-source-p (eql *error-formulator* (let ((formulate::*get-formulator* t)) ,location))) (value ,location)) (when error-source-p (with-text-face (t :bold) (with-drawing-options (t :ink +red+) (write-string ">>>")))) (present value (presentation-type-of value)) (when error-source-p (with-text-face (t :bold) (with-drawing-options (t :ink +red+) (write-string "<<<")))))))) (defmethod frame-standard-output ((frame formulate)) (get-frame-pane frame 'interactor)) (define-presentation-type formula-error () :inherit-from t) (defstruct formula-error error formulator) (define-presentation-method present (error (type formula-error) stream (view textual-view) &key) (print-unreadable-object ((formula-error-error error) stream :type t))) (defun display-formula-error (error formulator) (with-output-as-presentation (t (make-formula-error :error error :formulator formulator) 'formula-error) (with-text-face (t :italic) (with-drawing-options (t :ink +red+) (write-char #\!) (prin1 (class-name (class-of error))) (write-char #\!))))) (define-formulate-command com-describe-error ((err 'formula-error :gesture :select)) (setf *error-formulator* (formula-error-formulator err)) (present (formula-error-error err) t) (format t "~&while computing ~A" (formulate::formulator-formula (formula-error-formulator err)))) --- /project/rjain-utils/cvsroot/formulate/src/clim-ui/formulate.clim-ui.asd 2009/11/19 01:17:18 NONE +++ /project/rjain-utils/cvsroot/formulate/src/clim-ui/formulate.clim-ui.asd 2009/11/19 01:17:18 1.1 (asdf:defsystem :formulate.clim-ui :components ((:file "package") (:file "application" :depends-on ("package")) (:file "variables" :depends-on ("package" "application")) (:file "objects" :depends-on ("package" "application"))) :depends-on (:formulate :clim)) --- /project/rjain-utils/cvsroot/formulate/src/clim-ui/objects.lisp 2009/11/19 01:17:18 NONE +++ /project/rjain-utils/cvsroot/formulate/src/clim-ui/objects.lisp 2009/11/19 01:17:18 1.1 (in-package :formulate.clim-ui) (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)))) (define-presentation-type slot-specification () :inherit-from 'expression) (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"))) (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 '(or class symbol) :prompt "Class")) (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-type formulated-slot () ;; 3 element list: (slot-value <object> <slot-name>) :inherit-from t) (define-presentation-method presentation-typep (object (type formulated-object)) (some (lambda (super) (typep super 'formulated-class)) (class-precedence-list object))) (defmethod display-slot-as-row (object slot stream view) (formatting-row (stream) (formatting-cell (stream) (with-text-face (stream :italic) (prin1 (slot-definition-name slot)) (write-char #\: stream))) (formatting-cell (stream) (display-formula-value (slot-value object (slot-definition-name slot)))))) (define-presentation-method present (object (type formulated-object) stream view &key) (with-output-as-presentation (stream object 'formulated-object) (with-output-as-presentation (stream (class-of object) 'class) (with-text-face (stream :bold) (prin1 (class-name (class-of object)) stream))) (fresh-line stream) (formatting-table (stream) (dolist (slot (class-slots (class-of object))) (with-output-as-presentation (stream `(slot-value ,object ',(slot-definition-name slot)) 'formulated-slot) (display-slot-as-row object slot stream view)))))) (define-presentation-translator slot-accessor (formulated-slot form formulate) (object) (format t "translating slot to expression") (values object 'expression t)) (define-formulate-command (com-set-slot-value :name "Set Slot Value") ((expression 'formulated-slot :prompt "Slot") (new-value 'form :prompt "New value")) (destructuring-bind (s-v object (q slot)) expression (declare (ignore s-v q)) (setf (slot-value object slot) (eval new-value)))) (define-presentation-to-command-translator set-slot-value (formulated-slot com-set-slot-value formulate :gesture :select) (object) (list object (accept 'form :prompt (format nil "Set Slot Value (Slot) ~a (New value)" object)))) (define-formulate-command (com-describe-slot :name "Describe Slot") ((expression 'formulated-slot :prompt "Slot" :gesture :describe)) (destructuring-bind (s-v object (q slot)) expression (declare (ignore s-v q)) (let ((formulator (formulate::slot-formulator object slot))) (format t "Slot ~A of ~A is computed by ~A~%using formula ~A" slot object formulator (formulate::formulator-formula formulator))))) --- /project/rjain-utils/cvsroot/formulate/src/clim-ui/package.lisp 2009/11/19 01:17:18 NONE +++ /project/rjain-utils/cvsroot/formulate/src/clim-ui/package.lisp 2009/11/19 01:17:18 1.1 (defpackage :formulate.clim-ui (:export #:formulate) (:use :clim-lisp :formulate :clim #.(first (list #+sbcl :sb-mop :mop)))) --- /project/rjain-utils/cvsroot/formulate/src/clim-ui/variables.lisp 2009/11/19 01:17:18 NONE +++ /project/rjain-utils/cvsroot/formulate/src/clim-ui/variables.lisp 2009/11/19 01:17:18 1.1 (in-package :formulate.clim-ui) (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)) (fresh-line) (with-text-face (t :bold) (present name 'symbol)) (write-string " = ") (display-formula-value (eval name))) (define-formulate-command (com-set-variable :name "Set Variable") ((name 'symbol) (new-value 'form)) (eval `(setf ,name ',value))) (define-presentation-to-command-translator set-variable (symbol com-set-variable formulate :gesture :select) (name) (list name (let ((stream t)) (format stream " Set Variable (Name) ~a (New value) " name) (accept 'form :prompt nil :stream stream)))) (define-formulate-command (com-describe-variable :name "Describe Variable") ((name 'symbol :prompt "Name" :gesture :describe)) (let ((formulator (let ((formulate::*get-formulator* t)) (eval name)))) (format t "Variable ~A is computed by ~A~%using formula ~A" name formulator (formulate::formulator-formula formulator))))

1 0

[rjain-utils-cvs] CVS formulate/src
by rjain 19 Nov '09

19 Nov '09

Update of /project/rjain-utils/cvsroot/formulate/src In directory cl-net:/tmp/cvs-serv2325/src Modified Files: formulate.asd Removed Files: clim-ui.lisp Log Message: move the CLIM UI to a separate directory add lots of functionality slot setting now works --- /project/rjain-utils/cvsroot/formulate/src/formulate.asd 2007/11/02 20:45:39 1.1.1.1 +++ /project/rjain-utils/cvsroot/formulate/src/formulate.asd 2009/11/19 01:17:18 1.2 @@ -4,8 +4,3 @@ (:file "formulate" :depends-on ("package")) (:file "variables" :depends-on ("package" "formulate")) (:file "metaobjects" :depends-on ("package" "formulate")))) - -(asdf:defsystem :formulate.clim-ui - :components - ((:file "clim-ui")) - :depends-on (:formulate :clim)) \ No newline at end of file

1 0

[rjain-utils-cvs] CVS formulate/src
by rjain 19 Nov '09

19 Nov '09

Update of /project/rjain-utils/cvsroot/formulate/src In directory cl-net:/tmp/cvs-serv28087/src Modified Files: formulate.lisp metaobjects.lisp package.lisp variables.lisp Log Message: add dynamic-formulators: formua-formulators which allow changing of the formula at run time unify the procedure for accessing the formuator of a variable or slot --- /project/rjain-utils/cvsroot/formulate/src/formulate.lisp 2009/11/11 08:52:10 1.4 +++ /project/rjain-utils/cvsroot/formulate/src/formulate.lisp 2009/11/19 00:44:14 1.5 @@ -7,6 +7,8 @@ ;;; *** GENERAL DEFINITIONS *** ;;; +(defvar *get-formulator* nil) + (defvar *formulating* '() "The FORMULATOR, if any, that is being evaluated.") @@ -116,3 +118,15 @@ (defmethod formulator-value-changed ((sink lazy-formula-formulator-sink) source new-value old-value) (formulator-invalidate sink)) + +;;; +;;; DYNAMIC-FORMULATOR +;;; + +(defclass dynamic-formulator (lazy-formula-formulator-sink) + ()) + +(defmethod (setf formulator-value) (new-value (formulator dynamic-formulator)) + (setf (formulator-formula formulator) new-value + (formulator-formula-function formulator) (compile nil `(lambda () ,new-value))) + (formulator-invalidate formulator)) --- /project/rjain-utils/cvsroot/formulate/src/metaobjects.lisp 2009/11/04 21:41:35 1.2 +++ /project/rjain-utils/cvsroot/formulate/src/metaobjects.lisp 2009/11/19 00:44:14 1.3 @@ -57,17 +57,15 @@ (defvar *me*) -(defvar *get-slot-formulator* nil) - (defmethod slot-value-using-class :around (class object (slotd formulated-effective-slot-definition)) - (if *get-slot-formulator* + (if *get-formulator* (call-next-method) (let ((*me* object)) (formulator-value (call-next-method) 'unbound-slot (slot-definition-name slotd))))) (defmethod slot-formulator-using-class (class object (slotd formulated-effective-slot-definition)) - (let ((*get-slot-formulator* t)) + (let ((*get-formulator* t)) (slot-value-using-class class object slotd))) (defmethod (setf slot-value-using-class) :around @@ -80,3 +78,7 @@ (declaim (inline my)) (defun my (slot) (slot-value *me* slot)) + +(defun slot-formulator (object slot-name) + (let ((*get-formulator* t)) + (slot-value object slot-name))) \ No newline at end of file --- /project/rjain-utils/cvsroot/formulate/src/package.lisp 2009/11/11 08:53:07 1.3 +++ /project/rjain-utils/cvsroot/formulate/src/package.lisp 2009/11/19 00:44:14 1.4 @@ -29,5 +29,6 @@ #:formulated-slot-definition #:formulated-direct-slot-definition #:formulated-effective-slot-definition + #:slot-formulator #:slot-formulator-using-class)) (:shadowing-import-from :formulate . #1#)) --- /project/rjain-utils/cvsroot/formulate/src/variables.lisp 2009/11/11 08:54:08 1.3 +++ /project/rjain-utils/cvsroot/formulate/src/variables.lisp 2009/11/19 00:44:14 1.4 @@ -12,7 +12,7 @@ (setf (symbol-value ',name) (make-instance ',(or formulator-class (if formula-p - 'lazy-formula-formulator-sink + 'dynamic-formulator 'simple-formulator-source)) 'formula ',formula 'formula-function (lambda () (declare ,@declare) ,formula) @@ -20,7 +20,9 @@ ',name)) (defun formulate-variable (name) - (formulator-value (symbol-value name) 'unbound-variable name)) + (if *get-formulator* + (symbol-value name) + (formulator-value (symbol-value name) 'unbound-variable name))) (defun (setf formulate-variable) (new-value name) (setf (formulator-value (symbol-value name)) new-value))

1 0

[rjain-utils-cvs] CVS formulate/examples
by rjain 19 Nov '09

19 Nov '09

Update of /project/rjain-utils/cvsroot/formulate/examples In directory cl-net:/tmp/cvs-serv27901/examples Modified Files: simple.lisp Log Message: another formulated class for more interesting testing --- /project/rjain-utils/cvsroot/formulate/examples/simple.lisp 2009/11/11 08:57:21 1.3 +++ /project/rjain-utils/cvsroot/formulate/examples/simple.lisp 2009/11/19 00:41:57 1.4 @@ -25,6 +25,20 @@ (area formula-p t :initform (expt (my 'side) 2) :reader area)) (:metaclass formulated-class)) +(defclass polygon () + ((side :initarg side :initform 0 :accessor polygon-side) + (num-sides :initarg num-sides :initform 1 :accessor polygon-num-sides) + (perimeter formula-p t + :initform (* (my 'side) (my 'num-sides)) + :reader perimeter) + (area formula-p t + :initform (* 1/4 + (my 'num-sides) + (expt (my 'side) 2) + (/ (tan (/ pi (my 'num-sides))))) + :reader area)) + (:metaclass formulated-class)) + (defclass circle () ((radius :initform 0 :initarg radius :accessor circle-radius) (perimeter formula-p t :initform (* (my 'radius) 2 pi) :reader perimeter)

1 0

[rjain-utils-cvs] CVS formulate/src/clim-ui
by rjain 11 Nov '09

11 Nov '09

Update of /project/rjain-utils/cvsroot/formulate/src/clim-ui In directory cl-net:/tmp/cvs-serv15937/src/clim-ui Log Message: Directory /project/rjain-utils/cvsroot/formulate/src/clim-ui added to the repository

1 0

[rjain-utils-cvs] CVS formulate/src
by rjain 11 Nov '09

11 Nov '09

Update of /project/rjain-utils/cvsroot/formulate/src In directory cl-net:/tmp/cvs-serv9682/src Added Files: protocol.lisp Log Message: add definitions for formulator protocol and subprotocols --- /project/rjain-utils/cvsroot/formulate/src/protocol.lisp 2009/11/11 08:58:02 NONE +++ /project/rjain-utils/cvsroot/formulate/src/protocol.lisp 2009/11/11 08:58:02 1.1 (defprotocol formulator ()) (defprotocol formulator-source (formulator)) (defprotocol formulator-sink (formulator)) (defprotocol formula-formulator (formulator)) (defgeneric formulator-value (formulator &optional unbound-condition cell-name)) (defsignature formulator-value (formulator-source)) (defgeneric (setf formulator-value) (new-value formulator)) ;; separate formulator-root that allows setf? (defsignature (setf formulator-value) (t formulator-source)) (defgeneric formulator-value-validp (formulator)) (defsignature formulator-value-validp (formulator-source)) (defgeneric formulator-invalidate (formulator)) (defsignature formulator-invalidate (formulator-source)) (defgeneric formulator-dependents (formulator)) (defsignature formulator-dependents (formulator-source)) (defgeneric formulator-value-changed (sink source new-value old-value)) (defsignature formulator-value-changed (formulator-sink formulator-source t t)) (defgeneric formulator-formula (formulator)) ; change to formulator-formula-source? (defsignature formulator-formula (formula-formulator)) ; change to formulator-formula-source? (defgeneric formulator-formula-function (formulator)) ; change to formulator-function? (defsignature formulator-formula-function (formula-formulator)) ; change to formulator-function? (defgeneric (setf formulator-value) (new-formula formulator)) (defsignature (setf formulator-value) (function formula-formulator)) ; separate dynamic-formula-formulator subprotocol?

1 0

[rjain-utils-cvs] CVS formulate/examples
by rjain 11 Nov '09

11 Nov '09

Update of /project/rjain-utils/cvsroot/formulate/examples In directory cl-net:/tmp/cvs-serv9595/examples Modified Files: simple.lisp Log Message: fix perimeter formula and provide default side lengths --- /project/rjain-utils/cvsroot/formulate/examples/simple.lisp 2009/11/04 21:41:34 1.2 +++ /project/rjain-utils/cvsroot/formulate/examples/simple.lisp 2009/11/11 08:57:21 1.3 @@ -1,7 +1,8 @@ (in-package :formulate-user) +;; default is for variables to be formulas (define-formulated-variable *x* 5 - :formulator-class simple-formulator-source) + :formula-p nil) (define-formulated-variable *y* (expt *x* 2)) @@ -17,14 +18,15 @@ (defgeneric area (shape)) (defgeneric perimeter (shape)) +;; default is for slots to not be formulas --- is this inconsistency good or bad? (defclass square () - ((side :initarg side :accessor square-side) - (perimeter formula-p t :initform (* (my 'side) 2) :reader perimeter) + ((side :initarg side :initform 0 :accessor square-side) + (perimeter formula-p t :initform (* (my 'side) 4) :reader perimeter) (area formula-p t :initform (expt (my 'side) 2) :reader area)) (:metaclass formulated-class)) (defclass circle () - ((radius :initarg radius :accessor circle-radius) + ((radius :initform 0 :initarg radius :accessor circle-radius) (perimeter formula-p t :initform (* (my 'radius) 2 pi) :reader perimeter) (area formula-p t :initform (* (expt (my 'radius) 2) pi) :reader area)) (:metaclass formulated-class))

1 0

[rjain-utils-cvs] CVS formulate/src
by rjain 11 Nov '09

11 Nov '09

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)))) +

1 0