[cells-cvs] CVS Celtk
ktilton
ktilton at common-lisp.net
Tue May 16 21:17:16 UTC 2006
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;a=summary
+;;
+;;; 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 , at 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)
More information about the Cells-cvs
mailing list