Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv26224

Modified Files: Celtk.lisp demos.lisp load.lisp lotsa-widgets.lisp menu.lisp multichoice.lisp tk-interp.lisp widget.lisp Log Message:

--- /project/cells/cvsroot/Celtk/Celtk.lisp 2006/05/16 02:52:22 1.21 +++ /project/cells/cvsroot/Celtk/Celtk.lisp 2006/05/16 21:17:15 1.22 @@ -62,23 +62,22 @@

(define-symbol-macro .tkw (nearest self window))

+ ; --- tk-format --- talking to wish/Tk -----------------------------------------------------

+(defconstant +tk-client-task-priority+ + '(:delete :forget :destroy + :pre-make-tk :make-tk :make-tk-menubutton :post-make-tk + :variable :bind :selection :trace :configure :grid :pack :fini)) + (defun tk-user-queue-sort (task1 task2) "Intended for use as user queue sorter, to make Tk happy by giving it stuff in the order it needs to work properly." - (let ((priority '(:delete :forget :destroy - :pre-make-tk :make-tk :make-tk-menubutton :post-make-tk - :variable :bind :selection :trace :configure :grid :pack :fini))) - (destructuring-bind (type1 self1 &rest dbg) task1 + (destructuring-bind (type1 self1 &rest dbg) task1 (declare (ignorable dbg)) - (assert type1) - (assert (find type1 priority) () "unknown task type ~a in task ~a" type1 task1) (destructuring-bind (type2 self2 &rest dbg) task2 (declare (ignorable dbg)) - (assert type2) - (assert (find type2 priority) () "unknown task type ~a in task ~a" type2 task2) - (let ((p1 (position type1 priority)) - (p2 (position type2 priority))) + (let ((p1 (position type1 +tk-client-task-priority+)) + (p2 (position type2 +tk-client-task-priority+))) (cond ((< p1 p2) t) ((< p2 p1) nil) @@ -86,12 +85,14 @@ (:make-tk (fm-ordered-p self1 self2)) (:pack - (fm-ascendant-p self2 self1)))))))))) + (fm-ascendant-p self2 self1)))))))))

