[cells-cvs] CVS Celtk
ktilton
ktilton at common-lisp.net
Thu Mar 16 05:15:15 UTC 2006
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 at nyc.rr.com>"
:version "2.0"
:maintainer "Kenny Tilton <ktilton at 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 at 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*
, at inits))
, at 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]
More information about the Cells-cvs
mailing list