[cells-cvs] CVS Celtk

ktilton ktilton at common-lisp.net
Mon Jun 16 12:35:56 UTC 2008


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

Modified Files:
	CELTK.lpr CelloTk.lpr Celtk.lisp composites.lisp demos.lisp 
	lotsa-widgets.lisp run.lisp tk-object.lisp tk-structs.lisp 
Added Files:
	notebook.lisp 
Log Message:
Notebook.lisp from Andy and random other recent work

--- /project/cells/cvsroot/Celtk/CELTK.lpr	2008/03/23 23:47:42	1.25
+++ /project/cells/cvsroot/Celtk/CELTK.lpr	2008/06/16 12:35:52	1.26
@@ -1,4 +1,4 @@
-;; -*- lisp-version: "8.1 [Windows] (Mar 4, 2008 15:30)"; cg: "1.103.2.10"; -*-
+;; -*- lisp-version: "8.1 [Windows] (Jun 3, 2008 13:12)"; cg: "1.103.2.10"; -*-
 
 (in-package :cg-user)
 
@@ -33,7 +33,8 @@
                  (make-instance 'module :name "ltktest-ci.lisp")
                  (make-instance 'module :name "lotsa-widgets.lisp")
                  (make-instance 'module :name "demos.lisp")
-                 (make-instance 'module :name "andy-expander.lisp"))
+                 (make-instance 'module :name "andy-expander.lisp")
+                 (make-instance 'module :name "notebook.lisp"))
   :projects (list (make-instance 'project-module :name
                                  "..\\cells\\cells")
                   (make-instance 'project-module :name
--- /project/cells/cvsroot/Celtk/CelloTk.lpr	2008/01/03 20:23:30	1.3
+++ /project/cells/cvsroot/Celtk/CelloTk.lpr	2008/06/16 12:35:55	1.4
@@ -1,4 +1,4 @@
-;; -*- lisp-version: "8.0 [Windows] (Mar 11, 2007 7:25)"; cg: "1.81"; -*-
+;; -*- lisp-version: "8.1 [Windows] (Apr 15, 2008 21:33)"; cg: "1.103.2.10"; -*-
 
 (in-package :cg-user)
 
@@ -33,68 +33,76 @@
   :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)
+  :runtime-modules (list :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)
+  :include-flags (list :top-level :debugger)
+  :build-flags (list :allow-runtime-debug :purify)
   :autoload-warning t
   :full-recompile-for-runtime-conditionalizations nil
+  :include-manifest-file-for-visual-styles t
   :default-command-line-arguments "+M +t \"Console for Debugging\""
-  :additional-build-lisp-image-arguments '(:read-init-files nil)
+  :additional-build-lisp-image-arguments (list :read-init-files nil)
   :old-space-size 256000
   :new-space-size 6144
   :runtime-build-option :standard
-  :on-initialization 'celtk::cellogears
+  :on-initialization 'celtk::test
   :on-restart 'do-default-restart)
 
 ;; End of Project Definition
--- /project/cells/cvsroot/Celtk/Celtk.lisp	2008/01/03 20:23:30	1.42
+++ /project/cells/cvsroot/Celtk/Celtk.lisp	2008/06/16 12:35:55	1.43
@@ -16,10 +16,11 @@
 
 |#
 
-;;; $Header: /project/cells/cvsroot/Celtk/Celtk.lisp,v 1.42 2008/01/03 20:23:30 ktilton Exp $
+;;; $Header: /project/cells/cvsroot/Celtk/Celtk.lisp,v 1.43 2008/06/16 12:35:55 ktilton Exp $
 
 ;(pushnew :tile *features*) ;; frgo, 2007-09-21: Need to do this only when tile actually loaded
 
+
 (defpackage :celtk
   (:nicknames "CTK")
   (:use :common-lisp :utils-kt :cells :cffi)
--- /project/cells/cvsroot/Celtk/composites.lisp	2008/04/11 09:23:51	1.28
+++ /project/cells/cvsroot/Celtk/composites.lisp	2008/06/16 12:35:56	1.29
@@ -148,6 +148,7 @@
 Actually holds last event code, :focusin or :focusout")
   on-key-down
   on-key-up
+  (post-event-do nil :cell nil) ;; such as pop up alert for user
   (show-tool-tips? (c-in t))
   :width (c?n 800)
   :height (c?n 600))
@@ -201,6 +202,8 @@
       (setf (keyboard-modifiers .tkw)
         (delete mod (keyboard-modifiers .tkw))))))
 
+
+
 ;;; Helper function that actually executes decoration change
 (defun %%do-decoration (widget decoration)
   (let ((path (path widget)))
--- /project/cells/cvsroot/Celtk/demos.lisp	2007/01/29 06:48:41	1.27
+++ /project/cells/cvsroot/Celtk/demos.lisp	2008/06/16 12:35:56	1.28
@@ -87,7 +87,7 @@
                              (make-instance 'entry
                                :id :entree
                                :fm-parent *parent*
-                               :value (c-in "Boots")))))))))
+                               :value (c-in "kenzo")))))))))
 
 (defun one-deep-menubar ()
   (mk-menubar
--- /project/cells/cvsroot/Celtk/lotsa-widgets.lisp	2008/01/03 20:23:30	1.11
+++ /project/cells/cvsroot/Celtk/lotsa-widgets.lisp	2008/06/16 12:35:56	1.12
@@ -37,7 +37,7 @@
                    (mk-label :text "aaa"
                      :image-files (list (list 'kt (data-pathname "kt69" "gif")))
                      :height 400
-                     :width 300
+                     :width 200
                      :image (c? (format nil "~(~a.~a~)" (ctk::^path) 'kt)))
                    
                    (assorted-canvas-items)
--- /project/cells/cvsroot/Celtk/run.lisp	2008/04/11 09:23:51	1.29
+++ /project/cells/cvsroot/Celtk/run.lisp	2008/06/16 12:35:56	1.30
@@ -29,11 +29,15 @@
 (defun run-window (root-class &optional (resetp t) &rest window-initargs)
   (assert (symbolp root-class))
   (setf *tkw* nil)
+  
   (when resetp
     (cells-reset 'tk-user-queue-handler))
   (tk-interp-init-ensure)
 
   (setf *tki* (Tcl_CreateInterp))
+  ;(break "ok?")
+  ;(deep)
+  
   ;; not recommended by Tcl doc (tcl-do-when-idle (get-callback 'tcl-idle-proc) 42)
   (tk-app-init *tki*)
   (tk-togl-init *tki*)
@@ -53,25 +57,28 @@
 
   (tcl-create-command *tki* "do-key-down" (get-callback 'do-on-key-down) (null-pointer) (null-pointer))
   (tcl-create-command *tki* "do-key-up" (get-callback 'do-on-key-up) (null-pointer) (null-pointer))
-
+  (tcl-create-command *tki* "do-double-click-1" (get-callback 'do-on-double-click-1) (null-pointer) (null-pointer))
+  (trc "integ" cells::*within-integrity*)
+  
   (with-integrity () ;; w/i somehow ensures tkwin slot gets populated
     (setf *app*
       (make-instance 'application
         :kids (c? (the-kids
                    (setf *tkw* (apply 'make-instance root-class
                                  :fm-parent *parent*
-                                 window-initargs))))
-        )))
+                                 window-initargs)))))))
   
   (assert (tkwin *tkw*))
   
   (tk-format `(:fini) "wm deiconify .")
-  (tk-format-now "bind . <Escape> {destroy .}")
+  #-its-alive! (tk-format-now "bind . <Escape> {destroy .}")
   ;
   ; see above for why we are converting key x-events to application key virtual events:
   ;
   (tk-format-now "bind . <KeyPress> {do-key-down %W %K}")
   (tk-format-now "bind . <KeyRelease> {do-key-up %W %K}")
+  (tk-format-now "bind . <Double-ButtonPress-1> {do-double-click-1 %W %K; break}")
+  
   (block nil
     (bwhen (ifn (start-up-fn *tkw*))
       (funcall ifn *tkw*))
@@ -152,6 +159,9 @@
              (otherwise
               (give-to-window)))))
         (otherwise (give-to-window)))
+      (bwhen (do (post-event-do self))
+        (setf (post-event-do self) nil)
+        (funcall do self))
       0)))
 
 ;; Our own event loop ! - Use this if it is desirable to do something
@@ -220,4 +230,5 @@
 ;
 (defcommand key-down)
 (defcommand key-up)
+(defcommand double-click-1)
 
--- /project/cells/cvsroot/Celtk/tk-object.lisp	2008/03/23 23:47:42	1.16
+++ /project/cells/cvsroot/Celtk/tk-object.lisp	2008/06/16 12:35:56	1.17
@@ -31,7 +31,9 @@
      :documentation "Long story. Tcl C API weak for keypress events. This gets dispatched
 eventually thanks to DEFCOMMAND")
    (on-key-up :initarg :on-key-up :accessor on-key-up :initform nil)
+   (on-double-click-1 :initarg :on-double-click-1 :accessor on-double-click-1 :initform nil)
    (user-errors :initarg :user-errors :accessor user-errors :initform nil)
+   
    (tile? :initform t :cell nil :reader tile? :initarg :tile?))
   (:documentation "Root class for widgets and (canvas) items"))
 
--- /project/cells/cvsroot/Celtk/tk-structs.lisp	2008/01/03 20:23:30	1.7
+++ /project/cells/cvsroot/Celtk/tk-structs.lisp	2008/06/16 12:35:56	1.8
@@ -162,6 +162,8 @@
 
 (defun xbe-x (xbe) (xbe x xbe))
 (defun xbe-y (xbe) (xbe y xbe))
+(defun xbe-button (xbe) (xbe button xbe))
+(export! xbe-x xbe-y xbe-button xbe)
 
 ;; --------------------------------------------
 

--- /project/cells/cvsroot/Celtk/notebook.lisp	2008/06/16 12:35:56	NONE
+++ /project/cells/cvsroot/Celtk/notebook.lisp	2008/06/16 12:35:56	1.1
(in-package :celtk)

;--- n o t e b o o k ----------------------------------------------

#+test
(test-nb)

(deftk notebook (widget decoration-mixin)
 ()
 (:tk-spec notebook
   -height -padding -width)
 (:default-initargs
     :id (gentemp "NB")
   :packing nil))

(defmethod make-tk-instance ((self notebook))
 (tk-format `(:make-tk ,self) "ttk::notebook ~a" (^path))
 (tk-format `(:pack ,self) "pack ~a -expand yes -fill both" (^path)))

(defobserver .kids ((self notebook))
 (loop for k in (^kids)
     do (trc "ttk::notebook adds" k (type-of k) (md-name k) (path k))
       (tk-format `(:post-make-tk ,self) "~a add ~a -text ~a"
                                         (^path)
                                         (path k)
                                         (text k))))

;--- t a b -----------------------------------------------------------

(deftk tab (frame-stack widget)
 ()
 (:tk-spec tab
   -state -sticky -padding -text -image)
 (:default-initargs
     :id (gentemp "TB")))


(defmacro mk-tab ((&rest inits) &body body)
 `(make-instance 'tab :fm-parent *parent* , at inits
                 :kids (c? (the-kids
                            , at body))))

(defmethod make-tk-instance ((self tab))
 (tk-format `(:make-tk ,self) "frame ~a" (^path)))

;--- example usage ---------------------------------------------------

(defmd nb-test (window)
 (kids (c? (the-kids
            (mk-notebook
             :width 100
             :kids (c? (the-kids
                        (mk-tab (:text "first")
                          (mk-stack ("tab with container")
                            (mk-label :text "hi")))
                        (mk-tab (:text "second")
                          (mk-label :text "a")
                          (mk-label :text "b")))))))))

(defun test-nb ()
 (test-window 'nb-test))



More information about the Cells-cvs mailing list