[rjain-utils-cvs] CVS formulate/src/clim-ui
rjain
rjain at common-lisp.net
Thu Nov 19 01:17:18 UTC 2009
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))))
More information about the Rjain-utils-cvs
mailing list