(defun tk-user-queue-handler (user-q) - #+shh (loop for (defer-info . nil) in (sort (copy-list (fifo-data user-q)) 'tk-user-queue-sort :key 'car) - do (trc "user-q-handler sees" defer-info)) + (loop for (defer-info . nil) in (fifo-data user-q) + unless (find (car defer-info) +tk-client-task-priority+) + do (error "unknown tk client task type ~a in task: ~a " (car defer-info) defer-info)) + (loop for (nil #+not defer-info . task) in (prog1 (sort (fifo-data user-q) 'tk-user-queue-sort :key 'car) (fifo-clear user-q)) --- /project/cells/cvsroot/Celtk/demos.lisp 2006/05/16 02:52:22 1.15 +++ /project/cells/cvsroot/Celtk/demos.lisp 2006/05/16 21:17:15 1.16 @@ -137,8 +137,7 @@ for n below 5 counting sym into symct collecting sym into syms - finally (trc "syms found !!!" symct) - (return syms))))) + finally (return syms))))) :list-item-factory (lambda (sym) (make-instance 'listbox-item :fm-parent *parent* @@ -154,7 +153,7 @@ (mk-popup-menubutton :id :font-face :initial-value (c? (second (^entry-values))) - :entry-values (c? (eko ("popup ff") (subseq (tk-eval-list "font families") 4 10)))) + :entry-values (c? (subseq (tk-eval-list "font families") 4 10))) (mk-label :text "Four score and seven years ago today, our fathers broguht forth on this continent a new nation..." :wraplength 200 :justify 'left --- /project/cells/cvsroot/Celtk/load.lisp 2006/05/12 08:30:14 1.5 +++ /project/cells/cvsroot/Celtk/load.lisp 2006/05/16 21:17:15 1.6 @@ -1,9 +1,26 @@ +;;; +;;; +;;; First, grab these: +;;; +;;; http://common-lisp.net/cgi-bin/viewcvs.cgi/cells/?root=cells +;;; Celtk: http://common-lisp.net/cgi-bin/viewcvs.cgi/Celtk/?root=cells +;;; CFFI: http://common-lisp.net/project/cffi/releases/cffi_0.9.1.tar.gz +;;; cl-opengl: http://common-lisp.net/cgi-bin/darcsweb/darcsweb.cgi?r=cl-opencl%20cl-opengl... +;; +;;; At the bottom of any of those pages look for a "Download tarball" link. Except cl-opengl, those guys +;;; are not download-friendly. +;;; +;;; Next, get ASDF loaded: + #+eval-this-if-you-do-not-autoload-asdf (load (make-pathname #+lispworks :host #-lispworks :device "c" :directory '(:absolute "0dev" "cells") :name "asdf" :type "lisp"))

+;;; /After/ you have manually evaluated the above form, you can tell ASDF +;;; where you put everything by adjusting these paths and evaluating: + (progn (push (make-pathname #+lispworks :host #-lispworks :device "c" :directory '(:absolute "0dev" "cells")) @@ -21,16 +38,14 @@ :directory '(:absolute "0dev" "Celtk")) asdf:*central-registry*))

-#-runtestsuite -(ASDF:OOS 'ASDF:LOAD-OP :CELLS) - -#+runtestsuite -(ASDF:OOS 'ASDF:LOAD-OP :CELLS-TEST) +;;; and now you can try building the whole mess:

(ASDF:OOS 'ASDF:LOAD-OP :CELTK)

-#+ortestceltk -(ctk:test-window 'celtk-user::ltktest-cells-inside) +;;; and test: + +(ctk::test-window 'celtk-user::lotsa-widgets) + +;;; When that crashes, track down all the define-foreign-library calls in the source +;;; and fix the pathnames to point to your shared libraries.

-#+opengl -(celtk-user::gears) \ No newline at end of file --- /project/cells/cvsroot/Celtk/lotsa-widgets.lisp 2006/05/13 14:36:58 1.1 +++ /project/cells/cvsroot/Celtk/lotsa-widgets.lisp 2006/05/16 21:17:15 1.2 @@ -88,8 +88,7 @@ for n below 25 counting sym into symct collecting sym into syms - finally (trc "syms found !!!" symct) - (return syms))))) + finally (return syms))))) :list-item-factory (lambda (sym) (make-instance 'listbox-item :fm-parent *parent* @@ -161,7 +160,7 @@ (mk-popup-menubutton :id :font-face :initial-value (c? (second (^entry-values))) - :entry-values (c? (eko ("popup ff") (subseq (tk-eval-list "font families") 4 10)))) + :entry-values (c? (subseq (tk-eval-list "font families") 4 10)))

(mk-scale :id :font-size :md-value (c-in 14) --- /project/cells/cvsroot/Celtk/menu.lisp 2006/05/15 05:15:37 1.13 +++ /project/cells/cvsroot/Celtk/menu.lisp 2006/05/16 21:17:15 1.14 @@ -63,11 +63,11 @@ `(mk-menu :kids (c? (the-kids ,@submenus))))

(defmethod make-tk-instance :after ((self menu)) - (trc "make-tk-instance > traversing menu" self) + (trc nil "make-tk-instance > traversing menu" self) (fm-menu-traverse self (lambda (entry &aux (menu self)) (assert (typep entry 'menu-entry)) - (trc "make-tk-instance visiting menu entry" (path menu) entry) + (trc nil "make-tk-instance visiting menu entry" (path menu) entry) (tk-format `(:post-make-tk ,self) "~(~a~) add ~(~a~) ~{~(~a~) ~a~^ ~}" (path menu) (tk-class entry) @@ -273,11 +273,9 @@ :kids (c? (the-kids ;; don't worry, this flattens (loop for v in (entry-values .parent) collecting - (progn - (trc "popup-menubutton entry label" v (down$ v)) - (mk-menu-entry-radiobutton + (mk-menu-entry-radiobutton :label (down$ v) - :value v)))))))))) + :value v)))))))))

(defobserver initial-value ((self popup-menubutton)) (when new-value --- /project/cells/cvsroot/Celtk/multichoice.lisp 2006/05/16 02:52:22 1.6 +++ /project/cells/cvsroot/Celtk/multichoice.lisp 2006/05/16 21:17:15 1.7 @@ -46,7 +46,7 @@ :yscrollcommand (c-in nil) :command (c? (format nil "event generate ~a <<do-on-command>> -data" (^path))) :on-command (lambda (self value) - (trc "hi scale" self value) + ;; (trc "hi scale" self value) (setf (^md-value) value))))

(defmethod make-tk-instance :after ((self scale)) --- /project/cells/cvsroot/Celtk/tk-interp.lisp 2006/05/16 02:52:22 1.8 +++ /project/cells/cvsroot/Celtk/tk-interp.lisp 2006/05/16 21:17:15 1.9 @@ -100,7 +100,7 @@ (Tcl_Init interp) (Tk_Init interp)

- (format t "~%*** Tk_AppInit has been called.~%") + ;;(format t "~%*** Tk_AppInit has been called.~%")

;; Return OK (foreign-enum-value 'tcl-retcode-values :tcl-ok)) --- /project/cells/cvsroot/Celtk/widget.lisp 2006/05/16 02:52:22 1.6 +++ /project/cells/cvsroot/Celtk/widget.lisp 2006/05/16 21:17:15 1.7 @@ -73,13 +73,13 @@ (defobserver event-handler () (when new-value ;; \\ work out how to unregister any old value (with-integrity (:client `(:post-make-tk ,self)) - (trc "creating event handler for" self) + (trc nil "creating event handler for" self) (tk-create-event-handler-ex self 'widget-event-handler -1)))) ;; // make this -1 more efficient

(defun tk-create-event-handler-ex (widget callback-name &rest masks) (let ((self-tkwin (widget-to-tkwin widget))) (assert (plusp self-tkwin)) - (trc "setting up widget virtual-event handler" widget :tkwin self-tkwin) + (trc nil "setting up widget virtual-event handler" widget :tkwin self-tkwin) (tk-create-event-handler self-tkwin (apply 'foreign-masks-combine 'tk-event-mask masks) (get-callback callback-name)