cells-cvs May 2006

cells-cvs@common-lisp.net

2 participants
64 discussions

[cells-cvs] CVS Celtk
by fgoenninger 28 May '06

28 May '06

Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv18944 Modified Files: Celtk.lisp Log Message: Commented out debug stuff in tk-format-now. Added Header info tag at beginning of file. --- /project/cells/cvsroot/Celtk/Celtk.lisp 2006/05/28 15:34:27 1.26 +++ /project/cells/cvsroot/Celtk/Celtk.lisp 2006/05/28 23:45:03 1.27 @@ -16,6 +16,7 @@ |# +;;; $Header: /project/cells/cvsroot/Celtk/Celtk.lisp,v 1.27 2006/05/28 23:45:03 fgoenninger Exp $ (defpackage :celtk (:nicknames "CTK") @@ -133,6 +134,16 @@ ; ; --- debug stuff --------------------------------- ; +<<<<<<< Celtk.lisp +;; (let ((yes '( "insert" "end")) +;; (no '())) +;; (declare (ignorable yes no)) +;; (when (and (find-if (lambda (s) (search s tk$)) yes) +;; (not (find-if (lambda (s) (search s tk$)) no))) +;; (format t "~&tk> ~a~%" tk$)) +;; (break)) +;; (assert *tki*) +======= (let ((yes '( "insert")) (no '())) (declare (ignorable yes no)) @@ -140,6 +151,7 @@ (not (find-if (lambda (s) (search s tk$)) no))) (format t "~&tk> ~a~%" tk$))) (assert *tki*) +>>>>>>> 1.26 ; --- end debug stuff ------------------------------ ; ; --- serious stuff ---

1 0

[cells-cvs] CVS Celtk
by fgoenninger 28 May '06

28 May '06

Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv18540 Modified Files: entry.lisp Log Message: Removed function replace-dangerous-chars. Removed slot eval-text from text widget. --- /project/cells/cvsroot/Celtk/entry.lisp 2006/05/28 15:34:27 1.11 +++ /project/cells/cvsroot/Celtk/entry.lisp 2006/05/28 23:40:32 1.12 @@ -16,6 +16,8 @@ |# +;;; $Header: /project/cells/cvsroot/Celtk/entry.lisp,v 1.12 2006/05/28 23:40:32 fgoenninger Exp $ + (in-package :Celtk) ;---------------------------------------------------------------------------- @@ -68,9 +70,7 @@ (tcl-set-var *tki* (^path) new-value (var-flags :TCL-NAMESPACE-ONLY))))) (deftk text-widget (widget) - ((modified :initarg :modified :accessor modified :initform nil) - (eval-text :initarg :eval-text :accessor eval-text :initform (c-in t) - :documentation "Set to nil if you want to make sure text entries do not get evaluated. If set to nil the /dangerous charachters/ will be replaced by space char.")) + ((modified :initarg :modified :accessor modified :initform nil)) (:tk-spec text -background -borderwidth -cursor -exportselection (tkfont -font) -foreground @@ -106,20 +106,8 @@ (tk-format-now "~a delete 1.0 end" (^path)) (when (plusp (length new-value)) (tk-format-now "~a insert end {~a}" (^path) new-value)))) ;; kt060528: simple {} seems to block evaluation - -;; frgo, 2006-05-27: -;; replace-dangeorous-chars is meant to replace characters in a -;; sequence that would start/end evaluation in Tcl land. -(defun replace-dangerous-chars (seq &optional (dangerous-chars "[]{}")) - (assert (stringp seq)) - (let ((result seq)) - (loop for pos from 0 to (1- (length result)) - do - (let ((c (char result pos))) - (if (find c dangerous-chars) - (setf (char result pos) #\Space)))) - (values result))) ->>>>>>> 1.10 + ;; Yes, it does. But we had to change ~s to ~a also in order to prevent + ;; side effects - frgo 2006-05-29 1:30 am ;-) ;;;(defvar +tk-keysym-table+ ;;; (let ((ht (make-hash-table :test 'string=)))

1 0

[cells-cvs] CVS Celtk
by ktilton 28 May '06

