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

Modified Files: CELTK.lpr Celtk.lisp demos.lisp entry.lisp ltktest-ci.lisp run.lisp tk-interp.lisp Log Message:

--- /project/cells/cvsroot/Celtk/CELTK.lpr 2006/05/12 08:30:13 1.9 +++ /project/cells/cvsroot/Celtk/CELTK.lpr 2006/05/13 13:26:42 1.10 @@ -8,6 +8,7 @@ :modules (list (make-instance 'module :name "Celtk.lisp") (make-instance 'module :name "tk-interp.lisp") (make-instance 'module :name "tk-object.lisp") + (make-instance 'module :name "tk-events.lisp") (make-instance 'module :name "widget.lisp") (make-instance 'module :name "font.lisp") (make-instance 'module :name "layout.lisp") --- /project/cells/cvsroot/Celtk/Celtk.lisp 2006/05/12 08:30:13 1.18 +++ /project/cells/cvsroot/Celtk/Celtk.lisp 2006/05/13 13:26:43 1.19 @@ -24,6 +24,7 @@ (:nicknames "CTK") (:use :common-lisp :utils-kt :cells :cffi) (:export + #:<1> #:title$ #:pop-up #:event-root-x #:event-root-y #:window #:panedwindow #:mk-row #:c?pack-self #:mk-stack #:mk-text-widget #:text-widget #:mk-panedwindow @@ -127,7 +128,7 @@ ; ; --- debug stuff --- ; - (let ((yes '( )) + (let ((yes '("bind" "entry")) (no '("tk-events")))

(declare (ignorable yes no)) @@ -135,7 +136,7 @@ (break "Hey, fix this.") (replace tk$ "{Alt Q}" :start1 st))

- (when nil #+not (and (or (null yes) (find-if (lambda (s) (search s tk$)) yes)) + (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$)))

@@ -144,7 +145,7 @@ ; --- serious stuff --- ; (setf *tk-last* tk$) - (eval-script *tki* tk$)) + (tcl-eval-ex *tki* tk$))

(defun tk-format (defer-info fmt$ &rest fmt-args) "Format then send to wish (via user queue)" --- /project/cells/cvsroot/Celtk/demos.lisp 2006/05/12 08:30:14 1.12 +++ /project/cells/cvsroot/Celtk/demos.lisp 2006/05/13 13:26:43 1.13 @@ -24,21 +24,13 @@ (in-package :celtk-user)

(defun ctk::tk-test () ;; ACL project manager needs a zero-argument function, in project package - #+test (dolist (dll (ff:list-all-foreign-libraries)) - (when (find-if (lambda (lib) - (search lib (pathname-name dll))) '("ftgl" "tcl" "tk")) - (print `(unloading foreign library ,dll)) - (ff:unload-foreign-library dll))) - ;(cffi:use-foreign-library ctk::tcl) - ;(cffi:use-foreign-library ctk::tk) - ;(cffi:use-foreign-library ctk::togl) (test-window - ;;'one-button - 'ltktest-cells-inside - ;;'menu-button-test - ;;'spinbox-test - ;; 'lotsa-widgets - ;;'gears-demo + ;; dont try this one, it is deliberately dysfunctional 'one-button + ;; OK 'ltktest-cells-inside + ;; OK 'menu-button-test + ;; OK 'spinbox-test + 'lotsa-widgets + ;; Now in Gears project 'gears-demo ))

(defmodel one-button (window) @@ -72,6 +64,10 @@ :width 25) (make-instance 'button :fm-parent *parent* + :text "<<kenny>>" + :command "event generate . <<kenny>> -data "Hi mom"") + (make-instance 'button + :fm-parent *parent* :text "time now?" :on-command (c? (lambda (self) (trc "we got callbacks" self)))) --- /project/cells/cvsroot/Celtk/entry.lisp 2006/05/12 08:30:14 1.4 +++ /project/cells/cvsroot/Celtk/entry.lisp 2006/05/13 13:26:43 1.5 @@ -84,12 +84,26 @@ :xscrollcommand (c-in nil) :yscrollcommand (c-in nil) :modified (c-in nil) - :bindings (c? (list (list '|<<Modified>>| + :borderwidth (c? (if (^modified) 8 2)) + :bindings nil #+not (c? (list (list '|<<Modified>>| (lambda (self event &rest args) (eko ("<<Modified>> !!TK value for text-widget" self event args) - (setf (^modified) t)))))))) + nil #+not (setf (^modified) t))))))))

