[cells-cvs] CVS update: cell-cultures/celtic/button.lisp cell-cultures/celtic/celtic.lisp cell-cultures/celtic/celtic.lpr cell-cultures/celtic/frame.lisp cell-cultures/celtic/ctk-test.lisp cell-cultures/celtic/visual-apropos.lisp

[Kenny Tilton]

Update of /project/cells/cvsroot/cell-cultures/celtic
In directory common-lisp.net:/tmp/cvs-serv23697/celtic

Modified Files:
	button.lisp celtic.lisp celtic.lpr frame.lisp 
Removed Files:
	ctk-test.lisp visual-apropos.lisp 
Log Message:

Date: Sun Jun 27 16:54:29 2004
Author: ktilton

Index: cell-cultures/celtic/button.lisp
diff -u cell-cultures/celtic/button.lisp:1.1 cell-cultures/celtic/button.lisp:1.2
--- cell-cultures/celtic/button.lisp:1.1	Sat Jun 26 11:38:38 2004
+++ cell-cultures/celtic/button.lisp	Sun Jun 27 16:54:28 2004
@@ -34,8 +34,6 @@
      (-command nil)
       -compound -default -height -overrelief -state -width))
 
-
-
 (defun test-button ()
   (make-be 'button :text (format nil "Time is ~a" (get-internal-real-time))
     :width 48
@@ -58,6 +56,11 @@
     -overrelief -selectcolor -selectimage -state -tristateimage 
     -tristatevalue (-tk-variable -variable) -width))
 
+(def-c-output .md-value ((self checkbutton))
+  (tk-send (format nil "set ~a ~a"
+               (down$ (md-name self))
+               (if new-value 1 0))))
+
 (def-widget radiobutton ()
   (-activebackground -activeforeground -anchor -background
     -bitmap -borderwidth -cursor -disabledforeground
@@ -70,7 +73,6 @@
     -overrelief -selectcolor -selectimage -state -tristateimage 
     -tristatevalue (-tk-variable -variable) -width)
   (:default-initargs
-      :value (c? (eql self (selection (upper self selector))))
       :command  (lambda (self)
                   (setf (selection (upper self selector)) self))))
 


Index: cell-cultures/celtic/celtic.lisp
diff -u cell-cultures/celtic/celtic.lisp:1.1 cell-cultures/celtic/celtic.lisp:1.2
--- cell-cultures/celtic/celtic.lisp:1.1	Sat Jun 26 11:38:38 2004
+++ cell-cultures/celtic/celtic.lisp	Sun Jun 27 16:54:28 2004
@@ -88,7 +88,7 @@
 
 (defun tk-send (text)
   "send a string to wish"
-  (when t ;;*debug-tk*
+  (when *debug-tk*
     (format t "~&tk-send> ~A~%" text)
     (force-output))
   (format *w* "~A~%" text)


Index: cell-cultures/celtic/celtic.lpr
diff -u cell-cultures/celtic/celtic.lpr:1.1 cell-cultures/celtic/celtic.lpr:1.2
--- cell-cultures/celtic/celtic.lpr:1.1	Sat Jun 26 11:38:38 2004
+++ cell-cultures/celtic/celtic.lpr	Sun Jun 27 16:54:28 2004
@@ -11,9 +11,7 @@
                  (make-instance 'module :name "frame.lisp")
                  (make-instance 'module :name "canvas.lisp")
                  (make-instance 'module :name "textual.lisp")
-                 (make-instance 'module :name "button.lisp")
-                 (make-instance 'module :name "ps-test.lisp")
-                 (make-instance 'module :name "visual-apropos.lisp"))
+                 (make-instance 'module :name "button.lisp"))
   :projects (list (make-instance 'project-module :name
                                  "c:\\dvl\\cells\\cells"))
   :libraries nil


Index: cell-cultures/celtic/frame.lisp
diff -u cell-cultures/celtic/frame.lisp:1.1 cell-cultures/celtic/frame.lisp:1.2
--- cell-cultures/celtic/frame.lisp:1.1	Sat Jun 26 11:38:38 2004
+++ cell-cultures/celtic/frame.lisp	Sun Jun 27 16:54:28 2004
@@ -21,7 +21,6 @@
 
 (in-package :celtic)
 
-
 (def-widget frame ()
   (-borderwidth -cursor	-highlightbackground -highlightcolor
     -highlightthickness -padx -pady -relief
@@ -60,6 +59,12 @@
                            :cursor "hand2"
                            :font "Courier"))))
 
+; ------------------------------------------------------------------
+
+(defmodel labelframe-selector (selector labelframe)())
+(defun labelframe-selector (&rest init-args)
+  (apply 'make-instance 'labelframe-selector init-args))
+
 ;-------------------------------------------------------
 
 (defun layout-row ()
@@ -67,7 +72,7 @@
                       (path self) (mapcar 'path (^kids)))))
 
 (defun layout-stack ()
-  (c? (format nil "pack ~a -side {left}; pack~{ ~a~} -side {top}"
+  (c? (format nil "pack ~a -side {left}; pack~{ ~a~} -side {top} -anchor nw"
                       (path self) (mapcar 'path (^kids)))))
 
 (defmacro frame-row ((&rest options) &rest kids)
@@ -79,3 +84,34 @@
   `(frame ,@(append options
              `(:layout (layout-stack)
                 :kids (c? (list , at kids))))))
+
+;------------------------------------------------------
+
+(defmodel selector ()
+  ((selection :accessor selection :initarg :selection)
+   (initial-selection :initform nil :reader initial-selection
+     :initarg :initial-selection)
+   (tk-variable :cell nil :accessor tk-variable :initarg :tk-variable))
+   (:default-initargs
+    :selection (c-in nil)))
+
+(def-c-output initial-selection ()
+  (setf (selection self) new-value))
+
+(def-c-output selection ()
+  (when new-value
+    (tk-send (format nil "set ~a ~a"
+               (down$ (tk-variable self))
+               (down$ (md-name new-value))))))
+
+;---------------------------------------------------------
+
+(defmodel radiogroup (selector)
+  ((tk-variable :accessor tk-variable :initarg :tk-variable))
+  (:default-initargs
+      :tk-variable (c? (md-name self))))
+
+(defmodel labelframe-radiogroup (radiogroup labelframe)())
+(defun labelframe-radiogroup (&rest init-args)
+  (apply 'make-instance 'labelframe-radiogroup init-args))
+