From b71ef75be74e2655163d90cf17b99101a7d1636f Mon Sep 17 00:00:00 2001 From: cer <cer> Date: Fri, 17 Jan 1992 17:49:53 +0000 Subject: [PATCH] fixes --- clim/accept-values.lisp | 8 +- clim/gadget-output.lisp | 16 +- misc/go.lisp | 41 ++- silica/gadgets.lisp | 111 +++++-- test/test-suite.lisp | 8 +- test/test.lisp | 10 + tk-silica/sysdcl.lisp | 26 +- tk-silica/xm-frames.lisp | 253 +++++--------- tk-silica/xm-gadgets.lisp | 662 ++++++++++++------------------------- tk-silica/xm-graphics.lisp | 490 +-------------------------- tk-silica/xm-silica.lisp | 511 +--------------------------- tk-silica/xt-silica.lisp | 4 +- tk/callbacks.lisp | 27 +- tk/defsys.lisp | 43 +-- tk/examples.lisp | 13 +- tk/foreign-obj.lisp | 12 +- tk/load-ol.lisp | 126 +++++-- tk/load-xm.lisp | 56 ++-- tk/macros.lisp | 21 +- tk/make-classes.lisp | 28 +- tk/make-widget.lisp | 4 +- tk/ol-examples.lisp | 85 ++++- tk/ol-init.lisp | 114 ++++--- tk/resources.lisp | 212 +++++++++++- tk/widget.lisp | 20 +- tk/xm-widgets.lisp | 32 +- tk/xtk.lisp | 73 +++- 27 files changed, 1109 insertions(+), 1897 deletions(-) diff --git a/clim/accept-values.lisp b/clim/accept-values.lisp index e19c9e36..f20c4980 100644 --- a/clim/accept-values.lisp +++ b/clim/accept-values.lisp @@ -19,7 +19,7 @@ ;; applicable. ;; -;; $fiHeader: accept-values.lisp,v 1.2 92/01/02 15:11:54 cer Exp Locker: cer $ +;; $fiHeader: accept-values.lisp,v 1.3 92/01/06 20:44:10 cer Exp Locker: cer $ (in-package :clim) @@ -759,7 +759,8 @@ Copyright (c) 1991, Franz Inc. All rights reserved (avv-stream (car stream-and-record)) (avv-record (cdr stream-and-record))) (cond (avv-stream - (letf-globally (((stream-default-view avv-stream) +dialog-view+)) + (letf-globally (((stream-default-view avv-stream) + (port-dialog-view (port avv-stream)))) (redisplay avv-record avv-stream :check-overlapping check-overlapping) (when resynchronize-every-pass (redisplay avv-record avv-stream :check-overlapping check-overlapping)))) @@ -769,7 +770,8 @@ Copyright (c) 1991, Franz Inc. All rights reserved (defun accept-values-pane-displayer-1 (frame pane displayer) (let ((avv-stream (make-instance 'avv-stream :stream pane)) (avv-record nil)) - (letf-globally (((stream-default-view avv-stream) +dialog-view+)) + (letf-globally (((stream-default-view avv-stream) + (port-dialog-view (port avv-stream)))) (setq avv-record (updating-output (avv-stream) (with-new-output-record (avv-stream 'avv-output-record avv-record) diff --git a/clim/gadget-output.lisp b/clim/gadget-output.lisp index ac54f2e8..979f781b 100644 --- a/clim/gadget-output.lisp +++ b/clim/gadget-output.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: gadget-output.cl,v 1.1 92/01/06 20:36:58 cer Exp Locker: cer $ +;; $fiHeader: gadget-output.cl,v 1.2 92/01/08 14:58:58 cer Exp Locker: cer $ (in-package :clim) @@ -120,7 +120,7 @@ (realize-pane 'silica::toggle-button :client stream :id query-identifier - :set default))) + :value default))) (define-presentation-method accept-present-default ((type integer) @@ -253,23 +253,27 @@ (declare (ignore present-p)) ;; value-key, test, sequence (with-output-as-gadget (:stream stream) - (let* ((frame-pane + (let* ( + #+ignore + (frame-pane (realize-pane 'silica::frame-pane)) (gadget (realize-pane 'silica::radio-box :client stream :id query-identifier - :parent frame-pane))) + #+ignore :parent + #+ignore frame-pane))) (dolist (element sequence) (realize-pane 'toggle-button - :set (and default-supplied-p + :value (and default-supplied-p (funcall test (funcall value-key element) (funcall value-key default))) :label (princ-to-string element) :id element :parent gadget)) - frame-pane))) + gadget + #+ignore frame-pane))) (defmethod silica::value-changed-callback ((gadget silica::radio-box) (client avv-stream) diff --git a/misc/go.lisp b/misc/go.lisp index 422a5765..ff2f5875 100644 --- a/misc/go.lisp +++ b/misc/go.lisp @@ -22,6 +22,7 @@ excl::*load-source-file-info* t) (without-package-locks + (excl::compile-file-if-needed "sys/defsystem") (load "sys/defsystem") (load "sys/sysdcl")) @@ -46,15 +47,36 @@ (load "tk/defsys.cl") -(defsys::compile-system :xm-tk) -(defsys::load-system :xm-tk) - -(load "xm-silica/sysdcl.cl") -(defsys::compile-system :xm-silica) -(defsys::load-system :xm-silica) - -(defsys::compile-system :xm-ws) -(defsys::load-system :xm-ws) +(defsys::compile-system :basic-tk) +(defsys::load-system :basic-tk) + +(let ((which (or (and (boundp 'which) + which) + :motif))) + (let ((sys + (ecase which + (:motif :xm-tk) + (:openlook :ol-tk)))) + (defsys::compile-system sys) + (defsys::load-system sys)) + + (defsys::compile-system :hi-tk) + (defsys::load-system :hi-tk) + + (load "xm-silica/sysdcl.cl") + + (let ((sys (ecase which + (:motif :xm-silica) + (:openlook :ol-silica)))) + (defsys::compile-system sys) + (defsys::load-system sys)) + + + (let ((sys (ecase which + (:motif :xm-ws) + (:openlook :ol-ws)))) + (defsys::compile-system sys) + (defsys::load-system sys))) #+:composer (progn @@ -62,6 +84,7 @@ (load "draw-sheets") ) +(excl::compile-file-if-needed "test/test") (load "test/test") (excl::compile-file-if-needed "test/test-suite") diff --git a/silica/gadgets.lisp b/silica/gadgets.lisp index 73f016c8..5df2caca 100644 --- a/silica/gadgets.lisp +++ b/silica/gadgets.lisp @@ -18,45 +18,106 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: gadgets.cl,v 1.4 92/01/06 20:44:20 cer Exp Locker: cer $ +;; $fiHeader: gadgets.cl,v 1.5 92/01/08 14:59:00 cer Exp Locker: cer $ (in-package :silica) +;;; Does this make sense +;;; We want to be able to specify visual attributes of gadgets -(defclass gadget () +(defclass foreground-background-and-text-style-mixin () + ((foreground :initform nil :initarg :foreground) + (background :initform nil :initarg :background) + (text-style :initform nil :initarg :text-style))) + +(defclass gadget (foreground-background-and-text-style-mixin) ((id :initarg :id :reader gadget-id :initform nil) (client :initarg :client :initform nil :accessor gadget-client))) -(defclass value-gadget (gadget) ()) - -(defmethod value-changed-callback ((v gadget) (client t) (id t) (value t)) - ()) +(defclass value-gadget (gadget) + ((value :initarg :value + :initform nil + :reader gadget-initial-value) + (value-changed-callback + :initarg :value-changed-callback + :initform nil + :reader gadget-value-changed-callback))) + +(defmethod value-changed-callback ((gadget gadget) (client t) (id t) (value + t)) + (when (gadget-value-changed-callback gadget) + (invoke-callback-function + (gadget-value-changed-callback gadget) + gadget + value))) + +(defun invoke-callback-function (function &rest args) + (if (consp function) + (apply (car function) (append args (cdr function))) + (apply function args))) (defgeneric gadget-value (gadget)) -(defgeneric (setf gadget-value) (gadget)) +(defmethod gadget-value ((gadget gadget)) + (with-slots (value) gadget + value)) + +(defmethod value-changed-callback :before ((gadget gadget) client id new-value) + (declare (ignore id client)) + (with-slots (value) gadget + (setf value new-value))) + +(defgeneric (setf gadget-value) (nv gadget)) + +(defmethod (setf gadget-value) :after (nv (gadget gadget)) + (with-slots (value) gadget + (setf value nv))) + +;;;;;;;;;;;;; -(defclass action-gadget (gadget) ()) +(defclass action-gadget (gadget) + ((action-callback + :initarg :action-callback + :initform nil + :reader gadget-action-callback))) + +(defmethod activate-callback ((gadget gadget) (client t) (id t)) + (when (gadget-action-callback gadget) + (invoke-callback-function + (gadget-action-callback gadget) + gadget))) + +;;; Basic gadgets-mixins + +(defclass oriented-gadget () + ((orientation :initarg :orientation + :reader gadget-orientation)) + + (:default-initargs :orientation :horizontal)) + +(defclass labelled-gadget () + ((label :initarg :label + :reader gadget-label)) + (:default-initargs :label "")) -(defmethod activate-callback ((v gadget) (client t) (id t)) - ()) ;;;;;;;;;;;;;;;;;;;; The intent is that the real implementations ;;;;;;;;;;;;;;;;;;;; inherit from these ;; slider -(defclass slider () ()) +(defclass slider (value-gadget oriented-gadget) + ()) ;; push-button -(defclass silica::push-button () ()) +(defclass silica::push-button (action-gadget labelled-gadget) + ()) -;; toggle-button ;; scroll-bar -(defclass scrollbar () +(defclass scrollbar (value-gadget oriented-gadget) ((current-value :initform nil) (current-size :initform nil))) @@ -67,7 +128,8 @@ ;; radio-box [exclusive-choice] ;; .. [inclusive-choice] -(defclass silica::radio-box () ()) +(defclass silica::radio-box (value-gadget oriented-gadget) + ()) ;; menu-bar @@ -80,11 +142,14 @@ ;; text-edit -(defclass text-field () ()) +(defclass text-field (value-gadget action-gadget) + ()) ;; toggle buttton -(defclass toggle-button () ()) +(defclass toggle-button (value-gadget labelled-gadget) + ((indicator-type :initarg :indicator-type :initform :some-of + :reader gadget-indicator-type))) ;;; Viewport @@ -114,18 +179,14 @@ ((value :initarg :value :reader event-value))) (defmethod handle-event ((gadget value-gadget) (event value-changed-gadget-event)) - (value-changed-callback gadget (gadget-client gadget) (gadget-id gadget) (slot-value event 'value))) + (value-changed-callback gadget + (gadget-client gadget) + (gadget-id gadget) + (slot-value event 'value))) (defclass activate-gadget-event (gadget-event) ()) (defmethod handle-event ((gadget action-gadget) (event activate-gadget-event)) (activate-callback gadget (gadget-client gadget) (gadget-id gadget))) -;; Does this make sense - -(defclass foreground-background-and-text-style-mixin () - ((foreground :initform nil :initarg :foreground) - (background :initform nil :initarg :background) - (text-style :initform nil :initarg :text-style))) - ;;; Do these have readers and writers? diff --git a/test/test-suite.lisp b/test/test-suite.lisp index 8083590e..5873d6fa 100644 --- a/test/test-suite.lisp +++ b/test/test-suite.lisp @@ -1,6 +1,6 @@ ;;; -*- Syntax: Common-Lisp; Base: 10; Package: CLIM; Mode: LISP; Lowercase: T -*- -;; $fiHeader: test-suite.cl,v 1.4 92/01/06 20:44:32 cer Exp Locker: cer $ +;; $fiHeader: test-suite.cl,v 1.5 92/01/08 14:59:16 cer Exp Locker: cer $ (in-package :clim) @@ -2917,12 +2917,14 @@ Luke Luck licks the lakes Luke's duck likes.")) ("Exit" :command (exit-clim-tests))))) (:command-definer nil) (:pane (with-slots (caption-pane display-pane) *application-frame* - (silica::vertically () + (silica::vertically () + (silica::scrolling + () (setf caption-pane (silica::realize-pane 'application-pane :height 50 - )) + ))) (silica::scrolling () (setf display-pane diff --git a/test/test.lisp b/test/test.lisp index 0833816b..2098e921 100644 --- a/test/test.lisp +++ b/test/test.lisp @@ -49,6 +49,16 @@ (make-text-style :serif :roman 20))))) + +(define-application-frame test-frame0 () + (a b c) + (:command-table test-frame) + (:pane + (silica::scrolling + () + (silica::realize-pane + 'interactor-pane)))) + (define-application-frame test-frame2 () (a b c) (:command-table test-frame) diff --git a/tk-silica/sysdcl.lisp b/tk-silica/sysdcl.lisp index 24b3c2f2..1181c643 100644 --- a/tk-silica/sysdcl.lisp +++ b/tk-silica/sysdcl.lisp @@ -18,20 +18,42 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader$ +;; $fiHeader: sysdcl.cl,v 1.2 92/01/02 15:09:42 cer Exp Locker: cer $ (in-package :cl-user) (defsys::defsystem :xm-silica (:default-pathname (frob-pathname "xm-silica")) ("pkg") + ("xt-silica") ("xm-silica") + ("xt-graphics") ("xm-graphics") ("image")) +(defsys::defsystem :ol-silica + (:default-pathname (frob-pathname "xm-silica")) + ("pkg") + ("xt-silica") + ("ol-silica") + ("xt-graphics") + ("ol-graphics") + ("image")) + + (defsys::defsystem :xm-ws - (:default-pathname (frob-pathname "xm-silica")) + (:default-pathname (frob-pathname "xm-silica")) + ("xt-frames") ("xm-frames") + ("xt-gadgets") ("xm-gadgets")) +(defsys::defsystem :ol-ws + (:default-pathname (frob-pathname "xm-silica")) + ("xt-frames") + ("ol-frames") + ("xt-gadgets") + ("ol-gadgets")) + + diff --git a/tk-silica/xm-frames.lisp b/tk-silica/xm-frames.lisp index c0162d2b..a50ea179 100644 --- a/tk-silica/xm-frames.lisp +++ b/tk-silica/xm-frames.lisp @@ -18,184 +18,22 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xm-frames.cl,v 1.2 92/01/02 15:09:43 cer Exp Locker: cer $ +;; $fiHeader: xm-frames.cl,v 1.3 92/01/06 20:43:59 cer Exp Locker: cer $ (in-package :xm-silica) +;; Motif stuff -(defclass motif-frame-manager (frame-manager) +(defclass motif-frame-manager (xt-frame-manager) ()) (defmethod make-frame-manager ((port motif-port)) (make-instance ' motif-frame-manager :port port)) -(defmethod adopt-frame ((framem motif-frame-manager) (frame application-frame)) - (call-next-method) - (when (frame-panes frame) - (let* ((top-pane (frame-panes frame)) - (sheet (make-instance 'motif-top-level-sheet - :region (make-bounding-rectangle - 0 0 (sheet-width - top-pane) - (sheet-height top-pane)) - :parent (find-graft)))) - (setf (frame-top-level-sheet frame) sheet - (frame-shell frame) (sheet-shell sheet)) - (adopt-child sheet (frame-panes frame)) - (establish-wm-protocol-callbacks frame)))) +(defmethod adopt-frame :after ((framem motif-frame-manager) (frame application-frame)) + (establish-wm-protocol-callbacks framem frame)) -(defmethod note-frame-enabled :after ((framem motif-frame-manager) frame) - ;; Perhaps we want to resize the top leve sheet if there is one - (when (frame-top-level-sheet frame) - (setf (sheet-enabled-p (frame-top-level-sheet frame)) t))) - -(defmethod note-frame-disabled :after ((framem motif-frame-manager) frame) - (setf (sheet-enabled-p (frame-top-level-sheet frame)) nil)) - -;;; Definitions of the individual classes - -;;; Main window - -(defclass motif-main-window (motif-composite-pane) - ( - (contents :accessor main-window-contents :initform nil) - (command-window :initform nil :accessor main-window-command-window) - command-window-location - menu-bar - message-window - )) - -(defmethod initialize-instance :after ((mw motif-main-window) - &key - command-window - command-window-location - menu-bar - message-window - contents) - (when contents - (setf (main-window-contents mw) contents)) - (when command-window - (setf (main-window-command-window mw) command-window)) - (when message-window - (setf (main-window-message-window mw) message-window))) - -(defmethod (setf main-window-contents) :after (nv (mw motif-main-window)) - (unless (sheet-parent nv) - (adopt-child mw nv))) - -(defmethod (setf main-window-command-window) :after (nv (mw motif-main-window)) - (unless (sheet-parent nv) - (adopt-child mw nv))) - -#+ignore -(defmethod realize-mirror :around (port (motif-main-window)) - (let ((m (call-next-method))) - (tk::xm_set_main_window_areas - (object-handle m) - .. - (and command-window (realize-mirror port command-window)) - .. - (and message-window (realize-mirror port message-window)) - ...))) - -;;; Drawing area - -#+ignore -(defclass motif-drawing-area (motif-composite-pane) ()) - -;;; Row colum - -(defclass motif-row-colum (motif-composite-pane) ()) - -;;; Push button - -#+ignore -(defclass motif-push-button (motif-leaf-pane) ()) - -;;; Menu bar - -(defclass motif-menu-bar (motif-composite-pane) ()) -(defclass motif-pulldown-menu (motif-composite-pane) ()) - -(defclass motif-cascade-button (motif-composite-pane) - ((submenu :accessor cascade-button-submenu :initform nil)) - ) - -(defmethod realize-mirror :around ((port motif-port) (sheet motif-cascade-button)) - (let ((m (call-next-method))) - (when (cascade-button-submenu sheet) - (tk::set-values m :sub-menu-id - (realize-mirror port (cascade-button-submenu sheet)))) - m)) - - - -#+ignore -(define-application-frame motif-example-frame () - :pane (make-instance 'motif-main-window - )) - -#| - -(defmethod compose-space ((sheet motif-pane)) - (multiple-value-bind - (width height) - (tk::get-values (sheet-mirror sheet) :width :height) - (make-instance 'space-req - :width width - :height height))) - -(make-instance 'motif-main-window - :parent .. - :contents ...) - -;; What about all the readers/writers that are applicable? -;; We have to trampoline those? - -(setf (sheet-resource sheet :x) value) - -Can the basic motif stuff support lazy realization? - -|# - -#+ignore -(define-motif-sheet motif-menu-bar tk::xm-menu-bar) - - -;; Leaf panes - - - -;;; definition of the composite pane stuff - -;;; So once we have done all this we will be able to -;;; define-application-frames using motif widgets -;;; Still need a stream pane though - -;;; These frames use the Motif layout technology but perhaps we can -;;; plug in CLIM style stuff too. - -;;; Need a pane we can draw on. - -;;; Perhaps a :resources initarg to specify resources - -;;; Do scrollbars come from the use of the scrolling macro. - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; How do we interface to motif UIL. -;;; Perhaps use the name of the widget?? -;;; We can query the UIL file to obtain the widget hiearchy. - -;;; Gadget callbacks are not interfaced to the CP. - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; Final step is mapping abstract gadgets onto motif gadgets -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - - -(defmethod establish-wm-protocol-callbacks (frame) +(defmethod establish-wm-protocol-callbacks ((framem motif-frame-manager) frame) (let ((shell (frame-shell frame))) (tk::set-values shell :icon-name (frame-name frame) @@ -208,6 +46,82 @@ Can the basic motif stuff support lazy realization? 'frame-wm-protocol-callback frame))) +;;; Definitions of the individual classes + +;; This looks like garbage?? + +;(defclass motif-main-window (motif-composite-pane) +; ( +; (contents :accessor main-window-contents :initform nil) +; (command-window :initform nil :accessor main-window-command-window) +; command-window-location +; menu-bar +; message-window +; )) +; +;(defmethod initialize-instance :after ((mw motif-main-window) +; &key +; command-window +; command-window-location +; menu-bar +; message-window +; contents) +; (when contents +; (setf (main-window-contents mw) contents)) +; (when command-window +; (setf (main-window-command-window mw) command-window)) +; (when message-window +; (setf (main-window-message-window mw) message-window))) +; +;(defmethod (setf main-window-contents) :after (nv (mw motif-main-window)) +; (unless (sheet-parent nv) +; (adopt-child mw nv))) +; +;(defmethod (setf main-window-command-window) :after (nv (mw motif-main-window)) +; (unless (sheet-parent nv) +; (adopt-child mw nv))) +; +;#+ignore +;(defmethod realize-mirror :around (port (motif-main-window)) +; (let ((m (call-next-method))) +; (tk::xm_set_main_window_areas +; (object-handle m) +; .. +; (and command-window (realize-mirror port command-window)) +; .. +; (and message-window (realize-mirror port message-window)) +; ...))) + +;;;; Drawing area +; +;#+ignore +;(defclass motif-drawing-area (motif-composite-pane) ()) +; +;;;; Row colum +; +;(defclass motif-row-colum (motif-composite-pane) ()) +; +;;;; Push button + +;#+ignore +;(defclass motif-push-button (motif-leaf-pane) ()) + +;;; Menu bar + +;(defclass motif-menu-bar (motif-composite-pane) ()) +;(defclass motif-pulldown-menu (motif-composite-pane) ()) +; +;(defclass motif-cascade-button (motif-composite-pane) +; ((submenu :accessor cascade-button-submenu :initform nil)) +; ) +; +;(defmethod realize-mirror :around ((port motif-port) (sheet motif-cascade-button)) +; (let ((m (call-next-method))) +; (when (cascade-button-submenu sheet) +; (tk::set-values m :sub-menu-id +; (realize-mirror port (cascade-button-submenu sheet)))) +; m)) + (defclass window-manager-event (event) ()) @@ -238,8 +152,7 @@ Can the basic motif stuff support lazy realization? (clim-internals::frame-command-table frame)) pane))) -(defclass motif-menubar (motif-leaf-pane - sheet-permanently-enabled-mixin) +(defclass motif-menubar (xt-leaf-pane) ((command-table :initarg :command-table))) (defmethod find-widget-class-and-initargs-for-sheet (port (sheet motif-menubar)) diff --git a/tk-silica/xm-gadgets.lisp b/tk-silica/xm-gadgets.lisp index 6bc8c033..9ff41854 100644 --- a/tk-silica/xm-gadgets.lisp +++ b/tk-silica/xm-gadgets.lisp @@ -18,93 +18,43 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xm-gadgets.cl,v 1.4 92/01/06 20:44:01 cer Exp Locker: cer $ +;; $fiHeader: xm-gadgets.cl,v 1.5 92/01/08 14:58:39 cer Exp Locker: cer $ (in-package :xm-silica) - -(defmethod realize-pane-internal ((realizer motif-frame-manager) - frame - abstract-type - &rest options) - (let ((type (second (assoc abstract-type '( - (silica::scroll-bar motif-scrollbar) - (slider motif-slider) - (push-button motif-push-button) - (canvas motif-drawing-area) - (text-field motif-text-field) - (toggle-button motif-toggle-button) - (silica::menubar motif-menubar) - (silica::viewport xm-viewport) - (silica::radio-box motif-radio-box) - (silica::frame-pane motif-frame-pane) - ;; One day - (line-editor-pane) - (label-button-pane) - (radio-button-pane) - (horizontal-divider-pane) - (vertical-divider-pane) - (label-pane) +(defmethod realize-pane-class ((realizer motif-frame-manager) class &rest options) + (declare (ignore options)) + (second (assoc class '( + (silica::scroll-bar motif-scrollbar) + (slider motif-slider) + (push-button motif-push-button) + (canvas motif-drawing-area) + (text-field motif-text-field) + (toggle-button motif-toggle-button) + (silica::menubar motif-menubar) + (silica::viewport xm-viewport) + (silica::radio-box motif-radio-box) + (silica::frame-pane motif-frame-pane) + (silica::top-level-sheet motif-top-level-sheet) + ;; One day + (line-editor-pane) + (label-button-pane) + (radio-button-pane) + (horizontal-divider-pane) + (vertical-divider-pane) + (label-pane) ;;; - (list-pane) - (menu-bar) - (caption-pane) - (scroll-bar) - (radio-box) - (cascade-button) - ))))) - (if type - (apply #'make-instance - type - :frame frame - :frame-manager realizer - (apply #'realize-pane-arglist - realizer - abstract-type options)) - (call-next-method)))) - -(defmethod realize-pane-arglist (realizer type &rest options) - options) + (list-pane) + (menu-bar) + (caption-pane) + (scroll-bar) + (radio-box) + (cascade-button) + )))) ;;; We now need a lot of classes that mirror the xm classes. -(defclass motif-pane (silica::pane) (#+ignore resources)) - -(defmethod allocate-space ((p motif-pane) width height) - (when (sheet-mirror p) - (tk::set-values (sheet-mirror p) :width width :height height))) - - -#+ignore -(defmethod initialize-instance :after ((x motif-pane) &rest args) - (setf (slot-value x 'resources) args)) - -#+ignore -(defmethod find-widget-class-and-initargs-for-sheet :around (port (sheet motif-pane)) - (multiple-value-bind - (x y) (call-next-method) - (clos::doplist (key value) (slot-value sheet 'resources) - (unless (getf y key) - (setf (getf y key) value))) - (values x y))) - -(defclass motif-composite-pane () ()) - -(defclass ask-widget-for-size-mixin () ()) - -(defmethod compose-space ((pane ask-widget-for-size-mixin)) - (multiple-value-bind - (x y width height borderwidth - care-x care-y care-width care-height care-borderwidth) - (tk::widget-best-geometry (sheet-direct-mirror pane)) - (declare (ignore x y borderwidth care-x care-y care-width - care-height care-borderwidth)) - (make-instance 'silica::space-req :width width :height height))) - -(defclass motif-leaf-pane (motif-pane mirrored-sheet-mixin ask-widget-for-size-mixin) - ()) - ;;; Motif widgets that support the :value resource and value-changed callback (defclass motif-value-pane () ()) @@ -115,13 +65,14 @@ 'queue-value-changed-event sheet)) +(defmethod silica::gadget-value ((gadget motif-value-pane)) + (if (sheet-direct-mirror gadget) + (tk::get-values (sheet-mirror gadget) :value) + (call-next-method))) - -(defmethod gadget-value ((gadget motif-value-pane)) - (tk::get-values (sheet-mirror gadget) :value)) - -(defmethod (setf gadget-value) (nv (gadget motif-value-pane)) - (tk::set-values (sheet-mirror gadget) :value nv)) +(defmethod (setf silica::gadget-value) (nv (gadget motif-value-pane)) + (when (sheet-mirror gadget) + (tk::set-values (sheet-mirror gadget) :value nv))) (defmethod queue-value-changed-event (widget sheet) (declare (ignore widget)) @@ -129,7 +80,7 @@ (port sheet) (make-instance 'value-changed-gadget-event :gadget sheet - :value (gadget-value sheet)))) + :value (silica::gadget-value sheet)))) ;;; Motif widgets that support the activate callback @@ -141,32 +92,6 @@ 'queue-active-event sheet)) -;;; Push button - -(defclass motif-push-button (motif-leaf-pane - silica::push-button - action-gadget - motif-action-pane - sheet-permanently-enabled-mixin - silica::foreground-background-and-text-style-mixin) - ((label-string :initarg :label-string :initform ""))) - -(defmethod realize-pane-arglist (realizer (type (eql 'push-button)) - &rest args - &key (label "")) - (list* :label-string label - (with-rem-keywords (args args '(:label)) - (apply #'call-next-method realizer type args)))) - -(defmethod find-widget-class-and-initargs-for-sheet (port (sheet motif-push-button)) - (values 'tk::xm-push-button - (list :label-string (slot-value sheet 'label-string)))) - -;;; This widget knows how big it wants to be so asking it returns a -;;; meaningful answer. ie. Something other than the current size. - -;; This should support the arm-callback - (defmethod queue-active-event (widget count sheet) (declare (ignore widget count)) (distribute-event @@ -174,20 +99,22 @@ (make-instance 'activate-gadget-event :gadget sheet))) +;;; Push button -;; Drawing area +(defclass motif-push-button (xt-leaf-pane + silica::push-button + motif-action-pane) + ()) -(defclass motif-drawing-area (motif-leaf-pane - standard-sheet-input-mixin - permanent-medium-sheet-output-mixin - mute-repainting-mixin) ()) -(defmethod find-widget-class-and-initargs-for-sheet (port (sheet motif-drawing-area)) - (values 'tk::xm-drawing-area (list :margin-width 0 - :resize-policy :none - :margin-height 0))) -(defmethod add-sheet-callbacks :after ((port motif-port) (sheet motif-drawing-area) widget) +(defmethod find-widget-class-and-initargs-for-sheet (port (sheet motif-push-button)) + (declare (ignore port)) + (with-accessors ((label silica::gadget-label)) sheet + (values 'tk::xm-push-button + (list :label-string label)))) + +(defmethod add-sheet-callbacks ((port motif-port) (sheet t) (widget tk::xm-drawing-area)) (tk::add-callback widget :expose-callback 'sheet-mirror-exposed-callback @@ -196,7 +123,6 @@ :input-callback 'sheet-mirror-input-callback sheet) - (tk::add-event-handler widget '(:enter-window :leave-window @@ -213,35 +139,45 @@ 'sheet-mirror-event-handler sheet)) +;; Drawing area +;; Who uses this anyway?????????????? + +(defclass motif-drawing-area (xt-leaf-pane + standard-sheet-input-mixin + permanent-medium-sheet-output-mixin + mute-repainting-mixin) + ()) + +(defmethod find-widget-class-and-initargs-for-sheet ((port motif-port) + (sheet motif-drawing-area)) + (values 'tk::xm-drawing-area (list :margin-width 0 + :resize-policy :none + :margin-height 0))) + +(defmethod add-sheet-callbacks :after ((port motif-port) (sheet motif-drawing-area) widget) + ;; Now does nothing + ) + ;;; Slider -(defclass motif-slider (silica::client-overridability - motif-leaf-pane - sheet-permanently-enabled-mixin - value-gadget +(defclass motif-slider (xt-leaf-pane motif-value-pane slider) - ((value :initarg :value :initform nil) - (orientation :initarg :orientation)) - (:default-initargs :orientation :horizontal)) + ()) -(defmethod realize-pane-arglist (realizer (type (eql 'slider)) &rest args &key orientation) - (append (and orientation (list :orientation orientation)) - (with-rem-keywords (args args '(:orientation)) - (apply #'call-next-method realizer type args)))) -(defmethod find-widget-class-and-initargs-for-sheet (port (sheet motif-slider)) - (with-slots (orientation value) sheet +(defmethod find-widget-class-and-initargs-for-sheet ((port motif-port) (sheet motif-slider)) + (with-accessors ((orientation silica::gadget-orientation) + (value silica::gadget-value)) sheet (values 'tk::xm-scale (append (list :orientation orientation) (and value (list :value value)))))) -;; This should suport the drag callback (defmethod compose-space ((m motif-slider)) (let ((x 16)) - (ecase (slot-value m 'orientation) + (ecase (silica::gadget-orientation m) (:vertical (silica::make-space-req :width x :min-height x @@ -256,22 +192,15 @@ ;;; Scrollbar -(defclass motif-scrollbar (motif-leaf-pane - silica::sheet-permanently-enabled-mixin - gadget +(defclass motif-scrollbar (xt-leaf-pane silica::scrollbar) - ((orientation :initarg :orientation)) - (:default-initargs :orientation :horizontal)) - -(defmethod realize-pane-arglist (realizer (type (eql 'silica::scrollbar)) - &rest args &key orientation) - (list* :orientation orientation - (with-rem-keywords (args args '(:orientation)) - (apply #'call-next-method realizer type args)))) + ()) -(defmethod find-widget-class-and-initargs-for-sheet (port (sheet motif-scrollbar)) - (values 'tk::xm-scroll-bar - (list :orientation (slot-value sheet 'orientation)))) +(defmethod find-widget-class-and-initargs-for-sheet ((port motif-port) + (sheet motif-scrollbar)) + (with-accessors ((orientation silica::gadget-orientation)) sheet + (values 'tk::xm-scroll-bar + (list :orientation orientation)))) (defmethod (setf silica::scrollbar-size) (nv (sb motif-scrollbar)) (tk::set-values (sheet-direct-mirror sb) :slider-size nv) @@ -281,7 +210,8 @@ (tk::set-values (sheet-direct-mirror sb) :value nv) nv) -(defmethod silica::change-scrollbar-values ((sb motif-scrollbar) &rest args &key slider-size value) +(defmethod silica::change-scrollbar-values ((sb motif-scrollbar) &rest args + &key slider-size value) (declare (ignore slider-size value)) (apply #'tk::set-values (sheet-direct-mirror sb) @@ -308,7 +238,7 @@ (defmethod compose-space ((m motif-scrollbar)) (let ((x 16)) - (ecase (slot-value m 'orientation) + (ecase (silica::gadget-orientation m) (:vertical (silica::make-space-req :width x :min-height x @@ -324,6 +254,7 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (defclass motif-top-level-sheet ( #+ignore sheet mirrored-sheet-mixin @@ -343,32 +274,33 @@ (defmethod stream-read-char-no-hang ((x motif-top-level-sheet)) nil) -(defmethod add-sheet-callbacks :after ((port motif-port) (sheet - motif-top-level-sheet) widget) - - (tk::add-callback widget - :expose-callback - 'sheet-mirror-exposed-callback - sheet) - (tk::add-callback widget - :input-callback - 'sheet-mirror-input-callback - sheet) - (tk::add-event-handler widget - '(:enter-window - :leave-window - :pointer-motion-hint - :pointer-motion - :button1-motion - :button2-motion - :button3-motion - :button4-motion - :button5-motion - :button-motion - ) - 0 - 'sheet-mirror-event-handler - sheet) +(defmethod add-sheet-callbacks :after ((port motif-port) + (sheet motif-top-level-sheet) + widget) + +; (tk::add-callback widget +; :expose-callback +; 'sheet-mirror-exposed-callback +; sheet) +; (tk::add-callback widget +; :input-callback +; 'sheet-mirror-input-callback +; sheet) +; (tk::add-event-handler widget +; '(:enter-window +; :leave-window +; :pointer-motion-hint +; :pointer-motion +; :button1-motion +; :button2-motion +; :button3-motion +; :button4-motion +; :button5-motion +; :button-motion +; ) +; 0 +; 'sheet-mirror-event-handler +; sheet) (tk::add-callback widget :resize-callback 'sheet-mirror-resized-callback @@ -381,7 +313,8 @@ (defmethod compose-space ((sheet motif-top-level-sheet)) (compose-space (car (sheet-children sheet)))) -(defmethod find-widget-class-and-initargs-for-sheet (port (sheet motif-top-level-sheet)) +(defmethod find-widget-class-and-initargs-for-sheet ((port motif-port) + (sheet motif-top-level-sheet)) (values 'tk::xm-drawing-area (list :resize-policy :none :margin-width 0 :margin-height 0))) @@ -389,28 +322,31 @@ ;;;; text field -(defclass motif-text-field (motif-leaf-pane value-gadget - sheet-permanently-enabled-mixin +(defclass motif-text-field (xt-leaf-pane motif-value-pane motif-action-pane text-field) ()) -(defmethod find-widget-class-and-initargs-for-sheet (port (sheet motif-text-field)) - (values 'tk::xm-text-field nil)) +(defmethod find-widget-class-and-initargs-for-sheet ((port motif-port) + (sheet motif-text-field)) + (with-accessors ((value silica::gadget-value)) sheet + (values 'tk::xm-text-field + (append + (and value `(:value ,value)))))) + ;;; Toggle button -(defclass motif-toggle-button (motif-leaf-pane - sheet-permanently-enabled-mixin - motif-value-pane - value-gadget +(defclass motif-toggle-button (xt-leaf-pane + motif-value-pane toggle-button) - ((set :initarg :set :initform nil) - (indicator-type :initarg :indicator-type :initform :some-of) - (label :initform nil :initarg :label))) + ()) -(defmethod find-widget-class-and-initargs-for-sheet (port (sheet motif-toggle-button)) - (with-slots (set label indicator-type) sheet +(defmethod find-widget-class-and-initargs-for-sheet ((port motif-port) + (sheet motif-toggle-button)) + (with-accessors ((set silica::gadget-value) + (label silica::gadget-label) + (indicator-type silica::gadget-indicator-type)) sheet (values 'tk::xm-toggle-button (append (list :set set) (and label (list :label-string label)) @@ -419,104 +355,48 @@ (:one-of :one-of-many) (:some-of :n-of-many))))))) -(defmethod gadget-value ((gadget motif-toggle-button)) - (tk::get-values (sheet-mirror gadget) :set)) +(defmethod silica::gadget-value ((gadget motif-toggle-button)) + (if (sheet-direct-mirror gadget) + (tk::get-values (sheet-mirror gadget) :set) + (call-next-method))) -(defmethod (setf gadget-value) (nv (gadget motif-toggle-button)) - (tk::set-values (sheet-mirror gadget) :set nv)) +(defmethod (setf silica::gadget-value) (nv (gadget motif-toggle-button)) + (when (sheet-direct-mirror gadget) + (tk::set-values (sheet-mirror gadget) :set nv))) -(defmethod sheet-shell (sheet) - (do ((w (sheet-mirror sheet) (tk::widget-parent w))) - ((typep w '(or tk::shell null)) - w))) - -(defmethod xm-silica::add-sheet-callbacks :after - ((port motif-port) - (sheet clim::extended-stream-sheet) - (widget t)) +(defmethod xm-silica::add-sheet-callbacks :after ((port motif-port) + (sheet clim::extended-stream-sheet) + (widget t)) (declare (ignore sheet)) - (tk::add-callback widget - :expose-callback - 'sheet-mirror-exposed-callback - sheet) - (tk::add-callback widget - :input-callback - 'sheet-mirror-input-callback - sheet) - (tk::add-event-handler widget - '(:enter-window - :leave-window - :pointer-motion-hint - :pointer-motion - :button1-motion - :button2-motion - :button3-motion - :button4-motion - :button5-motion - :button-motion - ) - 0 - 'sheet-mirror-event-handler - sheet) +; (tk::add-callback widget +; :expose-callback +; 'sheet-mirror-exposed-callback +; sheet) +; (tk::add-callback widget +; :input-callback +; 'sheet-mirror-input-callback +; sheet) +; (tk::add-event-handler widget +; '(:enter-window +; :leave-window +; :pointer-motion-hint +; :pointer-motion +; :button1-motion +; :button2-motion +; :button3-motion +; :button4-motion +; :button5-motion +; :button-motion +; ) +; 0 +; 'sheet-mirror-event-handler +; sheet) + ;; It would suprise me if we needed this. (tk::add-callback widget :resize-callback 'sheet-mirror-resized-callback sheet)) -;;; scrolling stuff -; -;;;; Scroller Sheet -> xm-scrollbar, make some scrollbars also -;;;; Viewport Sheet -> xm-drawing-area -;;;; Child of the viewport has its transform altered to accomplish the -;;;; scrolling -; -;(defclass xm-scroller-sheet (motif-pane -; gadget -; mirrored-sheet-mixin -; silica::sheet-single-child-mixin -; mute-repainting-mixin -; ask-widget-for-size-mixin) -; (horizontal-scrollbar -; vertical-scrollbar)) -; -;(defmethod compose-space ((sheet xm-scroller-sheet)) -; (let ((req (call-next-method))) -; (setf (silica::space-req-max-height req) silica::+fill+ -; (silica::space-req-max-width req) silica::+fill+) -; req)) -; -;(defmethod initialize-instance :after ((scroller xm-scroller-sheet) &key contents) -; (let ((vp (make-instance 'xm-viewport :parent scroller))) -; (adopt-child vp contents))) -; -;(defmethod find-widget-class-and-initargs-for-sheet (port (sheet xm-scroller-sheet)) -; (values 'tk::xm-scrolled-window -; '(:scrolling-policy :application-defined -; :scroll-bar-display-policy :static))) -; -;(defmethod realize-mirror :around ((port motif-port) (sheet xm-scroller-sheet)) -; (let* ((m (call-next-method)) -; (sb1 (make-instance 'tk::xm-scroll-bar :parent m :orientation :horizontal)) -; (sb2 (make-instance 'tk::xm-scroll-bar :parent m :orientation -; :vertical))) -; (setf (slot-value sheet 'horizontal-scrollbar) sb1 -; (slot-value sheet 'vertical-scrollbar) sb2) -; (tk::set-values m :horizontal-scroll-bar sb1 :vertical-scroll-bar sb2) -; (add-scrollbar-callbacks sheet) -; m)) -; -;(defun add-scrollbar-callbacks (sheet) -; (with-slots (horizontal-scrollbar vertical-scrollbar) sheet -; (tk::add-callback horizontal-scrollbar -; :value-changed-callback -; 'scrollbar-changed-callback -; :horizontal -; sheet) -; (tk::add-callback vertical-scrollbar -; :value-changed-callback -; 'scrollbar-changed-callback -; :vertical -; sheet))) (defun scrollbar-changed-callback (widget which scroller) (let* ((vp (silica::sheet-child scroller)) @@ -547,10 +427,7 @@ 0 (/ value (- 100 size))))) :y (bounding-rectangle-min-y viewport))))))) - - - ;;;;;;;;;;;;;;; (defclass xm-viewport (mirrored-sheet-mixin @@ -583,174 +460,47 @@ (silica::sheet-child vp) vp)) -;(defun update-scrollbar (horizontal-scrollbar minx maxx vminx vmaxx) -; (let ((size (truncate (* 100 -; (if (zerop (- maxx minx)) -; 1.0 -; (min 1.0 (/ (- vmaxx vminx) (- maxx minx))))))) -; (pos (min 1.0 -; (max 0.0 -; (if (zerop (- (- maxx minx) (- vmaxx vminx))) -; 0.0 -; (/ (- vminx minx) -; (- (- maxx minx) (- vmaxx vminx)))))))) -; (tk::set-values horizontal-scrollbar -; :slider-size size -; :value (min (- 100 size) -; (truncate (* 100 pos)))))) - -(defmethod find-widget-class-and-initargs-for-sheet (port (sheet xm-viewport)) + +(defmethod find-widget-class-and-initargs-for-sheet ((port motif-port) (sheet xm-viewport)) (values 'tk::xm-drawing-area '(:scrolling-policy :application-defined :margin-width 0 :margin-height 0 :resize-policy :none :scroll-bar-display-policy :static))) -; From the days when the parent used to be a motif scroll window -;(defmethod realize-mirror :around ((port motif-port) (sheet xm-viewport)) -; (let* ((m (call-next-method))) -; (tk::set-values (sheet-mirror (silica::sheet-parent sheet)) :work-window m) -; m)) - - -(defmethod add-sheet-callbacks ((port motif-port) (sheet xm-viewport) widget) +(defmethod add-sheet-callbacks :after ((port motif-port) (sheet xm-viewport) widget) + ;; I wonder whether this is needed since it should not be resized by + ;; the toolkit and only as part of the goe management code that will + ;; recurse to children anyway (tk::add-callback widget :resize-callback 'sheet-mirror-resized-callback sheet) - (tk::add-callback widget - :expose-callback - 'sheet-mirror-exposed-callback - sheet) - (tk::add-callback widget - :input-callback - 'sheet-mirror-input-callback - sheet) - (tk::add-event-handler widget - '(:enter-window - :leave-window - :pointer-motion-hint - :pointer-motion - :button1-motion - :button2-motion - :button3-motion - :button4-motion - :button5-motion - :button-motion - ) - 0 - 'sheet-mirror-event-handler - sheet)) - -;;; We have the viewport - -;;; Viewport describes the region that is being mapped onto - - -(defmethod clim::pane-viewport-sheet (x) - (and (typep (silica::sheet-parent x) 'xm-silica::xm-viewport) - (silica::sheet-parent x))) - -(defmethod clim::pane-viewport (x) - (clim::pane-viewport-sheet x)) - -(defmethod clim::pane-viewport-region (x) - (let ((vp (clim::pane-viewport-sheet x))) - (and vp - (silica::xm-viewport-viewport vp)))) - -(defun clim::pane-scroller (x) - (clim::pane-scroller-sheet x)) - -(defun clim::update-region (stream width height &key no-repaint) - (when (or (> width (bounding-rectangle-width stream)) - (> height (bounding-rectangle-height stream))) - (setf (sheet-region stream) - (make-bounding-rectangle 0 0 - (max (bounding-rectangle-width stream) width) - (max (bounding-rectangle-height stream) height))))) - -(defun clim::scroll-extent (stream &key (x 0) (y 0)) - - ;; This should copy-area and then do a repaint of the new stuff. - ;; Perhaps for the time being we can just clear the current area and - ;; then repaint the whole thing - #+ignore-why-is-this-here - (setq y (min y (max (- (bounding-rectangle-height stream) - (bounding-rectangle-height - (clim::pane-viewport stream))) - 0))) - (let ((vp (clim::pane-viewport stream))) - (setf (sheet-transformation stream) - (make-translation-transformation (- x) (- y))) - (bounding-rectangle-set-position* - (silica::xm-viewport-viewport vp) x y) - (with-sheet-medium (medium vp) - (draw-rectangle* - medium - 0 0 - (bounding-rectangle-width (silica::xm-viewport-viewport vp)) - (bounding-rectangle-height (silica::xm-viewport-viewport vp)) - :ink +background+ - :filled t)) - (clim::replay - (clim-internals::output-recording-stream-output-record stream) - stream - (silica::xm-viewport-viewport vp)))) - - -(defmethod find-widget-class-and-initargs-for-sheet - ((port motif-port) - (sheet - silica::foreground-background-and-text-style-mixin)) - (multiple-value-bind - (class initargs) - (call-next-method) - (with-slots - (silica::foreground silica::background silica::text-style) - sheet - - ;; Background can either be a pixel of a bitmap - ;; Foreground has to be a pixel - ;; clx-decode-gadget-background - ;; clx-decode-gadget-foreground - - (when silica::background - (with-sheet-medium (medium sheet) - (setf initargs - (append (clx-decode-gadget-background medium sheet silica::background) - initargs)))) - - (when silica::foreground - (with-sheet-medium (medium sheet) - (setf initargs - (append (clx-decode-gadget-foreground medium sheet silica::foreground) - initargs)))) - - (when silica::text-style - (setf (getf initargs :font-list) - (realize-text-style port silica::text-style))) - - (values class initargs)))) - -(defmethod clx-decode-gadget-background (medium sheet ink) - (declare (ignore sheet)) - (let ((gc (clx-decode-ink ink medium))) - (if (tk::gcontext-tile gc) - (list :background-pixmap (tk::gcontext-tile gc)) - (list :background (tk::gcontext-foreground gc))))) - - -(defmethod clx-decode-gadget-foreground (medium sheet ink) - (declare (ignore sheet)) - (let ((gc (clx-decode-ink ink medium))) - (if (tk::gcontext-tile gc) - (error "Gadget foreground cannot be pixmap") - (list :foreground (tk::gcontext-foreground gc))))) - +; (tk::add-callback widget +; :expose-callback +; 'sheet-mirror-exposed-callback +; sheet) +; (tk::add-callback widget +; :input-callback +; 'sheet-mirror-input-callback +; sheet) +; (tk::add-event-handler widget +; '(:enter-window +; :leave-window +; :pointer-motion-hint +; :pointer-motion +; :button1-motion +; :button2-motion +; :button3-motion +; :button4-motion +; :button5-motion +; :button-motion +; ) +; 0 +; 'sheet-mirror-event-handler +; sheet) + ) -;; Implementation of radio box -;; should this be a composite-motif-pane ;; In some ways this behaves like a leaf since the management of the ;; children is left to the row column widget @@ -760,17 +510,16 @@ sheet-permanently-enabled-mixin silica::radio-box silica::pane - gadget ask-widget-for-size-mixin) - ((orientation :initarg :orientation) - (current-selection :accessor radio-box-current-selection)) - (:default-initargs :orientation :horizontal)) + ((current-selection :accessor radio-box-current-selection))) (defmethod adopt-child :after ((gadget motif-radio-box) child) (setf (silica::gadget-client child) gadget)) -(defmethod find-widget-class-and-initargs-for-sheet (port (sheet motif-radio-box)) - (with-slots (orientation) sheet +(defmethod find-widget-class-and-initargs-for-sheet ((port motif-port) + (sheet motif-radio-box)) + + (with-accessors ((orientation silica::gadget-orientation)) sheet (values 'tk::xm-radio-box (list :orientation orientation)))) @@ -789,13 +538,14 @@ ;; it (defclass motif-frame-pane (mirrored-sheet-mixin - sheet-single-child-mixin - sheet-permanently-enabled-mixin - silica::pane - ask-widget-for-size-mixin) - ()) + sheet-single-child-mixin + sheet-permanently-enabled-mixin + silica::pane + ask-widget-for-size-mixin) + ()) -(defmethod find-widget-class-and-initargs-for-sheet (port (sheet motif-frame-pane)) +(defmethod find-widget-class-and-initargs-for-sheet ((port motif-port) + (sheet motif-frame-pane)) (values 'tk::xm-frame nil)) diff --git a/tk-silica/xm-graphics.lisp b/tk-silica/xm-graphics.lisp index 8452b833..eea98f86 100644 --- a/tk-silica/xm-graphics.lisp +++ b/tk-silica/xm-graphics.lisp @@ -18,498 +18,20 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xm-graphics.cl,v 1.2 92/01/02 15:09:46 cer Exp Locker: cer $ +;; $fiHeader: xm-graphics.cl,v 1.3 92/01/06 20:44:02 cer Exp Locker: cer $ (in-package :xm-silica) +;; Motif specific +;;; Is there any need for this?? (defmethod make-medium ((port motif-port) sheet) (make-instance 'motif-medium :port port :sheet sheet)) -(defclass motif-medium (medium) - ((foreground-gcontext :reader medium-foreground-gcontext :initform nil) - (background-gcontext :reader medium-background-gcontext :initform nil) - (flipping-gcontext :reader medium-flipping-gcontext :initform nil) - (ink-table :initform (make-hash-table)))) +(defclass motif-medium (xt-medium) + ()) +;; End of the motif specific code - -(defmethod engraft-medium :after (medium (port motif-port) sheet) - (with-slots - (foreground-gcontext background-gcontext flipping-gcontext) - medium - (let ((drawable (tk::display-root-window (port-display port)))) - (unless foreground-gcontext - (setf foreground-gcontext (tk::make-instance 'tk::gcontext :drawable drawable))) - (unless background-gcontext - (setf background-gcontext (tk::make-instance 'tk::gcontext - :drawable drawable))) - (unless flipping-gcontext - (setf flipping-gcontext - (tk::make-instance 'tk::gcontext - :function boole-xor - :drawable drawable))) - (recompute-gcs medium)))) - -(defmethod silica::degraft-medium :after (medium (port motif-port) sheet) - (declare (ignore sheet)) - (with-slots - (foreground-gcontext background-gcontext flipping-gcontext) - medium - (macrolet ((loose-gc (gc) - `(when ,gc - (tk::free-gcontext ,gc) - (setf ,gc nil)))) - (loose-gc foreground-gcontext) - (loose-gc background-gcontext) - (loose-gc flipping-gcontext)))) - -(defun recompute-gcs (medium) - (with-slots - (foreground-gcontext background-gcontext flipping-gcontext) - medium - (let ((foreground-pixel - (clx-decode-color medium (medium-foreground medium))) - (background-pixel - (clx-decode-color medium (medium-background medium)))) - (setf (tk::gcontext-foreground foreground-gcontext) foreground-pixel - (tk::gcontext-background foreground-gcontext) background-pixel - (tk::gcontext-foreground background-gcontext) background-pixel - (tk::gcontext-foreground flipping-gcontext) - (logxor foreground-pixel background-pixel))))) - - - -(defmethod (setf medium-background) :after (ink (medium motif-medium)) - (recompute-gcs medium)) - -(defmethod (setf medium-foreground) :after (ink (medium motif-medium)) - (recompute-gcs medium)) - -(defmethod (setf medium-ink) :after (ink (medium motif-medium)) - (recompute-gcs medium)) - -;;; Below is stuff from clx-implementation - -(defgeneric clx-decode-ink (ink medium)) - -(defmethod clx-decode-ink ((ink (eql +foreground+)) medium) - (slot-value medium 'foreground-gcontext)) - -(defmethod clx-decode-ink ((ink (eql +background+)) medium) - (slot-value medium 'background-gcontext)) - -(defmethod clx-decode-ink ((ink (eql +flipping-ink+)) stream) - (slot-value stream 'flipping-gcontext)) - -(defmethod clx-decode-ink ((ink color) medium) - (let ((ink-table (slot-value medium 'ink-table))) - (or (gethash ink ink-table) - (setf (gethash ink ink-table) - (let ((new-gc - (make-instance 'tk::gcontext - :drawable (tk::display-root-window - (port-display (port medium)))))) - (setf (tk::gcontext-foreground new-gc) - (clx-decode-color medium ink)) - new-gc))))) - -(defmethod clx-decode-ink ((ink contrasting-ink) stream) - (clx-decode-ink (make-color-for-contrasting-ink ink) stream)) - - - -(defmethod clx-decode-color ((medium motif-medium) (x (eql +foreground+))) - (with-slots (foreground-gcontext) medium - (tk::gcontext-foreground foreground-gcontext))) - -(defmethod clx-decode-color ((medium motif-medium) (x (eql +background+))) - (with-slots (background-gcontext) medium - (tk::gcontext-foreground background-gcontext))) - - -(defmethod clx-decode-color ((stream motif-medium) (ink standard-opacity)) - (if (> (slot-value ink 'clim-utils::value) 0.5) - (clx-decode-color stream +foreground+) - (clx-decode-color stream +background+))) - -(defmethod clx-decode-color ((medium motif-medium) (ink color)) - (or (gethash ink (port-color-cache (port medium))) - (setf (gethash ink (port-color-cache (port medium))) - (multiple-value-bind - (red green blue) - (color-rgb ink) - (tk::allocate-color - (tk::default-colormap (port-display (port medium))) - (make-instance 'tk::color - :red (truncate (* 65356 red)) - :green (truncate (* 65356 green)) - :blue (truncate (* 65356 blue)))))))) - - -(defmethod clx-adjust-ink ((medium motif-medium) gc ink line-style x-origin y-origin) - ;; This is used to adjust for the line-style - (declare (ignore ink)) - - (let ((thickness (silica::line-style-thickness line-style))) - (if (< thickness 2) - (setq thickness 0)) - (setf (tk::gcontext-line-width gc) (round thickness))) - - (setf (tk::gcontext-cap-style gc) - (ecase (silica::line-style-cap-shape line-style) - (:butt :butt) - (:square :projecting) - (:round :round) - (:no-end-point :not-last))) - - (setf (tk::gcontext-join-style gc) - (ecase (silica::line-style-joint-shape line-style) - ((:miter :none) :miter) - (:bevel :bevel) - (:round :round))) - - - (when (eq (tk::gcontext-fill-style gc) :tiled) - (setf (tk::gcontext-ts-x-origin gc) x-origin - (tk::gcontext-ts-y-origin gc) y-origin)) - - gc) - -(defmethod clx-decode-ink :around ((ink t) (medium motif-medium)) - (let ((gc (call-next-method))) - #+ignore - (setf (tk::gcontext-clip-mask gc) - (compute-gcontext-clip-mask medium)) - gc)) - -(defmethod compute-gcontext-clip-mask (medium) - (with-bounding-rectangle* - (minx miny maxx maxy) - (sheet-device-region (medium-sheet medium)) - (list (truncate minx) - (truncate miny) - (truncate maxx) - (truncate maxy)))) - -(defun devicize-point (transform x y) - (multiple-value-setq (x y) - (transform-point* transform x y)) - (values (truncate x) (truncate y))) - -(defun devicize-distance (transform x y) - (multiple-value-setq (x y) - (transform-distance transform x y)) - (values (truncate x) (truncate y))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - -(defmethod port-draw-line* ((port motif-port) - sheet - medium - x1 y1 x2 y2) - (let ((transform (compose-transformations - (medium-transformation medium) - (sheet-device-transformation sheet)))) - (multiple-value-setq (x1 y1) (devicize-point transform x1 y1)) - (multiple-value-setq (x2 y2) (devicize-point transform x2 y2))) - (tk::draw-line - (tk::widget-window (sheet-mirror sheet)) - (clx-adjust-ink medium - (clx-decode-ink (medium-ink medium) medium) - (medium-ink medium) - (medium-line-style medium) - (min x1 x2) - (min y1 y2)) - x1 - y1 - x2 - y2)) - - -(defmethod port-draw-rectangle* ((port motif-port) - sheet - medium - x1 y1 x2 y2 filled) - (let ((transform (compose-transformations - (medium-transformation medium) - (sheet-device-transformation sheet)))) - (if (rectilinear-transformation-p transform) - (progn - (multiple-value-setq (x1 y1) (devicize-point transform x1 y1)) - (multiple-value-setq (x2 y2) (devicize-point transform x2 y2)) - (tk::draw-rectangle - (tk::widget-window (sheet-mirror sheet)) - (clx-adjust-ink medium - (clx-decode-ink (medium-ink medium) medium) - (medium-ink medium) - (medium-line-style medium) - (min x1 x2) - (min y1 y2)) - (min x1 x2) - (min y1 y2) - (abs (- x2 x1)) - (abs (- y2 y1)) - filled)) - (port-draw-transformed-rectangle* - port sheet medium x1 y1 x2 y2 filled)))) - - - - -(defmethod port-draw-text* ((port motif-port) - sheet medium string-or-char x y start end align-x align-y - towards-point towards-x towards-y - transform-glyphs) - - (let ((transform (compose-transformations - (medium-transformation medium) - (sheet-device-transformation sheet))) - (font (realize-text-style port (medium-text-style medium)))) - - (multiple-value-setq (x y) (devicize-point transform x y)) - (when (typep string-or-char 'character) - (setq string-or-char (string string-or-char))) - - (ecase align-x - (:center (decf x (floor (silica::text-size - sheet - string-or-char - :text-style - (medium-text-style medium) - :start start - :end end) - 2))) - (:left nil)) - - (ecase align-y - (:center (decf y (- (text-style-descent (medium-text-style medium) medium) - (floor (text-style-height (medium-text-style medium) medium) - 2)))) - (:base-line nil) - (:top - (incf y (tk::font-ascent font)))) - - (let ((gc (clx-decode-ink (medium-ink medium) medium))) - (setf (tk::gcontext-font gc) font) - (tk::draw-string - (tk::widget-window (sheet-mirror sheet)) - gc - x y - string-or-char - start end)))) - - -(defmethod silica::port-write-string-internal ((port motif-port) - medium - glyph-buffer - start - end - x-font - color - x - y) - (unless (= start end) - (let* ((sheet (medium-sheet medium)) - (transform (compose-transformations - (medium-transformation medium) - (sheet-device-transformation sheet))) - (window (tk::widget-window (sheet-mirror sheet) nil)) - (font x-font)) - - ;; At one point we checked to see whether the widget is unrealized - ;; or not. Can we draw on disabled sheets? - - (multiple-value-setq (x y) (devicize-point transform x y)) - - (incf y (tk::font-ascent font)) - - (let ((gc (clx-decode-ink (medium-ink medium) medium))) - (setf (tk::gcontext-font gc) font) - (etypecase glyph-buffer - ((simple-array (unsigned-byte 16)) - (x11::xdrawstring16 - (tk::display-handle (tk::object-display window)) - (tk::object-handle window) - (tk::object-handle gc) - x - y - glyph-buffer - (- end start)))))))) - - -(defmethod port-beep ((port motif-port) (sheet t)) - (x11:xbell (tk::display-handle (port-display port)) 100)) - - -(defmethod silica::port-draw-ellipse* ((port motif-port) - sheet - medium - center-x - center-y - radius-1-dx - radius-1-dy - radius-2-dx - radius-2-dy - start-angle - end-angle - filled) - (let ((transform (compose-transformations - (medium-transformation medium) - (sheet-device-transformation sheet)))) - (multiple-value-setq (center-x center-y) - (devicize-point transform center-x center-y)) - - - (multiple-value-setq (radius-1-dx radius-1-dy) - (devicize-distance transform radius-1-dx radius-1-dy)) - - - (multiple-value-setq (radius-2-dx radius-2-dy) - (devicize-distance transform radius-2-dx - radius-2-dy)) - - (tk::draw-ellipse - (tk::widget-window (sheet-mirror sheet)) - (clx-adjust-ink medium - (clx-decode-ink (medium-ink medium) medium) - (medium-ink medium) - (medium-line-style medium) - (- center-x - (if (zerop radius-1-dx) - radius-2-dx - radius-1-dx)) - (- center-y - (if (zerop radius-1-dy) - radius-2-dy - radius-1-dy))) - center-x - center-y - radius-1-dx - radius-1-dy - radius-2-dx - radius-2-dy - start-angle - end-angle - filled))) - -(ff::def-c-type (xpoint-array :in-foreign-space) 2 x11::xpoint) - -(defmethod silica::port-draw-polygon* ((port motif-port) - sheet - medium - list-of-x-and-ys - closed - filled) - (let* ((transform (compose-transformations - (medium-transformation medium) - (sheet-device-transformation sheet))) - (npoints (/ (length list-of-x-and-ys) 2)) - (points (excl::malloc ;; BUG BUG BUG - (* 4 (cond - ((and closed (not filled)) - (incf npoints)) - (t npoints))))) - (window (tk::widget-window (sheet-mirror sheet))) - (minx most-positive-fixnum) - (miny most-positive-fixnum)) - - (do ((ps list-of-x-and-ys (cddr ps)) - (i 0 (1+ i)) - r) - ((null ps) - (setq list-of-x-and-ys (nreverse r))) - (multiple-value-bind - (x y) - (devicize-point transform (car ps) (cadr ps)) - (minf minx x) - (minf miny y) - (setf (xpoint-array-x points i) x - (xpoint-array-y points i) y))) - - (when (and closed (not filled)) - (setf (xpoint-array-x points (- npoints 1)) (xpoint-array-x points 0) - (xpoint-array-y points (- npoints 1)) (xpoint-array-y points 0))) - - (if filled - (x11:xfillpolygon - (tk::display-handle (tk::object-display window)) - (tk::object-handle window) - (tk::object-handle (clx-adjust-ink medium - (clx-decode-ink (medium-ink medium) medium) - (medium-ink medium) - (medium-line-style medium) - minx - miny)) - points - npoints - x11:complex - x11:coordmodeorigin) - (x11:xdrawlines - (tk::display-handle (tk::object-display window)) - (tk::object-handle window) - (tk::object-handle (clx-adjust-ink medium - (clx-decode-ink (medium-ink medium) medium) - (medium-ink medium) - (medium-line-style medium) - minx - miny)) - points - npoints - x11:coordmodeorigin)))) - - -(defmethod clx-decode-ink ((ink rectangular-tile) medium) - (multiple-value-bind (pattern width height) - (decode-rectangular-tile ink) - (clx-decode-pattern pattern medium width height t))) - -(defmethod clx-decode-ink ((ink pattern) medium) - (clx-decode-pattern ink medium)) - -(defmethod clx-decode-pattern ((pattern pattern) medium &optional width height tiled-p) - (let ((ink-table (slot-value medium 'ink-table))) - (or (gethash pattern ink-table) - (setf (gethash pattern ink-table) - (multiple-value-bind - (array designs) - (decode-pattern pattern) - (let ((image-data (make-array (array-dimensions array)))) - (dotimes (w (array-dimension array 1)) - (dotimes (h (array-dimension array 0)) - (setf (aref image-data h w) - (clx-decode-color medium - (elt designs (aref array h w)))))) - (let* ((pattern-height (array-dimension array 0)) - (pattern-width (array-dimension array 1)) - (image (make-instance - 'tk::image - :width pattern-width - :height pattern-height - :data image-data - :depth 8 ;; hardwire - )) - (gc - (make-instance 'tk::gcontext - :drawable (tk::display-root-window - (port-display (port - medium))))) - (pixmap - (make-instance 'tk::pixmap - :drawable (tk::display-root-window - (port-display (port - medium))) - - :width pattern-width - :height pattern-height - :depth 8))) - (tk::put-image pixmap gc image :x 0 :y 0) - (setf (tk::gcontext-tile gc) pixmap - (tk::gcontext-fill-style gc) :tiled) - gc))))))) - - - diff --git a/tk-silica/xm-silica.lisp b/tk-silica/xm-silica.lisp index 635f28a0..358e5b41 100644 --- a/tk-silica/xm-silica.lisp +++ b/tk-silica/xm-silica.lisp @@ -18,505 +18,27 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xm-silica.cl,v 1.3 92/01/06 20:44:03 cer Exp Locker: cer $ +;; $fiHeader: xm-silica.cl,v 1.4 92/01/08 14:58:42 cer Exp Locker: cer $ (in-package :xm-silica) +;; Motif specific stuff + +(defclass motif-port (xt-port) + ()) (defmethod find-port-type ((type (eql ':motif))) 'motif-port) -(defclass motif-port (port) - ((application-shell :reader port-application-shell) - (display :reader port-display) - (context :reader port-context) - )) - -(defmethod initialize-instance :after ((port motif-port) &key server-path) - (destructuring-bind - (ignore &key display) server-path - (declare (ignore ignore)) - (multiple-value-bind - (context display application-shell) - (initialize-motif-toolkit display) - (setf (slot-value port 'application-shell) application-shell - (slot-value port 'context) context - (slot-value port 'display) display) - (initialize-xlib-display-device port display)))) - -(defvar *clx-font-families* '((:fix "*-courier-*") - (:sans-serif "*-helvetica-*") - (:serif "*-charter-*" "*-new century schoolbook-*" - "*-times-*"))) - -(defun disassemble-x-font-name (name) - (let ((cpos 0) - (tokens nil)) - (loop - (let ((dpos (position #\- name :start cpos))) - (when (null dpos) - (push (subseq name cpos) tokens) - (return)) - (push (if (= cpos dpos) - nil - (subseq name cpos dpos)) - tokens) - (setf cpos (1+ dpos)))) - (reverse tokens))) - - -(defvar *clx-fallback-font* "8x13" - "When non NIL and nothing better exists use this as the fallback font") - -(defmethod initialize-xlib-display-device (display-device display) - - (setf (silica::device-undefined-text-style display-device) - (silica::standardize-text-style display-device - *standard-character-set* - (make-text-style - :stand-in-for-undefined-style :roman - 10))) - - (let* () - (flet ((font->text-style (font family) - (let* ((tokens (disassemble-x-font-name font)) - (italic (member (fifth tokens) '("i" "o") :test #'equalp)) - (bold (equalp (fourth tokens) "Bold")) - (face (if italic - (if bold '(:bold :italic) :italic) - (if bold :bold :roman))) - (designed-point-size (parse-integer (ninth tokens))) - (designed-y-resolution (parse-integer (nth 10 tokens))) - (point-size (float designed-point-size)) - (size (/ point-size 10))) - (make-text-style family face size)))) - (dolist (family-stuff *clx-font-families*) - (let ((family (car family-stuff))) - (dolist (font-pattern (cdr family-stuff)) - (dolist (xfont (tk::list-font-names display font-pattern)) - (let ((text-style (font->text-style xfont family))) - ;; prefer first font satisfying this text style, so - ;; don't override if we've already defined one. - (unless (silica::text-style-mapping-exists-p - display-device *standard-character-set* text-style t) - (silica::add-text-style-mapping display-device *standard-character-set* - text-style xfont))))) - ;; Now build the logical size alist for the family - - - )) - - (let (temp) - (cond ((setq temp - (dolist (family *clx-font-families*) - (when (silica::text-style-mapping-exists-p display-device - *standard-character-set* - `(,(car family) :roman 10)) - (return (make-text-style (car family) :roman 10))))) - (silica::add-text-style-mapping display-device *standard-character-set* - (silica::device-undefined-text-style display-device) - #+ignore *undefined-text-style* - temp)) - - ;; Perhaps we should look for some other conveniently sized - ;; fonts. - - (*clx-fallback-font* - (silica::add-text-style-mapping display-device - *standard-character-set* - (silica::device-undefined-text-style display-device) - #+ignore *undefined-text-style* - (make-instance 'tk::font - :display display - :name *clx-fallback-font*))) - - ;;; Perhaps we should just grab the first font we can find. - - (t - (error "Unable to determine default font"))))))) - -(defparameter *clx-logical-size-alist* - '((:tiny 6) - (:very-small 8) - (:small 10) - (:normal 12) - (:large 14) - (:very-large 18) - (:huge 24))) - -(defmethod silica::standardize-text-style ((display-device motif-port) character-set style) - (silica::standardize-text-style-1 - display-device style character-set *clx-logical-size-alist*)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defmethod silica::destroy-mirror ((port motif-port) sheet) - (tk::destroy-widget (sheet-direct-mirror sheet))) - -(defmethod realize-mirror ((port motif-port) sheet) - (multiple-value-bind - (class initargs) - (find-widget-class-and-initargs-for-sheet port sheet) - (let ((widget (apply #'make-instance class - :parent (find-widget-parent port sheet) - :managed (sheet-enabled-p sheet) - initargs))) - (add-sheet-callbacks port sheet widget) - widget))) - -(defmethod add-sheet-callbacks ((port motif-port) sheet (widget t)) - (declare (ignore sheet))) - -(defmethod sheet-mirror-event-handler (widget event sheet) - (multiple-value-bind - (same-p root child root-x root-y native-x native-y mask) - (tk::query-pointer (tk::widget-window widget)) - (declare (ignore same-p root child root-x root-y)) - (let ((modifiers (logand #16rff mask)) - (button (ash mask -8))) - (distribute-event - (port sheet) - (ecase (tk::event-type event) - (:leave-notify - (make-instance 'pointer-exit-event - :native-x native-x - :native-y native-y - :button (x-button->silica-button button) - :modifiers modifiers - :sheet sheet)) - (:enter-notify - (make-instance 'pointer-enter-event - :native-x native-x - :native-y native-y - :button (x-button->silica-button button) - :modifiers modifiers - :sheet sheet)) - (:motion-notify - (make-instance 'pointer-motion-event - :native-x native-x - :native-y native-y - :button (x-button->silica-button button) - :modifiers modifiers - :sheet sheet))))))) - -(defun x-button->silica-button (button) - (ecase button - (0 nil) - (4 - (warn "got an event 4") - silica::+pointer-right-button+) - (#.x11::button3 silica::+pointer-right-button+) - (#.x11::button2 silica::+pointer-middle-button+) - (#.x11::button1 silica::+pointer-left-button+))) - -(defmethod sheet-mirror-resized-callback (widget window event sheet) - (declare (ignore widget window event)) - (dispatch-event - sheet - (let ((r (mirror-region (port sheet) sheet))) - (make-instance 'window-configuration-event - :native-region r - :region (untransform-region - (sheet-native-transformation - sheet) - r) - :sheet sheet)))) - -#+ignore -(mirror-region-updated (port sheet) sheet) - -(defmethod sheet-mirror-exposed-callback (widget window event sheet) - (declare (ignore widget window)) - (let* ((minx (x11::xexposeevent-x event)) - (miny (x11::xexposeevent-y event)) - (width (x11::xexposeevent-width event)) - (height (x11::xexposeevent-height event)) - (maxx (+ minx width)) - (maxy (+ miny height))) - - (dispatch-repaint - sheet - (make-instance 'window-repaint-event - :native-region (make-rectangle* minx miny maxx maxy) - :region (untransform-region - (sheet-native-transformation sheet) - (make-rectangle* minx miny maxx maxy)) - :sheet sheet)))) - -(defmethod sheet-mirror-input-callback (widget window event sheet) - (declare (ignore widget window)) - - (ecase (tk::event-type event) - (:key-press - (distribute-event - (port sheet) - (multiple-value-bind - (ignore character keysym) - (tk::lookup-string event) - (declare (ignore ignore)) - (make-instance 'key-press-event - :key-name keysym - :character (and (= (length character) 1) - (aref character 0)) - :sheet sheet - :modifiers (x11::xkeyevent-state event))))) - - (:key-release - (distribute-event - (port sheet) - (multiple-value-bind - (ignore character keysym) - (tk::lookup-string event) - (declare (ignore ignore)) - (make-instance 'key-release-event - :key-name keysym - :character (and (= (length character) 1) - (aref character 0)) - :sheet sheet - :modifiers (x11::xkeyevent-state event))))) - - (:button-press - (distribute-event - (port sheet) - (make-instance 'pointer-press-event - :sheet sheet - :x :?? - :y :?? - :modifiers (x11::xkeyevent-state event) - :button (x-button->silica-button - (x11::xbuttonevent-button event)) - :native-x (x11::xbuttonevent-x event) - :native-y (x11::xbuttonevent-y event)))) - (:button-release - (distribute-event - (port sheet) - (make-instance 'pointer-release-event - :sheet sheet - :x :?? - :y :?? - :modifiers (x11::xkeyevent-state event) - :button (x-button->silica-button - (x11::xbuttonevent-button event)) - :native-x (x11::xbuttonevent-x event) - :native-y (x11::xbuttonevent-y event)))))) - -(defmethod find-widget-class-and-initargs-for-sheet (port (sheet sheet)) - (declare (ignore port)) - (values 'xm-drawing-area (list :resize-policy :grow))) - -(defmethod find-widget-class-and-initargs-for-sheet :around (port (sheet sheet)) - (declare (ignore port)) - (multiple-value-bind - (class initargs) - (call-next-method) - (setq initargs (set-mirror-geometry sheet initargs)) - (values class initargs))) - - -(defmethod set-mirror-geometry (sheet initargs) - (unless (getf initargs :x) - (multiple-value-bind - (left top right bottom) - (sheet-actual-native-edges sheet) - (setf (getf initargs :x) left - (getf initargs :y) top - (getf initargs :width) (- right left) - (getf initargs :height) (- bottom top)))) - initargs) - -;; If we are creating a top level sheet then we have to create a shell -;; for it - -(defmethod find-widget-parent (port sheet) - (let ((ma (sheet-mirrored-ancestor sheet))) - (if (graftp ma) - (multiple-value-bind - (class initargs) - (find-shell-class-and-initargs port sheet) - (apply #'make-instance class - :parent (port-application-shell port) - initargs)) - (sheet-mirror ma)))) - -(defmethod find-shell-class-and-initargs (port sheet) - (values 'top-level-shell - ;; Need this so that an interactive pane can have children - ;; but still accept the focus - '(:keyboard-focus-policy :pointer))) - -(defmethod enable-mirror (port sheet) - (declare (ignore port)) - (let ((mirror (sheet-mirror sheet))) - (typecase (widget-parent mirror) - (null) - (top-level-shell - ;; this is a nasty hack just to make sure that the child is managed. - ;; top-level-sheets are created unmanaged because they are - ;; disabled to we have to do not! - (manage-child mirror) - (popup (widget-parent mirror))) - (t - (manage-child mirror))))) - -(defmethod disable-mirror (port sheet) - (declare (ignore port)) - (let ((mirror (sheet-mirror sheet))) - (when mirror - (typecase (widget-parent mirror) - (null) - (top-level-shell - (tk::popdown (widget-parent mirror))) - (t - (tk::unmanage-child mirror)))))) - -(defmethod realize-graft ((port motif-port) graft) - ;; Set the width etc etc - (setf (sheet-direct-mirror graft) (port-application-shell port)) - ;; Mess with the region - ;; Mess with the native transformation - ) - -(defmethod mirror-region* ((port motif-port) sheet) - (when (sheet-mirror sheet) - (multiple-value-bind - (x y width height) - (get-values (sheet-mirror sheet) :x :y :width :height) - (values x y - (+ x width) - (+ y height))))) - -(defmethod mirror-region ((port motif-port) sheet) - (multiple-value-call #'make-rectangle* - (mirror-region* port sheet))) - -(defmethod mirror-inside-region* ((port motif-port) sheet) - (multiple-value-bind - (minx miny maxx maxy) - (mirror-region* port sheet) - (values 0 0 (- maxx minx) (- maxy miny)))) - -(defmethod mirror-native-edges* ((port motif-port) sheet) - (let* ((mirror (sheet-direct-mirror sheet))) - (multiple-value-bind - (x y width height) - (get-values mirror :x :y :width :height) - (values x y (+ x width) (+ y height))))) - -(defmethod mirror-inside-edges* ((port motif-port) sheet) - (multiple-value-bind - (a b c d) - (mirror-native-edges* port sheet) - (values 0 0 (- c a) (- d b)))) - -(defmethod set-sheet-mirror-edges* ((port motif-port) sheet - target-left target-top - target-right target-bottom) - (let ((w (- target-right target-left)) - (h (- target-bottom target-top))) - (tk::set-values (sheet-direct-mirror sheet) - :x target-left - :y target-top - :width w - :height h) - (multiple-value-bind - (nx ny nw nh) - (tk::get-values (sheet-direct-mirror sheet) :x :y :width - :height) - (when (or (/= target-left nx) - (/= target-top ny) - (/= w nw) - (/= h nh)) - (warn "Geo set fail, ~S, ~S,~S" - sheet - (list target-left target-top w h) - (list nx ny nw nh)))))) - -(defmethod process-next-event (port &key wait-function timeout) - (tk::process-one-event (port-context port) - :wait-function wait-function - :timeout timeout)) - - -(defmethod port-force-output ((port motif-port)) - nil) - - -(defmethod port-glyph-for-character ((port motif-port) - character - appearance - &optional - our-font) - (let* ((index (char-int character)) - (x-font (or our-font - (realize-text-style port appearance))) - (escapement-x (tk::char-width x-font index)) - (escapement-y 0) - (origin-x 0) - (origin-y (tk::font-ascent x-font)) - (bb-x escapement-x) - (bb-y (+ origin-y (tk::font-descent x-font)))) - (when (zerop escapement-x) (break)) - (values index x-font escapement-x escapement-y - origin-x origin-y bb-x bb-y))) - -(defmethod silica::text-size (medium string &key text-style start end) - (when (characterp string) - (setq string (string string) - start 0 - end nil)) - (unless start (setq start 0)) - (unless end (setq end (length string))) - (clim::stream-string-output-size medium string - :start start :end end :text-style text-style)) - - - -(defmethod realize-text-style (port font) - (silica::text-style-mapping port nil font nil)) - - - -(defmethod text-style-mapping :around ((device motif-port) - character-set - text-style - etc) - (declare (ignore etc)) - (let ((font (call-next-method))) - (when (or (stringp font) (symbolp font)) - (let* ((font-name (string font))) - (setf font (make-instance 'tk::font - :display (port-display device) - :name font-name)) - (add-text-style-mapping - device character-set (parse-text-style text-style) font))) - font)) - - -(defmethod silica::text-style-width ((text-style text-style) medium) - (tk::font-width (realize-text-style (port medium) text-style))) - -(defmethod text-style-ascent ((text-style text-style) medium) - (tk::font-ascent (realize-text-style (port medium) text-style))) - -(defmethod text-style-descent ((text-style text-style) medium) - (tk::font-descent (realize-text-style (port medium) text-style))) - -(defmethod text-style-height ((text-style text-style) medium) - (+ (text-style-ascent text-style medium) - (text-style-descent text-style medium))) - -(ff::defforeign 'xtsetkeyboardfocus - :entry-point "_XtSetKeyboardFocus") - (ff:defforeign 'xmprocesstraversal :entry-point "_XmProcessTraversal") (defmethod port-note-cursor-change ((port motif-port) - cursor - stream - type - old - new) + cursor + stream + type + old + new) (declare (ignore old type cursor)) (call-next-method) (when new @@ -526,15 +48,4 @@ (tk::object-handle (sheet-mirror stream)) (tk::object-handle (sheet-mirror stream)))) (setf (silica::port-keyboard-focus port) - (and new stream))) - -(defun sheet-top-level-mirror (stream) - (let ((last-mirror nil)) - (loop - (when (graftp stream) (return last-mirror)) - (when (sheet-direct-mirror stream) - (setq last-mirror stream)) - (setq stream (sheet-parent stream))))) - -(defmethod clim::stream-set-input-focus (stream) - nil) + (and new stream))) diff --git a/tk-silica/xt-silica.lisp b/tk-silica/xt-silica.lisp index d9f063bc..09a42d2c 100644 --- a/tk-silica/xt-silica.lisp +++ b/tk-silica/xt-silica.lisp @@ -20,9 +20,9 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader$ - +;; $fiHeader: xt-silica.cl,v 1.1 92/01/15 16:16:15 cer Exp Locker: cer $ +(in-package :xm-silica) (defclass xt-port (port) ((application-shell :reader port-application-shell) diff --git a/tk/callbacks.lisp b/tk/callbacks.lisp index ead8205d..a7996def 100644 --- a/tk/callbacks.lisp +++ b/tk/callbacks.lisp @@ -20,13 +20,19 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader$ +;; $fiHeader: callbacks.cl,v 1.3 92/01/02 15:08:35 cer Exp Locker: cer $ (in-package :tk) (defforeign 'add_callback :entry-point "_XtAddCallback") +(defforeign 'xt_has_callbacks + :entry-point "_XtHasCallbacks") + +(defun has-callbacks-p (w name) + (not (zerop (xt_has_callbacks (object-handle w) name)))) + (defun-c-callable callback-handler ((widget :unsigned-long) (client-data :unsigned-long) (call-data :unsigned-long)) @@ -69,14 +75,15 @@ (defun new-callback-id () (incf *callback-ids*)) +(defun process-callback-alist-component (x) + (destructuring-bind (name &optional type) x + (list (lispify-tk-name name :package :keyword) + name + nil;; malloc cache + type))) + (defparameter *callback-name-alist* - (mapcar #'(lambda (x) - (destructuring-bind (name &optional type) x - (list (lispify-tk-name name :package :keyword) - name - nil;; malloc cache - type - ))) + (mapcar #'process-callback-alist-component '( ("activateCallback" :activate) ("armCallback") @@ -117,6 +124,10 @@ ("destroyCallback") ("gainPrimaryCallback") ("losePrimaryCallback") + + ;; OpenLook Callbacks + ("sliderMoved" slider-moved) + ))) (defun convert-callback-name (x) diff --git a/tk/defsys.lisp b/tk/defsys.lisp index c5ca1272..f8646c35 100644 --- a/tk/defsys.lisp +++ b/tk/defsys.lisp @@ -20,21 +20,16 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: defsys.cl,v 1.2 92/01/02 15:08:37 cer Exp Locker: cer $ +;; $fiHeader: defsys.cl,v 1.3 92/01/06 20:43:43 cer Exp Locker: cer $ - -(defsys::defsystem :xm-tk - (:default-pathname (frob-pathname "tk")) +(defsys::defsystem :basic-tk + (:default-pathname (frob-pathname "tk")) (|pkg|) (|foreign-obj|) (|macros|) - ;;; Do the foreign loads - - (|load-xm|) - - ;; Clos<->xlib interface + ;; Xlib stuff (|xlib|) (|font|) @@ -53,33 +48,27 @@ (|resources|) (|event|) (|callbacks|) - (|convenience|) + ) +(defsys::defsystem :xm-tk + (:default-pathname (frob-pathname "tk")) + (|load-xm|) (|xm-init|) (|xm-widgets|) (|xm-font-list|) (|xm-protocols|) - + (|convenience|) (|examples|) ) -#+this-is-totally-out-of-date + +(defsys::defsystem :hi-tk + (:default-pathname (frob-pathname "tk")) + (|make-widget|)) + (defsys::defsystem :ol-tk (:default-pathname (frob-pathname "tk")) - (|pkg|) - (|foreign-obj|) (|load-ol|) - (|xlib|) - (|xtk|) - (|make-classes|) - (|foreign|) - (|widget|) - (|resources|) - (|event|) - (|callbacks|) (|ol-init|) - (|graphics|) - (|font|) - (|gcontext|) - (|ol-examples|) - ) + (|ol-callbacks|) + (|ol-examples|)) diff --git a/tk/examples.lisp b/tk/examples.lisp index e16f1022..cd1c200b 100644 --- a/tk/examples.lisp +++ b/tk/examples.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader$ +;; $fiHeader: examples.cl,v 1.3 92/01/02 15:08:39 cer Exp Locker: cer $ (in-package :tk) @@ -47,17 +47,6 @@ (add-callback da :input-callback 'da-button-press-handler :input) (popup app4)) -(defun setup (hostspec) - (setq context (create-application-context)) - (setq display (make-instance 'display - :host hostspec - :context context)) - (setq app (app-create-shell :display display :widget-class 'application-shell))) - -(defun initialize-motif-toolkit (hostspec) - (setup hostspec) - (values context display app)) - (defvar *bitmaps* (quote ("background" "25_foreground" "50_foreground" "75_foreground" "horizontal" "vertical" "slant_right" "slant_left" "1x1" "2x2" "black" "boxes" "cntr_ptr" "cntr_ptrmsk" diff --git a/tk/foreign-obj.lisp b/tk/foreign-obj.lisp index d5612936..61d5736f 100644 --- a/tk/foreign-obj.lisp +++ b/tk/foreign-obj.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: foreign-obj.cl,v 1.2 92/01/02 15:08:42 cer Exp Locker: cer $ +;; $fiHeader: foreign-obj.cl,v 1.3 92/01/06 20:43:44 cer Exp Locker: cer $ (in-package :tk) @@ -88,5 +88,11 @@ initargs))) ((typep x class) x) (t - (error "~s has the wrong class: ~s" - x class))))) + (cerror "Make a new one" + "~s has the wrong class: ~s" + x class) + (setf (gethash handle table) + (apply #'make-instance + class + :handle handle + initargs)))))) diff --git a/tk/load-ol.lisp b/tk/load-ol.lisp index 84c77942..086c5680 100644 --- a/tk/load-ol.lisp +++ b/tk/load-ol.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader$ +;; $fiHeader: load-ol.cl,v 1.2 92/01/02 15:08:48 cer Exp Locker: cer $ (in-package :tk) @@ -28,24 +28,106 @@ make ucl_xtras='/usr/tech/cer/stuff/clim-2.0/ol-classes.o /usr/tech/cer/stuff/clim-2.0/lib/libXol.a /usr/tech/cer/stuff/clim-2.0/lib/libXt.a /usr/tech/cer/stuff/clim-2.0/lib/libX11.a' ucl |# -(flet ((foundp (entry-point) - (let ((x (make-array 1 :initial-contents - (list (ff:convert-to-lang - entry-point)))) - (y - - (make-array 1 :element-type '(unsigned-byte 32)))) - (zerop (ff:get-entry-points x y))))) - (unless (foundp "insert_classes") - #+ingnore - (mapc #'foreign-functions:remove-entry-point - '("__unpack_quadruple" - "__prod_b10000" - "__carry_out_b10000" - "__prod_65536_b10000")) - (load "classes.o" - :foreign-files - '("/vapor/usr/tech/cer/stuff/clim-2.0/lib/libXol.a" - "/vapor/usr/tech/cer/stuff/clim-2.0/lib/libXt.a" - "/vapor/usr/tech/cer/stuff/clim-2.0/lib/libX11.a") - :print t))) +(eval-when (compile load eval) + (defparameter *openlook-classes* '( + ;; Base classes + "_constraintWidgetClass" + "_objectClass" + "_wmShellWidgetClass" + "_vendorShellWidgetClass" + "_coreWidgetClass" + "_shellWidgetClass" + "_compositeWidgetClass" + "_applicationShellWidgetClass" + "_overrideShellWidgetClass" + "_topLevelShellWidgetClass" + "_transientShellWidgetClass" + + ;; OpenLook specific classes + ;; Some of these are both gadgets + ;; and widget and I think the + ;; names are the same! + + "_abbrevMenuButtonWidgetClass" + "_abbrevStackWidgetClass" + "_arrowWidgetClass" + "_baseWindowShellWidgetClass" + "_bulletinBoardWidgetClass" + "_buttonWidgetClass" + "_buttonGadgetClass" + "_buttonStackWidgetClass" + + ;;"_buttonStackGadgetClass" + + "_captionWidgetClass" + "_checkBoxWidgetClass" + "_controlAreaWidgetClass" + "_eventObjClass" + "_exclusivesWidgetClass" + "_flatCheckBoxWidgetClass" + "_flatExclusivesWidgetClass" + "_flatNonexclusivesWidgetClass" + "_flatWidgetClass" + "_footerPanelWidgetClass" + "_formWidgetClass" + "_helpWidgetClass" + "_listPaneWidgetClass" + "_magWidgetClass" + "_managerWidgetClass" + "_menuShellWidgetClass" + "_menuButtonWidgetClass" + + ;;"_menuButtonGadgetClass" + + "_nonexclusivesWidgetClass" + "_noticeShellWidgetClass" + "_oblongButtonWidgetClass" + ;; "_oblongButtonGadgetClass" + "_popupWindowShellWidgetClass" + "_primitiveWidgetClass" + "_pushpinWidgetClass" + "_rectButtonWidgetClass" + "_scrollbarWidgetClass" + "_scrolledWindowWidgetClass" + "_scrollingListWidgetClass" + "_sliderWidgetClass" + "_staticTextWidgetClass" + "_stubWidgetClass" + "_textWidgetClass" + + ;;; This two seem to be broken! + ;; "_textEditWidgetClass" + ;;"_textPaneWidgetClass" + + "_compositeWidgetClass" + "_overrideShellWidgetClass" + "_shellWidgetClass" + "_topLevelShellWidgetClass" + "_widgetClass" + "_widgetClassRec" + "_drawAreaWidgetClass" + ))) + +(defun load-ol (&optional (what *openlook-classes*)) + (setq what (remove-if #'ff::get-entry-point `(,@what))) + (when what + (mapc #'foreign-functions:remove-entry-point + '("__unpack_quadruple" + "__prod_b10000" + "__unpacked_to_decimal" + "__carry_out_b10000" + "__prod_65536_b10000")) + (load "" + :unreferenced-lib-names + what + :foreign-files + '("/usr/openwin-3.0/lib/libXol.a" + "/usr/motif/usr/lib/libXt.a" + "/usr/motif/usr/lib/libX11.a" + ;; Hopefully + ;;"/usr/openwin-3.0/lib/libXt.a" + ;; "/usr/openwin-3.0/lib/libX11.a" + ) + :print t))) + +(load-ol) diff --git a/tk/load-xm.lisp b/tk/load-xm.lisp index 140e07d5..b65d8695 100644 --- a/tk/load-xm.lisp +++ b/tk/load-xm.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader$ +;; $fiHeader: load-xm.cl,v 1.2 92/01/02 15:08:49 cer Exp Locker: cer $ (in-package :tk) @@ -80,36 +80,26 @@ make ucl_xtras='/usr/tech/cer/stuff/clim-2.0/xm-classes.o /usr/motif/usr/lib/lib "_transientShellWidgetClass" ))) -(flet ((foundp (entry-point) - (let ((x (make-array 1 :initial-contents - (list (ff:convert-to-lang - entry-point)))) - (y - - (make-array 1 :element-type '(unsigned-byte 32)))) - (zerop (ff:get-entry-points x y))))) - (unless (foundp "insert_classes") - (mapc #'foreign-functions:remove-entry-point - '("__unpack_quadruple" - "__prod_b10000" - "__carry_out_b10000" - "__prod_65536_b10000")) - (load "classes.o" - :unreferenced-lib-names `( - "_XCopyGC" - ,@*motif-classes* - ) - :foreign-files - '("/usr/motif/usr/lib/libXm.a" - "/usr/motif/usr/lib/libXt.a" - "/usr/motif/usr/lib/libX11.a") - :print t))) +(defun load-from-xm (&optional (what *motif-classes*)) + (setq what (remove-if #'ff::get-entry-point + `( + "_XCopyGC" + ,@what + ))) + (when what + #+ignore + (mapc #'foreign-functions:remove-entry-point + '("__unpack_quadruple" + "__prod_b10000" + "__carry_out_b10000" + "__prod_65536_b10000")) + (load "" + :unreferenced-lib-names what + :foreign-files + '("/usr/motif/usr/lib/libXm.a" + "/usr/motif/usr/lib/libXt.a" + "/usr/motif/usr/lib/libX11.a") + :print t))) + +(load-from-xm) -(defun load-from-xm (unref) - (load "" - :unreferenced-lib-names (if (listp unref) unref (list unref)) - :foreign-files - '("/usr/motif/usr/lib/libXm.a" - "/usr/motif/usr/lib/libXt.a" - "/usr/motif/usr/lib/libX11.a") - :print t)) diff --git a/tk/macros.lisp b/tk/macros.lisp index 91edebb4..104801fa 100644 --- a/tk/macros.lisp +++ b/tk/macros.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: macros.cl,v 1.2 92/01/02 15:08:51 cer Exp Locker: cer $ +;; $fiHeader: macros.cl,v 1.3 92/01/08 14:58:16 cer Exp Locker: cer $ (in-package :tk) @@ -31,12 +31,13 @@ `(progn ,@body) (destructuring-bind ((var value) &rest more-bindings) bindings - `(let ((,var (or (pop *temp-with-ref-par*) - (make-array 1 :element-type '(unsigned-byte - 32))))) - (declare (type (simple-array (unsigned-byte 32) (1)) ,var)) - (setf (aref ,var 0) ,value) - (multiple-value-prog1 - (with-ref-par ,more-bindings ,@body) - (push ,var *temp-with-ref-par*)))))) - + (let ((val (gensym))) + `(let ((,val ,value) + (,var (or (pop *temp-with-ref-par*) + (make-array 1 :element-type '(unsigned-byte + 32))))) + (declare (type (simple-array (unsigned-byte 32) (1)) ,var)) + (setf (aref ,var 0) ,val) + (multiple-value-prog1 + (with-ref-par ,more-bindings ,@body) + (push ,var *temp-with-ref-par*))))))) diff --git a/tk/make-classes.lisp b/tk/make-classes.lisp index ccc260a5..62d2e435 100644 --- a/tk/make-classes.lisp +++ b/tk/make-classes.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: make-classes.cl,v 1.3 92/01/06 20:43:47 cer Exp Locker: cer $ +;; $fiHeader: make-classes.cl,v 1.4 92/01/08 14:58:18 cer Exp Locker: cer $ (in-package :tk) @@ -33,20 +33,11 @@ (error "Cannot find the entry-point for: ~S" x)) (aref xx 0))) -(defvar *class-table-addr* - (get-entry-point-value "_classtable")) - - (def-c-type (class-array :in-foreign-space) 1 :unsigned-long) (defun get-foreign-variable-value (x) (class-array (get-entry-point-value x) 0)) -(defun nth-class (n) - (class-array *class-table-addr* n)) - -;;; (char*-to-string (widget-struct-name (nth-class 0))) - (defun get-resource-list-internal (class fn resource-class) (let ((x (make-array 1 :element-type '(unsigned-byte 32))) (y (make-array 1 :element-type '(unsigned-byte 32)))) @@ -175,6 +166,9 @@ (dolist (r (class-direct-resources class)) (let* ((rname (resource-name r)) (name (intern (format nil "~A-~A" 'widget rname)))) + (setq name (case name + (widget-window 'widget-stub-window) + (t name))) (add-method (ensure-generic-function name) (make-instance 'clos::standard-method @@ -201,7 +195,12 @@ (defun widget-class-name (h) (char*-to-string (xtk-class-name h))) -(defun lispify-class-name (x) (lispify-tk-name x)) +(defun lispify-class-name (x) + (let ((name (lispify-tk-name x))) + (case name + ;; Openlook + (list 'ol-list) + (t name)))) (defun lispify-tk-name (string &key (start 0) @@ -247,6 +246,13 @@ (warn "toolkit warning: ~a" (char*-to-string message))) +(defun add-resource-to-class (class resource) + (clos::map-over-subclasses + #'(lambda (c) + (push + resource + (slot-value c 'resources))) + class)) #| (make-widget class parent . resources) diff --git a/tk/make-widget.lisp b/tk/make-widget.lisp index 5c45d7d9..52ce89a4 100644 --- a/tk/make-widget.lisp +++ b/tk/make-widget.lisp @@ -20,7 +20,9 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader$ +;; $fiHeader: make-widget.cl,v 1.1 92/01/14 20:37:55 cer Exp Locker: cer $ + +(in-package :tk) (defgeneric make-widget (widget &key) ;;; returns the handle of a widget diff --git a/tk/ol-examples.lisp b/tk/ol-examples.lisp index e441ccd7..2195799d 100644 --- a/tk/ol-examples.lisp +++ b/tk/ol-examples.lisp @@ -20,20 +20,77 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader$ +;; $fiHeader: ol-examples.cl,v 1.2 92/01/02 15:08:54 cer Exp Locker: cer $ (in-package :tk) -(defun example-1 () - (let (shell) - -(setq shell (create-popup-shell "foo" 'base-window-shell old-shell)) -(setq cp (create-managed-widget 'control "fio" shell)) -(setq bs (create-managed-widget - 'menu-button "foo" cp - :label "foo" - :font - "-adobe-courier-medium-r-normal--12-120-75-75-m-70-iso8859-1")) - - - (popup shell))) +(defun simple-ol-example () + (setq shell (make-instance 'base-window-shell :parent app)) + (setq control (make-instance 'control :parent shell + :layout-type :fixedcols + )) + (setq button (make-instance 'menu-button :parent control + :label "foo" + :font + "-adobe-courier-medium-r-normal--12-120-75-75-m-70-iso8859-1")) + + (setq menu (tk::get-values button :menu-pane)) + + (setq b1 (make-instance 'oblong-button :parent menu + :label "bar" + :font + "-adobe-courier-medium-r-normal--12-120-75-75-m-70-iso8859-1")) + + + (setq b2 (make-instance 'oblong-button :parent menu + :label "baz" + :font + "-adobe-courier-medium-r-normal--12-120-75-75-m-70-iso8859-1")) + + (setq slider (make-instance 'slider + :orientation :horizontal + :height 100 + :parent control)) + + (setq scrollbar (make-instance 'scrollbar + :orientation :horizontal + :height 100 + :parent control)) + + (setq list-pane (make-instance 'list-pane + :parent control + )) + + (setq ab-menu (make-instance 'abbrev-menu-button + :parent control + )) + + (setq menu1 (tk::get-values ab-menu :menu-pane)) + + (setq b3 (make-instance 'oblong-button :parent menu1 + :label "Lisp" + :font + "-adobe-courier-medium-r-normal--12-120-75-75-m-70-iso8859-1")) + + + (setq b4 (make-instance 'oblong-button :parent menu1 + :label "Fortran" + :font + "-adobe-courier-medium-r-normal--12-120-75-75-m-70-iso8859-1")) + + (setq stext (make-instance 'static-text + :string "heooo" + :parent control)) + + (set-values ab-menu :preview-widget stext) + + + ) + + + + + +(defun simple-ol-example-2 () + (setq shell (make-instance 'base-window-shell :parent app)) + (setq da (make-instance 'draw-area :parent shell))) diff --git a/tk/ol-init.lisp b/tk/ol-init.lisp index dddb01c5..40e70ee5 100644 --- a/tk/ol-init.lisp +++ b/tk/ol-init.lisp @@ -20,26 +20,15 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader$ +;; $fiHeader: ol-init.cl,v 1.2 92/01/02 15:08:56 cer Exp Locker: cer $ (in-package :tk) -(defforeign 'ol_initialize :entry-point "_OlInitialize") - -(defun ol-initialize (&key (shell-name "foo") - (application-class "foo") - ) - (with-ref-par ((argc 0) - (argv 0)) - (ol_initialize - (string-to-char* shell-name) - (string-to-char* application-class) - 0 ;; options - 0;; num-options - argc ;; argc - argv ;; argv - ))) +(defforeign 'ol_toolkit_initialize :entry-point "_OlToolkitInitialize") + +(defun ol-initialize () + (ol_toolkit_initialize)) (defun-c-callable ol-error-handler ((message :unsigned-long)) (error "toolkit error: ~A" @@ -50,38 +39,81 @@ (warn "toolkit error: ~A" (char*-to-string message))) +(defun-c-callable ol-error-va-handler ((message :unsigned-long)) + (error "toolkit error: ~A" + (char*-to-string message))) + + +(defun-c-callable ol-warning-va-handler ((message :unsigned-long)) + (warn "toolkit error: ~A" + (char*-to-string message))) + + (defforeign 'ol_set_warning_handler :entry-point "_OlSetWarningHandler") (defforeign 'ol_set_error_handler :entry-point "_OlSetErrorHandler") +(defforeign 'ol_set_va_display_error_msg_handler + :entry-point "_OlSetVaDisplayErrorMsgHandler") + +(defforeign 'ol_set_va_display_warning_msg_handler + :entry-point "_OlSetVaDisplayWarningMsgHandler") (ol_set_warning_handler (register-function 'ol-warning-handler)) +(ol_set_va_display_warning_msg_handler (register-function 'ol-warning-va-handler)) (ol_set_error_handler (register-function 'ol-error-handler)) - -(setq shell (ol-initialize)) - -(defvar *done* nil) -(defvar *n-classes*) - -(unless *done* - (setq *n-classes* (insert_classes)) - (make-classes *n-classes*) - (setq *done* t)) - - -(setq shell (intern-widget shell (widget-class-of shell))) - -(defforeign 'xt_display :entry-point "_XtDisplay") -(defforeign 'xt_display_to_application_context - :entry-point "_XtDisplayToApplicationContext") - -(setf (slot-value shell 'display) - (let* ((d (xt_display (object-handle shell))) - (c (xt_display_to_application_context d))) - (intern-widget d 'display - :display d - :context - (make-instance 'application-context :context c)))) +(ol_set_va_display_error_msg_handler (register-function 'ol-error-va-handler)) + + +(ol-initialize) +(toolkit-initialize) + +(defvar *ol-done* nil) + +(unless *ol-done* + (make-classes *openlook-classes*) + (setq *ol-done* t)) + +(defmethod make-widget ((w event) + &rest args &key parent (managed t) (name "") &allow-other-keys) + (remf :managed args) + (remf :name args) + (remf :parent args) + (let ((class (class-of w))) + (if managed + (apply #'create-managed-widget name class parent args) + (apply #'create-widget name class parent args)))) + +(add-resource-to-class (find-class 'menu-button) + (make-instance 'resource + :name :menu-pane + :type 'widget + :original-name + (string-to-char* + "menuPane"))) + +(add-resource-to-class (find-class 'abbrev-menu-button) + (make-instance 'resource + :name :menu-pane + :type 'widget + :original-name + (string-to-char* + "menuPane"))) + + +;(setq shell (intern-widget shell (widget-class-of shell))) +; +;(defforeign 'xt_display :entry-point "_XtDisplay") +;(defforeign 'xt_display_to_application_context +; :entry-point "_XtDisplayToApplicationContext") +; +;(setf (slot-value shell 'display) +; (let* ((d (xt_display (object-handle shell))) +; (c (xt_display_to_application_context d))) +; (intern-widget d 'display +; :display d +; :context +; (make-instance 'application-context :context c)))) diff --git a/tk/resources.lisp b/tk/resources.lisp index 1c578b0f..f45c7be0 100644 --- a/tk/resources.lisp +++ b/tk/resources.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: resources.cl,v 1.3 92/01/06 20:43:48 cer Exp Locker: cer $ +;; $fiHeader: resources.cl,v 1.4 92/01/08 14:58:20 cer Exp Locker: cer $ (in-package :tk) @@ -54,7 +54,7 @@ value) ((null args) (make-array (length new-args) - :element-type '(unsigned-byte 32) + :element-type '(signed-byte 32) :initial-contents (nreverse new-args))) (setq keyword (pop args) value (pop args)) @@ -99,7 +99,7 @@ (push (resource-original-name resource) arglist) (push (make-x-arglist) arglist))) - (setq arglist (coerce (nreverse arglist) '(vector (unsigned-byte 32)))) + (setq arglist (coerce (nreverse arglist) '(vector (signed-byte 32)))) (get_values (object-handle widget) arglist (truncate (length arglist) 2)) @@ -200,8 +200,11 @@ :system-modal)) (defmethod convert-resource-out ((parent t) (type (eql 'font-struct)) value) - (object-handle (load-query-font (widget-display parent) - value))) + (object-handle + (make-instance 'font + :display (widget-display parent) + :name value))) + (defmethod convert-resource-in ((parent t) (type (eql 'string)) value) (unless (zerop value) @@ -298,4 +301,201 @@ (defmethod convert-resource-in ((widget t) (type (eql 'widget)) x) - (intern-widget x)) + (intern-widget x :display (widget-display widget))) + +(defmethod convert-resource-out ((widget t) (type (eql 'widget)) x) + (object-handle x)) + +;; Could not think of anywhere better! + + +(defun setup (&optional (hostspec "localhost:0")) + (setq context (create-application-context)) + (setq display (make-instance 'display + :host hostspec + :context context)) + (setq app (app-create-shell :display display :widget-class 'application-shell))) + +(defun initialize-motif-toolkit (hostspec) + (setup hostspec) + (values context display app)) + + +;;; ol resource + +(defmethod convert-resource-out ((parent t) (type (eql 'position)) value) + value) + +(defmethod convert-resource-in ((parent t) (type (eql 'position)) value) + (ash value -16)) + +(defmethod convert-resource-out ((parent t) (type (eql 'dimension)) value) + value) + +(defmethod convert-resource-in ((parent t) (type (eql 'dimension)) + value) + (ash value -16)) + +;; from OpenLook.h + +(defvar *ol-defines* '( + (:absent-pair 0) + (:all 1) + (:always 2) + (:atom-help 3) + (:both 4) + (:bottom 5) + (:buttonstack 6) + (:center 7) + (:class-help 8) + (:columns 9) + (:copy-mask-value 10) + (:copy-size 11) + (:copy-source-value 12) + (:current 13) + (:default-pair 14) + (:disk-source 15) + (:display-form 16) + (:down 17) + (:existing-source 18) + (:fixedcols 19) + (:fixedheight 20) + (:fixedrows 21) + (:fixedwidth 22) + (:flat-button 23) + (:flat-checkbox 24) + (:flat-container 25) + (:flat-exclusives 26) + (:flat-help 27) + (:flat-nonexclusives 28) + (:halfstack 29) + (:horizontal 30) + (:image 31) + (:in 32) + (:indirect-source 33) + (:label 34) + (:left 35) + (:mask-pair 36) + (:maximize 37) + (:millimeters 38) + (:minimize 39) + (:never 40) + (:next 41) + (:none 42) + (:nonebottom 43) + (:noneleft 44) + (:noneright 45) + (:nonetop 46) + (:notices 47) + (:no-virtual-mapping 48) + (:oblong 49) + (:out 50) + (:override-pair 51) + (:pixels 52) + (:points 53) + (:popup 54) + (:previous 55) + (:prog-defined-source 56) + (:rectbutton 57) + (:right 58) + (:rows 59) + (:source-form 60) + (:source-pair 61) + (:stayup 62) + (:string 63) + (:string-source 64) + (:text-append 65) + (:text-edit 66) + (:text-read 67) + (:top 68) + (:transparent-source 69) + (:vertical 70) + (:virtual-button 71) + (:virtual-key 72) + (:widget-help 73) + (:window-help 74) + (:wrap-any 75) + (:wrap-white-space 76) + (:continuous 77) + (:granularity 78) + (:release 79) + (:tickmark 80) + (:percent 81) + (:slidervalue 82) + (:wt-base 83) + (:wt-cmd 84) + (:wt-notice 85) + (:wt-help 86) + (:wt-other 87) + (:success 88) + (:duplicate-key 89) + (:duplicatekey 89) + (:bad-key 90) + (:menu-full 91) + (:menu-limited 92) + (:menu-cancel 93) + (:selectkey 94) + (:menukey 95) + (:menudefault 96) + (:menudefaultkey 97) + (:hsbmenu 98) + (:vsbmenu 99) + (:adjustkey 100) + (:nextapp 101) + (:nextwindow 102) + (:prevapp 103) + (:prevwindow 104) + (:windowmenu 105) + (:workspacemenu 106) + (:defaultaction 108) + (:drag 109) + (:drop 110) + (:togglepushpin 111) + (:pageleft 112) + (:pageright 113) + (:scrollbottom 114) + (:scrolltop 115) + (:multiright 116) + (:multileft 117) + (:multidown 118) + (:multiup 119) + (:immediate 120) + (:moveup 121) + (:movedown 122) + (:moveright 123) + (:moveleft 124) + (:click-to-type 125) + (:realestate 126) + (:underline 127) + (:highlight 128) + (:inactive 129) + (:display 130) + (:proc 131) + (:size-proc 132) + (:draw-proc 133) + (:pinned-menu 134) + (:press-drag-menu 135) + (:stayup-menu 136) + (:pointer 137) + (:inputfocus 138) + (:quit 142) + (:destroy 143) + (:dismiss 144) + (:pre 145) + (:post 146) + (:grow-off 147) + (:grow-horizontal 148) + (:grow-vertical 149) + (:grow-both 150) + )) + +(defmethod convert-resource-in (parent (type (eql 'ol-define)) value) + (setq value (ash value -16)) + (or (car (find value *ol-defines* :key #'second)) + (call-next-method))) + + +(defmethod convert-resource-out (parent (type (eql 'ol-define)) value) + (or (second (find value *ol-defines* :key #'first)) + (call-next-method))) + diff --git a/tk/widget.lisp b/tk/widget.lisp index 625ded1e..5d613fc6 100644 --- a/tk/widget.lisp +++ b/tk/widget.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: widget.cl,v 1.5 92/01/06 20:43:49 cer Exp Locker: cer $ +;; $fiHeader: widget.cl,v 1.6 92/01/08 14:58:23 cer Exp Locker: cer $ (in-package :tk) @@ -143,13 +143,6 @@ (let* ((window-id (xt_window (object-handle widget)))) (make-clx-window-from-id display window-id))) -#+xlib -(defun make-clx-window-from-id (display window-id) - (or (xlib::lookup-resource-id display window-id) - (let ((x-window (xlib::make-window :id window-id :display display))) - (xlib::save-id display window-id x-window) - x-window))) - (defun widget-class-of (x) (intern-widget-class (xtk-widget-widget-class x))) @@ -178,10 +171,13 @@ (defforeign 'xt_parent :entry-point "_XtParent") -(defun intern-widget (widget) - (intern-object-address - widget - (widget-class-of widget))) +(defun intern-widget (widget &rest args) + (and (not (zerop widget)) + (apply + #'intern-object-address + widget + (widget-class-of widget) + args))) (defmethod widget-parent (widget) (let ((x (xt_parent (object-handle widget)))) diff --git a/tk/xm-widgets.lisp b/tk/xm-widgets.lisp index 9bb8b48a..64ddfadb 100644 --- a/tk/xm-widgets.lisp +++ b/tk/xm-widgets.lisp @@ -20,23 +20,10 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader$ +;; $fiHeader: xm-widgets.cl,v 1.2 92/01/02 15:09:04 cer Exp Locker: cer $ (in-package :tk) -(defgeneric make-widget (widget &key) - ;;; returns the handle of a widget - ) - -(defmethod make-widget ((w core) &rest args &key parent (managed t) (name "") &allow-other-keys) - (remf :managed args) - (remf :name args) - (remf :parent args) - (let ((class (class-of w))) - (if managed - (apply #'create-managed-widget name class parent args) - (apply #'create-widget name class parent args)))) - (defmethod make-widget ((w xm-gadget) &rest args &key parent (managed t) (name "") &allow-other-keys) (remf :managed args) @@ -47,15 +34,6 @@ (apply #'create-managed-widget name class parent args) (apply #'create-widget name class parent args)))) - -(defmethod make-widget ((w shell) &rest args &key parent (name "") &allow-other-keys) - (error "shells not made this way")) - -(defmethod make-widget ((w top-level-shell) &rest args &key parent (name "") &allow-other-keys) - (remf :parent args) - (remf :name args) - (apply #'create-popup-shell name (class-of w) parent args)) - (defmethod make-widget ((w xm-dialog-shell) &rest args &key parent (name "") &allow-other-keys) (remf :parent args) (remf :name args) @@ -69,14 +47,6 @@ (defforeign 'xm_main_window_set_area :entry-point "_XmMainWindowSetAreas") -(defun add-resource-to-class (class resource) - (clos::map-over-subclasses - #'(lambda (c) - (push - resource - (slot-value c 'resources))) - class)) - (tk::add-resource-to-class (find-class 'vendor-shell) (make-instance 'resource :name :delete-response diff --git a/tk/xtk.lisp b/tk/xtk.lisp index bfb02b6d..646b0e0f 100644 --- a/tk/xtk.lisp +++ b/tk/xtk.lisp @@ -20,18 +20,61 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xtk.cl,v 1.2 92/01/02 15:09:05 cer Exp Locker: cer $ +;; $fiHeader: xtk.cl,v 1.3 92/01/06 20:43:51 cer Exp Locker: cer $ (in-package :tk) (def-c-typedef :cardinal :unsigned-int) +(def-c-typedef xt-proc * :unsigned-long) +(def-c-typedef action-list * :char) +(def-c-typedef resource-list * :char) +(def-c-typedef xrm-quark :int) +(def-c-typedef xrm-quark-list * :int) +(def-c-typedef boolean :unsigned-long) +(def-c-typedef xrm-class xrm-quark) +(def-c-typedef xt-enum :long) +(def-c-typedef xt-version-type :long) + +(def-c-type (xrm-resource :in-foreign-space) :struct + (name xrm-quark) + (class xrm-quark) + (type xrm-quark) + (size :cardinal) + (offset :long) + (default-type xrm-quark) + (default-addr * :char)) + +(def-c-type (xrm-resource-array :in-foreign-space) 1 xrm-resource) (def-c-type (xtk-class :in-foreign-space) :struct - (superclass :long) - (name * :char) - (widget-size :cardinal) - (class-part-initialize * :unsigned-long) - (inited :unsigned-long)) + (superclass :long) + (name * :char) + (widget-size :cardinal) + (class-initialize xt-proc) + (class-part-initialize xt-proc) + (inited xt-enum) + (initialize xt-proc) + (initialize-hook xt-proc) + (realize xt-proc) + (actions action-list) + (num-actions :cardinal) + (resources resource-list) + (num-resources :cardinal) + (xrm-class xrm-class) + (compress-motion boolean) + (compress-exposure xt-enum) + (compress-enter-leave boolean) + (visible-interest boolean) + (destroy xt-proc) + (resize xt-proc) + (expose xt-proc) + (set-values xt-proc) + (set-values-hook xt-proc) + (set-values-almost xt-proc) + (get-values-hook xt-proc) + (accept-focus xt-proc) + (version xt-version-type) + (callback-private * :char)) (def-c-type (x-resource :in-foreign-space) :struct (name * :char) @@ -43,6 +86,24 @@ (default-addr * :char) ) +;; Horrible internal stuff + +(defforeign 'quark_to_string + :entry-point "_XrmQuarkToString") + +(def-c-type (xt-offset-rec :in-foreign-space) :struct + (next * :char) + (name xrm-quark) + (offset :int)) + +(defun import-offset-list (x) + (let ((r nil)) + (do ((x x (xt-offset-rec-next x))) + ((zerop x) + (nreverse r)) + (push (list (xt-offset-rec-name x) + (xt-offset-rec-offset x)) r)))) + (def-c-type (xtk-widget :in-foreign-space) :struct (self :unsigned-long) (widget-class :unsigned-long) -- GitLab