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

Modified Files: CELTK.lpr Celtk.asd Celtk.lisp demos.lisp font.lisp item-pictorial.lisp layout.lisp load.lisp lotsa-widgets.lisp ltktest-ci.lisp multichoice.lisp run.lisp scroll.lisp tk-interp.lisp tk-object.lisp tk-structs.lisp widget.lisp Log Message: Resurrect under Lispworks

--- /project/cells/cvsroot/Celtk/CELTK.lpr 2006/06/03 12:12:19 1.15 +++ /project/cells/cvsroot/Celtk/CELTK.lpr 2006/06/07 22:13:41 1.16 @@ -11,8 +11,8 @@ (make-instance 'module :name "tk-events.lisp") (make-instance 'module :name "tk-object.lisp") (make-instance 'module :name "widget.lisp") - (make-instance 'module :name "font.lisp") (make-instance 'module :name "layout.lisp") + (make-instance 'module :name "font.lisp") (make-instance 'module :name "timer.lisp") (make-instance 'module :name "menu.lisp") (make-instance 'module :name "label.lisp") @@ -35,7 +35,9 @@ :projects (list (make-instance 'project-module :name "..\cells\cells") (make-instance 'project-module :name - "C:\1-devtools\cffi\cffi")) + "C:\1-devtools\cffi\cffi") + (make-instance 'project-module :name + "..\Cells\gui-geometry\gui-geometry")) :libraries nil :distributed-files nil :internally-loaded-files nil --- /project/cells/cvsroot/Celtk/Celtk.asd 2006/05/26 17:50:36 1.9 +++ /project/cells/cvsroot/Celtk/Celtk.asd 2006/06/07 22:13:41 1.10 @@ -12,7 +12,7 @@ :licence "Lisp LGPL" :description "Tcl/Tk with Cells Inside(tm)" :long-description "A Cells-driven portable GUI, ultimately implmented by Tcl/Tk" - :depends-on (:cells :cffi) + :depends-on (:cells :cffi :gui-geometry) :serial t :components ((:file "Celtk") (:file "tk-structs") @@ -20,8 +20,8 @@ (:file "tk-events") (:file "tk-object") (:file "widget") - (:file "font") (:file "layout") + (:file "font") (:file "timer") (:file "menu") (:file "label") @@ -35,9 +35,9 @@ (:file "item-shaped") (:file "composites") (:file "frame") + (:file "fileevent") (:file "togl") (:file "run") - (:file "fileevent") - (:file "ltktest-ci") + (:file "ltktest-ci") (:file "lotsa-widgets") (:file "demos"))) --- /project/cells/cvsroot/Celtk/Celtk.lisp 2006/06/03 12:04:37 1.29 +++ /project/cells/cvsroot/Celtk/Celtk.lisp 2006/06/07 22:13:41 1.30 @@ -16,14 +16,14 @@

|#

-;;; $Header: /project/cells/cvsroot/Celtk/Celtk.lisp,v 1.29 2006/06/03 12:04:37 ktilton Exp $ +;;; $Header: /project/cells/cvsroot/Celtk/Celtk.lisp,v 1.30 2006/06/07 22:13:41 ktilton Exp $

