[cells-cvs] CVS Celtk
ktilton
ktilton at common-lisp.net
Sat May 13 14:36:58 UTC 2006
Update of /project/cells/cvsroot/Celtk
In directory clnet:/tmp/cvs-serv26494
Added Files:
Gears.lpr lotsa-widgets.lisp tk-events.lisp
Log Message:
--- /project/cells/cvsroot/Celtk/Gears.lpr 2006/05/13 14:36:58 NONE
+++ /project/cells/cvsroot/Celtk/Gears.lpr 2006/05/13 14:36:58 1.1
;; -*- lisp-version: "8.0 [Windows] (May 5, 2006 15:39)"; cg: "1.81"; -*-
(in-package :cg-user)
(defpackage :GEARS)
(define-project :name :gears
:modules (list (make-instance 'module :name "gears.lisp"))
:projects (list (make-instance 'project-module :name "CELTK")
(make-instance 'project-module :name
"C:\\0devtools\\cl-opengl\\glu"))
:libraries nil
:distributed-files nil
:internally-loaded-files nil
:project-package-name :gears
: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 'gears::gears
:on-restart 'do-default-restart)
;; End of Project Definition
--- /project/cells/cvsroot/Celtk/lotsa-widgets.lisp 2006/05/13 14:36:58 NONE
+++ /project/cells/cvsroot/Celtk/lotsa-widgets.lisp 2006/05/13 14:36:58 1.1
(in-package :celtk-user)
(defmodel lotsa-widgets (window)
()
(:default-initargs
:kids (c? (the-kids
(demo-all-menubar)
(mk-row (:packing (c?pack-self))
(mk-label :text "aaa"
:image-files (list (list 'kt (make-pathname #+lispworks :host #-lispworks :device "c"
:directory '(:absolute "0dev" "Celtk")
:name "kt69" :type "gif")))
:height 200
:width 300
:image (c? (format nil "~(~a.~a~)" (ctk::^path) 'kt)))
(assorted-canvas-items)
(mk-stack ()
(mk-text-widget
:id :my-text
:md-value (c?n "hello, world")
:height 8
:width 25)
(spin-package-with-symbols))
(mk-stack ()
(mk-row (:id :radio-ny :selection (c-in 'yes))
(mk-radiobutton-ex ("yes" 'yes))
(mk-radiobutton-ex ("no" 'no))
(mk-label :text (c? (string (selection (upper self selector))))))
(mk-row ()
(mk-checkbutton :id :check-me
:text "Check Me"
:md-value (c-in t))
(mk-label :text (c? (if (fm^v :check-me) "checked" "unchecked"))))
(mk-row ()
(mk-button-ex ("Time now?" (setf (fm^v :push-time)
(get-universal-time))))
(mk-label :text (c? (time-of-day (^md-value)))
:id :push-time
:md-value (c-in (get-universal-time))))
(style-by-edit-menu)
(style-by-widgets)
(mk-row (:layout-anchor 'sw)
(mk-entry
:id :enter-me)
(mk-label :text (c? (conc$ "echo " (fm^v :enter-me))))))
(duelling-scrolled-lists)
)))))
(defun style-by-edit-menu ()
(mk-row ("Style by Edit Menu")
(mk-label :text "Four score and seven years ago today"
:wraplength 600
:tkfont (c? (list
(selection (fm^ :app-font-face))
(selection (fm^ :app-font-size))
(if (fm^v :app-font-italic)
'italic 'roman)
(if (fm^v :app-font-bold)
'bold 'normal))))))
(defun spin-package-with-symbols ()
(mk-stack ()
(mk-spinbox
:id :spin-pkg
:md-value (cells::c?n "cells")
:tk-values (mapcar 'down$
(sort (mapcar 'package-name
(list-all-packages))
'string>)))
(mk-scrolled-list
:id :spinpkg-sym-list
:list-height 6
:list-item-keys (c? (let* ((spinner (fm^ :spin-pkg))
(item (when spinner (md-value spinner)))
(pkg (find-package (string-upcase item))))
(when pkg
(loop for sym being the symbols in pkg
for n below 25
counting sym into symct
collecting sym into syms
finally (trc "syms found !!!" symct)
(return syms)))))
:list-item-factory (lambda (sym)
(make-instance 'listbox-item
:fm-parent *parent*
:md-value sym
:item-text (down$ (symbol-name sym)))))))
(defun duelling-scrolled-lists ()
(mk-row ()
(mk-scrolled-list
:id :pkg-list
:selection (c-in (find-package "ASDF"))
:list-height 6
:list-item-keys (list-all-packages)
:list-item-factory (lambda (pkg)
(make-instance 'listbox-item
:fm-parent *parent*
:md-value pkg
:item-text (down$ (package-name pkg)))))
(mk-scrolled-list
:id :pkg-sym-list
:list-height 6
:list-item-keys (c? (bwhen (pkg (selection (fm^ :pkg-list)))
(loop for sym being the present-symbols in pkg
for n below 25
collecting sym)))
:list-item-factory (lambda (sym)
(make-instance 'listbox-item
:md-value sym
:fm-parent *parent*
:item-text (down$ (symbol-name sym)))))))
(defun assorted-canvas-items ()
(mk-canvas
:height 350
:kids (c? (the-kids
(mk-bitmap :coords (list 140 140)
:bitmap "@\\0dev\\Celtk\\x1.xbm" #+not "@\\temp\\gsl.xbm")
(mk-rectangle :coords (list 10 10 100 60)
:tk-fill "red")
(mk-text-item :coords (list 100 80)
:text "i am an item"
:tk-fill 'blue)
(mk-arc :coords (list 10 100 100 160)
:start 45
:tk-fill "orange")
(mk-line :coords (list 250 10 300 40 250 70 400 100)
:width 8
:smooth 'bezier
:joinstyle 'miter
:arrow 'both
:tk-fill 'purple)
(mk-oval :coords (list 10 200 100 260)
:tk-fill "yellow")
(mk-polygon :coords (list 250 210 300 220 340 200 260 180)
:width 4
:tk-fill 'green
:smooth 'bezier
:joinstyle 'miter)
(mk-arc :coords (list 10 300 100 360)
:start 45
:tk-fill "white")
))))
(defun style-by-widgets ()
(mk-stack ("Style by Widgets" :id :widstyle)
(mk-row (:id :stywid
:packing-side 'left
:layout-anchor 'sw)
(mk-popup-menubutton
:id :font-face
:initial-value (c? (second (^entry-values)))
:entry-values (c? (eko ("popup ff") (subseq (tk-eval-list "font families") 4 10))))
(mk-scale :id :font-size
:md-value (c-in 14)
:tk-label "Font Size"
:from 7 :to 24
:orient 'horizontal))
(mk-label :text "Four score and seven years ago today, our fathers broguht forth on this continent a new nation..."
:wraplength 200
:justify 'left
:tkfont (c? (list
(selection (fm^ :font-face))
(md-value (fm^ :font-size)))))))
(defun demo-all-menubar ()
(mk-menubar
:id 'mbar
:kids (c? (the-kids
(mk-menu-entry-cascade
:id 'file
:label "File"
:kids (c? (the-kids
(mk-menu
:id 'filemenu
:kids (c? (the-kids
(mk-menu-entry-command :label "New" :command "exit")
(mk-menu-entry-command :label "Open" :command "tk_getOpenFile")
(mk-menu-entry-command :label "Close" :command "exit")
(mk-menu-entry-separator)
(mk-menu-entry-command :label "Quit"
:state (c? (if t ;; (md-value (fm^ :check-me))
'normal 'disabled))
:command "exit")))))))
(mk-menu-entry-cascade
:id 'editcascade
:label "Edit"
:kids (c? (the-kids
(mk-menu
:id 'editmenu
:kids (c? (the-kids
(mk-menu-entry-command :label "Undo"
:on-command (lambda (self)
(trc "edit menu undo" self)))
(mk-menu-entry-separator)
(mk-menu-entry-command :label "Cut" :command "exit")
(mk-menu-entry-command :label "Copy" :command "exit")
(mk-menu-entry-command :label "Paste" :command "exit")
(mk-menu-entry-command :label "Clear" :command "exit")
(mk-menu-entry-separator)
(mk-menu-radio-group :id :app-font-face
:selection (c-in "courier")
:kids (c? (the-kids
(mk-menu-entry-radiobutton :label "Times" :value "times")
(mk-menu-entry-radiobutton :label "Courier" :value "courier")
(mk-menu-entry-radiobutton :label "Helvetica" :value "helvetica"))))
(mk-menu-entry-separator)
(mk-menu-entry-cascade
:id :app-font-size
:label "Font Size"
:menu (c? (path (kid1 self)))
:selection (c-in 12)
:kids (c? (the-kids
(mk-menu
:id :fsztoff
:tearoff 1
:kids (c? (the-kids
(loop for (label value) in '(("9" 9)("12" 12)("14" 14))
collecting (mk-menu-entry-radiobutton :label label :value value))))))))
(mk-menu-entry-separator)
(mk-menu-entry-checkbutton :id :app-font-italic :label "Italic")
(mk-menu-entry-checkbutton :id :app-font-bold :label "Bold" :md-value (c-in t))))))))))))
--- /project/cells/cvsroot/Celtk/tk-events.lisp 2006/05/13 14:36:58 NONE
+++ /project/cells/cvsroot/Celtk/tk-events.lisp 2006/05/13 14:36:58 1.1
(in-package :celtk)
#|
typedef struct {
int type;
unsigned long serial; /* # of last request processed by server */
Bool send_event; /* True if this came from a SendEvent request */
Display *display; /* Display the event was read from */
Window event; /* Window on which event was requested. */
Window root; /* root window that the event occured on */
Window subwindow; /* child window */
Time time; /* milliseconds */
int x, y; /* pointer x, y coordinates in event window */
int x_root, y_root; /* coordinates relative to root */
unsigned int state; /* key or button mask */
Tk_Uid name; /* Name of virtual event. */
Bool same_screen; /* same screen flag */
Tcl_Obj *user_data; /* application-specific data reference; Tk will
* decrement the reference count *once* when it
* has finished processing the event. */
} XVirtualEvent;
|#
(defctype Window-ptr :unsigned-long)
(defctype Time :unsigned-long)
(defctype Tk_Uid :string)
(defcstruct x-virtual-event
(type :int)
(serial :unsigned-long)
(send-event :boolean)
(display :pointer)
(event-window Window-ptr)
(root-window Window-ptr)
(sub-window Window-ptr)
(time Time)
(x :int)
(y :int)
(x-root :int)
(y-root :int)
(state :unsigned-int)
(name Tk_Uid)
(same-screen :boolean)
(user-data :string)
)
(defcenum tcl-event-flag-values
(:tcl-dont-wait 2)
(:tcl-window-events 4)
(:tcl-file-events 8)
(:tcl-timer-events 16)
(:tcl-idle-events 32)
(:tcl-all-events -3))
(defcfun ("Tcl_DoOneEvent" Tcl_DoOneEvent) :int
(flags :int))
(defcfun ("Tcl_DoWhenIdle" tcl-do-when-idle) :void
(tcl-idle-proc :pointer)
(client-data :int))
(defcallback tcl-idle-proc :void ((client-data :int))
(unless (c-stopped)
(print (list :idle-proc :client-data client-data))))
;; Tk_MainLoop
(defcfun ("Tk_MainLoop" Tk_MainLoop) :void)
(defcfun ("Tk_CreateEventHandler" tk-create-event-handler) :void
(tkwin :pointer)
(mask :int)
(proc :pointer)
(client-data :int))
(defcallback tk-event-proc :void ((client-data :int)(XEvent :pointer))
(trc "yowza tk-event-proc" client-data XEvent (tk-event-type (mem-aref XEvent :int))
[42 lines skipped]
More information about the Cells-cvs
mailing list