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)