[cells-cvs] CVS Celtk
ktilton
ktilton at common-lisp.net
Tue May 2 12:48:05 UTC 2006
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]
More information about the Cells-cvs
mailing list