Update of /project/cells/cvsroot/cell-cultures/celtic In directory common-lisp.net:/tmp/cvs-serv28119/celtic Modified Files: canvas.lisp celtic.lisp celtic.lpr demos.lisp widget-item.lisp window.lisp Log Message: Now supporting all Tk menu types, all Tk widgets, and all Tk canvas items except image and window Date: Thu Sep 2 05:19:17 2004 Author: ktilton Index: cell-cultures/celtic/canvas.lisp diff -u cell-cultures/celtic/canvas.lisp:1.3 cell-cultures/celtic/canvas.lisp:1.4 --- cell-cultures/celtic/canvas.lisp:1.3 Wed Jul 21 13:49:38 2004 +++ cell-cultures/celtic/canvas.lisp Thu Sep 2 05:19:16 2004 @@ -32,29 +32,8 @@ -closeenough -confine -height -scrollregion -width -xscrollincrement -yscrollincrement)) -(def-item rectangle - (-dash - -activedash - -disableddash - -dashoffset - (tk-fill -fill) - -activefill - -disabledfill - -offset - -outline - -activeoutline - -disabledoutline - -outlinestipple - -activeoutlinestipple - -disabledoutlinestipple - -stipple - -activestipple - -disabledstipple - -state - -tags - -width - -activewidth - -disabledwidth)) +(def-item rectangle (standard-item)()) +(def-item oval (standard-item)()) (defun test-rectangle () (make-be 'canvas @@ -62,65 +41,41 @@ :coords (list 10 10 100 60) :tk-fill "red")))) -(def-item text - ((tk-fill -fill) - -activefill - -disabledfill - -stipple - -activestipple - -disabledstipple - -state - -tags - -anchor +(def-item text (standard-item) + (-anchor -font -justify -text -width)) +(def-item arc (standard-item) + (-extent -start -style)) -#| +(def-item bitmap (standard-item) + (-anchor + -background + -activebackground + -disabledbackground + -bitmap + -activebitmap + -disabledbitmap + -foreground + -activeforeground + -disabledforeground)) + +(def-item image (standard-item) + (-anchor + -image + -activeimage + -disabledimage)) -ARC ITEMS +(def-item line (standard-item) + (-arrow -arrowshape -capstyle -joinstyle -smooth -splinesteps)) -Items of type arc appear on the display as arc-shaped regions. An arc is a section of an oval delimited by two angles (specified by the -start and -extent options) and displayed in one of several ways (specified by the -style option). Arcs are created with widget commands of the following form: +(def-item polygon (standard-item) + (-joinstyle -smooth -splinesteps)) -pathName create arc x1 y1 x2 y2 ?option value option value ...? -pathName create arc coordList ?option value option value ...? - -The arguments x1, y1, x2, and y2 or coordList give the coordinates of two diagonally opposite corners of a rectangular region enclosing the oval that defines the arc. After the coordinates there may be any number of option-value pairs, each of which sets one of the configuration options for the item. These same option-value pairs may be used in itemconfigure widget commands to change the item's configuration. -The following standard options are supported by arcs: - --dash --activedash --disableddash --dashoffset --fill --activefill --disabledfill --offset --outline --activeoutline --disabledoutline --outlinestipple --activeoutlinestipple --disabledoutlinestipple --stipple --activestipple --disabledstipple --state --tags --width --activewidth --disabledwidth - -The following extra options are supported for arcs: - --extent degrees - Specifies the size of the angular range occupied by the arc. The arc's range extends for degrees degrees counter-clockwise from the starting angle given by the -start option. Degrees may be negative. If it is greater than 360 or less than -360, then degrees modulo 360 is used as the extent. --start degrees - Specifies the beginning of the angular range occupied by the arc. Degrees is given in units of degrees measured counter-clockwise from the 3-o'clock position; it may be either positive or negative. --style type - Specifies how to draw the arc. If type is pieslice (the default) then the arc's region is defined by a section of the oval's perimeter plus two line segments, one between the center of the oval and each end of the perimeter section. If type is chord then the arc's region is defined by a section of the oval's perimeter plus a single line segment connecting the two end points of the perimeter section. If type is arc then the arc's region consists of a section of the perimeter alone. In this last case the -fill option is ignored. +|# BITMAP ITEMS @@ -173,47 +128,6 @@ -activeimage name -disabledimage name Specifies the name of the images to display in the item in is normal, active and disabled states. This image must have been created previously with the image create command. - -LINE ITEMS - -Items of type line appear on the display as one or more connected line segments or curves. Line items support coordinate indexing operations using the canvas widget commands: dchars, index, insert. Lines are created with widget commands of the following form: - -pathName create line x1 y1... xn yn ?option value option value ...? -pathName create line coordList ?option value option value ...? - -The arguments x1 through yn or coordList give the coordinates for a series of two or more points that describe a series of connected line segments. After the coordinates there may be any number of option-value pairs, each of which sets one of the configuration options for the item. These same option-value pairs may be used in itemconfigure widget commands to change the item's configuration. -The following standard options are supported by lines: - --dash --activedash --disableddash --dashoffset --fill --activefill --disabledfill --stipple --activestipple --disabledstipple --state --tags --width --activewidth --disabledwidth - -The following extra options are supported for lines: - --arrow where - Indicates whether or not arrowheads are to be drawn at one or both ends of the line. Where must have one of the values none (for no arrowheads), first (for an arrowhead at the first point of the line), last (for an arrowhead at the last point of the line), or both (for arrowheads at both ends). This option defaults to none. --arrowshape shape - This option indicates how to draw arrowheads. The shape argument must be a list with three elements, each specifying a distance in any of the forms described in the COORDINATES section above. The first element of the list gives the distance along the line from the neck of the arrowhead to its tip. The second element gives the distance along the line from the trailing points of the arrowhead to the tip, and the third element gives the distance from the outside edge of the line to the trailing points. If this option isn't specified then Tk picks a ``reasonable'' shape. --capstyle style - Specifies the ways in which caps are to be drawn at the endpoints of the line. Style may have any of the forms accepted by Tk_GetCapStyle (butt, projecting, or round). If this option isn't specified then it defaults to butt. Where arrowheads are drawn the cap style is ignored. --joinstyle style - Specifies the ways in which joints are to be drawn at the vertices of the line. Style may have any of the forms accepted by Tk_GetCapStyle (bevel, miter, or round). If this option isn't specified then it defaults to miter. If the line only contains two points then this option is irrelevant. --smooth smoothMethod - smoothMethod must have one of the forms accepted by Tk_GetBoolean or a line smoothing method. Only bezier is supported in the core, but more can be added at runtime. If a boolean false value or empty string is given, no smoothing is applied. A boolean truth value assume bezier smoothing. It indicates whether or not the line should be drawn as a curve. If so, the line is rendered as a set of parabolic splines: one spline is drawn for the first and second line segments, one for the second and third, and so on. Straight-line segments can be generated within a curve by duplicating the end-points of the desired line segment. --splinesteps number - Specifies the degree of smoothness desired for curves: each spline will be approximated with number line segments. This option is ignored unless the -smooth option is true. OVAL ITEMS Index: cell-cultures/celtic/celtic.lisp diff -u cell-cultures/celtic/celtic.lisp:1.7 cell-cultures/celtic/celtic.lisp:1.8 --- cell-cultures/celtic/celtic.lisp:1.7 Wed Jul 21 13:49:38 2004 +++ cell-cultures/celtic/celtic.lisp Thu Sep 2 05:19:16 2004 @@ -19,6 +19,9 @@ |# +(eval-when (compile load) + (proclaim '(optimize (speed 2) (safety 3) (space 1) (debug 3)))) + (defpackage :celtic (:nicknames :ctk) (:use #:common-lisp #:utils-kt #:cells @@ -31,6 +34,8 @@ ;communication with wish ;;; this is the only function one needs to adapt to other lisps +(defparameter *ewish* nil) + (defun do-execute (program args &optional (wt nil)) "execute program with args a list containing the arguments passed to the program if wt is non-nil, the function will wait for the execution of the program to return. @@ -63,106 +68,22 @@ (process-output proc) (process-input proc)) ) - #+:lispworks (system:open-pipe fullstring :direction :io) - #+allegro (let ((proc (excl:run-shell-command - #+mswindows fullstring - #-mswindows (apply #'vector program program args) - :input :stream :output :stream :wait wt))) - (unless proc - (error "Cannot create process.")) - proc - ))) - -(defun convert(from to) - (close (do-execute "convert" (list from to) t))) - -;; tool functions used by the objects - -;; incremental counter to create unique numbers -(let ((counter 1)) - (defun tk-names-reset() - (setf counter 1)) - (defun get-counter() - (incf counter))) - -;; create unique widget name, append unique number to "w" -(defun create-name () - (format nil "w~A" (get-counter))) - -;;;; main event loop, runs until stream is closed by wish (wish exited) or -;;;; the variable *exit-tk-listen* is set - -(defvar *exit-tk-listen* nil) - -(defun tk-listen (window &optional exit-callback-id &aux (wish (wish window))) - (let ((*exit-tk-listen* nil) - (*read-eval* nil) ;;safety against malicious clients - (*readtable* (copy-readtable))) - (set-macro-character #\} (get-macro-character #\))) - (set-macro-character #\{ - #'(lambda (s c1) - (declare (ignore c1)) - (read-delimited-list #\} s t))) - - (loop - (let ((msg$ (read-line #+not read-preserving-whitespace wish nil nil))) - (when (null msg$) - (return)) - (trc nil "tk-listen> read:" msg$) - (loop with start = 0 - and state = 'init - and func and self and callback-id and args - for (msg start-next) = (multiple-value-list - (read-from-string msg$ nil nil :start start)) - while msg - do (setf start start-next) - (ecase state - (init - (case msg - (callback (setf state 'get-callback-id)) - (otherwise (c-break "TKERR> " msg$)))) - (get-callback-id - (assert msg) - (let ((callback-info (gethash msg (callbacks window)))) - (assert callback-info () "No callback with ID ~a" msg) - (setf callback-id msg - func (car callback-info) - self (cdr callback-info) - state 'get-args))) - (get-args - (pushnew msg args))) - finally - (setf args (nreverse args)) - (apply func self callback-id args) - (cond - (*exit-tk-listen* - (tk-send window "exit") - (return)) - ((And exit-callback-id ;; play it safe - (or (trc "comparing callback id" callback-id exit-callback-id - (eql callback-id exit-callback-id)) - (eql callback-id exit-callback-id))) - (return-from tk-listen)))))))) - -;; create pathname from master widget <master> and widget name <name> -(defun create-path (master name) - (let ((master-path (if master - (path master) - ""))) - (format nil "~A.~A" master-path name))) - -(defgeneric grid-columnconfigure (w c o v)) -(defmethod grid-columnconfigure (self column option value) - (tk-send self "grid columnconfigure ~a ~a -~a {~a}" (path self) column option value)) - -(defgeneric grid-rowconfigure (w r o v)) -(defmethod grid-rowconfigure (self row option value) - (tk-send self "grid rowconfigure ~a ~a -~a {~a}" (path self) row option value)) - -(defgeneric grid-configure (w o v)) -(defmethod grid-configure (self option value) - (tk-send self "grid configure ~a -~a {~a}" (path self) option value)) + #+:lispworks (system:open-pipe fullstring :direction :io) + #+allegro (multiple-value-bind (stream error-stream process-id) + (excl:run-shell-command + #+mswindows fullstring + #-mswindows (apply #'vector program program args) + :input :stream :output :stream + :error-output :stream + :wait wt) + (declare (ignorable dummy error-stream process-id)) + (trc "doexec!!!> " stream error-stream process-id) + (if stream + (progn + (setf *ewish* error-stream) + stream) + (error "Cannot create WISH process."))))) Index: cell-cultures/celtic/celtic.lpr diff -u cell-cultures/celtic/celtic.lpr:1.6 cell-cultures/celtic/celtic.lpr:1.7 --- cell-cultures/celtic/celtic.lpr:1.6 Wed Jul 21 13:49:38 2004 +++ cell-cultures/celtic/celtic.lpr Thu Sep 2 05:19:16 2004 @@ -7,6 +7,7 @@ (define-project :name :celtic :application-type (intern "Standard EXE" (find-package :keyword)) :modules (list (make-instance 'module :name "celtic.lisp") + (make-instance 'module :name "celtic2.lisp") (make-instance 'module :name "widget-item.lisp") (make-instance 'module :name "window.lisp") (make-instance 'module :name "frame.lisp") @@ -47,7 +48,7 @@ :old-space-size 256000 :new-space-size 6144 :runtime-build-option :standard - :on-initialization 'nowtest + :on-initialization 'celtic::tk-test-all :on-restart 'do-default-restart) ;; End of Project Definition Index: cell-cultures/celtic/demos.lisp diff -u cell-cultures/celtic/demos.lisp:1.3 cell-cultures/celtic/demos.lisp:1.4 --- cell-cultures/celtic/demos.lisp:1.3 Wed Jul 21 13:49:38 2004 +++ cell-cultures/celtic/demos.lisp Thu Sep 2 05:19:16 2004 @@ -26,6 +26,7 @@ (tk-names-reset) (tk-listen (make-be root-class))) +(defun tk-test-all ()(tk-test 'all)) (defun mk-font-view () (make-be 'font-view)) @@ -38,6 +39,37 @@ (mk-frame-stack :layout (pack-self) :kids (c? (list + (mk-canvas + :kids (c? (list + (mk-rectangle + :coords (list 10 10 100 60) + :tk-fill "red") + (mk-text + :coords (list 100 80) + :text "i am an item" + :tk-fill 'blue) + (mk-arc + :coords (list 10 100 100 160) + :start 45 + :tk-fill "white") + (mk-line + :width 8 + :smooth 'bezier + :joinstyle 'miter + :coords (list 250 10 300 40 250 70 400 100) + :arrow 'both) + (mk-oval + :coords (list 10 200 100 260) + :tk-fill "yellow") + (mk-polygon + :width 4 + :tk-fill 'green + :smooth 'bezier + :joinstyle 'miter + :coords (list 250 210 300 220 340 200 260 180)) + (mk-bitmap + :coords (list 40 300) + :bitmap "@\\temp\\gsl.xbm")))) (mk-labelframe-row :text "Style by Edit Menu" ;;:layout (pack-layout? "-side left -fill x -expand 1") @@ -116,6 +148,26 @@ (selection (fm^ :font-face)) (md-value (fm^ :font-size))))))))) +#| +-defaultextension + Specifies a string that will be appended to the filename if the user enters a filename without an extension. The defaut value is the empty string, which means no extension will be appended to the filename in any case. This option is ignored on the Macintosh platform, which does not require extensions to filenames, and the UNIX implementation guesses reasonable values for this from the -filetypes option when this is not supplied. +-filetypes filePatternList + If a File types listbox exists in the file dialog on the particular platform, this option gives the filetypes in this listbox. When the user choose a filetype in the listbox, only the files of that type are listed. If this option is unspecified, or if it is set to the empty list, or if the File types listbox is not supported by the particular platform then all files are listed regardless of their types. See the section SPECIFYING FILE PATTERNS below for a discussion on the contents of filePatternList. +-initialdir directory + Specifies that the files in directory should be displayed when the dialog pops up. If this parameter is not specified, then the files in the current working directory are displayed. If the parameter specifies a relative path, the return value will convert the relative path to an absolute path. This option may not always work on the Macintosh. This is not a bug. Rather, the General Controls control panel on the Mac allows the end user to override the application default directory. +-initialfile filename + Specifies a filename to be displayed in the dialog when it pops up. This option is ignored on the Macintosh platform. +-multiple + Allows the user to choose multiple files from the Open dialog. On the Macintosh, this is only available when Navigation Services are installed. +-message string + Specifies a message to include in the client area of the dialog. This is only available on the Macintosh, and only when Navigation Services are installed. +-parent window + Makes window the logical parent of the file dialog. The file dialog is displayed on top of its parent window. +-title titleString + Specifies a string to display as the title of the dialog box. If this option is not specified, then a default title is displayed. + +|# + (defun demo-all-menubar () (mk-menubar :kids (c? (list @@ -127,12 +179,12 @@ (mk-menu-entry-command :label "New" :command "exit") (mk-menu-entry-command :label "Open" - :command "exit") + :command "tk_getOpenFile") (mk-menu-entry-command :label "Close" :command "exit") (mk-menu-entry-separator) (mk-menu-entry-command :label "Quit" - :state (c? (if (md-value (fm^ :check-me)) + :state (c? (if t ;; (md-value (fm^ :check-me)) 'normal 'disabled)) :command "exit"))))))) (mk-menu-entry-cascade Index: cell-cultures/celtic/widget-item.lisp diff -u cell-cultures/celtic/widget-item.lisp:1.8 cell-cultures/celtic/widget-item.lisp:1.9 --- cell-cultures/celtic/widget-item.lisp:1.8 Wed Jul 21 13:49:38 2004 +++ cell-cultures/celtic/widget-item.lisp Thu Sep 2 05:19:16 2004 @@ -178,7 +178,7 @@ (coords :initarg :coords :initform nil)) (:documentation "not full blown widgets, but decorations thereof") (:default-initargs - :name (c-in nil) ;; assigned by Tk upon creation + ;;:name (c-in nil) ;; assigned by Tk upon creation )) (defmethod not-to-be :after ((self item)) @@ -187,14 +187,16 @@ (defmethod make-tk-instance :after ((self item)) (setf (id-no self) (let ((msg (tk-read self))) + (unless (parse-integer msg) + (break "Error creating item ~a : ~a" self msg)) (trc "created item" self :id msg) (read-from-string msg)))) (defmethod configure ((self item) option value) (assert (id-no self) () "cannot configure item until instantiated and id obtained") - (tk-send self "~A itemconfigure ~a ~a {~a}" (path .parent) (id-no self) option value)) + (tk-send self "~A itemconfigure ~a ~a {~a}" (path .parent) (id-no self) (down$ option) value)) -(defmacro def-item (class (&rest tk-options)) +(defmacro def-item (class (&rest superclasses)(&rest tk-options)) (multiple-value-bind (slots outputs) (loop for tk-option-def in tk-options for tk-option = (if (atom tk-option-def) @@ -213,7 +215,7 @@ into outputs finally (return (values slot-defs outputs))) `(progn - (defmodel ,class (item) + (defmodel ,class ,(or superclasses '(item)) (,@slots)) (defun ,(intern (conc$ "MK-" (symbol-name class))) (&rest inits) (apply 'make-instance ',class inits)) @@ -227,3 +229,28 @@ (when (and (id-no self) new-value) (tk-send self "~a coords ~a ~{ ~a~}" (path .parent) (id-no self) new-value))) + + +(def-item standard-item () + (-dash + -activedash + -disableddash + -dashoffset + (tk-fill -fill) + -activefill + -disabledfill + -offset + -outline + -activeoutline + -disabledoutline + -outlinestipple + -activeoutlinestipple + -disabledoutlinestipple + -stipple + -activestipple + -disabledstipple + -state + -tags + -width + -activewidth + -disabledwidth)) \ No newline at end of file Index: cell-cultures/celtic/window.lisp diff -u cell-cultures/celtic/window.lisp:1.2 cell-cultures/celtic/window.lisp:1.3 --- cell-cultures/celtic/window.lisp:1.2 Wed Jul 21 13:49:38 2004 +++ cell-cultures/celtic/window.lisp Thu Sep 2 05:19:16 2004 @@ -66,10 +66,14 @@ ; -------------------------------------------------------- + + (defmodel window (family) ((wish :initarg :wish :accessor wish - :initform (c? (do-execute "wish" - (list (format nil "-name ~s" (title$ self)))))) + :initform (c? (do-execute "wish84" + nil #+not (list (format nil "-name ~s" (title$ self)))))) + (ewish :initarg :ewish :accessor ewish + :initform nil :cell nil) (title$ :initarg :title$ :accessor title$ :initform (c? (string (class-name (class-of self))))) (dictionary :initarg :dictionary :initform (make-hash-table) :accessor dictionary) @@ -86,7 +90,7 @@ "send a string to wish" (let ((text (apply 'format nil fmt$ args))) (when (find-if (lambda (s) (search s text)) - '(".font-size" )) ;; *debug-tk* + '("100" )) ;; *debug-tk* (format t "~&tk-send> ~A~%" text)) (format (wish .tkw) "~A~%" text) #+needed? (force-output (wish .tkw))))