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