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]