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

Added Files: CELTK.lpr Celtk.asd Celtk.lisp canvas.lisp composites.lisp demos.lisp kt69.gif load.lisp ltk-kt.lisp menu.lisp textual.lisp tk-format.lisp widgets.lisp Log Message: Initial release of a portable Common Lisp GUI, with Cells and LTk Inside

--- /project/cells/cvsroot/Celtk/CELTK.lpr 2006/03/16 05:15:14 NONE +++ /project/cells/cvsroot/Celtk/CELTK.lpr 2006/03/16 05:15:14 1.1 ;; -*- lisp-version: "8.0 [Windows] (Mar 7, 2006 20:04)"; cg: "1.81"; -*-

(in-package :cg-user)

(defpackage :CELTK)

(define-project :name :celtk :modules (list (make-instance 'module :name "ltk-kt.lisp") (make-instance 'module :name "notes.lisp") (make-instance 'module :name "Celtk.lisp") (make-instance 'module :name "tk-format.lisp") (make-instance 'module :name "menu.lisp") (make-instance 'module :name "composites.lisp") (make-instance 'module :name "textual.lisp") (make-instance 'module :name "widgets.lisp") (make-instance 'module :name "canvas.lisp") (make-instance 'module :name "demos.lisp")) :projects (list (make-instance 'project-module :name "..\cells\cells")) :libraries nil :distributed-files nil :internally-loaded-files nil :project-package-name :celtk :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 'celtk::tk-test :on-restart 'do-default-restart)

;; End of Project Definition --- /project/cells/cvsroot/Celtk/Celtk.asd 2006/03/16 05:15:14 NONE +++ /project/cells/cvsroot/Celtk/Celtk.asd 2006/03/16 05:15:14 1.1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-

#+(or allegro lispworks cmu mcl clisp cormanlisp sbcl scl) (progn (declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))))

(asdf:defsystem :celtk :name "celtk" :author "Kenny Tilton ktilton@nyc.rr.com" :version "2.0" :maintainer "Kenny Tilton ktilton@nyc.rr.com" :licence "MIT Style" :description "Tk via LTk with Cells Inside(tm)" :long-description "A Cells-driven portable GUI built atop the LTk core, ultimately implmented by Tk" :depends-on (:cells) :serial t :components ((:file "ltk-kt") (:file "Celtk") (:file "tk-format") (:file "menu") (:file "composites") (:file "textual") (:file "widgets") (:file "canvas") (:file "demos"))) --- /project/cells/cvsroot/Celtk/Celtk.lisp 2006/03/16 05:15:14 NONE +++ /project/cells/cvsroot/Celtk/Celtk.lisp 2006/03/16 05:15:14 1.1 #|

Celtic / widget.lisp : Foundation classes

Copyright (c) 2004 by Kenneth William Tilton ktilton@nyc.rr.com

A work derived from Peter Herth's LTk. As a derived work, usage is governed by LTk's "Lisp LGPL" licensing:

You have the right to distribute and use this software as governed by the terms of the Lisp Lesser GNU Public License (LLGPL):

(http://opensource.franz.com/preamble.html)

This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the Lisp Lesser GNU Public License for more details.

|#

(defpackage :celtk (:nicknames "CTK") (:use :common-lisp :utils-kt :cells)

(:import-from #:ltk #:wish-stream #:*wish* #:*ewish* "*DEBUG-TK*" #:peek-char-no-hang #:read-data #:send-wish #:tkescape #:with-ltk #:do-execute #:add-callback)

(:export #:window #:panedwindow #:mk-row #:pack-self #:mk-stack #:mk-text-widget #:mk-panedwindow #:mk-stack #:mk-radiobutton #:mk-radiobutton-ex #:mk-radiobutton #:mk-label #:selection #:selector #:mk-checkbutton #:mk-button #:mk-button-ex #:mk-entry #:frame-stack #:mk-frame-stack #:pack-layout? #:path #:mk-menu-entry-radiobutton #:mk-menu-entry-checkbutton #:mk-menu-radio-group #:mk-menu-entry-separator #:mk-menu-entry-command #:tk-callback #:mk-menu #:mk-menu-entry-cascade #:mk-menubar #:^entry-values #:tk-eval-list #:mk-scale #:mk-popup-menubutton #:mk-polygon #:mk-oval #:mk-line #:mk-arc #:mk-text-item #:mk-rectangle #:mk-bitmap #:mk-canvas #:mk-frame-row #:mk-scrolled-list #:listbox-item #:mk-spinbox #:with-ltk #:tk-format #:send-wish #:value #:.tkw #:tk-user-queue-handler))

(defpackage :celtk-user (:use :common-lisp :utils-kt :cells :celtk))

(in-package :Celtk)

(defmodel tk-object (model) ((.md-name :cell nil :initform (gentemp "TK") :initarg :id) (tk-class :cell nil :initform nil :initarg :tk-class :reader tk-class)))

(defmethod md-awaken :before ((self tk-object)) (make-tk-instance self))

(define-symbol-macro .tkw (nearest self window))

;;; --- widget -----------------------------------------

(defmodel widget (family tk-object) ((path :accessor path :initarg :path :initform (c? (trc nil "path calc" self (parent-path (fm-parent self)) (md-name self)) (format nil "~(~a.~a~)" (parent-path (fm-parent self)) (md-name self)))) (layout :reader layout :initarg :layout :initform nil) (enabled :reader enabled :initarg :enabled :initform t) (bindings :reader bindings :initarg :bindings :initform nil) (image-files :reader image-files :initarg :image-files :initform nil) (selector :reader selector :initarg :selector :initform (c? (upper self selector)))) (:default-initargs :id (gentemp "W")))

(defmethod make-tk-instance ((self widget)) (setf (gethash (^path) (dictionary .tkw)) self) (when (tk-class self) (tk-format `(:make-tk ,self) "~(~a~) ~a ~{~(~a~) ~a~^ ~}" (tk-class self) (path self)(tk-configurations self)) :stdfctry))

;;;(defmethod md-awaken :before ((self widget)) ;;; (loop for (name file-pathname) in (^image-files) ;;; do (tk-format "image create photo ~(~a.~a~) -file ~a" ;;; (^path) name (tkescape (namestring file-pathname)))))

(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)))))

(defobserver bindings () ;;; (w widget) event fun) (loop for (event fmt fn) in new-value for name = (gentemp "BNDG") do (tk-format `(:bind ,self) "bind ~a ~a ~a" ;; {puts {:callback ~a}}" (^path) event (format nil fmt (register-callback self name fn)))))

(defobserver layout ((self widget)) (when new-value (assert (null (kids-layout .parent)) () "Do not specify layout (here for ~a) unless parent leaves kids-layout unspecified. This parent is ~a, kids-layout ~a" self (list .parent (type-of .parent)) (kids-layout .parent))) ; ; This use next of the parent instead of self is pretty tricky. It has to do with getting ; the pack commands out nested widgets before parents. The pack command issued on behalf ; of a top frame is sorted on the parent. Now we have to pack the top frame. If we associate ; the command with the frame, the sort is a tie and either might go first. So we continue ; the theme and associate /this/ pack with this top frame's parent. Note that we cannot go the ; normal route and pack the kids in their own context, because multiple kids get packed ; in one pack statement (and we cannot arbitrarily pack with the first kid because this is a nested ; deal and any kid might have kids, so each family packs associated with itself) ; (when (and new-value (not (typep .parent 'panedwindow))) (tk-format `(:pack ,(fm-parent self)) new-value)))

(defun pack-self () (c? (format nil "pack ~a" (path self))))

(defmethod tk-configure ((self widget) option value) (tk-format `(:configure ,self ,option) "~A configure ~(~a~) ~a" (path self) option (tk-send-value value)))

(defmethod not-to-be :after ((self widget)) (trc nil "not-to-be tk-forgetting true widget" self) (tk-format `(:forget ,self) "pack forget ~a" (^path)) (tk-format `(:destroy ,self) "destroy ~a" (^path)))

;;; --- items -----------------------------------------------------------------------

(defmodel item (tk-object) ((id-no :cell nil :initarg :id-no :accessor id-no :initform nil) (coords :initarg :coords :initform nil)) (:documentation "not full blown widgets, but decorations thereof") (:default-initargs :id (gentemp "I")))

(defmethod make-tk-instance ((self item)) (when (tk-class self) (with-integrity (:client `(:make-tk ,self)) (tk-format :grouped "senddata [~a create ~a ~{ ~a~} ~{~(~a~) ~a~^ ~}]" (path .parent) (down$ (tk-class self)) (coords self) (tk-configurations self)) (setf (id-no self) (read-data)))))

(defmethod tk-configure ((self item) option value) (assert (id-no self) () "cannot configure item ~a until instantiated and id obtained" self) (tk-format `(:itemconfigure ,self ,option) "~A itemconfigure ~a ~a {~a}" (path .parent) (id-no self) (down$ option) value))

(defobserver coords () (when (and (id-no self) new-value) (tk-format `(:coords ,self) "~a coords ~a ~{ ~a~}" (path .parent) (id-no self) new-value)))

(defmethod not-to-be :after ((self item)) (trc nil "whacking item" self) (tk-format `(:delete ,self) "~a delete ~a" (path (upper self widget)) (id-no self)))

(defparameter *tk-changers* nil)

;;; --- deftk --------------------

(defmacro deftk (class superclasses (&rest std-slots) &rest defclass-options) (destructuring-bind (&optional tk-class &rest tk-options) (cdr (find :tk-spec defclass-options :key 'car))

(setf tk-options (tk-options-normalize tk-options))

(multiple-value-bind (slots outputs) (loop for (slot-name tk-option) in tk-options collecting `(,slot-name :initform nil :initarg ,(intern (string slot-name) :keyword) :accessor ,slot-name) into slot-defs when tk-option collecting `(defobserver ,slot-name ((self ,class)) (when (and new-value old-value-boundp) (tk-configure self ,(string tk-option) new-value))) into outputs finally (return (values slot-defs outputs))) `(progn (defmodel ,class ,(or superclasses '(widget)) (,@(append std-slots slots)) ,@(remove-if (lambda (k) (find k '(:default-initargs :tk-spec))) defclass-options :key 'car) (:default-initargs ,@(when tk-class `(:tk-class ',tk-class)) ,@(cdr (find :default-initargs defclass-options :key 'car)))) (defmethod tk-class-options append ((self ,class)) ',tk-options) (defmacro ,(intern (conc$ "MK-" (symbol-name class))) (&rest inits) `(make-instance ',',class :fm-parent *parent* ,@inits)) ,@outputs))))

(defun tk-options-normalize (tk-options) "normalize '(-aaa (tk-bbb -bbb)) => '((aaa -aaa)(tk-bbb -bbb))" (loop for tk-option-def in tk-options for slot-name = (intern (de- (if (atom tk-option-def) tk-option-def (car tk-option-def)))) collecting (list slot-name (if (atom tk-option-def) tk-option-def (cadr tk-option-def)))))

(eval-when (compile load eval) (defun de- (sym) (remove #- (symbol-name sym) :end 1)))

(defgeneric tk-class-options (self) (:method-combination append))

(defun tk-configurations (self) (loop for (slot-name tk-option) in (remove-duplicates (tk-class-options self) :key 'second) for slot-value = (funcall slot-name self) ;; must go thru accessor with Cells, cannot (slot-value self slot-name) when (and tk-option slot-value) nconcing (list tk-option (tk-send-value slot-value))))

; --- callbacks ----------------------------------------------------

(defun tk-callback (self id-suffix fn &optional command) (declare (ignorable command)) (let ((id (register-callback self id-suffix fn))) (trc nil "tk-callback" self id command) (list 'callback id)))

(defun tk-callbackstring (self id-suffix tk-token fn) (format nil "callbackstring ~s ~a; return 1;" (register-callback self id-suffix fn) (string tk-token)))

(defun tk-callbackstring-x (self id-suffix tk-token fn) (format nil "callbackstring ~s ~a" (register-callback self id-suffix fn) (string tk-token)))

(defun tk-callbackval (self id-suffix fn &optional command) (declare (ignorable command)) (format nil (or command "callbackval ~s") (register-callback self id-suffix fn)))

(defun register-callback (self callback-id fun) (assert callback-id) (let ((id (format nil "~a.~a" (path-index self) callback-id))) ;; (trc "registering callback" self :id (type-of id) id) (add-callback id fun) id))

(defmethod path-index (self) (^path))

(defun tk-eval-var (var) (tk-format :grouped "senddatastring [set ~a]" var) (read-data))

(defun tk-eval-list (self form$) (declare (ignore self)) (tk-format :grouped "senddatastrings [~a]" form$) (read-data))

;--- selector ---------------------------------------------------

(defmodel selector () ;; mixin ((selection :initform nil :accessor selection :initarg :selection) (tk-variable :initform nil :accessor tk-variable :initarg :tk-variable :documentation "The TK node name to set as the selection changes (not the TK -variable option)")) (:default-initargs :selection (c-in nil) :tk-variable (c? (^path))))

(defobserver selection () ; ; handling varies on this, so we hand off to standard GF lest the PROGN ; method combo on slot-listener cause multiple handling ; (tk-output-selection self new-value old-value old-value-boundp))

[9 lines skipped] --- /project/cells/cvsroot/Celtk/canvas.lisp 2006/03/16 05:15:15 NONE +++ /project/cells/cvsroot/Celtk/canvas.lisp 2006/03/16 05:15:15 1.1

[215 lines skipped] --- /project/cells/cvsroot/Celtk/composites.lisp 2006/03/16 05:15:15 NONE +++ /project/cells/cvsroot/Celtk/composites.lisp 2006/03/16 05:15:15 1.1

[385 lines skipped] --- /project/cells/cvsroot/Celtk/demos.lisp 2006/03/16 05:15:15 NONE +++ /project/cells/cvsroot/Celtk/demos.lisp 2006/03/16 05:15:15 1.1

[723 lines skipped] --- /project/cells/cvsroot/Celtk/kt69.gif 2006/03/16 05:15:15 NONE +++ /project/cells/cvsroot/Celtk/kt69.gif 2006/03/16 05:15:15 1.1

[1066 lines skipped] --- /project/cells/cvsroot/Celtk/load.lisp 2006/03/16 05:15:15 NONE +++ /project/cells/cvsroot/Celtk/load.lisp 2006/03/16 05:15:15 1.1

[1082 lines skipped] --- /project/cells/cvsroot/Celtk/ltk-kt.lisp 2006/03/16 05:15:15 NONE +++ /project/cells/cvsroot/Celtk/ltk-kt.lisp 2006/03/16 05:15:15 1.1

[4453 lines skipped] --- /project/cells/cvsroot/Celtk/menu.lisp 2006/03/16 05:15:15 NONE +++ /project/cells/cvsroot/Celtk/menu.lisp 2006/03/16 05:15:15 1.1

[4715 lines skipped] --- /project/cells/cvsroot/Celtk/textual.lisp 2006/03/16 05:15:15 NONE +++ /project/cells/cvsroot/Celtk/textual.lisp 2006/03/16 05:15:15 1.1

[4834 lines skipped] --- /project/cells/cvsroot/Celtk/tk-format.lisp 2006/03/16 05:15:15 NONE +++ /project/cells/cvsroot/Celtk/tk-format.lisp 2006/03/16 05:15:15 1.1

[4956 lines skipped] --- /project/cells/cvsroot/Celtk/widgets.lisp 2006/03/16 05:15:15 NONE +++ /project/cells/cvsroot/Celtk/widgets.lisp 2006/03/16 05:15:15 1.1

[5206 lines skipped]