28 May '06

Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv19640 Modified Files: CELTK.lpr Celtk.lisp demos.lisp entry.lisp fileevent.lisp tk-structs.lisp Log Message: Suppress Tcl evaluation of entry and text fields; look for more of these to surface --- /project/cells/cvsroot/Celtk/CELTK.lpr 2006/05/27 06:04:22 1.13 +++ /project/cells/cvsroot/Celtk/CELTK.lpr 2006/05/28 15:34:27 1.14 @@ -104,7 +104,7 @@ :old-space-size 256000 :new-space-size 6144 :runtime-build-option :standard - :on-initialization 'celtk::test-fileevent + :on-initialization 'celtk::tk-test :on-restart 'do-default-restart) ;; End of Project Definition --- /project/cells/cvsroot/Celtk/Celtk.lisp 2006/05/25 15:41:32 1.25 +++ /project/cells/cvsroot/Celtk/Celtk.lisp 2006/05/28 15:34:27 1.26 @@ -124,6 +124,8 @@ "]" "\\]") "\"" "\\\"")) +(tkescape "[exit]") + (defun tk-format-now (fmt$ &rest fmt-args) (unless (find *tkw* *windows-destroyed*) (let* ((*print-circle* nil) @@ -131,10 +133,10 @@ ; ; --- debug stuff --------------------------------- ; - (let ((yes '( "destroy")) + (let ((yes '( "insert")) (no '())) (declare (ignorable yes no)) - (when nil #+not (and (find-if (lambda (s) (search s tk$)) yes) + (when (and (find-if (lambda (s) (search s tk$)) yes) (not (find-if (lambda (s) (search s tk$)) no))) (format t "~&tk> ~a~%" tk$))) (assert *tki*) --- /project/cells/cvsroot/Celtk/demos.lisp 2006/05/25 07:12:59 1.19 +++ /project/cells/cvsroot/Celtk/demos.lisp 2006/05/28 15:34:27 1.20 @@ -20,11 +20,11 @@ (defun ctk::tk-test () ;; ACL project manager needs a zero-argument function, in project package (test-window - ;;'one-button-window + 'one-button-window ;;'ltktest-cells-inside ;;'menu-button-test ;;'spinbox-test - 'lotsa-widgets + ;;'lotsa-widgets ;; Now in Gears project 'gears-demo )) @@ -33,22 +33,22 @@ (:default-initargs :kids (c? (the-kids (mk-menubar - :kids (c? (the-kids - (mk-menu-entry-cascade-ex (:label "File") - (mk-menu-entry-command-ex () "Load" (format t "~&Load pressed")) - (mk-menu-entry-command-ex () "Save" (format t "~&Save pressed")))))) + :kids (c? (the-kids + (mk-menu-entry-cascade-ex (:label "File") + (mk-menu-entry-command-ex () "Load" (format t "~&Load pressed")) + (mk-menu-entry-command-ex () "Save" (format t "~&Save pressed")))))) (mk-frame-stack :packing (c?pack-self) :kids (c? (the-kids (mk-text-widget :id :my-text - :md-value (c?n "hello, world") + :md-value (c?n "[bzbzbzbz]") :height 8 :width 25) - ;;; (make-instance 'entry - ;;; :id :entree - ;;; :fm-parent *parent* - ;;; :md-value (c-in "Boots")) + (make-instance 'entry + :id :entree + :fm-parent *parent* + :md-value (c-in "Boots")) ;;; (make-instance 'button ;;; :fm-parent *parent* ;;; :text "read" --- /project/cells/cvsroot/Celtk/entry.lisp 2006/05/27 22:28:01 1.10 +++ /project/cells/cvsroot/Celtk/entry.lisp 2006/05/28 15:34:27 1.11 @@ -48,7 +48,7 @@ (tcl-get-string (xsv user-data xe)))) ;; assuming write op, but data field shows that (let ((new-value (tcl-get-var *tki* (^path) - (var-flags :TCL_NAMESPACE_ONLY)))) + (var-flags :TCL-NAMESPACE-ONLY)))) (unless (string= new-value (^md-value)) (setf (^md-value) new-value)))))))) @@ -65,7 +65,7 @@ (when new-value (unless (string= new-value old-value) (trc nil "md-value output" self new-value) - (tk-format `(:variable ,self) "set ~a ~s" (^path) new-value)))) + (tcl-set-var *tki* (^path) new-value (var-flags :TCL-NAMESPACE-ONLY))))) (deftk text-widget (widget) ((modified :initarg :modified :accessor modified :initform nil) @@ -104,12 +104,8 @@ (trc nil "md-value output" self new-value) (with-integrity (:client `(:variable ,self)) (tk-format-now "~a delete 1.0 end" (^path)) - (let ((value nil)) - (when (plusp (length new-value)) - (if (not (^eval-text)) - (setq value (replace-dangerous-chars new-value)) - (setq value new-value)) - (tk-format-now "~a insert end ~s" (^path) value))))) + (when (plusp (length new-value)) + (tk-format-now "~a insert end {~a}" (^path) new-value)))) ;; kt060528: simple {} seems to block evaluation ;; frgo, 2006-05-27: ;; replace-dangeorous-chars is meant to replace characters in a @@ -123,6 +119,7 @@ (if (find c dangerous-chars) (setf (char result pos) #\Space)))) (values result))) +>>>>>>> 1.10 ;;;(defvar +tk-keysym-table+ ;;; (let ((ht (make-hash-table :test 'string=))) --- /project/cells/cvsroot/Celtk/fileevent.lisp 2006/05/27 22:25:18 1.3 +++ /project/cells/cvsroot/Celtk/fileevent.lisp 2006/05/28 15:34:27 1.4 @@ -21,7 +21,7 @@ ;;; DEALINGS IN THE SOFTWARE. ;;; ;;; --------------------------------------------------------------------------- -;;; $Header: /project/cells/cvsroot/Celtk/fileevent.lisp,v 1.3 2006/05/27 22:25:18 fgoenninger Exp $ +;;; $Header: /project/cells/cvsroot/Celtk/fileevent.lisp,v 1.4 2006/05/28 15:34:27 ktilton Exp $ ;;; --------------------------------------------------------------------------- ;;; =========================================================================== @@ -352,7 +352,7 @@ (interp :pointer) (argc :int) (argv :pointer)) - (declare (ignorable clientData argc interp)) + (declare (ignore clientData argc interp)) (let* ((path (foreign-string-to-lisp (mem-aref argv :pointer 1))) (self (gethash path (dictionary *tkw*)))) (bwhen (fn (^read-fn)) @@ -364,7 +364,7 @@ (interp :pointer) (argc :int) (argv :pointer)) - (declare (ignorable clientData argc interp)) + (declare (ignore clientData argc interp)) (let* ((path (foreign-string-to-lisp (mem-aref argv :pointer 1))) (self (gethash path (dictionary *tkw*)))) (bwhen (fn (^write-fn)) @@ -376,7 +376,8 @@ (interp :pointer) (argc :int) (argv :pointer)) - (declare (ignorable clientData interp argc)) + (declare (ignore clientData interp argc)) + (trc "eof!!!!!") (let* ((path (foreign-string-to-lisp (mem-aref argv :pointer 1))) (self (gethash path (dictionary *tkw*)))) (bwhen (fn (^eof-fn)) @@ -466,7 +467,7 @@ :eval-text nil)) (mk-fileevent :id :fileevent-test :read-fn 'read-from-pipe - :iostream (open "/Users/frgo/tmp/frgo-test" + :iostream (open "/0dev/hw.txt" ;;; Adapt here !!! ^^^^^^^^^^^^^^^^^^^^^^^^^^^ :direction :input)))))) @@ -475,3 +476,6 @@ (trc "-----------------------------------------------------------------------------") (test-window 'fileevent-test-window) (trc "-----------------------------------------------------------------------------")) + +#+test +(test-window 'fileevent-test-window) \ No newline at end of file --- /project/cells/cvsroot/Celtk/tk-structs.lisp 2006/05/24 20:38:54 1.2 +++ /project/cells/cvsroot/Celtk/tk-structs.lisp 2006/05/28 15:34:27 1.3 @@ -132,23 +132,23 @@ (:tcl-all-events -3)) (defcenum tcl-variable-related-flag - "Flags passed to getvar, setvar, tracevar, etc" - (:TCL_GLOBAL_ONLY 1) - (:TCL_NAMESPACE_ONLY 2) - (:TCL_APPEND_VALUE 4) - (:TCL_LIST_ELEMENT 8) - (:TCL_TRACE_READS #x10) - (:TCL_TRACE_WRITES #x20) - (:TCL_TRACE_UNSETS #x40) - (:TCL_TRACE_DESTROYED #x80) - (:TCL_INTERP_DESTROYED #x100) - (:TCL_LEAVE_ERR_MSG #x200) - (:TCL_TRACE_ARRAY #x800) - ;; Required to support old variable/vdelete/vinfo traces */ - (:TCL_TRACE_OLD_STYLE #x1000) - ;; Indicate the semantics of the result of a trace */ - (:TCL_TRACE_RESULT_DYNAMIC #x8000) - (:TCL_TRACE_RESULT_OBJECT #x10000)) + "flags passed to getvar, setvar, tracevar, etc" + (:tcl-global-only 1) + (:tcl-namespace-only 2) + (:tcl-append-value 4) + (:tcl-list-element 8) + (:tcl-trace-reads #x10) + (:tcl-trace-writes #x20) + (:tcl-trace-unsets #x40) + (:tcl-trace-destroyed #x80) + (:tcl-interp-destroyed #x100) + (:tcl-leave-err-msg #x200) + (:tcl-trace-array #x800) + ;; required to support old variable/vdelete/vinfo traces */ + (:tcl-trace-old-style #x1000) + ;; indicate the semantics of the result of a trace */ + (:tcl-trace-result-dynamic #x8000) + (:tcl-trace-result-object #x10000)) (defun var-flags (&rest kws) (apply '+ (loop for kw in kws

1 0

[cells-cvs] CVS Celtk
by fgoenninger 27 May '06

27 May '06

Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv12824 Modified Files: entry.lisp Log Message: Changed/added: text widget: new slot eval-text. Defaults to t. If nil then upon setting the model value of the text widget the new valiue will be scanned for "dangerous" characters. These are: [Ê]Ê{Ê} Reason: Tcl evaluates text in brackets as commands. This may be dangerous. If any such dangerous character is found it is replaced by a Space character in order to not change the length of the text. --- /project/cells/cvsroot/Celtk/entry.lisp 2006/05/24 20:38:54 1.9 +++ /project/cells/cvsroot/Celtk/entry.lisp 2006/05/27 22:28:01 1.10 @@ -68,7 +68,9 @@ (tk-format `(:variable ,self) "set ~a ~s" (^path) new-value)))) (deftk text-widget (widget) - ((modified :initarg :modified :accessor modified :initform nil)) + ((modified :initarg :modified :accessor modified :initform nil) + (eval-text :initarg :eval-text :accessor eval-text :initform (c-in t) + :documentation "Set to nil if you want to make sure text entries do not get evaluated. If set to nil the /dangerous charachters/ will be replaced by space char.")) (:tk-spec text -background -borderwidth -cursor -exportselection (tkfont -font) -foreground @@ -102,8 +104,25 @@ (trc nil "md-value output" self new-value) (with-integrity (:client `(:variable ,self)) (tk-format-now "~a delete 1.0 end" (^path)) - (when (plusp (length new-value)) - (tk-format-now "~a insert end ~s" (^path) new-value)))) + (let ((value nil)) + (when (plusp (length new-value)) + (if (not (^eval-text)) + (setq value (replace-dangerous-chars new-value)) + (setq value new-value)) + (tk-format-now "~a insert end ~s" (^path) value))))) + +;; frgo, 2006-05-27: +;; replace-dangeorous-chars is meant to replace characters in a +;; sequence that would start/end evaluation in Tcl land. +(defun replace-dangerous-chars (seq &optional (dangerous-chars "[]{}")) + (assert (stringp seq)) + (let ((result seq)) + (loop for pos from 0 to (1- (length result)) + do + (let ((c (char result pos))) + (if (find c dangerous-chars) + (setf (char result pos) #\Space)))) + (values result))) ;;;(defvar +tk-keysym-table+ ;;; (let ((ht (make-hash-table :test 'string=))) @@ -116,7 +135,7 @@ ;;; finally (return ht))))) (defun tk-translate-keysym (keysym$) - (if (= 1 (length keysym$)) + (if (= 1 (length keysym$)) (schar keysym$ 0) (intern (string-upcase keysym$)) #+nah (gethash keysym$ +tk-keysym-table+))) \ No newline at end of file

1 0

[cells-cvs] CVS Celtk
by fgoenninger 27 May '06

27 May '06

Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv12756 Modified Files: fileevent.lisp Log Message: Changed testing example to use the new slot eval-text of the text widget. See file entry.lisp for more details. --- /project/cells/cvsroot/Celtk/fileevent.lisp 2006/05/25 14:03:44 1.2 +++ /project/cells/cvsroot/Celtk/fileevent.lisp 2006/05/27 22:25:18 1.3 @@ -21,7 +21,7 @@ ;;; DEALINGS IN THE SOFTWARE. ;;; ;;; --------------------------------------------------------------------------- -;;; $Header: /project/cells/cvsroot/Celtk/fileevent.lisp,v 1.2 2006/05/25 14:03:44 fgoenninger Exp $ +;;; $Header: /project/cells/cvsroot/Celtk/fileevent.lisp,v 1.3 2006/05/27 22:25:18 fgoenninger Exp $ ;;; --------------------------------------------------------------------------- ;;; =========================================================================== @@ -188,6 +188,33 @@ ;;; =========================================================================== (defmethod set-tk-readable ((self tk-fileevent) ch-name path) + +;; frgo, 2006-05-26: +;; The code here was aimed at EOF checking after reading... +;; So the API needs rework... +;; (tk-format-now " proc readable {channel path} { +;; # check for async errors (sockets only, I think) +;; if {[string length [set err [fconfigure $channel -error]]]} { +;; error-cb $path $err +;; close $channel +;; return +;; } +;; # read a line from the channel +;; if {[catch {set line [gets $channel]} err]} { +;; error-cb $path $err +;; close $channel +;; return +;; } +;; if {[string length $line]} { +;; received-cb $path $line +;; } +;; # check for eof +;; if {[eof $channel]} { +;; eof-cb $path +;; close $channel +;; } +;; }") + (tk-format-now "proc readable {channel path} { if [ eof $channel ] then { eof-cb $path } else { readable-cb $path } }") (tk-format-now "fileevent ~A readable [list readable ~A ~A]" ch-name @@ -419,8 +446,7 @@ (let ((data (read-line stream nil nil nil))) (trc "*** READ-FROM-PIPE: data = " data) (when data - (setf (md-value (fm-other :receive-window)) data)))) -) + (setf (md-value (fm-other :receive-window)) data))))) (defmodel fileevent-test-window (window) () @@ -436,7 +462,8 @@ :width 80 :borderwidth 2 :relief 'sunken - :pady 5)) + :pady 5 + :eval-text nil)) (mk-fileevent :id :fileevent-test :read-fn 'read-from-pipe :iostream (open "/Users/frgo/tmp/frgo-test"

1 0

[cells-cvs] CVS Celtk
by ktilton 27 May '06

27 May '06

Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv7353 Modified Files: CELTK.lpr togl.lisp Log Message: Get destroy callbacks working on Togls --- /project/cells/cvsroot/Celtk/CELTK.lpr 2006/05/24 20:38:54 1.12 +++ /project/cells/cvsroot/Celtk/CELTK.lpr 2006/05/27 06:04:22 1.13 @@ -10,6 +10,7 @@ (make-instance 'module :name "tk-interp.lisp") (make-instance 'module :name "tk-events.lisp") (make-instance 'module :name "tk-object.lisp") + (make-instance 'module :name "fileevent.lisp") (make-instance 'module :name "widget.lisp") (make-instance 'module :name "font.lisp") (make-instance 'module :name "layout.lisp") @@ -103,7 +104,7 @@ :old-space-size 256000 :new-space-size 6144 :runtime-build-option :standard - :on-initialization 'celtk::tk-test + :on-initialization 'celtk::test-fileevent :on-restart 'do-default-restart) ;; End of Project Definition --- /project/cells/cvsroot/Celtk/togl.lisp 2006/05/26 17:50:36 1.7 +++ /project/cells/cvsroot/Celtk/togl.lisp 2006/05/27 06:04:22 1.8 @@ -98,7 +98,7 @@ ;(assert (not (zerop (tk-init-stubs interp "8.1" 0)))) (togl_init interp) (togl-create-func (callback togl-create)) - ;;; needed? (togl-destroy-func (callback togl-destroy) + (togl-destroy-func (callback togl-destroy)) (togl-display-func (callback togl-display)) (togl-reshape-func (callback togl-reshape)) (togl-timer-func (callback togl-timer)) ;; probably want to make this optional @@ -175,6 +175,7 @@ (let ((,self-var (or (gethash (pointer-address ,ptr-var) (tkwins *tkw*)) (gethash (togl-ident ,ptr-var)(dictionary *tkw*))))) ,@preamble + (trc nil "selves" ,cb$ (togl-ident ,ptr-var) (gethash (pointer-address ,ptr-var) (tkwins *tkw*))(gethash (togl-ident ,ptr-var)(dictionary *tkw*))) (,(intern uc$) ,self-var)))) (defmethod ,(intern uc$) :around ((self togl)) (if (,(intern cb-slot$) self) @@ -183,7 +184,9 @@ (defmethod ,(intern uc$) ((self togl)))))) (def-togl-callback create () - (setf (togl-ptr self) togl-ptr)) + (setf (togl-ptr self) togl-ptr) + (setf (gethash (pointer-address togl-ptr) (tkwins *tkw*)) self)) + (def-togl-callback display ()) (def-togl-callback reshape ()) (def-togl-callback destroy ()) @@ -195,3 +198,16 @@ (tk-format-now "togl ~a ~{~(~a~) ~a~^ ~}" (path self)(tk-configurations self)))) ;; this leads to "togl <path> [-<config option> <value]*", in turn to togl_create + +;;; +;;;(DEFCFUN ("Togl_DestroyFunc" TOGL-DESTROY-FUNC) :VOID (CALLBACK :POINTER)) +;;;(defcallback togl-destroy :void ((togl-ptr :pointer)) +;;; (trc "togl-destroy ptr" togl-ptr (loop for k being the hash-keys of (tkwins *tkw*) +;;; collecting k)) +;;; (unless (c-stopped) +;;; (let ((self (or (gethash (pointer-address togl-ptr) (tkwins *tkw*)) (gethash (togl-ident togl-ptr) (dictionary *tkw*))))) +;;; +;;; (togl-destroy-using-class self)))) +;;;(DEFMETHOD TOGL-DESTROY-USING-CLASS :AROUND ((SELF TOGL)) +;;; (IF (CB-DESTROY SELF) (FUNCALL (CB-DESTROY SELF) SELF) (CALL-NEXT-METHOD))) +;;;(DEFMETHOD TOGL-DESTROY-USING-CLASS ((SELF TOGL))) \ No newline at end of file

