[cells-cvs] CVS Celtk
ktilton
ktilton at common-lisp.net
Fri May 26 17:50:36 UTC 2006
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 at gmail.com>"
:version "2.0"
:maintainer "Kenny Tilton <kentilton at 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))
More information about the Cells-cvs
mailing list