[cells-cvs] CVS Celtk
ktilton
ktilton at common-lisp.net
Wed Jun 7 22:13:41 UTC 2006
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;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.
+;;; 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))))))
More information about the Cells-cvs
mailing list