(defpackage :celtk (:nicknames "CTK") (:use :common-lisp :utils-kt :cells :cffi) (:export - #:<1> #:tk-event-type #:xsv #:name #:x-root #:y-root - #:title$ #:pop-up + #:<1> #:tk-event-type #:xsv #:name #:x #:y #:x-root #:y-root + #:title$ #:pop-up #:path #:parent-path #:^keyboard-modifiers #:keyboard-modifiers #:window #:panedwindow #:mk-row #:c?pack-self #:mk-stack #:mk-text-widget #:text-widget #:mk-panedwindow #:mk-stack #:mk-radiobutton #:mk-radiobutton-ex #:mk-radiobutton #:mk-label @@ -62,7 +62,6 @@

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

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

(defconstant +tk-client-task-priority+ @@ -133,11 +132,12 @@ ; --- debug stuff --------------------------------- ;

- (let ((yes '( "photo")) - (no '())) + (let ((yes '()) + (no '("font"))) (declare (ignorable yes no)) - (when (and (find-if (lambda (s) (search s tk$)) yes) - (not (find-if (lambda (s) (search s tk$)) no))) + (when (and (or ;; (null yes) + (find-if (lambda (s) (search s tk$)) yes)) + (not (find-if (lambda (s) (search s tk$)) no))) (format t "~&tk> ~a~%" tk$))) (assert *tki*)

@@ -194,7 +194,8 @@ (format nil "{~{~a~^ ~}}" (mapcar 'tk-send-value values)))

(defmethod parent-path ((nada null)) "") -(defmethod parent-path ((self t)) (path self)) +(defmethod parent-path ((other t)) "") +

; --- tk eval ----------------------------------------------------

@@ -213,6 +214,9 @@ (tk-format :grouped (apply 'format nil tk-form$ fmt-args)) (parse-tcl-list-result (tcl-get-string-result *tki*)))

+#+test +(parse-tcl-list-result "-ascent 58 -descent 15 -linespace 73 -fixed 0") + (defun parse-tcl-list-result (result &aux item items) (when (plusp (length result)) (trc nil "parse-tcl-list-result" result) @@ -239,5 +243,6 @@ else do (gather-item) (setf item nil) else do (push ch item) - finally (return (nreverse items)))))) + finally (gather-item) + (return (nreverse items))))))

\ No newline at end of file --- /project/cells/cvsroot/Celtk/demos.lisp 2006/06/03 12:04:37 1.21 +++ /project/cells/cvsroot/Celtk/demos.lisp 2006/06/07 22:13:41 1.22 @@ -18,10 +18,11 @@

(in-package :celtk-user)

+ (defun ctk::tk-test () ;; ACL project manager needs a zero-argument function, in project package (test-window ;;'place-test - ;;'one-button-window + ;; 'one-button-window ;;'ltktest-cells-inside ;;'menu-button-test ;;'spinbox-test @@ -34,14 +35,14 @@ (:default-initargs :kids (c? (the-kids (mk-label :text "hi, Mom" - :x 100 - :y 20))))) + :px 100 + :py 20)))))

(defmodel one-button-window (window) () (:default-initargs :kids (c? (the-kids - (mk-menubar + #+shhhh (mk-menubar :kids (c? (the-kids (mk-menu-entry-cascade-ex (:label "File") (mk-menu-entry-command-ex () "Load" (format t "~&Load pressed")) --- /project/cells/cvsroot/Celtk/font.lisp 2006/05/24 20:38:54 1.4 +++ /project/cells/cvsroot/Celtk/font.lisp 2006/06/07 22:13:41 1.5 @@ -22,7 +22,7 @@

(eval-when (compile load eval) (export '(make-tkfinfo tkfinfo-family tkfinfo-size tkfinfo-slant tkfinfo-ascent tkfinfo-linespace tkfinfo-fixed - tkfont-id tkfont-info bounds-offset tkfinfo-ascent tkfont-height tkfont-ascent + tkfont-id tkfont-info tkfinfo-ascent tkfont-height tkfont-ascent tkfinfo-descent ^tkfont-descent ^tkfont-find tkfinfo tkfinfo-em ^tkfont-em line-up line-down tkfont-size-info))) --- /project/cells/cvsroot/Celtk/item-pictorial.lisp 2006/05/24 20:38:54 1.2 +++ /project/cells/cvsroot/Celtk/item-pictorial.lisp 2006/06/07 22:13:41 1.3 @@ -34,7 +34,7 @@ -disabledforeground))

-(deftk image (item) +(deftk image-item (item) () (:tk-spec image -state --- /project/cells/cvsroot/Celtk/layout.lisp 2006/05/24 20:38:54 1.2 +++ /project/cells/cvsroot/Celtk/layout.lisp 2006/06/07 22:13:41 1.3 @@ -27,7 +27,7 @@ This parent is ~a, kids-packing ~a" self (list .parent (type-of .parent)) (kids-packing .parent))) ; ; This use next of the parent instead of self is pretty tricky. It has to do with getting - ; the pack commands out nested widgets before parents. The pack command issued on behalf + ; the pack commands out with nested widgets pacing before parents. The pack command issued on behalf ; of a top frame is sorted on the parent. Now we have to pack the top frame. If we associate ; the command with the frame, the sort is a tie and either might go first. So we continue ; the theme and associate /this/ pack with this top frame's parent. Note that we cannot go the @@ -59,80 +59,3 @@ (loop for config in rows for idx upfrom 0 do (tk-format `(:grid ,self) (format nil "grid rowconfigure ~a ~a ~a" (^path) idx config))))))) - -;;; --- Layout ------------ - -(eval-when (compile load eval) - (export '( b-left b-top b-right b-bottom b-width b-height - l-bounds l-left l-top l-right l-left l-top l-right l-bottom l-width l-height - p-offset ^p-offset p-bounds ^p-bounds p-left p-top p-right p-bottom - make-bounds p-center-vt b-center-vt p-center-hz - c-offset c-bounds offset+))) - -(defun bounds-offset (b x-y) - (destructuring-bind (x y) x-y - (vector (+ (svref b 0) x) - (+ (svref b 1) y) - (+ (svref b 2) x) - (+ (svref b 3) y)))) - -(defun c-offset (self) - (assert (typep self 'item-geometer)() "~a is not typep item-geomete. Type is ~a" self (type-of self)) - (if (or (null .parent) (typep .parent 'canvas)) - (eko (nil "c-offset at top" self (type-of self) .parent) - (progn - (unless .parent (break "no parent for ~a?!" self)) - #+not (when (and (null .parent)(typep self 'mathx::mx-theq)) - (break)) - (^p-offset))) - (offset+ (p-offset self) (c-offset .parent)))) - -(defun c-bounds (self) ;; make this a slot? - (assert (typep self 'item)) - (bounds-offset (l-bounds self) (c-offset self))) - -(defmacro b-left (b) `(svref ,b 0)) -(defmacro b-top (b) `(svref ,b 1)) -(defmacro b-right (b) `(svref ,b 2)) -(defmacro b-bottom (b) `(svref ,b 3)) -(defun b-width (b) (- (b-right b) (b-left b))) -(defun b-height (b) (- (b-bottom b) (b-top b))) - -(defmacro l-left (mx) `(b-left (l-bounds ,mx))) -(defmacro l-top (mx) `(b-top (l-bounds ,mx))) -(defmacro l-right (mx) `(b-right (l-bounds ,mx))) -(defmacro l-bottom (mx) `(b-bottom (l-bounds ,mx))) -(defun l-center-vt (self) - (floor (+ (l-top self)(l-bottom self)) 2)) - -(defun l-width (mx) (b-width (l-bounds mx))) -(defun l-height (mx) (b-height (l-bounds mx))) - -(defmacro p-left (mx) `(b-left (p-bounds ,mx))) -(defmacro p-top (mx) `(b-top (p-bounds ,mx))) -(defmacro p-right (mx) `(b-right (p-bounds ,mx))) -(defmacro p-bottom (mx) `(b-bottom (p-bounds ,mx))) - -(defun make-bounds (left top right bottom) - (vector left top right bottom)) - -(defun p-center-vt (self) - (b-center-vt (p-bounds self))) - -(defun b-center-vt (b) - (floor (+ (b-bottom b)(b-top b)) 2)) - -(defun p-center-hz (self) - (b-center-hz (p-bounds self))) - -(defun b-center-hz (b) - (floor (+ (b-left b)(b-right b)) 2)) - -(defun offset+ (off1 off2) - (mapcar '+ off1 off2)) - - - - - - --- /project/cells/cvsroot/Celtk/load.lisp 2006/05/26 17:50:36 1.8 +++ /project/cells/cvsroot/Celtk/load.lisp 2006/06/07 22:13:41 1.9 @@ -1,25 +1,34 @@ ;;; ;;; -;;; First, grab these: +;;; 1. 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. +;;; 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: +;;; 2. Get ASDF loaded. From http://www.cliki.net/asdf we learn: +;;; +;;; "If you have SBCL, OpenMCL, ECL or ACL, it's bundled and you need only (require 'asdf). +;;; If you have Debian or Gentoo and the Common Lisp Controller installed, you also +;;; already have it. Otherwise you can find it in the Sourceforge cCLan CVS repository: +;;; +;;; http://cclan.cvs.sourceforge.net/cclan/asdf/ " +;;; +;;; 3. If the automatic options in step 2 could not be used, adjust the path and evaluate + +#+adjust-pathname-first!

-#+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: +;;; 4. Only after you have gotten ASDF loaded, you can tell ASDF +;;; where you put everything by adjusting these paths and evaluating:

(progn (push (make-pathname #+lispworks :host #-lispworks :device "c" @@ -27,14 +36,21 @@ asdf:*central-registry*)

(push (make-pathname #+lispworks :host #-lispworks :device "c" - :directory '(:absolute "1-devtools" "cffi")) + :directory '(:absolute "1-devtools" "cffi-060606")) asdf:*central-registry*)

(push (make-pathname #+lispworks :host #-lispworks :device "c" :directory '(:absolute "0dev" "Celtk")) asdf:*central-registry*))

-;;; and now you can try building the whole mess: +;;; 5. Track down all the define-foreign-library calls in the source +;;; and fix the pathnames to point to your shared libraries. Recently these were: +;;; +;;; In tk-interp.lisp, Tcl and Tk d-f-ls. + +;;; 6. Now you can try building the whole mess. Warning: I use ":serial t" to work around +;;; silly ASDF default behavior, so if you start fiddling with the code you may not want +;;; to use ASDF to build (or comment out the :serial option until the next session):

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

@@ -42,16 +58,30 @@

(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. - -;;; To see the OpenGL Gears demo: +;;; To see the OpenGL Gears demo, some heavy lifting is required. +;;; +;;; 1. Get, install, and test Togl. Here is a Web link: +;;; +;;; http://www.mesa3d.org/brianp/sig97/togl.htm +;;; +;;; If you are on win32 and have trouble, send an email to the list and I will send you a DLL +;;; +;;; 2. You already grabbed cl-opengl from the location shown above. Now: +;;;

+#+adjust-pathname-and-evaluate (push (make-pathname #+lispworks :host #-lispworks :device "c" - :directory '(:absolute "1-devtools" "cl-opengl")) - asdf:*central-registry*) + :directory '(:absolute "1-devtools" "cl-opengl")) + asdf:*central-registry*) + +;;; +;;; 3. Adjust the pathname again in togl.lisp, in the define-foreign-library for Togl. +;;; +;;; 4. Build:

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

+;;; 5. Test: + #+test (gears::gears) --- /project/cells/cvsroot/Celtk/lotsa-widgets.lisp 2006/05/24 20:38:54 1.3 +++ /project/cells/cvsroot/Celtk/lotsa-widgets.lisp 2006/06/07 22:13:41 1.4 @@ -16,6 +16,7 @@

|#

+ (in-package :celtk-user)

(defmodel lotsa-widgets (window) --- /project/cells/cvsroot/Celtk/ltktest-ci.lisp 2006/05/25 07:12:59 1.7 +++ /project/cells/cvsroot/Celtk/ltktest-ci.lisp 2006/06/07 22:13:41 1.8 @@ -82,7 +82,7 @@ ; at just the right time in the larger scheme of state propagation one needs for ; data integrity. What is that scheme? ; - ; Data integrity: when the overall Cells data model gets perturbed by imperative code -- typically an + ; Data integrity: when the overall Cells data model gets perturbed by imperative code -- typically in an ; event loop -- executing a SETF of some datapoint X, we want these requirements met: ; ; - recompute all and (for efficiency) only state computed off X (directly or indirectly through some intermediate datapoint); @@ -119,6 +119,7 @@ ; which operates on the outside world via observers (on-change callbacks) triggered ; automatically by the Cells engine. See DEFOBSERVER.

+ (defmodel ltktest-cells-inside (window) ()

--- /project/cells/cvsroot/Celtk/multichoice.lisp 2006/05/24 20:38:54 1.9 +++ /project/cells/cvsroot/Celtk/multichoice.lisp 2006/06/07 22:13:41 1.10 @@ -65,6 +65,7 @@ :event-handler (lambda (self xe) (case (tk-event-type (xsv type xe)) (:virtualevent + (trc ":virtualevent" (xsv name xe)) (case (read-from-string (string-upcase (xsv name xe))) (ListboxSelect (let ((selection (parse-integer (tk-eval "~a curselection" (^path))))) --- /project/cells/cvsroot/Celtk/run.lisp 2006/06/03 12:04:37 1.15 +++ /project/cells/cvsroot/Celtk/run.lisp 2006/06/07 22:13:41 1.16 @@ -153,9 +153,8 @@ (^on-name (read-from-string (format nil "^ON-~a" name)))) `(progn (defmethod ,do-on-name (self &rest args) - (bIf (cmd (,^on-name)) - (apply cmd self args) - (format t "~&Warning: Target widget ~a has no ~a to run" self ',do-on-name)) + (bwhen (cmd (,^on-name)) + (apply cmd self args)) 0)

(defcallback ,do-on-name :int ((client-data :pointer)(interp :pointer)(argc :int)(argv :pointer)) @@ -176,16 +175,3 @@ (defcommand key-up) (defcommand key-down)

-;;;(defcallback do-on-command :int ((client-data :pointer)(interp :pointer)(argc :int)(argv :pointer)) -;;; (declare (ignore client-data)) -;;; (let ((*tki* interp) -;;; (args (loop for argn upfrom 1 below argc -;;; collecting (mem-aref argv :string argn)))) -;;; (bif (self (gethash (car args) (dictionary *tkw*))) -;;; (apply 'do-on-command self (rest args)) -;;; (progn -;;; (break "do-on-command> Target widget ~a does not exist" path) -;;; #+anyvalue? (tcl-set-result interp -;;; (format nil "do-on-command> Target widget ~a does not exist" path) -;;; (null-pointer)) -;;; 1))))) \ No newline at end of file --- /project/cells/cvsroot/Celtk/scroll.lisp 2006/05/24 20:38:54 1.3 +++ /project/cells/cvsroot/Celtk/scroll.lisp 2006/06/07 22:13:41 1.4 @@ -21,7 +21,6 @@

; --- scroll bars ----------------------------------------

- (deftk scrollbar (widget) () (:tk-spec scrollbar --- /project/cells/cvsroot/Celtk/tk-interp.lisp 2006/06/03 12:04:37 1.14 +++ /project/cells/cvsroot/Celtk/tk-interp.lisp 2006/06/07 22:13:41 1.15 @@ -33,7 +33,6 @@ (:unix "libtk.so") (t (:default "libtk")))

- (defctype tcl-retcode :int)

(defcenum tcl-retcode-values --- /project/cells/cvsroot/Celtk/tk-object.lisp 2006/06/03 12:04:37 1.5 +++ /project/cells/cvsroot/Celtk/tk-object.lisp 2006/06/07 22:13:41 1.6 @@ -35,6 +35,8 @@ (defmethod md-awaken :before ((self tk-object)) (make-tk-instance self))

+(defmethod parent-path ((self tk-object)) (path self)) + ;;; --- deftk --------------------

(defmacro deftk (class superclasses --- /project/cells/cvsroot/Celtk/tk-structs.lisp 2006/06/03 12:04:37 1.5 +++ /project/cells/cvsroot/Celtk/tk-structs.lisp 2006/06/07 22:13:41 1.6 @@ -120,6 +120,8 @@ (defmacro xsv (slot-name xptr) `(foreign-slot-value ,xptr 'X-Virtual-Event ',slot-name))

+(defun myx (xe) + (xsv x xe)) (defmacro xke (slot-name xptr) `(foreign-slot-value ,xptr 'x-key-event ',slot-name))

--- /project/cells/cvsroot/Celtk/widget.lisp 2006/06/03 12:04:37 1.12 +++ /project/cells/cvsroot/Celtk/widget.lisp 2006/06/07 22:13:41 1.13 @@ -55,8 +55,8 @@ (xwin :cell nil :accessor xwin :initform nil) (packing :reader packing :initarg :packing :initform nil) (gridding :reader gridding :initarg :gridding :initform nil) - (x :reader x :initarg :x :initform nil) - (y :reader y :initarg :y :initform nil) + (px :reader px :initarg :px :initform nil) + (py :reader py :initarg :py :initform nil) (relx :reader relx :initarg :relx :initform nil) (rely :reader rely :initarg :rely :initform nil) (enabled :reader enabled :initarg :enabled :initform t) @@ -71,6 +71,9 @@ :event-handler nil #+debug (lambda (self xe) (TRC "widget-event-handler" self (tk-event-type (xsv type xe))))))

+(eval-when (compile load eval) + (export '())) + (defun tk-create-event-handler-ex (widget callback-name &rest masks) (let ((self-tkwin (widget-to-tkwin widget))) (assert (not (null-pointer-p self-tkwin))) @@ -113,11 +116,11 @@ ;;; "place ~a ~a -relx ~a -rely ~a" (if old-value "configure" "") ;;; (^path) new-value (^rely))))

-(defobserver x ((self widget)) +(defobserver px ((self widget)) (when new-value (tk-format `(:grid ,self) "place ~a ~a -x ~a -y ~a" (if old-value "configure" "") - (^path) new-value (^y)))) + (^path) new-value (^py))))

(defcallback widget-event-handler-callback :void ((client-data :pointer)(xe :pointer)) (let ((self (tkwin-widget client-data))) @@ -159,6 +162,8 @@ decorations ^decorations)))

(defmodel item-geometer () ;; mix-in + () + #+vestigial? ((canvas-offset :initarg :canvas-offset :accessor canvas-offset :initform (c_? (eko (nil "standard canvas offset" self (type-of self) (^p-offset)) (c-offset self)))) @@ -184,7 +189,7 @@ (coords-tweak :initarg :coords-tweak :initform '(0 0) :accessor coords-tweak :documentation "Text items need this to get positioned according to baseline") (coords :initarg :coords :accessor coords - :initform (c_? (eko (nil "final coords" self (anchor self)(^l-coords)(^canvas-offset)(^coords-tweak)) + :initform nil #+old (c_? (eko (nil "final coords" self (anchor self)(^l-coords)(^canvas-offset)(^coords-tweak)) (loop for coord-xy = (^l-coords) then (cddr coord-xy) while coord-xy nconcing (mapcar '+ coord-xy (^canvas-offset) (^coords-tweak))))))