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