Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv31024
Modified Files: button.lisp composites.lisp demos.lisp entry.lisp fileevent.lisp lotsa-widgets.lisp ltktest-ci.lisp menu.lisp multichoice.lisp togl.lisp Log Message: New "lite" versions of Celtk without all the Tk widgets, for PureCello
--- /project/cells/cvsroot/Celtk/button.lisp 2006/11/03 13:37:50 1.6 +++ /project/cells/cvsroot/Celtk/button.lisp 2006/11/04 20:53:08 1.7 @@ -66,12 +66,12 @@ -offvalue -onvalue) (:default-initargs :id (gentemp "CK") - :md-value (c-in nil) + :value (c-in nil) :tk-variable (c? (^path)) :on-command (lambda (self) - (setf (^md-value) (not (^md-value)))))) + (setf (^value) (not (^value))))))
-(defobserver .md-value ((self checkbutton)) +(defobserver .value ((self checkbutton)) (tk-format `(:variable ,self) "set ~(~a~) ~a" (path self) (if new-value 1 0)))
; --- radiobutton ------------------------------------- --- /project/cells/cvsroot/Celtk/composites.lisp 2006/10/02 02:56:01 1.19 +++ /project/cells/cvsroot/Celtk/composites.lisp 2006/11/04 20:53:08 1.20 @@ -113,6 +113,9 @@ on-key-down on-key-up)
+(export! .control-key-p) +(define-symbol-macro .control-key-p (find :control (keyboard-modifiers .tkw))) + (defmethod make-tk-instance ((self window)) (setf (gethash (^path) (dictionary .tkw)) self))
--- /project/cells/cvsroot/Celtk/demos.lisp 2006/11/03 13:37:50 1.25 +++ /project/cells/cvsroot/Celtk/demos.lisp 2006/11/04 20:53:08 1.26 @@ -26,7 +26,7 @@ :kids (c? (the-kids (mk-stack ("stack" :packing (c?pack-self "-side bottom") :relief 'ridge) (mk-entry :id :my-entry - :md-value (c-in "abc")) + :value (c-in "abc")) (mk-row ( "row" #| :packing (c?pack-self "-side bottom") |# :relief 'ridge) (mk-label :text (c? (format nil "selection: ~a" (selection (fm^ :my-selector))))) (mk-label :text "Labeltext") @@ -81,13 +81,13 @@ :kids (c? (the-kids (mk-text-widget :id :my-text - :md-value (c?n "[bzbzbzbz]") + :value (c?n "[bzbzbzbz]") :height 8 :width 25) (make-instance 'entry :id :entree :fm-parent *parent* - :md-value (c-in "Boots")) + :value (c-in "Boots")) ;;; (make-instance 'button ;;; :fm-parent *parent* ;;; :text "read" @@ -100,7 +100,7 @@ ;;; (trc "we got scale callbacks" self (parse-integer value))))) ;;; (mk-spinbox ;;; :id :spin-pkg - ;;; :md-value (c-in "cells") ;;(cells::c?n "cells") + ;;; :value (c-in "cells") ;;(cells::c?n "cells") ;;; :tk-values (mapcar 'down$ ;;; (sort (mapcar 'package-name ;;; (list-all-packages)) @@ -135,7 +135,7 @@ (mk-stack (:packing (c?pack-self)) (mk-spinbox :id :spin-pkg - :md-value (c-in "cells") ;;(cells::c?n "cells") + :value (c-in "cells") ;;(cells::c?n "cells") :tk-values (mapcar 'down$ (sort (mapcar 'package-name (list-all-packages)) @@ -145,7 +145,7 @@ :list-height 6 :list-item-keys (c? (trc "enter item keys" self (fm^ :spin-pkg)) (let* ((spinner (fm^ :spin-pkg)) - (item (when spinner (md-value spinner))) + (item (when spinner (value spinner))) (pkg (find-package (string-upcase item)))) (when pkg (loop for sym being the symbols in pkg @@ -156,7 +156,7 @@ :list-item-factory (lambda (sym) (make-instance 'listbox-item :fm-parent *parent* - :md-value sym + :value sym :item-text (down$ (symbol-name sym))))) (mk-label :text (c? (selection (fm^ :spinpkg-sym-list)))))))))
@@ -194,16 +194,16 @@ (defmodel font-view (frame-stack) () (:default-initargs - :md-value (c? (tk-eval-list "font families")) + :value (c? (tk-eval-list "font families")) :pady 2 :padx 4 :packing-side 'left :layout-anchor 'nw :kids (c? (the-kids (mk-spinbox :id :font-face - :md-value (c-in (car (^md-value))) - :tk-values (c? (md-value .parent))) + :value (c-in (car (^value))) + :tk-values (c? (value .parent))) (mk-scale :id :font-size - :md-value (c-in 14) + :value (c-in 14) :tk-label "Font Size" :from 7 :to 24 :orient 'horizontal) @@ -211,8 +211,8 @@ :text "Four score seven years ago today" :wraplength 600 :tkfont (c? (list ;; format nil "{{~{~a~^ ~}} ~a}" ;; eg, {{wp greek century} 24} - (md-value (fm^ :font-face)) - (md-value (fm^ :font-size))))))))) + (value (fm^ :font-face)) + (value (fm^ :font-size)))))))))
#| 06-02-14 following stuff not resurrected after latest revisions to Celtk
@@ -224,12 +224,12 @@ (defmodel file-open (toplevel) () (:default-initargs - :md-value (c? (directory "\windows\fonts\*.ttf")) + :value (c? (directory "\windows\fonts\*.ttf")) :pady 2 :padx 4 :kids (c? (the-kids (mk-spinbox :id :font-face - :md-value (c-in (car (^md-value))) - :tk-values (c? (mapcar 'pathname-name (md-value .parent)))) + :value (c-in (car (^value))) + :tk-values (c? (mapcar 'pathname-name (value .parent)))) (mk-button-ex ("Open" (progn (tk-format `(:destroy ,self) "destroy ~a" (path (upper self toplevel))) (not-to-be (upper self toplevel)))) --- /project/cells/cvsroot/Celtk/entry.lisp 2006/11/03 13:37:50 1.16 +++ /project/cells/cvsroot/Celtk/entry.lisp 2006/11/04 20:53:08 1.17 @@ -16,7 +16,7 @@
|#
-;;; $Header: /project/cells/cvsroot/Celtk/entry.lisp,v 1.16 2006/11/03 13:37:50 ktilton Exp $ +;;; $Header: /project/cells/cvsroot/Celtk/entry.lisp,v 1.17 2006/11/04 20:53:08 ktilton Exp $
(in-package :Celtk)
@@ -51,10 +51,10 @@ ;; assuming write op, but data field shows that (let ((new-value (tcl-get-var *tki* (^path) (var-flags :TCL-NAMESPACE-ONLY)))) - (unless (string= new-value (^md-value)) - (setf (^md-value) new-value)))))))) + (unless (string= new-value (^value)) + (setf (^value) new-value))))))))
- :md-value (c-in ""))) + :value (c-in "")))
(defmethod md-awaken :after ((self entry)) ;; move this to a traces slot on widget (with-integrity (:client `(:trace ,self)) @@ -63,10 +63,10 @@ ;;; /// this next replicates the handling of tk-mirror-variable because ;;; those leverage the COMMAND mechanism, which entry lacks ;; -(defobserver .md-value ((self entry)) +(defobserver .value ((self entry)) (when new-value (unless (string= new-value old-value) - (trc nil "md-value output" self new-value) + (trc nil "value output" self new-value) (tcl-set-var *tki* (^path) new-value (var-flags :TCL-NAMESPACE-ONLY)))))
(deftk text-widget (widget) @@ -86,7 +86,7 @@ -undo -width -wrap) (:default-initargs :id (gentemp "TXT") - :md-value (c-in "<your text here>") + :value (c-in "<your text here>") :xscrollcommand (c-in nil) :yscrollcommand (c-in nil) :modified (c-in nil) @@ -101,10 +101,10 @@ ))))
(defmethod clear ((self text-widget)) - (setf (md-value self) nil)) + (setf (value self) nil))
-(defobserver .md-value ((self text-widget)) - (trc nil "md-value output" self new-value) +(defobserver .value ((self text-widget)) + (trc nil "value output" self new-value) (with-integrity (:client `(:variable ,self)) (tk-format-now "~a delete 1.0 end" (^path)) (when (plusp (length new-value)) --- /project/cells/cvsroot/Celtk/fileevent.lisp 2006/06/03 12:12:19 1.8 +++ /project/cells/cvsroot/Celtk/fileevent.lisp 2006/11/04 20:53:08 1.9 @@ -21,7 +21,7 @@ ;;; DEALINGS IN THE SOFTWARE. ;;; ;;; --------------------------------------------------------------------------- -;;; $Header: /project/cells/cvsroot/Celtk/fileevent.lisp,v 1.8 2006/06/03 12:12:19 ktilton Exp $ +;;; $Header: /project/cells/cvsroot/Celtk/fileevent.lisp,v 1.9 2006/11/04 20:53:08 ktilton Exp $ ;;; ---------------------------------------------------------------------------
;;; =========================================================================== @@ -543,7 +543,7 @@ (let ((data (read-line stream nil nil nil))) (trc "*** USRF: data = " data) (if data - (setf (md-value (fm-other :receive-window)) data) + (setf (value (fm-other :receive-window)) data) (funcall (^eof-fn) self)))))
(defmodel fileevent-test-window (window) @@ -555,7 +555,7 @@ :pady 10) (mk-text-widget :id :receive-window ;:state 'disabled - :md-value (c-in "") + :value (c-in "") :height 10 :width 80 :borderwidth 2 --- /project/cells/cvsroot/Celtk/lotsa-widgets.lisp 2006/11/03 13:37:50 1.6 +++ /project/cells/cvsroot/Celtk/lotsa-widgets.lisp 2006/11/04 20:53:08 1.7 @@ -46,7 +46,7 @@ (mk-stack () (mk-text-widget :id :my-text - :md-value (c?n "hello, world") + :value (c?n "hello, world") :height 8 :width 25)
@@ -60,14 +60,14 @@ (mk-row () (mk-checkbutton :id :check-me :text "Check Me" - :md-value (c-in t)) + :value (c-in t)) (mk-label :text (c? (if (fm^v :check-me) "checked" "unchecked")))) (mk-row () (mk-button-ex ("Time now?" (setf (fm^v :push-time) (get-universal-time)))) - (mk-label :text (c? (time-of-day (^md-value))) + (mk-label :text (c? (time-of-day (^value))) :id :push-time - :md-value (c-in (get-universal-time)))) + :value (c-in (get-universal-time))))
(style-by-edit-menu)
@@ -98,7 +98,7 @@ (mk-stack () (mk-spinbox :id :spin-pkg - :md-value (cells::c?n "cells") + :value (cells::c?n "cells") :tk-values (mapcar 'down$ (sort (mapcar 'package-name (list-all-packages)) @@ -107,7 +107,7 @@ :id :spinpkg-sym-list :list-height 6 :list-item-keys (c? (let* ((spinner (fm^ :spin-pkg)) - (item (when spinner (md-value spinner))) + (item (when spinner (value spinner))) (pkg (find-package (string-upcase item)))) (when pkg (loop for sym being the symbols in pkg @@ -118,7 +118,7 @@ :list-item-factory (lambda (sym) (make-instance 'listbox-item :fm-parent *parent* - :md-value sym + :value sym :item-text (down$ (symbol-name sym)))))))
(defun duelling-scrolled-lists () @@ -131,7 +131,7 @@ :list-item-factory (lambda (pkg) (make-instance 'listbox-item :fm-parent *parent* - :md-value pkg + :value pkg :item-text (down$ (package-name pkg))))) (mk-scrolled-list :id :pkg-sym-list @@ -142,7 +142,7 @@ collecting sym))) :list-item-factory (lambda (sym) (make-instance 'listbox-item - :md-value sym + :value sym :fm-parent *parent* :item-text (down$ (symbol-name sym)))))))
@@ -190,7 +190,7 @@ :entry-values (c? (subseq (tk-eval-list "font families") 4 10)))
(mk-scale :id :font-size - :md-value (c-in 14) + :value (c-in 14) :tk-label "Font Size" :from 7 :to 24 :orient 'horizontal)) @@ -201,7 +201,7 @@ :tk-justify 'left :tkfont (c? (list (selection (fm^ :font-face)) - (md-value (fm^ :font-size))))))) + (value (fm^ :font-size)))))))
(defun demo-all-menubar () (mk-menubar @@ -219,7 +219,7 @@ (mk-menu-entry-command :label "Close" :command "{destroy .}") (mk-menu-entry-separator) (mk-menu-entry-command :label "Quit" - :state (c? (if t ;; (md-value (fm^ :check-me)) + :state (c? (if t ;; (value (fm^ :check-me)) 'normal 'disabled)) :command "tk_getOpenFile"))))))) ;; 'exit' in production, but under dev would take out Lisp IDE (mk-menu-entry-cascade @@ -259,6 +259,6 @@ collecting (mk-menu-entry-radiobutton :label label :value value)))))))) (mk-menu-entry-separator) (mk-menu-entry-checkbutton :id :app-font-italic :label "Italic") - (mk-menu-entry-checkbutton :id :app-font-bold :label "Bold" :md-value (c-in t)))))))))))) + (mk-menu-entry-checkbutton :id :app-font-bold :label "Bold" :value (c-in t))))))))))))
--- /project/cells/cvsroot/Celtk/ltktest-ci.lisp 2006/10/28 18:21:52 1.10 +++ /project/cells/cvsroot/Celtk/ltktest-ci.lisp 2006/11/04 20:53:08 1.11 @@ -216,7 +216,7 @@ ; solution to this riddle. ; (mk-entry-numeric :id :point-ct - :md-value (c-in "42") + :value (c-in "42") ; ; to help motivate "why Cells?" a little more, we deviate from ltktest 'classic" and ; start having the widgets take more interesting effect: The entry field now determines the number @@ -240,7 +240,7 @@ ; from outside the model. ; (handler-case - (let ((num (parse-integer (^md-value)))) + (let ((num (parse-integer (^value)))) (cond ((< num 2) (list (format nil "Yo, Euclid, at least two, not: ~a!!" num))) @@ -256,7 +256,7 @@ ; As you edit the field, if you key in an invalid (non-digit) character, the background ; immediately turns red. Delete it and it reverts to the default. ; - ; The interesting question is, how does the md-value slot of the Lisp instance stay + ; The interesting question is, how does the value slot of the Lisp instance stay ; current with the text being edited in the Tk entry widget? Here we have a fundamental ; difference between Ltk and Celtk. Ltk lets Tk take care of everything, including ; storing the data. eg, (text my-entry) is an accessor call that asks Tk the value of @@ -265,7 +265,7 @@ ; by having datapoints watching other datapoints, so we want data in the Lisp domain ; changing automatically as it changes on the TK side (such as when the user is actually ; typing in the entry widget). See the entry class to see how it uses the TCL "trace write" - ; mechanism to keep the Lisp md-value slot abreast of the Tk entry text configuration + ; mechanism to keep the Lisp value slot abreast of the Tk entry text configuration ; keystroke by keystroke. ; ; I added the :user-errors rule above to demonstrate the mechanism in action. Click @@ -275,28 +275,28 @@
(mk-button-ex ("Print" (format t "~&User wants to see ~A points" (fm^v :point-ct)))) ; - ; (fm^v :point-ct) -> (md-value (fm^ :point-ct)) + ; (fm^v :point-ct) -> (value (fm^ :point-ct)) ; - ; The idea being that every Cells model object has an md-value slot bearing the value + ; The idea being that every Cells model object has an value slot bearing the value ; of the thing being modeled. Here, the entry widget is modelling a place for users - ; to supply information to an application, and the md-value slot is a good place to + ; to supply information to an application, and the value slot is a good place to ; keep that information. ; - ; Thus each class uses md-value to hold something different, but in all cases it is + ; Thus each class uses value to hold something different, but in all cases it is ; the current value of whatever the instance of that class is understood to hold. ; (mk-button-ex ("Reset" (setf (fm^v :point-ct) "42"))) ; ; Driving home this point again, in Ltk one would SETF (text my-entry) and the ; SETF method would communicate with Tk to make the change to the Tk widget -text - ; configuration. In Celtk, the md-value slot of the entry gets changed (possibly + ; configuration. In Celtk, the value slot of the entry gets changed (possibly ; triggering other slots to update, which is why we do not just talk to Tk) and ; then that value gets propagated to Tk via "set <widget path> <value>". Because ; the textVariable for every entry is the entry itself, the text of the entry ; then changes. If that sounds weird, what we are actually doing is tapping into - ; the fact that Tk to a large degree takes the same approach as Cells does with md-value: + ; the fact that Tk to a large degree takes the same approach as Cells does with value: ; in Cells, we think of model instances as wrapping some model-specific - ; value, which is held in the md-value slot of the model instance. Tk simply + ; value, which is held in the value slot of the model instance. Tk simply ; allows a widget path to be a global variable. Furthermore, as the company name ; ActiveState suggests, Tk also provides automatic propagation: change the ; variable, and anyone with that as its textVariable also changes. @@ -439,7 +439,7 @@ ((num-parse :initarg :num-parse :accessor num-parse :initform (c? (eko ("numparse") (handler-case - (parse-integer (^md-value)) + (parse-integer (^value)) (parse-error (c) (princ-to-string c)))))) (num-value :initarg :num-value :accessor num-value @@ -447,7 +447,7 @@ (^num-parse) (or .cache 42))))) (:default-initargs - :md-value "42" + :value "42" :user-errors (c? (unless (numberp (^num-parse)) (^num-parse)))))
--- /project/cells/cvsroot/Celtk/menu.lisp 2006/11/03 13:37:50 1.17 +++ /project/cells/cvsroot/Celtk/menu.lisp 2006/11/04 20:53:08 1.18 @@ -192,13 +192,13 @@ -offvalue -onvalue) (:default-initargs - :md-value (c-in nil) + :value (c-in nil) :tk-variable (c? (format nil "~a.~(~a~)" (path .parent)(md-name self))) :on-command (lambda (self) - (setf (^md-value) (not (^md-value)))))) + (setf (^value) (not (^value))))))
-(defobserver .md-value ((self menu-entry-checkbutton)) - (trc nil "defobserver md-value menu-entry-checkbutton" self new-value old-value-boundp) +(defobserver .value ((self menu-entry-checkbutton)) + (trc nil "defobserver value menu-entry-checkbutton" self new-value old-value-boundp) (when (and new-value (not old-value-boundp)) (tk-format `(:variable ,self) "set ~a ~a" (^tk-variable) (if new-value 1 0))))
--- /project/cells/cvsroot/Celtk/multichoice.lisp 2006/11/03 13:37:50 1.11 +++ /project/cells/cvsroot/Celtk/multichoice.lisp 2006/11/04 20:53:08 1.12 @@ -34,18 +34,18 @@ -tickinterval -to (-tk-variable nil)) (:default-initargs :id (gentemp "SCL") - :md-value (c-in nil) + :value (c-in nil) :tk-variable nil ;;(c? (^path)) :xscrollcommand (c-in nil) :yscrollcommand (c-in nil) :on-command (lambda (self value) ;; (trc "hi scale" self value) - (setf (^md-value) (parse-integer value))))) + (setf (^value) (parse-integer value)))))
(defmethod make-tk-instance :after ((self scale)) "Still necessary?" - (when (^md-value) - (tk-format `(:variable ,self) "~a set ~a" (^path) (^md-value)))) + (when (^value) + (tk-format `(:variable ,self) "~a set ~a" (^path) (^value))))
; --- listbox --------------------------------------------------------------
@@ -70,11 +70,11 @@ (ListboxSelect (let ((selection (parse-integer (tk-eval "~a curselection" (^path))))) (setf (selection (selector self)) - (md-value (elt (^kids) selection))))))))))) + (value (elt (^kids) selection)))))))))))
(defmodel listbox-item (tk-object) ((item-text :initarg :item-text :accessor item-text - :initform (c? (format nil "~a" (^md-value)))))) + :initform (c? (format nil "~a" (^value))))))
(defmethod make-tk-instance ((self listbox-item)) (trc nil "make-tk-instance listbox-item insert" self) @@ -106,22 +106,22 @@ -troughcolor -underline -xscrollcommand -validate -validatecommand (tk-values -values) -width -wrap) (:default-initargs - :md-value (c-in nil) + :value (c-in nil) :id (gentemp "SPN") :textVariable (c? (^path)) :xscrollcommand (c-in nil) :command (c? (format nil "do-on-command ~a %s" (^path))) :on-command (c? (lambda (self text) (eko ("variable mirror command fired !!!!!!!" text) - (setf (^md-value) text)))))) + (setf (^value) text))))))
-(defobserver .md-value ((self spinbox)) +(defobserver .value ((self spinbox)) (when new-value (tk-format `(:variable ,self) "set ~a ~a" (^path) (tk-send-value new-value))))
(defobserver initial-value ((self spinbox)) (when new-value (trc "spinbox intializing from initvalue !!!!!!!!!!!!" self new-value) - (setf (^md-value) new-value))) + (setf (^value) new-value)))
--- /project/cells/cvsroot/Celtk/togl.lisp 2006/10/28 18:21:52 1.22 +++ /project/cells/cvsroot/Celtk/togl.lisp 2006/11/04 20:53:08 1.23 @@ -194,8 +194,11 @@
(def-togl-callback create () (trc "___________________ TOGL SET UP _________________________________________" togl-ptr ) - #+cl-ftgl (setf cl-ftgl:*ftgl-ogl* togl-ptr) ;; help debug failure to use lazy cells/classes to defer FTGL till Ogl ready - #+kt-opengl (kt-opengl:kt-opengl-reset) + ; + ; just comment out these two lines if not using Cello + ; + (setf cl-ftgl:*ftgl-ogl* togl-ptr) ;; help debug failure to use lazy cells/classes to defer FTGL till Ogl ready + (kt-opengl:kt-opengl-reset) (setf (togl-ptr self) togl-ptr) ;; this cannot be deferred (setf (togl-ptr-set self) togl-ptr) ;; this gets deferred, which is OK (setf (gethash (pointer-address togl-ptr) (tkwins *tkw*)) self))
-
ktilton