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 ,@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)) +