[cells-cvs] CVS Celtk
ktilton
ktilton at common-lisp.net
Sat Nov 4 20:53:08 UTC 2006
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))
More information about the Cells-cvs
mailing list