Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv25230
Modified Files: gears.lisp Added Files: multichoice.lisp run.lisp scroll.lisp text-item.lisp timer.lisp tk-interp.lisp tk-object.lisp togl.lisp widget.lisp Log Message: Missing pieces from last night's incomplete update.
--- /project/cells/cvsroot/Celtk/gears.lisp 2006/05/02 06:57:22 1.1 +++ /project/cells/cvsroot/Celtk/gears.lisp 2006/05/02 12:48:05 1.2 @@ -1,6 +1,68 @@
(in-package :celtk)
+(in-package :celtk) + +(defparameter *startx* nil) +(defparameter *starty* nil) +(defparameter *xangle0* nil) +(defparameter *yangle0* nil) +(defparameter *xangle* 0.0) +(defparameter *yangle* 0.0) + +(defparameter *vTime* 100) + +(defun gears () ;; ACL project manager needs a zero-argument function, in project package + (test-window 'gears-demo)) + + +(defmodel gears-demo (window) + ((gear-ct :initform (c-in 1) :accessor gear-ct :initarg :gear-ct) + (scale :initform (c-in 1) :accessor scale :initarg :scale)) + (:default-initargs + :title$ "Rotating Gear Widget Test" + :kids (c? (the-kids + (mk-stack (:packing (c?pack-self)) + (mk-label :text "Click and drag to rotate image") + #+tki (mk-row () + (mk-button-ex (" Add " (incf (gear-ct .tkw)))) + (mk-button-ex ("Remove" (when (plusp (gear-ct .tkw)) + (decf (gear-ct .tkw))))) + (mk-entry :id :vtime + :md-value (c-in "100")) + (mk-button-ex (" Quit " (progn)))) + (make-instance 'gears + :fm-parent *parent* + :width 400 + :height 400 + :timer-interval nil #+tki (c? (or .cache ;; comment out just ".cache" for some fun + (eko ("vtime is") + (md-value (fm-other :vtime))))) + :double "yes" + :bindings nil #+wait (c? (list + (list "<Button-1>" + (lambda (event) + (RotStart self + (event-root-x event) + (event-root-y event)))) + (list "<B1-Motion>" + (lambda (event) + (RotMove self + (event-root-x event) + (event-root-y event))) ))))))))) + +(defun RotStart (self x y) + (setf *startx* x) + (setf *starty* y) + (let ((vPos (tk-eval-list "~a position" (^path)))) ;; this fails for me -- command not recognized, it seems + (trc "got vpos" vpos) + (setf *xangle0* (read-from-string (nth 0 vpos))) + (setf *yangle0* (read-from-string (nth 1 vpos))))) + +(defun RotMove (self x y) + (setf *xangle* (+ *xangle0* (- x *startx*))) + (setf *yangle* (+ *yangle0* (- y *starty*))) + (tk-format-now "~a rotate ~a ~a" (^path) *xangle* *yangle*)) (defconstant +pif+ (coerce pi 'single-float))
(defmodel gears (togl)
--- /project/cells/cvsroot/Celtk/multichoice.lisp 2006/05/02 12:48:05 NONE +++ /project/cells/cvsroot/Celtk/multichoice.lisp 2006/05/02 12:48:05 1.1 ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: celtk; -*- ;;; ;;; Copyright (c) 2006 by Kenneth William Tilton. ;;; ;;; Permission is hereby granted, free of charge, to any person obtaining a copy ;;; of this software and associated documentation files (the "Software"), to deal ;;; in the Software without restriction, including without limitation the rights ;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell ;;; copies of the Software, and to permit persons to whom the Software is furnished ;;; to do so, subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be included in ;;; all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS ;;; IN THE SOFTWARE.
; --- scale ----------------------------------------------
(in-package :Celtk)
(deftk scale (commander widget) () (:tk-spec scale -activestyle -background -borderwidth -cursor -font -foreground -highlightbackground -highlightcolor -highlightthickness -relief -state -takefocus -troughcolor -width -xscrollcommand -yscrollcommand -orient -repeatdelay -repeatinterval -bigincrement -command -digits -from (-tk-label -label) (-tk-length -length) -resolution -showvalue -sliderlength -sliderrelief -tickinterval -to (-tk-variable nil)) (:default-initargs :id (gentemp "SCL") :md-value (c-in nil) :tk-variable nil ;;(c? (^path)) :xscrollcommand (c-in nil) :yscrollcommand (c-in nil) :on-command (lambda (self value) (setf (^md-value) value))))
(defmethod make-tk-instance :after ((self scale)) "Still necessary?" (when (^md-value) (tk-format `(:variable ,self) "~a set ~a" (^path) (^md-value))))
; --- listbox --------------------------------------------------------------
(deftk listbox (widget) () (:tk-spec listbox -activestyle -background -borderwidth -cursor -disabledforeground -exportselection -font -foreground -height -highlightbackground -highlightcolor -highlightthickness -listvariable -relief -selectmode -selectbackground -selectborderwidth -selectforeground -setgrid -state -takefocus -width -xscrollcommand -yscrollcommand) (:default-initargs :id (gentemp "LBX") :xscrollcommand (c-in nil) :yscrollcommand (c-in nil) :bindings (c? (assert (selector self)) (when (selector self) ;; if not? Figure out how listbox tracks own selection (list (list "<<ListboxSelect>>" (format nil "{callbackval ~~a [~a curselection]}" (^path)) (lambda (selection) (trc nil "listbox callback firing" self selection) (setf (selection (selector self)) (md-value (elt (^kids) selection))))))))))
(defmodel listbox-item (tk-object) ((item-text :initarg :item-text :accessor item-text :initform (c? (format nil "~a" (^md-value))))))
(defmethod make-tk-instance ((self listbox-item)) (tk-format `(:post-make-tk ,self) "~A insert end ~s" (path .parent) (^item-text)))
(defobserver .kids ((self listbox)) (when old-value (tk-format `(:destroy ,self) "~A delete ~a ~a" (^path) 0 (1- (length old-value)))))
; --- spinbox ---------------------------------------------
(deftk spinbox (widget) ((initial-value :initform nil :initarg :initial-value :reader initial-value)) (:tk-spec spinbox -activebackground -background -borderwidth -cursor -buttonbackground -buttoncursor -buttondownrelief -buttonuprelief -disabledforeground -disabledbackground -exportselection -font (spin-format -format) -foreground -from -command -invalidcommand -increment -highlightbackground -highlightcolor -highlightthickness -insertbackground -insertborderwidth -insertofftime -insertontime -insertwidth -jump -justify -orient -padx -pady -relief -repeatdelay -repeatinterval -selectbackground -selectborderwidth -selectforeground -readonlybackground -state -to -takefocus -text -textvariable -troughcolor -underline -xscrollcommand -validate -validatecommand (tk-values -values) -width -wrap) (:default-initargs :md-value (c-in nil) :id (gentemp "SPN") :textVariable (c? (^path)) :xscrollcommand (c-in nil) :on-command (lambda (self text) (eko (nil "variable mirror command fired !!!!!!!" text) (setf (^md-value) text)))))
(defobserver .md-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 (with-integrity (:change) (trc "spinbox intializing from initvalue !!!!!!!!!!!!" self new-value) (setf (^md-value) new-value))))
--- /project/cells/cvsroot/Celtk/run.lisp 2006/05/02 12:48:05 NONE +++ /project/cells/cvsroot/Celtk/run.lisp 2006/05/02 12:48:05 1.1 ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: celtk; -*- ;;; ;;; Copyright (c) 2006 by Kenneth William Tilton. ;;; ;;; Permission is hereby granted, free of charge, to any person obtaining a copy ;;; of this software and associated documentation files (the "Software"), to deal ;;; in the Software without restriction, including without limitation the rights ;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell ;;; copies of the Software, and to permit persons to whom the Software is furnished ;;; to do so, subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be included in ;;; all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS ;;; IN THE SOFTWARE.
(in-package :Celtk)
;;; --- running a Celtk application (window class, actually) --------------------------------------
(eval-when (compile load eval) (export '(tk-scaling run-window test-window)))
(defun run-window (root-class) (declare (ignorable root-class)) (setf *tkw* nil) (cells-reset 'tk-user-queue-handler) (tk-interp-init-ensure)
(setf *tki* (Tcl_CreateInterp)) (tk-app-init *tki*) (tk-togl-init *tki*)
#+soon (tk-format-now "proc trc2 {cb n1 n2 op} {puts "(:callback \"$cb\" :name1 $n1 :name2 \"$n2\" :op $op)"}") (tk-format-now "set tk-events {}") (tk-format-now "proc call-back {w args} { global tk-events lappend tk-events [concat do-on-command $w $args]}") ;; deadly (takes down ACL) -> (tk-format-now "bind . <Escape> exit")
(with-integrity () (setf *tkw* (make-instance root-class)))
(tk-format `(:fini) "wm deiconify .")
;; one or the other of...
;; hangs on win close now, but probably easy to fix, just needs to know when ;; to stop looping: -> (tcl-do-one-event-loop)
(tcl-do-one-event-loop) )
;; Our own event loop ! - Use this if it is desirable to do something ;; else between events
(defun tcl-do-one-event-loop () (loop with start-time = (get-internal-real-time) while (> 10 (floor (- (get-internal-real-time) start-time) internal-time-units-per-second)) do (bif (events (prog1 (tk-eval-list "set tk-events") (tk-eval "set tk-events {}"))) (loop ;; with x = (trc "no events") for e in events do (setf start-time (get-internal-real-time)) (tk-process-event e)) (sleep .05)) ;;*event-loop-delay*)) (loop until (zerop (Tcl_DoOneEvent 2)))))
(defun tk-process-event (event) (trc "event string:" event) (destructuring-bind (fn w-name &rest args) (read-from-string (conc$ "(" event ")")) (let ((id (symbol-name w-name))) (bif (w (gethash id (dictionary *tkw*))) (progn (trc "funcalling" fn w) (apply fn w args)) (progn (loop for k being the hash-keys of (dictionary *tkw*) do (trc "known key" k (type-of k))) (break "bad id ~a in event ~a" id event))))))
(defmethod do-on-command :around (self &rest args) (trc "on command!!!" self) (bwhen (ocb (on-command self)) (apply ocb self args)))
(defun test-window (root-class) "nails existing window as a convenience in iterative development" (declare (ignorable root-class))
#+tki (when (and *tkw* (open-stream-p *tkw*)) (format *tkw* "wm withdraw .~%") (force-output *tkw*) (format *tkw* "destroy .%") (force-output *tkw*) (setf *tkw* nil))
(run-window root-class))--- /project/cells/cvsroot/Celtk/scroll.lisp 2006/05/02 12:48:05 NONE +++ /project/cells/cvsroot/Celtk/scroll.lisp 2006/05/02 12:48:05 1.1 ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: celtk; -*- ;;; ;;; Copyright (c) 2006 by Kenneth William Tilton. ;;; ;;; Permission is hereby granted, free of charge, to any person obtaining a copy ;;; of this software and associated documentation files (the "Software"), to deal ;;; in the Software without restriction, including without limitation the rights ;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell ;;; copies of the Software, and to permit persons to whom the Software is furnished ;;; to do so, subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be included in ;;; all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS ;;; IN THE SOFTWARE.
(in-package :Celtk)
; --- scroll bars ----------------------------------------
(deftk scrollbar (widget) () (:tk-spec scrollbar -activebackground -activerelief -background -borderwidth -command -cursor -elementborderwidth -highlightbackground -highlightcolor -highlightthickness -jump -orient -relief -repeatdelay -repeatinterval -takefocus -troughcolor -width) (:default-initargs :id (gentemp "SBAR")))
(deftk scrolled-list (row-mixin frame-selector) ((list-item-keys :initarg :list-item-keys :accessor list-item-keys :initform nil) (list-item-factory :initarg :list-item-factory :accessor list-item-factory :initform nil) (list-height :initarg :list-height :accessor list-height :initform nil)) (:default-initargs :list-height (c? (max 1 (length (^list-item-keys)))) :kids-packing nil :kids (c? (the-kids (mk-listbox :id :list-me :kids (c? (the-kids (mapcar (list-item-factory .parent) (list-item-keys .parent)))) :font '(courier 9) :state (c? (if (enabled .parent) 'normal 'disabled)) :takefocus (c? (if (enabled .parent) 1 0)) :height (c? (list-height .parent)) :packing (c? (format nil "pack ~a -side left -fill both -expand 1" (^path))) :yscrollcommand (c? (when (enabled .parent) (format nil "~a set" (path (nsib)))))) (mk-scrollbar :id :vscroll :packing (c?pack-self "-side right -fill y") :command (c? (format nil "~a yview" (path (psib)))))))))
(defmethod tk-output-selection :after ((self scrolled-list) new-value old-value old-value-boundp) (declare (ignorable old-value old-value-boundp)) (trc nil "scrolled-list selection output" self new-value) (when new-value (let ((lb (car (^kids))) (item-no (position new-value (^list-item-keys) :test 'equal))) (if item-no (tk-format `(:selection ,self) "~(~a~) selection set ~a" (path lb) item-no) (break "~&scrolled-list ~a selection ~a not found in item keys ~a" self new-value (^list-item-keys))))))
;--- scroller (of canvas; need to generalize this) ----------
(defmodel scroller (grid-manager frame) ((canvas :initarg :canvas :accessor canvas :initform nil)) (:default-initargs :id :cv-scroller :kids-packing nil :gridding '(:columns ("-weight {1}" "-weight {0}") :rows ("-weight {1}" "-weight {0}")) :kids (c? (the-kids (^canvas) (mk-scrollbar :id :hscroll :orient "horizontal" :gridding "-row 1 -column 0 -sticky we" :command (c? (format nil "~a xview" (path (kid1 .parent)))))
[19 lines skipped] --- /project/cells/cvsroot/Celtk/text-item.lisp 2006/05/02 12:48:05 NONE +++ /project/cells/cvsroot/Celtk/text-item.lisp 2006/05/02 12:48:05 1.1
[65 lines skipped] --- /project/cells/cvsroot/Celtk/timer.lisp 2006/05/02 12:48:05 NONE +++ /project/cells/cvsroot/Celtk/timer.lisp 2006/05/02 12:48:05 1.1
[170 lines skipped] --- /project/cells/cvsroot/Celtk/tk-interp.lisp 2006/05/02 12:48:05 NONE +++ /project/cells/cvsroot/Celtk/tk-interp.lisp 2006/05/02 12:48:05 1.1
[666 lines skipped] --- /project/cells/cvsroot/Celtk/tk-object.lisp 2006/05/02 12:48:05 NONE +++ /project/cells/cvsroot/Celtk/tk-object.lisp 2006/05/02 12:48:05 1.1
[774 lines skipped] --- /project/cells/cvsroot/Celtk/togl.lisp 2006/05/02 12:48:05 NONE +++ /project/cells/cvsroot/Celtk/togl.lisp 2006/05/02 12:48:05 1.1
[922 lines skipped] --- /project/cells/cvsroot/Celtk/widget.lisp 2006/05/02 12:48:05 NONE +++ /project/cells/cvsroot/Celtk/widget.lisp 2006/05/02 12:48:05 1.1
[1155 lines skipped]
-
ktilton