[cells-cvs] CVS Celtk
ktilton
ktilton at common-lisp.net
Mon Jan 29 22:58:42 UTC 2007
Update of /project/cells/cvsroot/Celtk
In directory clnet:/tmp/cvs-serv31381
Modified Files:
Celtk.lisp lotsa-widgets.lisp movie.lisp multichoice.lisp
tk-interp.lisp tk-object.lisp
Log Message:
a little more on the movie widget
--- /project/cells/cvsroot/Celtk/Celtk.lisp 2007/01/29 06:48:41 1.39
+++ /project/cells/cvsroot/Celtk/Celtk.lisp 2007/01/29 22:58:41 1.40
@@ -16,7 +16,7 @@
|#
-;;; $Header: /project/cells/cvsroot/Celtk/Celtk.lisp,v 1.39 2007/01/29 06:48:41 ktilton Exp $
+;;; $Header: /project/cells/cvsroot/Celtk/Celtk.lisp,v 1.40 2007/01/29 22:58:41 ktilton Exp $
(pushnew :tile *features*)
@@ -114,7 +114,7 @@
; --- debug stuff ---------------------------------
;
- (let ((yes '("movie" "play"))
+ (let ((yes '("play-me"))
(no '("font")))
(declare (ignorable yes no))
(when (and (or ;; (null yes)
--- /project/cells/cvsroot/Celtk/lotsa-widgets.lisp 2007/01/29 06:48:41 1.9
+++ /project/cells/cvsroot/Celtk/lotsa-widgets.lisp 2007/01/29 22:58:41 1.10
@@ -74,35 +74,27 @@
(style-by-widgets)
(mk-row (:layout-anchor 'sw)
- (mk-entry
- :id :enter-me
- :event-handler (lambda (self xe)
- (case (tk-event-type (xsv type xe))
- (:virtualevent
- (case (read-from-string (string-upcase (xsv name xe)))
- (trace (let ((new-value (ctk::tcl-get-var ctk::*tki* (^path)
- (ctk::var-flags :TCL-NAMESPACE-ONLY))))
- (unless (string= new-value (^value)) ;; I guess it would loop
- (setf (^value) new-value))
- (cond
- ((find new-value '("bush" "war" "anger" "hate") :test 'string-equal)
- (setf (tk-file (fm^ :play-me))
- "c:/0dev/celtk/demo.mov"))
- ((find new-value '("sex" "drugs" "rock-n-roll" "peace") :test 'string-equal)
- (setf (tk-file (fm^ :play-me))
- "c:/0dev/celtk/good-thing2.mov"))))))))))
+ (mk-entry :id :enter-me)
(mk-label :text (c? (conc$ "echo " (fm^v :enter-me))))))
(mk-stack ()
(duelling-scrolled-lists)
(mk-row ()
- (mk-button-ex ("Serious Demo" (setf (tk-file (fm^ :play-me))
- "c:/0dev/celtk/demo.mov")))
- (mk-button-ex ("Celtk?" (setf (tk-file (fm^ :play-me))
- "c:/0dev/celtk/good-thing2.mov"))))
+ (mk-button-ex ("Serious Demo" (plug-n-play-movie (fm^ :play-me)
+ "c:/0dev/celtk/demo.mov")))
+ (mk-button-ex ("Celtk?" (plug-n-play-movie (fm^ :play-me)
+ "c:/0dev/celtk/good-thing2.mov"))))
+
(mk-movie :id :play-me
- :tk-file (c-in "c:/0dev/celtk/good-thing2.mov")))))))))))
+ :loopstate (c-in 0) :palindromeloopstate (c-in 0)
+ :tk-file (c? (let ((entry (fm^v :enter-me)))
+ (cond
+ ((find entry '("bush" "war" "anger" "hate") :test 'string-equal)
+ "c:/0dev/celtk/demo.mov")
+ ((find entry '("sex" "drugs" "rock-n-roll" "peace") :test 'string-equal)
+ "c:/0dev/celtk/good-thing2.mov")
+ (t "c:/0dev/celtk/good-thing2.mov" #+not .cache))))))))))))))
(defun style-by-edit-menu ()
(mk-row ("Style by Edit Menu")
--- /project/cells/cvsroot/Celtk/movie.lisp 2007/01/29 06:48:42 1.1
+++ /project/cells/cvsroot/Celtk/movie.lisp 2007/01/29 22:58:41 1.2
@@ -18,14 +18,34 @@
(in-package :celtk)
-(export! mk-movie url tk-file)
+(export! mk-movie url tk-file plug-n-play-movie)
+
(deftk movie (widget)
- ()
- (:tk-spec movie -url (tk-file -file))
+ ((loop :initarg :loop :accessor loop)) ;; fnyi
+ (:tk-spec movie -url (tk-file -file)
+ -controller -custombutton -highlightbackground -highlightcolor
+ -highlightthickness -height -loadcommand -loadintoram -loopstate
+ -mccommand -mcedit -palindromeloopstate -preferredrate -progressproc
+ -qtprogress -qtvrqualitymotion -qtvrqualitystatic -resizable
+ -swing -swingspeed -volume -width)
(:default-initargs
:tile? nil))
(defobserver tk-file :around ((self movie))
(call-next-method)
(when (and new-value old-value)
- (tk-format `(:fini ,self) "~a play" (^path))))
+ (plug-n-play-movie self new-value nil)))
+
+(defun plug-n-play-movie (m file &optional (install? t))
+ ;
+ ; silly harcodes follow....
+ ;
+ (when install? (setf (tk-file m) file))
+ ;
+ ; this off-on sequence apparently necessary each time a file is loaded or sth.
+ ;
+ (with-cc :loopstate
+ (setf (palindromeloopstate m) 0)
+ (with-cc :loopstate
+ (setf (palindromeloopstate m) 1)
+ (tk-format `(:fini ,m) "~a play" (path m)))))
\ No newline at end of file
--- /project/cells/cvsroot/Celtk/multichoice.lisp 2007/01/29 06:48:41 1.13
+++ /project/cells/cvsroot/Celtk/multichoice.lisp 2007/01/29 22:58:41 1.14
@@ -114,8 +114,7 @@
: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 (^value) text))))))
+ (setf (^value) text)))))
(defobserver .value ((self spinbox))
(when new-value
@@ -123,7 +122,6 @@
(defobserver initial-value ((self spinbox))
(when new-value
- (trc "spinbox intializing from initvalue !!!!!!!!!!!!" self new-value)
(setf (^value) new-value)))
--- /project/cells/cvsroot/Celtk/tk-interp.lisp 2007/01/29 06:48:41 1.17
+++ /project/cells/cvsroot/Celtk/tk-interp.lisp 2007/01/29 22:58:41 1.18
@@ -124,8 +124,6 @@
(flags :int))
(defun tcl-eval-ex (i s)
- (when (search "package" s)
- (print s))
(tcl_evalex i s -1 0))
(defcfun ("Tcl_GetVar" tcl-get-var) :string (interp :pointer)(varName :string)(flags :int))
--- /project/cells/cvsroot/Celtk/tk-object.lisp 2007/01/29 06:48:41 1.11
+++ /project/cells/cvsroot/Celtk/tk-object.lisp 2007/01/29 22:58:41 1.12
@@ -84,7 +84,7 @@
(defgeneric tk-class-options (self)
(:method-combination append)
(:method :around (self)
- (or ;;(get (type-of self) 'tk-class-options)
+ (or (get (type-of self) 'tk-class-options)
(setf (get (type-of self) 'tk-class-options)
(loop with all = (remove-duplicates (call-next-method) :key 'second)
for old in (when (tile? self)
More information about the Cells-cvs
mailing list