+ +(defcallback entry-modified-handler :void ((self-tkwin :int)(XEvent :pointer)) + (trc "yowza entry-modified-handler" self-tkwin XEvent (mem-aref XEvent :int) + (TK-EVENT-TYPE (mem-aref XEvent :int)))) + +(defmethod make-tk-instance :after ((self text-widget)) + (with-integrity(:client `(:post-make-tk ,self)) + ;;(tk-format-now "bind ~a <<Modified>> {set bxbxbxbx}" (^path)) ;; {event generate ~:*~a <<yowza>>}" (^path)) + (let ((self-tkwin (widget-to-tkwin self))) + (assert (plusp self-tkwin)) + (trc "setting up text-widget virtual-event handler" self :tkwin self-tkwin) + (tk-create-event-handler self-tkwin (expt 2 30) (callback entry-modified-handler) self-tkwin)))) + ;;;(defvar +tk-keysym-table+ ;;; (let ((ht (make-hash-table :test 'string=))) ;;; (with-open-file (ksyms "/0dev/math-paper/tk-keysym.dat" :direction :input) --- /project/cells/cvsroot/Celtk/ltktest-ci.lisp 2006/05/12 08:30:14 1.2 +++ /project/cells/cvsroot/Celtk/ltktest-ci.lisp 2006/05/13 13:26:43 1.3 @@ -328,7 +328,7 @@ ; appended. ; :bindings (c? (list - (list '(|<1>| "%X %Y") + (list '(<1> "%X %Y") (lambda (self event root-x root-y) (declare (ignorable event root-x root-y))

--- /project/cells/cvsroot/Celtk/run.lisp 2006/05/12 08:30:14 1.7 +++ /project/cells/cvsroot/Celtk/run.lisp 2006/05/13 13:26:43 1.8 @@ -44,13 +44,14 @@ ;; not recommended by Tcl doc (tcl-do-when-idle (get-callback 'tcl-idle-proc) 42) (tk-app-init *tki*) (tk-togl-init *tki*) - (tk-format-now "proc TraceOP {n1 n2 op} {call-back-event $n1 $op}") (tk-format-now "set tk-events {}") + (tk-format-now "event add <<kenny>> <Meta-Alt-Control-X><Control-S>") (tk-format-now "proc call-back {w args} {global tk-events; lappend tk-events [concat do-on-command \"$w\" $args]}") (tk-format-now "proc call-back-event {w e args} {global tk-events; lappend tk-events [concat do-on-event \"$w\" \"$e\" $args]}") ;; (tk-format-now "bind . <Escape> {call-back-event %W :type <Escape> :time %t}") - + (tk-create-event-handler (tk-main-window *tki*) (expt 2 30) (callback tk-event-proc) 42) + (with-integrity () (setf *tkw* (make-instance root-class)))

@@ -88,7 +89,7 @@ do (tk-process-event e)))) (progn (trc nil "tcl-do-one-event-loop sees no events" (get-internal-real-time)) - (sleep *event-loop-delay*))))) + #+nah (sleep *event-loop-delay*)))))

(defun tk-process-event (event) (trc nil "tk-process-event >" event *package*) --- /project/cells/cvsroot/Celtk/tk-interp.lisp 2006/05/12 08:30:14 1.5 +++ /project/cells/cvsroot/Celtk/tk-interp.lisp 2006/05/13 13:26:43 1.6 @@ -29,10 +29,10 @@

(define-foreign-library Tcl (:darwin (:framework "Tcl")) - (:windows (:or "/tcl/bin/Tcl84.dll"))) + (:windows (:or "/tcl/bin/Tcl85.dll"))) (define-foreign-library Tk (:darwin (:framework "Tk")) - (:windows (:or "/tcl/bin/tk84.dll"))) + (:windows (:or "/tcl/bin/tk85.dll")))

;; Togl (define-foreign-library Togl @@ -47,7 +47,7 @@

(defmethod translate-from-foreign (value (type (eql 'tcl-retcode))) (unless (eq value (foreign-enum-value 'tcl-retcode-values :tcl-ok)) - (error "*** Tcl error !")) + (error "Tcl error: ~a" (tcl-get-string-result *tki*))) value)

;; --- initialization ---------------------------------------- @@ -129,44 +129,31 @@ (with-foreign-string (filename-cstr filename) (%Tcl_EvalFile interp filename-cstr)))

-;; Tcl_Eval +(defcfun ("Tcl_Eval" tcl-eval) tcl-retcode + (interp :pointer) + (script-cstr :string))

-(defcfun ("Tcl_Eval" %Tcl_Eval) tcl-retcode +(defcfun ("Tcl_EvalEx" tcl_evalex) tcl-retcode (interp :pointer) - (script-cstr :pointer)) + (script-cstr :string) + (num-bytes :int) + (flags :int)) + +(defun tcl-eval-ex (i s) + (tcl_evalex i s -1 0))

(defcfun ("Tcl_GetStringResult" tcl-get-string-result) :string (interp :pointer))

(defcfun ("Tk_GetNumMainWindows" tk-get-num-main-windows) :int) +(defcfun ("Tk_MainWindow" tk-main-window) :pointer (interp :pointer)) +(defcfun ("Tk_NameToWindow" tk-name-to-window) :pointer + (interp :pointer) + (pathName :string) + (related-tkwin :pointer))

-(defun Tcl_Eval (interp script) - (with-foreign-string (script-cstr script) - (%Tcl_Eval interp script-cstr))) - -(defcenum tcl-event-flag-values - (:tcl-dont-wait 2) - (:tcl-window-events 4) - (:tcl-file-events 8) - (:tcl-timer-events 16) - (:tcl-idle-events 32) - (:tcl-all-events -3)) - -(defcfun ("Tcl_DoOneEvent" Tcl_DoOneEvent) :int - (flags :int)) - -(defcfun ("Tcl_DoWhenIdle" tcl-do-when-idle) :void - (tcl-idle-proc :pointer) - (client-data :int)) - -(defcallback tcl-idle-proc :void ((client-data :int)) - (unless (c-stopped) - (print (list :idle-proc :client-data client-data)))) - -;; Tk_MainLoop - -(defcfun ("Tk_MainLoop" Tk_MainLoop) :void) - +(defun widget-to-tkwin (self) + (tk-name-to-window *tki* (^path) (tk-main-window *tki*)))

;;; --- Togl (Version 1.7 and above needed!) -----------------------------

@@ -257,7 +244,7 @@ (assert interp) (assert script)

- (Tcl_Eval interp script)) + (tcl-eval interp script))

#+testing (defun exec-button ()