1 0

[cells-cvs] CVS Celtk
by ktilton 26 May '06

26 May '06

Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv6466 Modified Files: widget.lisp Removed Files: Gears.lpr textual.lisp Log Message: --- /project/cells/cvsroot/Celtk/widget.lisp 2006/05/25 07:12:59 1.10 +++ /project/cells/cvsroot/Celtk/widget.lisp 2006/05/26 18:02:02 1.11 @@ -260,12 +260,6 @@ ;;; --- images ------------------------------------------------------- (defobserver image-files () - ; - ; I do not know how to create the photo for X before X exists - ; though it seems to work. <g> perhaps Tk understands it does not need to - ; place the image in a tree and lets the undefined path go? If so, - ; just add :pre-make-kt before :make-kt in the sort list - ; (loop for (name file-pathname) in (set-difference new-value old-value :key 'car) do (tk-format `(:pre-make-tk ,self) "image create photo ~(~a.~a~) -file ~a" (^path) name (tkescape (namestring file-pathname)))))

1 0

[cells-cvs] CVS Celtk
by ktilton 26 May '06

26 May '06

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(a)gmail.com>" :version "2.0" :maintainer "Kenny Tilton <kentilton(a)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))

1 0

[cells-cvs] CVS Celtk/gears
by ktilton 26 May '06

26 May '06

Update of /project/cells/cvsroot/Celtk/gears In directory clnet:/tmp/cvs-serv4378/gears Added Files: gears.lisp gears.lpr Log Message: Gears demo at last --- /project/cells/cvsroot/Celtk/gears/gears.lisp 2006/05/26 17:50:36 NONE +++ /project/cells/cvsroot/Celtk/gears/gears.lisp 2006/05/26 17:50:36 1.1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; gears.lisp --- Celtk/Togl version of cl-opengl Lisp version of gears.c (GLUT Mesa demos). ;;; ;;; Simple program with rotating 3-D gear wheels. (defpackage :gears (:use :common-lisp :utils-kt :cells :celtk)) (in-package :gears) (defvar *startx*) (defvar *starty*) (defvar *xangle0*) (defvar *yangle0*) (defvar *xangle*) (defvar *yangle*) (defparameter *vTime* 100) (defun gears () ;; ACL project manager needs a zero-argument function, in project package (let ((*startx* nil) (*starty* nil) (*xangle0* nil) (*yangle0* nil) (*xangle* 0.2) (*yangle* 0.0)) (test-window 'gears-demo))) (defmodel gears-demo (window) ((gear-ct :initform (c-in 1) :accessor gear-ct :initarg :gear-ct) (scale :initform (c-in 1) :accessor scale :initarg :scale)) (:default-initargs :title$ "Rotating Gear Widget Test" :kids (c? (the-kids (mk-stack (:packing (c?pack-self "-side left -fill both")) (mk-label :text "Click and drag to rotate image") (mk-row () (mk-label :text "Spin delay (ms):") (mk-entry :id :vtime :md-value (c-in "10")) (mk-button-ex (" Quit " (tk-eval "destroy .")))) (make-instance 'gears :fm-parent *parent* :width 400 :height 400 :timer-interval (c? (let ((n$ (md-value (fm-other :vtime)))) (format nil "~a" (max 1 (or (parse-integer n$ :junk-allowed t) 0))))) :double 1 ;; "yes" :event-handler (c? (lambda (self xe) (case (tk-event-type (xsv type xe)) (:virtualevent (trc "canvas virtual" (xsv name xe))) (:buttonpress (RotStart self (xsv x-root xe) (xsv y-root xe))) (:motionnotify (RotMove self (xsv x-root xe) (xsv y-root xe))) (:buttonrelease (setf *startx* nil))))))))))) (defun RotStart (self x y) (setf *startx* x) (setf *starty* y) (setf *xangle0* (rotx self)) (setf *yangle0* (roty self))) (defun RotMove (self x y) (when *startx* (setf *xangle* (+ *xangle0* (- x *startx*))) (setf *yangle* (+ *yangle0* (- y *starty*))) (setf (rotx self) *xangle*) (setf (roty self) *yangle*))) (defconstant +pif+ (coerce pi 'single-float)) (defmodel gears (togl) ((rotx :initform (c-in 40) :accessor rotx :initarg :rotx) (roty :initform (c-in 25) :accessor roty :initarg :roty) (rotz :initform (c-in 10) :accessor rotz :initarg :rotz) (gear1 :initarg :gear1 :accessor gear1 :initform (c_? (trc "making list!!!!! 1") (let ((dl (gl:gen-lists 1))) (gl:with-new-list (dl :compile) (gl:material :front :ambient-and-diffuse #(0.8 0.1 0.0 1.0)) (draw-gear 1.0 4.0 1.0 20 0.7)) dl))) (gear2 :initarg :gear2 :accessor gear2 :initform (c_? (let ((dl (gl:gen-lists 1))) (gl:with-new-list (dl :compile) (gl:material :front :ambient-and-diffuse #(0.0 0.8 0.2 1.0)) (draw-gear 0.5 2.0 2.0 10 0.7)) dl))) (gear3 :initarg :gear3 :accessor gear3 :initform (c_? (let ((dl (gl:gen-lists 1))) (gl:with-new-list (dl :compile) (gl:material :front :ambient-and-diffuse #(0.2 0.2 1.0 1.0)) (draw-gear 1.3 2.0 0.5 10 0.7)) dl))) (angle :initform (c-in 0.0) :accessor angle :initarg :angle) (frame-count :cell nil :initform 0 :accessor frame-count) (t0 :cell nil :initform 0 :accessor t0) ; (width :initarg :wdith :initform 400 :accessor width) (height :initarg :wdith :initform 400 :accessor height))) (defmethod togl-timer-using-class ((self gears)) (trc nil "enter gear timer" self (togl-ptr self) (get-internal-real-time)) (incf (^angle) 5.0) (Togl_PostRedisplay (togl-ptr self)) ;(loop until (zerop (ctk::Tcl_DoOneEvent 2))) ) (defmethod togl-create-using-class ((self gears)) (gl:light :light0 :position #(5.0 5.0 10.0 0.0)) (gl:enable :cull-face :lighting :light0 :depth-test) (gl:material :front :ambient-and-diffuse #(0.8 0.1 0.0 1.0)) (gl:enable :normalize) (truc self)) (defmethod togl-reshape-using-class ((self gears)) (trc "reshape") (truc self t) ) (defun truc (self &optional truly) (let ((width (Togl_width (togl-ptr self))) (height (Togl_height (togl-ptr self)))) (trc "enter gear reshape" self width (width self)) (gl:viewport 0 (- height (height self)) (width self) (height self)) (unless truly (gl:matrix-mode :projection) (gl:load-identity) (let ((h (/ height width))) (gl:frustum -1 1 (- h) h 5 60))) (progn (gl:matrix-mode :modelview) (gl:load-identity) (gl:translate 0 0 -30)))) (defmethod togl-display-using-class ((self gears) &aux (scale (scale (upper self gears-demo)))) (declare (ignorable scale)) (gl:clear-color 0 0 0 1) (gl:clear :color-buffer-bit :depth-buffer-bit) (gl:with-pushed-matrix (gl:rotate (^rotx) 1 0 0) (gl:rotate (^roty) 0 1 0) (gl:rotate (^rotz) 0 0 1) (gl:with-pushed-matrix (gl:translate -3 -2 0) (gl:rotate (^angle) 0 0 1) (gl:call-list (^gear1))) (gl:with-pushed-matrix (gl:translate 3.1 -2 0) (gl:rotate (- (* -2 (^angle)) 9) 0 0 1) (gl:call-list (^gear2))) (gl:with-pushed-matrix ; gear3 (gl:translate -3.1 4.2 0.0) (gl:rotate (- (* -2 (^angle)) 25) 0 0 1) (gl:call-list (^gear3)))) (Togl_SwapBuffers (togl-ptr self)) #+shhh (print-frame-rate self)) (defun draw-gear (inner-radius outer-radius width n-teeth tooth-depth) "Draw a gear." (declare (single-float inner-radius outer-radius width tooth-depth) (fixnum n-teeth)) (let ((r0 inner-radius) (r1 (- outer-radius (/ tooth-depth 2.0))) (r2 (+ outer-radius (/ tooth-depth 2.0))) (da (/ (* 2.0 +pif+) n-teeth 4.0))) (gl:shade-model :flat) (gl:normal 0 0 1) ;; Draw front face. (gl:with-primitives :quad-strip (dotimes (i (1+ n-teeth)) (let ((angle (/ (* i 2.0 +pif+) n-teeth))) (gl:vertex (* r0 (cos angle)) (* r0 (sin angle)) (* width 0.5)) (gl:vertex (* r1 (cos angle)) (* r1 (sin angle)) (* width 0.5)) (gl:vertex (* r0 (cos angle)) (* r0 (sin angle)) (* width 0.5)) (gl:vertex (* r1 (cos (+ angle (* 3 da)))) (* r1 (sin (+ angle (* 3 da)))) (* width 0.5))))) ;; Draw front sides of teeth. (gl:with-primitives :quads (dotimes (i n-teeth) (let ((angle (/ (* i 2.0 +pif+) n-teeth))) (gl:vertex (* r1 (cos angle)) (* r1 (sin angle)) (* width 0.5)) (gl:vertex (* r2 (cos (+ angle da))) (* r2 (sin (+ angle da))) (* width 0.5)) (gl:vertex (* r2 (cos (+ angle (* 2 da)))) (* r2 (sin (+ angle (* 2 da)))) (* width 0.5)) (gl:vertex (* r1 (cos (+ angle (* 3 da)))) (* r1 (sin (+ angle (* 3 da)))) (* width 0.5))))) (gl:normal 0 0 -1) ;; Draw back face. (gl:with-primitives :quad-strip (dotimes (i (1+ n-teeth)) (let ((angle (/ (* i 2.0 +pif+) n-teeth))) (gl:vertex (* r1 (cos angle)) (* r1 (sin angle)) (* width -0.5)) (gl:vertex (* r0 (cos angle)) (* r0 (sin angle)) (* width -0.5)) (gl:vertex (* r1 (cos (+ angle (* 3 da)))) (* r1 (sin (+ angle (* 3 da)))) (* width -0.5)) (gl:vertex (* r0 (cos angle)) (* r0 (sin angle)) (* width -0.5))))) ;; Draw back sides of teeth. (gl:with-primitives :quads (dotimes (i n-teeth) (let ((angle (/ (* i 2.0 +pif+) n-teeth))) (gl:vertex (* r1 (cos (+ angle (* 3 da)))) (* r1 (sin (+ angle (* 3 da)))) (* (- width) 0.5)) (gl:vertex (* r2 (cos (+ angle (* 2 da)))) (* r2 (sin (+ angle (* 2 da)))) (* (- width) 0.5)) (gl:vertex (* r2 (cos (+ angle da))) (* r2 (sin (+ angle da))) (* (- width) 0.5)) (gl:vertex (* r1 (cos angle)) (* r1 (sin angle)) (* (- width) 0.5))))) ;; Draw outward faces of teeth. (gl:with-primitives :quad-strip (dotimes (i n-teeth) (let ((angle (/ (* i 2.0 +pif+) n-teeth))) (gl:vertex (* r1 (cos angle)) (* r1 (sin angle)) (* width 0.5)) (gl:vertex (* r1 (cos angle)) (* r1 (sin angle)) (* (- width) 0.5)) (let* ((u (- (* r2 (cos (+ angle da))) (* r1 (cos angle)))) (v (- (* r2 (sin (+ angle da))) (* r1 (sin angle)))) (len (sqrt (+ (* u u) (* v v))))) (setq u (/ u len)) (setq v (/ u len)) (gl:normal v (- u) 0.0) (gl:vertex (* r2 (cos (+ angle da))) (* r2 (sin (+ angle da))) (* width 0.5)) (gl:vertex (* r2 (cos (+ angle da))) (* r2 (sin (+ angle da))) (* (- width) 0.5)) (gl:normal (cos angle) (sin angle) 0.0) (gl:vertex (* r2 (cos (+ angle (* 2 da)))) (* r2 (sin (+ angle (* 2 da)))) (* width 0.5)) (gl:vertex (* r2 (cos (+ angle (* 2 da)))) (* r2 (sin (+ angle (* 2 da)))) (* (- width) 0.5)) (setq u (- (* r1 (cos (+ angle (* 3 da)))) (* r2 (cos (+ angle (* 2 da)))))) (setq v (- (* r1 (sin (+ angle (* 3 da)))) (* r2 (sin (+ angle (* 2 da)))))) (gl:normal v (- u) 0.0) (gl:vertex (* r1 (cos (+ angle (* 3 da)))) (* r1 (sin (+ angle (* 3 da)))) (* width 0.5)) (gl:vertex (* r1 (cos (+ angle (* 3 da)))) (* r1 (sin (+ angle (* 3 da)))) (* (- width) 0.5)) (gl:normal (cos angle) (sin angle) 0.0)))) (gl:vertex (* r1 (cos 0)) (* r1 (sin 0)) (* width 0.5)) (gl:vertex (* r1 (cos 0)) (* r1 (sin 0)) (* (- width) 0.5))) ;; Draw inside radius cylinder. (gl:shade-model :smooth) (gl:with-primitives :quad-strip (dotimes (i (1+ n-teeth)) (let ((angle (/ (* i 2.0 +pif+) n-teeth))) (gl:normal (- (cos angle)) (- (sin angle)) 0.0) (gl:vertex (* r0 (cos angle)) (* r0 (sin angle)) (* (- width) 0.5)) (gl:vertex (* r0 (cos angle)) (* r0 (sin angle)) (* width 0.5))))))) (defun print-frame-rate (window) (with-slots (frame-count t0) window (incf frame-count) (let ((time (get-internal-real-time))) (when (= t0 0) (setq t0 time)) (when (>= (- time t0) (* 5 internal-time-units-per-second)) (let* ((seconds (/ (- time t0) internal-time-units-per-second)) (fps (/ frame-count seconds))) (declare (ignorable fps)) #+shh (format *terminal-io* "~D frames in ~3,1F seconds = ~6,3F FPS~%" frame-count seconds fps)) (setq t0 time) (setq frame-count 0))))) --- /project/cells/cvsroot/Celtk/gears/gears.lpr 2006/05/26 17:50:36 NONE +++ /project/cells/cvsroot/Celtk/gears/gears.lpr 2006/05/26 17:50:36 1.1 ;; -*- lisp-version: "8.0 [Windows] (May 22, 2006 0:51)"; cg: "1.81"; -*- (in-package :cg-user) (defpackage :GEARS) (define-project :name :gears :modules (list (make-instance 'module :name "gears.lisp")) :projects (list (make-instance 'project-module :name "..\\CELTK") (make-instance 'project-module :name "C:\\1-devtools\\cl-opengl\\glu")) :libraries nil :distributed-files nil :internally-loaded-files nil :project-package-name :gears :main-form nil :compilation-unit t :verbose nil :runtime-modules '(:cg-dde-utils :cg.base :cg.bitmap-pane :cg.bitmap-pane.clipboard :cg.bitmap-stream :cg.button :cg.caret :cg.check-box :cg.choice-list :cg.choose-printer :cg.clipboard :cg.clipboard-stack :cg.clipboard.pixmap :cg.color-dialog :cg.combo-box :cg.common-control :cg.comtab :cg.cursor-pixmap :cg.curve :cg.dialog-item :cg.directory-dialog :cg.directory-dialog-os :cg.drag-and-drop :cg.drag-and-drop-image :cg.drawable :cg.drawable.clipboard :cg.dropping-outline :cg.edit-in-place :cg.editable-text :cg.file-dialog :cg.fill-texture :cg.find-string-dialog :cg.font-dialog :cg.gesture-emulation :cg.get-pixmap :cg.get-position :cg.graphics-context :cg.grid-widget :cg.grid-widget.drag-and-drop :cg.group-box :cg.header-control :cg.hotspot :cg.html-dialog :cg.html-widget :cg.icon :cg.icon-pixmap :cg.ie :cg.item-list :cg.keyboard-shortcuts :cg.lamp :cg.lettered-menu :cg.lisp-edit-pane :cg.lisp-text :cg.lisp-widget :cg.list-view :cg.mci :cg.menu :cg.menu.tooltip :cg.message-dialog :cg.multi-line-editable-text :cg.multi-line-lisp-text :cg.multi-picture-button :cg.multi-picture-button.drag-and-drop :cg.multi-picture-button.tooltip :cg.ocx :cg.os-widget :cg.os-window :cg.outline :cg.outline.drag-and-drop :cg.outline.edit-in-place :cg.palette :cg.paren-matching :cg.picture-widget :cg.picture-widget.palette :cg.pixmap :cg.pixmap-widget :cg.pixmap.file-io :cg.pixmap.printing :cg.pixmap.rotate :cg.printing :cg.progress-indicator :cg.project-window :cg.property :cg.radio-button :cg.rich-edit :cg.rich-edit-pane :cg.rich-edit-pane.clipboard :cg.rich-edit-pane.printing :cg.sample-file-menu :cg.scaling-stream :cg.scroll-bar :cg.scroll-bar-mixin :cg.selected-object :cg.shortcut-menu :cg.static-text :cg.status-bar :cg.string-dialog :cg.tab-control :cg.template-string :cg.text-edit-pane :cg.text-edit-pane.file-io :cg.text-edit-pane.mark :cg.text-or-combo :cg.text-widget :cg.timer :cg.toggling-widget :cg.toolbar :cg.tooltip :cg.trackbar :cg.tray :cg.up-down-control :cg.utility-dialog :cg.web-browser :cg.web-browser.dde :cg.wrap-string :cg.yes-no-list :cg.yes-no-string :dde) :splash-file-module (make-instance 'build-module :name "") :icon-file-module (make-instance 'build-module :name "") :include-flags '(:top-level :debugger) :build-flags '(:allow-runtime-debug :purify) :autoload-warning t :full-recompile-for-runtime-conditionalizations nil :default-command-line-arguments "+M +t \"Console for Debugging\"" :additional-build-lisp-image-arguments '(:read-init-files nil) :old-space-size 256000 :new-space-size 6144 :runtime-build-option :standard :on-initialization 'gears::gears :on-restart 'do-default-restart) ;; End of Project Definition

1 0

[cells-cvs] CVS Celtk
by fgoenninger 25 May '06

25 May '06

Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv27202 Modified Files: Celtk.lisp Log Message: Changed: function tk-format-now: let -> let* in order to get *print-circle* to be set to nil for the formatting of the string to be passed to tk-eval-ex. --- /project/cells/cvsroot/Celtk/Celtk.lisp 2006/05/25 07:12:59 1.24 +++ /project/cells/cvsroot/Celtk/Celtk.lisp 2006/05/25 15:41:32 1.25 @@ -126,8 +126,8 @@ (defun tk-format-now (fmt$ &rest fmt-args) (unless (find *tkw* *windows-destroyed*) - (let ((*print-circle* nil) - (tk$ (apply 'format nil fmt$ fmt-args))) + (let* ((*print-circle* nil) + (tk$ (apply 'format nil fmt$ fmt-args))) ; ; --- debug stuff --------------------------------- ;

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

2003

cells-cvs May 2006