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

Modified Files: Celtk.asd load.lisp run.lisp tk-interp.lisp togl.lisp Log Message: Gears demo at last

--- /project/cells/cvsroot/Celtk/Celtk.asd 2006/05/25 14:25:02 1.8 +++ /project/cells/cvsroot/Celtk/Celtk.asd 2006/05/26 17:50:36 1.9 @@ -9,10 +9,10 @@ :author "Kenny Tilton kentilton@gmail.com" :version "2.0" :maintainer "Kenny Tilton kentilton@gmail.com" - :licence "MIT Style" + :licence "Lisp LGPL" :description "Tcl/Tk with Cells Inside(tm)" - :long-description "A Cells-driven portable GUI, ultimately implmented by Tk" - :depends-on (:cells :cl-opengl :cl-glu) + :long-description "A Cells-driven portable GUI, ultimately implmented by Tcl/Tk" + :depends-on (:cells :cffi) :serial t :components ((:file "Celtk") (:file "tk-structs") --- /project/cells/cvsroot/Celtk/load.lisp 2006/05/24 20:38:54 1.7 +++ /project/cells/cvsroot/Celtk/load.lisp 2006/05/26 17:50:36 1.8 @@ -31,16 +31,12 @@ asdf:*central-registry*)

(push (make-pathname #+lispworks :host #-lispworks :device "c" - :directory '(:absolute "1-devtools" "cl-opengl")) - 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:

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

;;; and test:

@@ -49,3 +45,13 @@ ;;; 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: + +(push (make-pathname #+lispworks :host #-lispworks :device "c" + :directory '(:absolute "1-devtools" "cl-opengl")) + asdf:*central-registry*) + +(ASDF:OOS 'ASDF:LOAD-OP :gears) + +#+test +(gears::gears) --- /project/cells/cvsroot/Celtk/run.lisp 2006/05/25 07:12:59 1.13 +++ /project/cells/cvsroot/Celtk/run.lisp 2006/05/26 17:50:36 1.14 @@ -39,7 +39,7 @@ (with-integrity () (setf *tkw* (make-instance root-class))

- (tk-create-event-handler-ex *tkw* 'main-window-proc :structureNotifyMask :virtualEventMask)) + (tk-create-event-handler-ex *tkw* 'main-window-proc -1 :structureNotifyMask :virtualEventMask))

(tk-format `(:fini) "wm deiconify .") (tk-format-now "bind . <Escape> {destroy .}") --- /project/cells/cvsroot/Celtk/tk-interp.lisp 2006/05/25 14:35:27 1.11 +++ /project/cells/cvsroot/Celtk/tk-interp.lisp 2006/05/26 17:50:36 1.12 @@ -19,31 +19,6 @@

(in-package :celtk)

-;;------------------------------------------------------------------------------ -;; GLOBAL VARS AND PARAMS -;;------------------------------------------------------------------------------ - - -;;------------------------------------------------------------------------------ -;; External LIBRARIES -;;------------------------------------------------------------------------------ - -#+FRANKG -(eval-when (:load-toplevel :compile-toplevel :execute) - #+asdf (progn - #-cffi (progn - (asdf:operate 'asdf:load-op :cffi) - (use-package :cffi)) - #-cl-opengl (progn - (asdf:operate 'asdf:load-op :cl-opengl) - (use-package :cl-opengl)) - #-cells (progn - (asdf:operate 'asdf:load-op :cells) - (use-package :cells)) - ) - ) - - ;; Tcl/Tk

(define-foreign-library Tcl @@ -57,19 +32,7 @@ (:windows (:or "/tcl/bin/tk85.dll")) (:unix "libtk.so") (t (:default "libtk"))) - -;; Togl -(define-foreign-library Togl - (:darwin (:or "/opt/tcltk/togl/lib/Togl1.7/libtogl1.7.dylib")) - (:windows (:or "/tcl/lib/togl/togl17.dll")) - (:unix "/usr/lib/Togl1.7/libTogl1.7.so")) - -;;; wait till Stu confirms (use-foreign-library Togl) - -;; Togl -(define-foreign-library Togl - (:darwin (:or "/opt/tcltk/togl/lib/Togl1.7/libtogl1.7.dylib")) - (:windows (:or "/tcl/lib/togl/togl17.dll"))) +

(defctype tcl-retcode :int)

@@ -84,44 +47,23 @@

;; --- initialization ----------------------------------------

-(defcfun ("Tcl_FindExecutable" %Tcl_FindExecutable) :void +(defcfun ("Tcl_FindExecutable" tcl-find-executable) :void (argv0 :string))

-(defun Tcl_FindExecutable () - (with-foreign-string (argv0-cstr (argv0)) - (%Tcl_FindExecutable argv0-cstr))) - -;; Tcl_Init - (defcfun ("Tcl_Init" Tcl_Init) tcl-retcode (interp :pointer))

-;; Tk_Init - (defcfun ("Tk_Init" Tk_Init) tcl-retcode (interp :pointer))

-;; Tcl_SetVal -(defcfun ("Tcl_GetVar" tcl-get-var) :string (interp :pointer)(varName :string)(flags :int)) - -(defcfun ("Tcl_SetVar" tcl-set-var) :string - (interp :pointer) - (var-name :string) - (new-value :string) - (flags :int)) - (defcallback Tk_AppInit tcl-retcode ((interp :pointer)) (tk-app-init interp)) - -;; Tcl_AppInit

(defun tk-app-init (interp) (Tcl_Init interp) (Tk_Init interp) - ;;(format t "~%*** Tk_AppInit has been called.~%") - ;; Return OK (foreign-enum-value 'tcl-retcode-values :tcl-ok))

@@ -146,7 +88,17 @@ (defcfun ("Tcl_DeleteInterp" tcl-delete-interp) :void (interp :pointer))

-;; Tcl_EvalFile +;;; --- windows ---------------------------------- + +(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)) + +;;; --- eval -----------------------------------------------

(defcfun ("Tcl_EvalFile" %Tcl_EvalFile) tcl-retcode (interp :pointer) @@ -169,16 +121,16 @@ (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 ("Tcl_GetVar" tcl-get-var) :string (interp :pointer)(varName :string)(flags :int))

-(defcfun ("Tk_NameToWindow" tk-name-to-window) :pointer +(defcfun ("Tcl_SetVar" tcl-set-var) :string (interp :pointer) - (pathName :string) - (related-tkwin :pointer)) + (var-name :string) + (new-value :string) + (flags :int)) + +(defcfun ("Tcl_GetStringResult" tcl-get-string-result) :string + (interp :pointer))

;; ---------------------------------------------------------------------------- ;; Tcl_CreateCommand - used to implement direct callbacks @@ -215,67 +167,6 @@ (channelName :string) (modePtr :pointer))

-;;; --- Togl (Version 1.7 and above needed!) ----------------------------- - - -(defcfun ("Togl_Init" Togl_Init) tcl-retcode - (interp :pointer)) - -(defcfun ("Togl_CreateFunc" Togl_CreateFunc) :void - (togl-callback-ptr :pointer)) - -(defcfun ("Togl_DisplayFunc" Togl_DisplayFunc) :void - (togl-callback-ptr :pointer)) - -(defcfun ("Togl_ReshapeFunc" Togl_ReshapeFunc) :void - (togl-callback-ptr :pointer)) - -(defcfun ("Togl_DestroyFunc" Togl_DestroyFunc) :void - (togl-callback-ptr :pointer)) - -(defcfun ("Togl_TimerFunc" Togl_TimerFunc) :void - (togl-callback-ptr :pointer)) - -(defcfun ("Togl_PostRedisplay" Togl_PostRedisplay) :void - (togl-struct-ptr :pointer)) - -(defcfun ("Togl_SwapBuffers" Togl_SwapBuffers) :void - (togl-struct-ptr :pointer)) - -(defcfun ("Togl_Ident" Togl-Ident) :string - (togl-struct-ptr :pointer)) - -(defcfun ("Togl_Width" Togl_Width) :int - (togl-struct-ptr :pointer)) - -(defcfun ("Togl_Height" Togl_Height) :int - (togl-struct-ptr :pointer)) - -(defcfun ("Togl_Interp" Togl_Interp) :pointer - (togl-struct-ptr :pointer)) - -;; Togl_AllocColor -;; Togl_FreeColor - -;; Togl_LoadBitmapFont -;; Togl_UnloadBitmapFont - -;; Togl_SetClientData -;; Togl_ClientData - -;; Togl_UseLayer -;; Togl_ShowOverlay -;; Togl_HideOverlay -;; Togl_PostOverlayRedisplay -;; Togl_OverlayDisplayFunc -;; Togl_ExistsOverlay -;; Togl_GetOverlayTransparentValue -;; Togl_IsMappedOverlay -;; Togl_AllocColorOverlay -;; Togl_FreeColorOverlay -;; Togl_DumpToEpsFile - - ;; Initialization mgmt - required to avoid multiple library loads

(defvar *initialized* nil) @@ -287,16 +178,16 @@ (setq *initialized* nil))

(defun argv0 () - #+allegro (sys:command-line-argument 0) - #+lispworks (nth 0 (io::io-get-command-line-arguments)) - #+sbcl (nth 0 sb-ext:*posix-argv*)) + #+allegro (sys:command-line-argument 0) + #+lispworks (nth 0 system:*line-arguments-list*) ;; portable to OS X + #+sbcl (nth 0 sb-ext:*posix-argv*))

(defun tk-interp-init-ensure () (unless *initialized* (use-foreign-library Tcl) (use-foreign-library Tk) (use-foreign-library Togl) - (Tcl_FindExecutable) + (tcl-find-executable (argv0)) (set-initialized)))

;; Send a script to a piven Tcl/Tk interpreter @@ -304,19 +195,5 @@ (defun eval-script (interp script) (assert interp) (assert script) - (tcl-eval interp script))

- - -;;; Togl stuff - -(defparameter *togl-initialized* nil - "Flag, t if Togl is considered initialized") - -;; Callbacks, global - -(defctype togl-struct-ptr-type :pointer) - - - --- /project/cells/cvsroot/Celtk/togl.lisp 2006/05/24 20:38:54 1.6 +++ /project/cells/cvsroot/Celtk/togl.lisp 2006/05/26 17:50:36 1.7 @@ -1,7 +1,7 @@ ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- #|

- Celtk -- Cells, Tcl, and Tk + Togl Bindings and Cells/Tk Interfaces

Copyright (C) 2006 by Kenneth Tilton

@@ -16,36 +16,74 @@

|#

- (in-package :celtk)

-;;;(defctype tcl-retcode :int) -;;; -;;;(defcenum tcl-retcode-values -;;; (:tcl-ok 0) -;;; (:tcl-error 1)) -;;; -;;;(defmethod translate-from-foreign (value (type (eql 'tcl-retcode))) -;;; (unless (eq value (foreign-enum-value 'tcl-retcode-values :tcl-ok)) -;;; (error "*** Tcl error !")) -;;; value) -;;; -;;;(define-foreign-library Tcl -;;; (:windows "/tcl/bin/Tcl84.dll") -;;; (:darwin (:framework "Tcl"))) -;;; -;;;(define-foreign-library Tk -;;; (:windows "/tcl/bin/Tk84.dll") -;;; (:darwin (:framework "Tk"))) -;;; -;;;(defcfun ("Tcl_InitStubs" tcl-init-stubs) :int -;;; (interp :pointer)(version :string)(math-version-exactly :int)) -;;; -;;;(defcfun ("Tk_InitStubs" tk-init-stubs) :int -;;; (interp :pointer)(version :string)(math-version-exactly :int)) -;;; -;;;(defcfun ("Togl_Init" togl-init) tcl-retcode -;;; (interp :pointer)) + +(define-foreign-library Togl + (:darwin (:or "/opt/tcltk/togl/lib/Togl1.7/libtogl1.7.dylib")) + (:windows (:or "/tcl/lib/togl/togl17.dll")) + (:unix "/usr/lib/Togl1.7/libTogl1.7.so")) + +(defctype togl-struct-ptr-type :pointer) + +;;; --- Togl (Version 1.7 and above needed!) ----------------------------- + +(defcfun ("Togl_Init" Togl_Init) tcl-retcode + (interp :pointer)) + +(defcfun ("Togl_CreateFunc" Togl_CreateFunc) :void + (togl-callback-ptr :pointer)) + +(defcfun ("Togl_DisplayFunc" Togl_DisplayFunc) :void + (togl-callback-ptr :pointer)) + +(defcfun ("Togl_ReshapeFunc" Togl_ReshapeFunc) :void + (togl-callback-ptr :pointer)) + +(defcfun ("Togl_DestroyFunc" Togl_DestroyFunc) :void + (togl-callback-ptr :pointer)) + +(defcfun ("Togl_TimerFunc" Togl_TimerFunc) :void + (togl-callback-ptr :pointer)) + +(defcfun ("Togl_PostRedisplay" Togl_PostRedisplay) :void + (togl-struct-ptr :pointer)) + +(defcfun ("Togl_SwapBuffers" Togl_SwapBuffers) :void + (togl-struct-ptr :pointer)) + +(defcfun ("Togl_Ident" Togl-Ident) :string + (togl-struct-ptr :pointer)) + +(defcfun ("Togl_Width" Togl_Width) :int + (togl-struct-ptr :pointer)) + +(defcfun ("Togl_Height" Togl_Height) :int + (togl-struct-ptr :pointer)) + +(defcfun ("Togl_Interp" Togl_Interp) :pointer + (togl-struct-ptr :pointer)) + +;; Togl_AllocColor +;; Togl_FreeColor + +;; Togl_LoadBitmapFont +;; Togl_UnloadBitmapFont + +;; Togl_SetClientData +;; Togl_ClientData + +;; Togl_UseLayer +;; Togl_ShowOverlay +;; Togl_HideOverlay +;; Togl_PostOverlayRedisplay +;; Togl_OverlayDisplayFunc +;; Togl_ExistsOverlay +;; Togl_GetOverlayTransparentValue +;; Togl_IsMappedOverlay +;; Togl_AllocColorOverlay +;; Togl_FreeColorOverlay +;; Togl_DumpToEpsFile

(eval-when (compile load eval) (export '(togl_swapbuffers togl_postredisplay togl-ptr togl-reshape-func @@ -150,9 +188,6 @@ (def-togl-callback reshape ()) (def-togl-callback destroy ()) (def-togl-callback timer ()) -#+not -(defmethod togl-timer-using-class :after ((self togl)) - (loop until (zerop (ctk::Tcl_DoOneEvent 2))))

(defmethod make-tk-instance ((self togl)) (with-integrity (:client `(:make-tk ,self))