diff --git a/clim/accept.lisp b/clim/accept.lisp index dedd01a9fca6dc1a00a15734483f528a01d7f166..253a71273c5fa317f2f2e6f5d38d81a4c816807d 100644 --- a/clim/accept.lisp +++ b/clim/accept.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: accept.lisp,v 1.21 92/12/03 10:25:56 cer Exp $ +;; $fiHeader: accept.lisp,v 1.22 92/12/16 16:45:56 cer Exp $ (in-package :clim-internals) @@ -95,12 +95,12 @@ (defmethod stream-accept ((stream input-protocol-mixin) type &rest accept-args &key view &allow-other-keys) (declare (dynamic-extent accept-args)) - (let ((query-identifier - (apply #'prompt-for-accept - (encapsulated-stream stream) type view accept-args))) - (apply #'accept-1 (encapsulated-stream stream) type - :query-identifier query-identifier - accept-args))) + (let* ((stream (encapsulated-stream stream)) + (query-identifier (apply #'prompt-for-accept + stream type view accept-args))) + (apply #'accept-1 stream type + :query-identifier query-identifier + accept-args))) (defmethod prompt-for-accept ((stream input-protocol-mixin) type (view view) &rest accept-args diff --git a/clim/clim-defs.lisp b/clim/clim-defs.lisp index 7bafef6db9625f16e2c5d8185d4f91004f2c114f..826c92d071735d5fc951cc8825520378c4a35165 100644 --- a/clim/clim-defs.lisp +++ b/clim/clim-defs.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: clim-defs.lisp,v 1.21 92/12/07 12:14:08 cer Exp $ +;; $fiHeader: clim-defs.lisp,v 1.22 92/12/16 16:46:05 cer Exp $ (in-package :clim-internals) @@ -233,12 +233,14 @@ (expand-presentation-type-abbreviation ,type) ,override #'body-continuation #'context-continuation)))) -(defmacro with-input-focus ((stream) &body body) +(defmacro with-input-focus ((stream &optional (doit t)) &body body) (let ((old-input-focus '#:old-input-focus)) `(let ((,old-input-focus nil)) (unwind-protect - (progn (setq ,old-input-focus (stream-set-input-focus ,stream)) - ,@body) + (progn + (when ,doit + (setq ,old-input-focus (stream-set-input-focus ,stream))) + ,@body) (when ,old-input-focus (stream-restore-input-focus ,stream ,old-input-focus)))))) diff --git a/clim/cursor.lisp b/clim/cursor.lisp index 3d9ac1130d4cf7aa5e0a5517664facf91a5cb3d2..0a37c542e1372e262e926312b12dc022a7b8a73b 100644 --- a/clim/cursor.lisp +++ b/clim/cursor.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: cursor.lisp,v 1.22 93/01/21 14:57:42 cer Exp $ +;; $fiHeader: cursor.lisp,v 1.23 93/03/04 18:59:47 colin Exp $ (in-package :clim-internals) @@ -42,6 +42,8 @@ (defmethod bounding-rectangle* ((cursor standard-text-cursor)) (with-slots (x y width) cursor + ;; this is surely wrong (ie what about height) - but frankly who + ;; cares?? --CIM (values x y (+ x width) (+ y width)))) (defconstant cursor_active (byte 1 0)) @@ -67,31 +69,30 @@ (cursor-set-position cursor x y)) (defmethod cursor-set-position ((cursor standard-text-cursor) nx ny &optional fastp) - (with-slots (x y flags stream) cursor + (with-slots (x y stream) cursor (unless (and (= x (coordinate nx)) (= y (coordinate ny))) - (if (or fastp (not (cursor-state cursor))) - (setf x (coordinate nx) - y (coordinate ny)) - (let ((active (cursor-active cursor))) - ;; Turn it off and then turn it on to make it move - (unwind-protect - (progn - (when active - (setf (cursor-active cursor) nil)) - (setf x (coordinate nx) - y (coordinate ny))) - (when active - (setf (cursor-active cursor) active)))))))) - + (let ((state (cursor-state cursor)) + (active (cursor-active cursor))) + (if (or fastp + (not (and state active))) + (setf x (coordinate nx) + y (coordinate ny)) + ;; Turn it off and then turn it on to make it move + (unwind-protect + (progn + (setf (cursor-active cursor) nil) + (setf x (coordinate nx) + y (coordinate ny))) + (setf (cursor-active cursor) t))))))) + (defmethod (setf cursor-state) (new-state (cursor standard-text-cursor)) (with-slots (flags) cursor (multiple-value-bind (active state focus) (decode-cursor-flags flags) (declare (ignore active focus)) (setf (ldb cursor_state flags) (if new-state 1 0)) - (unless (eq state new-state) - (note-cursor-change cursor 'cursor-state state new-state))))) + (note-cursor-change cursor 'cursor-state state new-state)))) (defmethod cursor-state ((cursor standard-text-cursor)) (ldb-test cursor_state (slot-value cursor 'flags))) @@ -102,8 +103,7 @@ (decode-cursor-flags flags) (declare (ignore state focus)) (setf (ldb cursor_active flags) (if new-active 1 0)) - (unless (eq active new-active) - (note-cursor-change cursor 'cursor-active active new-active))))) + (note-cursor-change cursor 'cursor-active active new-active)))) (defmethod cursor-active ((cursor standard-text-cursor)) (ldb-test cursor_active (slot-value cursor 'flags))) @@ -114,14 +114,16 @@ (decode-cursor-flags flags) (declare (ignore active state)) (setf (ldb cursor_focus flags) (if new-focus 1 0)) - (unless (eq focus new-focus) - (note-cursor-change cursor 'cursor-focus focus new-focus))))) + (note-cursor-change cursor 'cursor-focus focus new-focus)))) (defmethod cursor-focus ((cursor standard-text-cursor)) (ldb-test cursor_focus (slot-value cursor 'flags))) (defmethod cursor-visibility ((cursor standard-text-cursor)) - (cursor-active cursor)) + (and (cursor-active cursor) + (if (cursor-state cursor) + :on + :off))) (defmethod (setf cursor-visibility) (visibility (cursor standard-text-cursor)) (setf (cursor-state cursor) @@ -152,6 +154,23 @@ (unless abort-p (setf (cursor-state cursor) old-state)))))) +(defmacro with-cursor-active ((stream active) &body body) + (default-input-stream stream) + `(let* ((cursor (and (extended-input-stream-p ,stream) + (stream-text-cursor ,stream))) + (old-active (and cursor (cursor-active cursor))) + (abort-p t)) + (unwind-protect + (progn (when cursor + (cond ((eq old-active ,active)) + (t + (setf (cursor-active cursor) ,active) + (setf abort-p nil)))) + ,@body) + (when cursor + (unless abort-p + (setf (cursor-active cursor) old-active)))))) + (defmethod cursor-width-and-height-pending-protocol ((cursor t)) (values 8 12)) @@ -172,61 +191,61 @@ ;;; state transitions. For example, the cursor might be getting the focus, and ;;; thus change from a hollow rectangle to a filled one (or in Genera, it might ;;; start blinking). -(defmethod port-note-cursor-change :after ((port basic-port) - cursor stream (type (eql 'cursor-focus)) old new) - (declare (ignore old cursor)) - ;;--- This should really only do this when PORT-INPUT-FOCUS-SELECTION - ;;--- is :SHEET-UNDER-POINTER, since this causes the "wrong" thing to - ;;--- happen from the perspective of Genera users. But where do we - ;;--- implement the :CLICK-TO-SELECT behavior? - (setf (port-keyboard-input-focus port) (and new stream))) (defmethod port-note-cursor-change ((port basic-port) cursor stream (type (eql 'cursor-state)) old new) - (declare (ignore old)) - (let ((active (cursor-active cursor))) + (let ((active (cursor-active cursor)) + (focus (cursor-focus cursor))) (when active (multiple-value-bind (x y) (bounding-rectangle* cursor) - (if new - (port-draw-cursor port cursor stream x y t) - (port-draw-cursor port cursor stream x y nil)))))) + (port-draw-cursor port cursor stream x y old new focus))))) (defmethod port-note-cursor-change ((port basic-port) cursor stream (type (eql 'cursor-active)) old new) - (declare (ignore old)) - (let ((state (cursor-state cursor))) + (let ((state (cursor-state cursor)) + (focus (cursor-focus cursor))) (when state (multiple-value-bind (x y) (bounding-rectangle* cursor) - (if new - (port-draw-cursor port cursor stream x y t) - (port-draw-cursor port cursor stream x y nil)))))) + (port-draw-cursor port cursor stream x y old new focus))))) (defmethod port-note-cursor-change ((port basic-port) cursor stream (type (eql 'cursor-focus)) old new) (let ((active (cursor-active cursor)) (state (cursor-state cursor))) - (declare (ignore focus)) - (when (and active state) + (when (and active + state + (not (eq old new))) (multiple-value-bind (x y) (bounding-rectangle* cursor) ;; erase it with old-focus - (port-draw-cursor port cursor stream x y nil old) + (port-draw-cursor port cursor stream x y t nil old) ;; draw it with new-focus - (port-draw-cursor port cursor stream x y t new))))) + (port-draw-cursor port cursor stream x y nil t new))))) ;; PORT-DRAW-CURSOR is invoked to draw or erase the cursor. (defmethod port-draw-cursor - ((port basic-port) (cursor standard-text-cursor) stream x y on-p - &optional (focus nil focus-p)) - #---ignore (declare (ignore on-p)) + ((port basic-port) (cursor standard-text-cursor) stream x1 y1 old new focus) ;;--- protocol violations: output recording protocol (with-output-recording-options) ;;--- graphics protocol (draw-rectangle*) ;;--- output protocol (stream-line-height) (let ((height (stream-line-height stream)) (width (slot-value cursor 'width))) - (unless focus-p (setq focus (cursor-focus cursor))) - (with-output-recording-options (stream :record nil) - (draw-rectangle* stream x y (+ x width) (+ y height) - :filled focus - :ink #+++ignore (if on-p +foreground-ink+ +background-ink+) - #---ignore +flipping-ink+)) - (force-output stream))) + (unless (eq old new) + (with-output-recording-options (stream :record nil) + (with-drawing-options (stream :ink +flipping-ink+) + (let ((x2 (+ x1 width)) + (y2 (+ y1 height))) + (if focus + (draw-rectangle* stream x1 y1 (1+ x2) (1+ y2) + :filled t) + (progn + (draw-line* stream x1 y1 x2 y1) + (draw-line* stream x1 y2 x2 y2) + (draw-line* stream x1 (1+ y1) x1 (1- y2)) + (draw-line* stream x2 (1+ y1) x2 (1- y2)))))) + (force-output stream))))) + + + + + + diff --git a/clim/db-stream.lisp b/clim/db-stream.lisp index 09904157dcefd8443f350a1bff35af8fac920b2e..638a841c4273af96961f465a8dbc1688034da7b2 100644 --- a/clim/db-stream.lisp +++ b/clim/db-stream.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: db-stream.lisp,v 1.50 1993/05/05 01:38:20 cer Exp $ +;; $fiHeader: db-stream.lisp,v 1.51 93/05/13 16:23:01 cer Exp $ (in-package :clim-internals) @@ -714,8 +714,8 @@ (port (port stream))) (setf (medium-foreground stream) foreground (medium-background stream) background - (medium-default-text-style stream) (or default-text-style (port-default-text-style port)) - (medium-text-style stream) (or text-style (port-default-text-style port)) + (medium-default-text-style stream) (or default-text-style *default-text-style*) + (medium-text-style stream) (or text-style *default-text-style*) (stream-vertical-spacing stream) vertical-spacing (stream-end-of-line-action stream) end-of-line-action (stream-end-of-page-action stream) end-of-page-action diff --git a/clim/gadget-output.lisp b/clim/gadget-output.lisp index 0807d0608da4488cdabb3459f0c8699184435827..b69d40feff12970ef66f1b1f824e1dcdceb5852b 100644 --- a/clim/gadget-output.lisp +++ b/clim/gadget-output.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: gadget-output.lisp,v 1.48 1993/05/05 01:38:27 cer Exp $ +;; $fiHeader: gadget-output.lisp,v 1.49 93/05/13 16:23:07 cer Exp $ (in-package :clim-internals) @@ -312,9 +312,7 @@ (when (typep sheet 'toggle-button) (when (setf (gadget-value sheet) (and default-supplied-p - (funcall test - (funcall value-key (gadget-id sheet)) - (funcall value-key default)))) + (funcall test (gadget-id sheet) default))) (setf (radio-box-current-selection radio-box) sheet)))) radio-box))) (with-output-as-gadget (stream :cache-value type :update-gadget #'update-gadget) @@ -328,24 +326,20 @@ (let* ((value (funcall value-key element)) (button (apply #'make-pane 'toggle-button - :label - (let ((name (funcall name-key element))) - (if (eq printer #'write-token) - name - (pixmap-from-menu-item stream name printer nil))) - :indicator-type - (getf toggle-options :indicator-type :one-of) - :value - (and default-supplied-p - (funcall test - value - (funcall value-key default))) - :id value - toggle-options))) + :label + (let ((name (funcall name-key element))) + (if (eq printer #'write-token) + name + (pixmap-from-menu-item stream name printer nil))) + :indicator-type + (getf toggle-options :indicator-type :one-of) + :value + (and default-supplied-p + (funcall test value default)) + :id value + toggle-options))) (when (and default-supplied-p - (funcall test - value - (funcall value-key default))) + (funcall test value default)) (setq current-selection button)) button)) sequence)) @@ -404,9 +398,7 @@ (let ((value (and default-supplied-p (member (gadget-id sheet) default - :test test - ;;--- Should the value-key be used? - :key value-key) + :test test) t))) (when value (push sheet current-selection)) (setf (gadget-value sheet) value)))) @@ -424,9 +416,7 @@ (let* ((value (funcall value-key element)) (actual-value (and default-supplied-p (member value default - :test test - ;;--- Should the value-key be used? - :key value-key) + :test test) t)) (button (apply #'make-pane 'toggle-button diff --git a/clim/input-protocol.lisp b/clim/input-protocol.lisp index 0997202df3af0e37c949c8c1cf8337628223194f..748bee74a151373c6da6aaacc716b51f5d226674 100644 --- a/clim/input-protocol.lisp +++ b/clim/input-protocol.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: input-protocol.lisp,v 1.40 1993/05/05 01:38:37 cer Exp $ +;; $fiHeader: input-protocol.lisp,v 1.41 93/05/13 16:23:13 cer Exp $ (in-package :clim-internals) @@ -66,7 +66,7 @@ (pointer-motion-pending :initform nil) (text-cursor :accessor stream-text-cursor :initarg :text-cursor) - (read-gesture-cursor-state :initarg :read-gesture-cursor-state + (read-gesture-cursor-state :initarg :read-gesture-cursor-state :accessor stream-read-gesture-cursor-state)) (:default-initargs :text-cursor (make-instance 'standard-text-cursor) @@ -102,15 +102,12 @@ ;; Assumes that the cursors are all off for the stream (cursor-set-position cursor x y t)))) - (defmethod initialize-menu :before (port (menu input-protocol-mixin) &key label) (declare (ignore port label)) (let ((cursor (stream-text-cursor menu))) (when cursor (setf (cursor-active cursor) nil)))) -(defvar *cursor-repaint-rectangle* (make-bounding-rectangle 0 0 0 0)) - (defmethod repaint-sheet :after ((stream input-protocol-mixin) (region nowhere)) ;; Repainting nowhere, don't repaint the cursor ) @@ -120,15 +117,18 @@ (viewport (pane-viewport stream))) (when (and cursor viewport) (when (and (cursor-active cursor) - (cursor-state cursor) - (cursor-focus cursor)) + (cursor-state cursor)) (multiple-value-bind (x y) (cursor-position cursor) (multiple-value-bind (width height) (cursor-width-and-height-pending-protocol cursor) (with-bounding-rectangle* (left top right bottom) region (when (ltrb-overlaps-ltrb-p left top right bottom - x y (+ x width) (+ y height)) - (note-cursor-change cursor 'cursor-active t t))))))))) + x y (+ x width) (+ y + height)) + (with-sheet-medium (medium stream) + (with-medium-clipping-region (medium region) + (declare (ignore medium)) + (note-cursor-change cursor 'cursor-active nil t))))))))))) (defmethod pointer-motion-pending ((stream input-protocol-mixin) &optional @@ -191,16 +191,6 @@ (let ((pointer (stream-primary-pointer stream))) (setf (pointer-motion-pending stream pointer) t))) -(defmethod queue-event :after ((stream input-protocol-mixin) (event pointer-enter-event)) - (let ((text-cursor (stream-text-cursor stream))) - (when text-cursor - (setf (cursor-focus text-cursor) t)))) - -(defmethod queue-event :before ((stream input-protocol-mixin) (event pointer-exit-event)) - (let ((text-cursor (stream-text-cursor stream))) - (when text-cursor - (setf (cursor-focus text-cursor) nil)))) - (defmethod queue-event ((stream input-protocol-mixin) (event pointer-exit-event)) (queue-put (stream-input-buffer stream) (copy-event event))) @@ -242,39 +232,41 @@ (declare (ignore pointer-button-press-handler)) (let ((read-gesture-cursor-state (stream-read-gesture-cursor-state stream))) (with-cursor-state (stream read-gesture-cursor-state) - (loop - (multiple-value-bind (input-happened flag) - (stream-input-wait - stream - :timeout timeout :input-wait-test input-wait-test) - (case flag - (:timeout - (return-from stream-read-gesture (values nil :timeout))) - (:input-wait-test - ;; only call the input-wait-handler if we didn't get a first-rate - ;; gesture back from stream-input-wait. - (when input-wait-handler - (funcall input-wait-handler stream))) - (otherwise - (when input-happened - (let ((gesture (queue-get (stream-input-buffer stream)))) - (when gesture - ;;--- What we *should* do is to reinstate a separate input - ;;--- buffer for the stream, then this should loop doing - ;;--- HANDLE-EVENT until something gets inserted into the - ;;--- stream's input buffer. Then this should read and - ;;--- process the gesture in the input buffer. - (let* ((sheet (and (typep gesture 'device-event) - (event-sheet gesture))) - (new-gesture - (receive-gesture - (if (or (null sheet) (eq sheet stream)) - (encapsulated-stream stream) - sheet) - gesture))) - (when new-gesture - (when peek-p (queue-unget (stream-input-buffer stream) gesture)) - (return-from stream-read-gesture new-gesture))))))))))))) + (with-input-focus (stream read-gesture-cursor-state) + (loop + (multiple-value-bind (input-happened flag) + (stream-input-wait + stream + :timeout timeout :input-wait-test input-wait-test) + (case flag + (:timeout + (return-from stream-read-gesture (values nil :timeout))) + (:input-wait-test + ;; only call the input-wait-handler if we didn't get a first-rate + ;; gesture back from stream-input-wait. + (when input-wait-handler + (funcall input-wait-handler stream))) + (otherwise + (when input-happened + (let ((gesture (queue-get (stream-input-buffer stream)))) + (when gesture + ;;--- What we *should* do is to reinstate a separate input + ;;--- buffer for the stream, then this should loop doing + ;;--- HANDLE-EVENT until something gets inserted into the + ;;--- stream's input buffer. Then this should read and + ;;--- process the gesture in the input buffer. + (let* ((sheet (and (typep gesture 'device-event) + (event-sheet gesture))) + (new-gesture + (receive-gesture + (if (or (null sheet) (eq sheet stream)) + (encapsulated-stream stream) + sheet) + gesture))) + (when new-gesture + (when peek-p + (queue-unget (stream-input-buffer stream) gesture)) + (return-from stream-read-gesture new-gesture)))))))))))))) ;; Presentation translators have probably already run... (defmethod receive-gesture @@ -672,3 +664,15 @@ (defmethod stream-restore-input-focus ((stream input-protocol-mixin) old-focus) (setf (port-keyboard-input-focus (port stream)) old-focus)) + +(defmethod note-sheet-gain-focus ((sheet input-protocol-mixin)) + (let ((text-cursor (stream-text-cursor sheet))) + (when text-cursor + (setf (cursor-focus text-cursor) t)))) + +(defmethod note-sheet-lose-focus ((sheet input-protocol-mixin)) + (let ((text-cursor (stream-text-cursor sheet))) + (when text-cursor + (setf (cursor-focus text-cursor) nil)))) + + diff --git a/clim/interactive-protocol.lisp b/clim/interactive-protocol.lisp index cc5f33befad5a0b3e6690ff77463eacf90b84de1..de0ae8c9c72e54c0afa732b78b015c8474929236 100644 --- a/clim/interactive-protocol.lisp +++ b/clim/interactive-protocol.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: interactive-protocol.lisp,v 1.25 1993/05/05 01:38:40 cer Exp $ +;; $fiHeader: interactive-protocol.lisp,v 1.26 93/05/13 16:23:19 cer Exp $ (in-package :clim-internals) @@ -469,10 +469,11 @@ ;; If there's anything in the input buffer, disallow accelerators (and *input-buffer-empty* *accelerator-gestures*))) (stream-read-gesture stream - :timeout timeout :peek-p peek-p - :input-wait-test input-wait-test - :input-wait-handler input-wait-handler - :pointer-button-press-handler pointer-button-press-handler)) + :timeout timeout :peek-p peek-p + :input-wait-test input-wait-test + :input-wait-handler input-wait-handler + :pointer-button-press-handler + pointer-button-press-handler)) (cond ((eq type ':timeout) (return-from stream-read-gesture (values thing type))) diff --git a/silica/classes.lisp b/silica/classes.lisp index 784aa5bbff51ac75e86e370d5c025a755b6f773f..b355322828ebc68664f48e9283a26ce0188e0f63 100644 --- a/silica/classes.lisp +++ b/silica/classes.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*- -;; $fiHeader: classes.lisp,v 1.31 93/03/04 19:01:04 colin Exp $ +;; $fiHeader: classes.lisp,v 1.32 93/03/25 15:40:19 colin Exp $ (in-package :silica) @@ -27,7 +27,7 @@ (mirror->sheet-table :initform (make-hash-table) :reader port-mirror->sheet-table) (focus :initform nil :accessor port-keyboard-input-focus) - (focus-selection :initform :sheet-under-pointer :initarg :focus-selection + (focus-selection :initform :click-to-select :initarg :focus-selection :accessor port-input-focus-selection :type (member :sheet-under-pointer :click-to-select)) (trace-thing :initform (make-array 10 :fill-pointer 0 :adjustable t) @@ -170,7 +170,6 @@ (define-event-class pointer-exit-event (pointer-boundary-event) ()) (define-event-class pointer-enter-event (pointer-boundary-event) ()) - (define-event-class window-event (event) ((region :reader window-event-region :initarg :region) (native-region :reader window-event-native-region :initarg :native-region) @@ -195,6 +194,12 @@ (define-event-class timer-event (event) ()) +(define-event-class focus-event (event) + ((sheet :reader event-sheet :initarg :sheet))) + +(define-event-class focus-in-event (focus-event) ()) +(define-event-class focus-out-event (focus-event) ()) + ;;; Values used in event objects diff --git a/silica/event.lisp b/silica/event.lisp index 30487a8a4ac0af7eb9231c15bcb8852de020e08e..a5dcd42e1b2211d0dc2d9a5787c6a903c1c9cde8 100644 --- a/silica/event.lisp +++ b/silica/event.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*- -;; $fiHeader: event.lisp,v 1.34 93/03/31 10:39:34 cer Exp $ +;; $fiHeader: event.lisp,v 1.35 93/05/05 01:39:44 cer Exp $ (in-package :silica) @@ -23,8 +23,23 @@ #+++ignore (warn "Ignoring event ~S on sheet ~S" sheet event) nil) +(defgeneric port-input-focus-selection (port)) (defgeneric port-keyboard-input-focus (port)) +(defgeneric note-sheet-gain-focus (sheet)) +(defgeneric note-sheet-lose-focus (sheet)) + +(defmethod note-sheet-gain-focus ((sheet basic-sheet)) nil) +(defmethod note-sheet-lose-focus ((sheet basic-sheet)) nil) + +(defmethod (setf port-keyboard-input-focus) :before (focus (port basic-port)) + (let ((old-focus (port-keyboard-input-focus port))) + (when (and old-focus + (not (eq focus old-focus))) + (note-sheet-lose-focus old-focus)) + (when focus + (note-sheet-gain-focus focus)))) + (defclass sheet-with-event-queue-mixin () ((event-queue :initform nil :initarg :event-queue :accessor sheet-event-queue))) @@ -207,6 +222,8 @@ (push sheet sheets)))) (macrolet ((generate-enter-event (sheet kind) `(let ((sheet ,sheet)) + (when (eq (port-input-focus-selection port) :sheet-under-pointer) + (setf (port-keyboard-input-focus port) sheet)) (dispatch-event sheet (allocate-event 'pointer-enter-event @@ -218,6 +235,10 @@ :pointer pointer)))) (generate-exit-event (sheet kind) `(let ((sheet ,sheet)) + (when (and (eq (port-input-focus-selection port) + :sheet-under-pointer) + (eq (port-keyboard-input-focus port) sheet)) + (setf (port-keyboard-input-focus port) nil)) (dispatch-event sheet (allocate-event 'pointer-exit-event @@ -346,6 +367,8 @@ (pointer (pointer-event-pointer event))) (macrolet ((generate-enter-event (sheet kind) `(let ((sheet ,sheet)) + (when (eq (port-input-focus-selection port) :sheet-under-pointer) + (setf (port-keyboard-input-focus port) sheet)) (dispatch-event sheet (allocate-event 'pointer-enter-event @@ -357,6 +380,10 @@ :pointer pointer)))) (generate-exit-event (sheet kind) `(let ((sheet ,sheet)) + (when (and (eq (port-input-focus-selection port) + :sheet-under-pointer) + (eq (port-keyboard-input-focus port) sheet)) + (setf (port-keyboard-input-focus port) nil)) (dispatch-event sheet (allocate-event 'pointer-exit-event @@ -469,7 +496,7 @@ (defmethod distribute-event :before ((port basic-port) (event pointer-button-press-event)) (let ((pointer (pointer-event-pointer event))) (setf (pointer-button-state pointer) - (logior (pointer-button-state pointer) (pointer-event-button event))))) + (logior (pointer-button-state pointer) (pointer-event-button event))))) (defmethod distribute-event :before ((port basic-port) (event pointer-button-release-event)) (let ((pointer (pointer-event-pointer event))) @@ -490,11 +517,17 @@ (dispatch-event (event-sheet event) event)) (defmethod distribute-event-1 ((port basic-port) (event keyboard-event)) - (let ((focus (or (port-keyboard-input-focus port) - (event-sheet event)))) - ;;--- Is this correct??? - (setf (slot-value event 'sheet) focus) - (dispatch-event focus event))) + (let ((sheet (port-keyboard-input-focus port))) + ;;---is it ok to setf an event's sheet?? + (when sheet + (setf (slot-value event 'sheet) sheet) + (dispatch-event sheet event)))) + +(defmethod distribute-event-1 ((port basic-port) (event focus-in-event)) + (setf (port-keyboard-input-focus port) (event-sheet event))) + +(defmethod distribute-event-1 ((port basic-port) (event focus-out-event)) + (setf (port-keyboard-input-focus port) nil)) (defmethod distribute-event-1 ((port basic-port) (event window-event)) (dispatch-event @@ -519,8 +552,14 @@ (aref v (1- (fill-pointer v))))))) (dispatch-pointer-event-to-sheet port event sheet))) -(defun dispatch-pointer-event-to-sheet (port event sheet) - (declare (ignore port)) +(defmethod dispatch-pointer-event-to-sheet :before + ((port basic-port) (event pointer-button-press-event) sheet) + (let ((button (pointer-event-button event))) + (when (and (eq (port-input-focus-selection port) :click-to-select) + (eq button +pointer-left-button+)) + (setf (port-keyboard-input-focus port) sheet)))) + +(defmethod dispatch-pointer-event-to-sheet ((port basic-port) (event event) sheet) (let ((event-type (class-name (class-of event))) (x (pointer-event-native-x event)) (y (pointer-event-native-y event)) diff --git a/silica/pixmaps.lisp b/silica/pixmaps.lisp index ab193987ebab2f8f9af71bb6aab28140e80a9652..469feefde08097dd2097eda3fdfec3bfe0552377 100644 --- a/silica/pixmaps.lisp +++ b/silica/pixmaps.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*- -;; $fiHeader: pixmaps.lisp,v 1.15 93/02/08 15:57:36 cer Exp $ +;; $fiHeader: pixmaps.lisp,v 1.16 93/03/25 15:40:37 colin Exp $ (in-package :silica) @@ -10,11 +10,14 @@ ;;; Pixmaps -(defclass pixmap () ()) +(defclass pixmap () + ((port :reader pixmap-port :initarg :port))) (defgeneric pixmap-width (pixmap)) (defgeneric pixmap-height (pixmap)) +(defmethod port ((pixmap pixmap)) + (pixmap-port pixmap)) ;;; Pixmap mediums @@ -40,12 +43,18 @@ (medium-copy-area medium from-x from-y width height medium to-x to-y))) -(defun copy-from-pixmap (pixmap pixmap-x pixmap-y width height - medium medium-x medium-y) +(defmethod copy-from-pixmap (pixmap pixmap-x pixmap-y width height + (medium basic-medium) medium-x medium-y) (medium-copy-area pixmap pixmap-x pixmap-y width height medium medium-x medium-y)) -(defun copy-to-pixmap (medium medium-x medium-y width height +(defmethod copy-from-pixmap (pixmap pixmap-x pixmap-y width height + (sheet basic-sheet) medium-x medium-y) + (with-sheet-medium (medium sheet) + (medium-copy-area pixmap pixmap-x pixmap-y width height + medium medium-x medium-y))) + +(defmethod copy-to-pixmap ((medium basic-medium) medium-x medium-y width height &optional pixmap (pixmap-x 0) (pixmap-y 0)) (unless pixmap (setf pixmap (allocate-pixmap medium width height))) @@ -53,6 +62,15 @@ pixmap pixmap-x pixmap-y) pixmap) +(defmethod copy-to-pixmap ((sheet basic-sheet) medium-x medium-y width height + &optional pixmap (pixmap-x 0) (pixmap-y 0)) + (with-sheet-medium (medium sheet) + (unless pixmap + (setf pixmap (allocate-pixmap medium width height))) + (medium-copy-area medium medium-x medium-y width height + pixmap pixmap-x pixmap-y) + pixmap)) + ;;; Pixmap sheets diff --git a/silica/text-style.lisp b/silica/text-style.lisp index 41e18eb41440eda5fddbe4afbc588cf797e4e731..b5d4fc5039b9eb01720034f094f0df0003da30e1 100644 --- a/silica/text-style.lisp +++ b/silica/text-style.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*- -;; $fiHeader: text-style.lisp,v 1.17 92/12/07 12:15:24 cer Exp $ +;; $fiHeader: text-style.lisp,v 1.18 92/12/16 16:49:52 cer Exp $ (in-package :silica) @@ -664,15 +664,15 @@ (let ((font-size (text-style-size (car tuple)))) (if exact-size-required (when (= size font-size) - (return (cdr tuple))) - (when (<= size font-size) - ;; Know which one to pick. - (cond ((null last-tuple) - (return (cadr tuple))) - ((< (abs (- size font-size)) (abs (- size last-size))) - (return (cadr tuple))) - (t - (return (cadr last-tuple)))))) + (return (cadr tuple))) + (when (<= size font-size) + ;; Know which one to pick. + (cond ((null last-tuple) + (return (cadr tuple))) + ((< (abs (- size font-size)) (abs (- size last-size))) + (return (cadr tuple))) + (t + (return (cadr last-tuple)))))) (setq last-tuple tuple) (setq last-size font-size))))))) diff --git a/test/test-suite.lisp b/test/test-suite.lisp index 1c2a23ce5871fcbbe06214dcd8844ab1da3993a9..d6c15b39e5cee296dc77b30d86211c1970ee9966 100644 --- a/test/test-suite.lisp +++ b/test/test-suite.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-USER; Base: 10; Lowercase: Yes -*- -;; $fiHeader: test-suite.lisp,v 1.62 93/04/23 09:18:17 cer Exp $ +;; $fiHeader: test-suite.lisp,v 1.63 93/05/13 16:24:24 cer Exp $ (in-package :clim-user) @@ -761,13 +761,16 @@ people, shall not perish from the earth. (draw-text* ps "hello" 10 50))))) (dotimes (i 5) (sleep 0.25) - (copy-from-pixmap pixmap 0 0 100 100 medium (* i 100) (* i 100)))) + (copy-from-pixmap pixmap 0 0 100 100 stream (* i 100) (* i 100))) + (deallocate-pixmap pixmap)) (dotimes (j 5) (let ((pixmap (copy-to-pixmap medium (* j 100) (* j 100) 100 100))) (dotimes (i 5) (unless (= i j) (sleep 0.25) - (copy-from-pixmap pixmap 0 0 100 100 medium (* j 100) (* i 100)))))))) + (copy-from-pixmap pixmap 0 0 100 100 medium (* j 100) (* i 100)))) + (deallocate-pixmap pixmap))))) + #+allegro (define-test (read-image-test graphics) (stream) @@ -2034,6 +2037,16 @@ Luke Luck licks the lakes Luke's duck likes.")) :default x)) (terpri stream)))) +(define-test (window-stream menus-and-dialogs) (stream) + "Simple test of open-window-stream" + (declare (ignore stream)) + (let ((w (open-window-stream))) + (window-expose w) + (sleep 0.1) ; so why do I need this? + (write-string "A window stream" w) + (sleep 2) + (destroy-frame (pane-frame w)))) + (define-test (slider-dialog menus-and-dialogs) (stream) "Various sliders" (let ((d 0.5) diff --git a/tk-silica/ol-frames.lisp b/tk-silica/ol-frames.lisp index 0cff1dc5d84e3ae5405e92a7843483feadb0a63f..cea90d8d396be37fb11d6bb67c5d1c738a906d22 100644 --- a/tk-silica/ol-frames.lisp +++ b/tk-silica/ol-frames.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: ol-frames.lisp,v 1.22 93/03/31 10:40:10 cer Exp $ +;; $fiHeader: ol-frames.lisp,v 1.23 93/04/08 13:18:52 colin Exp $ (in-package :xm-silica) @@ -63,7 +63,7 @@ row-wise n-columns n-rows) - (declare (ignore gesture)) + (declare (ignore gesture row-wise n-columns n-rows)) (let* (value-returned return-value (simplep (and (null printer) diff --git a/tk-silica/ol-gadgets.lisp b/tk-silica/ol-gadgets.lisp index d31bb52c97da379a55dd24a3d204d068fcb7258a..6a413ac616413db7b7c7cde1cfa4d670c3f7b926 100644 --- a/tk-silica/ol-gadgets.lisp +++ b/tk-silica/ol-gadgets.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: ol-gadgets.lisp,v 1.48 1993/05/05 01:40:28 cer Exp $ +;; $fiHeader: ol-gadgets.lisp,v 1.49 93/05/13 16:24:53 cer Exp $ (in-package :xm-silica) @@ -587,9 +587,6 @@ (tk::add-event-handler edit-widget '(:focus-change) 1 - ;; this should eventually be - ;; sheet-mirror-event-handler once all - ;; the focus stuff works 'openlook-text-field-event-handler sheet)))) @@ -1795,10 +1792,11 @@ :accelerator-text accel-text)))) (defmethod discard-accelerator-event-p ((port openlook-port) (event t)) - ;;-- There are a whole bunch of other keysyms that need to be ignored. - ;;-- Perhaps in OLIT there is a way of getting the actual keysym. - ;;-- Perhaps we need a way of representing them in the clim world - (call-next-method)) + (or (call-next-method) + ;;-- There are a whole bunch of other keysyms that need to be ignored. + ;;-- Perhaps in OLIT there is a way of getting the actual keysym. + ;;-- Perhaps we need a way of representing them in the clim world + (member (keyboard-event-key-name event) '(:tab)))) (defmethod frame-manager-notify-user ((framem openlook-frame-manager) message-string diff --git a/tk-silica/ol-silica.lisp b/tk-silica/ol-silica.lisp index 4ac109fc0fd82d5b9a5f1ff845db80325f31c850..8f0c1902709356cf1cabb5995f67e1fb9a4ae512 100644 --- a/tk-silica/ol-silica.lisp +++ b/tk-silica/ol-silica.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: ol-silica.lisp,v 1.18 93/04/27 14:36:07 cer Exp $ +;; $fiHeader: ol-silica.lisp,v 1.19 93/05/13 16:24:56 cer Exp $ (in-package :xm-silica) @@ -35,17 +35,9 @@ (setq *default-server-path* '(:openlook)) -(defmethod make-cursor-widget-for-port ((port openlook-port) parent) - (make-instance 'tk::draw-area - :parent parent - :background (tk::get-values parent :foreground) - :width 2 - :height 11 - :managed t)) - -(defmethod port-note-cursor-change :after ((port openlook-port) - cursor stream type old new) - (declare (ignore old type cursor)) +(defmethod port-note-cursor-change :after + ((port openlook-port) cursor stream (type (eql 'cursor-focus)) old new) + (declare (ignore cursor old)) (when new (let ((mirror (sheet-mirror stream))) (when mirror @@ -94,7 +86,6 @@ (append (let ((x (find-shell-of-calling-frame sheet))) (and x `(:transient-for ,x))) - '(:keyboard-focus-policy :pointer) (and (typep (pane-frame sheet) 'clim-internals::menu-frame) '(:override-redirect t))))) @@ -112,3 +103,6 @@ ;; Only do this if its the top most widget being destroyed or we are ;; screwing around with the tree in someway (xt::unmanage-child (sheet-direct-mirror sheet))) + +(defun ol-get-focus-widget (widget) + (tk::intern-widget (tk::ol_get_current_focus_widget widget))) diff --git a/tk-silica/xm-gadgets.lisp b/tk-silica/xm-gadgets.lisp index 306d01c81b19fd4ab966e9bf4df4ffadb3a1df21..93442e5ec654ae49a1ccefe3043f04502428f4f1 100644 --- a/tk-silica/xm-gadgets.lisp +++ b/tk-silica/xm-gadgets.lisp @@ -18,7 +18,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xm-gadgets.lisp,v 1.73 1993/05/05 01:40:32 cer Exp $ +;; $fiHeader: xm-gadgets.lisp,v 1.74 93/05/13 16:25:00 cer Exp $ (in-package :xm-silica) @@ -196,10 +196,10 @@ :expose-callback 'sheet-mirror-exposed-callback sheet) - (tk::add-callback widget - :input-callback - 'sheet-mirror-input-callback - sheet) + (tk::add-callback widget + :input-callback + 'sheet-mirror-input-callback + sheet) (tk::add-event-handler widget '(:enter-window :leave-window @@ -216,6 +216,7 @@ 'sheet-mirror-event-handler sheet)) + ;;-- This is identical to the method for label (defmethod compose-space ((sheet motif-push-button) &key width height) @@ -483,6 +484,7 @@ (defmethod find-widget-class-and-initargs-for-sheet ((port motif-port) (parent t) (sheet top-level-sheet)) + (cond ;;--- hack alert ;; Seems that we need to use a bulletin board so that everything @@ -1723,7 +1725,7 @@ ;;-- ignored too but there does not appear to be an easy way ;;-- of going from the osf name to the keysym that we need to ignore ;;-- osfMenuBar - (member (keyboard-event-key-name event) '(:f10)))) + (member (keyboard-event-key-name event) '(:f10 :tab)))) (defmethod set-button-accelerator-from-keystroke ((menubar motif-menu-bar) button keystroke) @@ -1743,3 +1745,5 @@ (tk::set-values button :accelerator accel :accelerator-text accel-text)))) + + diff --git a/tk-silica/xm-silica.lisp b/tk-silica/xm-silica.lisp index 34d0201b80de2d8925be9285c9175ef90a14a389..1a693b20e796e327721bdae3679c048138402683 100644 --- a/tk-silica/xm-silica.lisp +++ b/tk-silica/xm-silica.lisp @@ -18,7 +18,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xm-silica.lisp,v 1.34 93/04/07 09:07:25 cer Exp $ +;; $fiHeader: xm-silica.lisp,v 1.35 93/04/16 09:46:02 cer Exp $ (in-package :xm-silica) @@ -57,36 +57,29 @@ (defclass motif-geometry-manager (xt-geometry-manager) ()) + +(defmethod change-widget-geometry ((parent tk::xm-dialog-shell) child + &rest args + &key x y width height) + (declare (ignore x y args)) + (tk::set-values child :width width :height height :x x :y y)) + (defmethod find-shell-class-and-initargs ((port motif-port) sheet) - (if (popup-frame-p sheet) - (values 'tk::xm-dialog-shell - (append - (let ((x (find-shell-of-calling-frame sheet))) - (and x `(:transient-for ,x))) - '(:keyboard-focus-policy :pointer) - (and (typep (pane-frame sheet) - 'clim-internals::menu-frame) - '(:override-redirect t)))) - (call-next-method))) - -(defmethod make-cursor-widget-for-port ((port motif-port) parent) - (make-instance 'tk::xm-my-drawing-area - :parent parent - :background (tk::get-values parent :foreground) - :width 2 - :height 11 - :managed t)) - -#+ignore -(ff:defforeign 'xmprocesstraversal - :entry-point (ff:convert-to-lang "_XmProcessTraversal")) - -#+ignore -(defmethod port-note-cursor-change :after ((port motif-port) - cursor stream type old new) - (declare (ignore old type cursor)) - (when new - (xmprocesstraversal (sheet-mirror stream) 0))) + (multiple-value-bind (class initargs) + (if (popup-frame-p sheet) + (values 'tk::xm-dialog-shell + (append + (let ((x (find-shell-of-calling-frame sheet))) + (and x `(:transient-for ,x))) + (and (typep (pane-frame sheet) + 'clim-internals::menu-frame) + '(:override-redirect t)))) + (call-next-method)) + (values class `(:keyboard-focus-policy + ,(ecase (port-input-focus-selection port) + (:click-to-select :explicit) + (:sheet-under-pointer :pointer)) + ,@initargs)))) (defmethod enable-xt-widget ((parent tk::xm-dialog-shell) (mirror t)) ;; this is a nasty hack just to make sure that the child is managed. @@ -96,7 +89,6 @@ (popup (widget-parent mirror))) - (ff:defun-c-callable my-drawing-area-query-geometry-stub ((widget :unsigned-long) (intended :unsigned-long) (desired :unsigned-long)) @@ -137,3 +129,54 @@ (return-from my-drawing-area-query-geometry tk::xt-geometry-almost))) +;;; hacks for explicit focus + +(defmethod note-sheet-tree-grafted :after ((port motif-port) + (sheet clim-stream-sheet)) + ;; this is a hack which enables this child widget to take input + ;; events in the presence of explicit focus. + (let ((cursor (stream-text-cursor sheet)) + (widget (sheet-mirror sheet))) + (when cursor + (let ((input-widget (make-instance 'tk::xm-my-drawing-area + :parent widget + :background (tk::get-values widget + :background) + :width 1 + :height 1 + :managed (cursor-active cursor)))) + (with-slots (clim-internals::plist) cursor + (setf (getf clim-internals::plist :input-widget) input-widget) + (tk::add-callback input-widget + :input-callback + 'sheet-mirror-input-callback + sheet) + (tk::add-event-handler input-widget + '(:focus-change) + 1 + 'sheet-mirror-event-handler + sheet)))))) + +(defmethod port-note-cursor-change :after + ((port motif-port) cursor stream (type (eql 'cursor-active)) old new) + (declare (ignore stream old)) + (let* ((plist (slot-value cursor 'clim-internals::plist)) + (input-widget (getf plist :input-widget))) + (when input-widget + (if new + (tk::manage-child input-widget) + (tk::unmanage-child input-widget))))) + +(defmethod port-note-cursor-change :after + ((port motif-port) cursor stream (type (eql 'cursor-focus)) old new) + (declare (ignore stream old)) + (when new + (let* ((plist (slot-value cursor 'clim-internals::plist)) + (input-widget (getf plist :input-widget))) + (when input-widget + (tk::xm_process_traversal input-widget 0))))) + +(defun xm-get-focus-widget (widget) + (tk::intern-widget (tk::xm_get_focus_widget widget))) + + diff --git a/tk-silica/xt-graphics.lisp b/tk-silica/xt-graphics.lisp index a382b38d1ae069c84cab2aeb2f5abae188600bee..b7bf730966840c02666bf7d015eed4e53d118ea5 100644 --- a/tk-silica/xt-graphics.lisp +++ b/tk-silica/xt-graphics.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xt-graphics.lisp,v 1.71 93/04/12 21:22:25 colin Exp $ +;; $fiHeader: xt-graphics.lisp,v 1.72 93/05/13 16:25:03 cer Exp $ (in-package :tk-silica) @@ -99,22 +99,22 @@ (white-pixel :initarg :white-pixel) (black-pixel :initarg :black-pixel))) -(defun make-xt-palette (port colormap) + +(defmethod make-palette ((port xt-port) &key colormap) (let* ((display (port-display port)) (screen (tk::display-screen-number display))) (make-instance 'xt-palette - :port port - :colormap colormap - :dynamic-p (and - (member (port-visual-class port) - '(:gray-scale :pseudo-color :direct-color)) - t) - :color-p (port-color-p port) - :white-pixel (x11:xwhitepixel display screen) - :black-pixel (x11:xblackpixel display screen)))) - -(defmethod make-palette ((port xt-port) &key) - (make-xt-palette port (tk::create-colormap (port-display port)))) + :port port + :colormap (or colormap + (tk::create-colormap (port-display port))) + :dynamic-p (and + (member (port-visual-class port) + '(:gray-scale :pseudo-color :direct-color)) + t) + :color-p (port-color-p port) + :white-pixel (x11:xwhitepixel display screen) + :black-pixel (x11:xblackpixel display screen)))) + (defmethod medium-palette ((medium xt-medium)) (let ((frame (pane-frame (medium-sheet medium)))) diff --git a/tk-silica/xt-pixmaps.lisp b/tk-silica/xt-pixmaps.lisp index 014558b76a76767c798c6f4fecfe4d1f4cabb794..4a3fc9ea55a394eac653d7bc27b09d182d11a6ae 100644 --- a/tk-silica/xt-pixmaps.lisp +++ b/tk-silica/xt-pixmaps.lisp @@ -20,31 +20,35 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xt-pixmaps.lisp,v 1.14 93/02/08 15:58:17 cer Exp $ +;; $fiHeader: xt-pixmaps.lisp,v 1.15 93/02/10 10:04:31 cer Exp $ (in-package :xm-silica) +(defclass xt-pixmap (tk::pixmap pixmap) + ()) + (defmethod port-allocate-pixmap ((port xt-port) medium width height) (declare (ignore medium)) (fix-coordinates width height) (let ((root (tk::display-root-window (port-display port)))) - (make-instance 'tk::pixmap + (make-instance 'xt-pixmap :drawable root :width width :height height - :depth (tk::drawable-depth root)))) + :depth (tk::drawable-depth root) + :port port))) -(defmethod port-deallocate-pixmap ((port xt-port) (pixmap tk::pixmap)) +(defmethod port-deallocate-pixmap ((port xt-port) (pixmap xt-pixmap)) (x11:xfreepixmap (port-display port) pixmap)) -(defmethod pixmap-width ((pixmap tk::pixmap)) +(defmethod pixmap-width ((pixmap xt-pixmap)) (tk::pixmap-width pixmap)) -(defmethod pixmap-height ((pixmap tk::pixmap)) +(defmethod pixmap-height ((pixmap xt-pixmap)) (tk::pixmap-height pixmap)) -(defmethod pixmap-depth ((pixmap tk::pixmap)) +(defmethod pixmap-depth ((pixmap xt-pixmap)) (tk::pixmap-depth pixmap)) @@ -116,7 +120,7 @@ (defmethod medium-copy-area - ((pixmap tk::pixmap) from-x from-y width height + ((pixmap xt-pixmap) from-x from-y width height (to-medium xt-medium) to-x to-y) (let ((transform (sheet-native-transformation (medium-sheet to-medium)))) (convert-to-device-coordinates transform to-x to-y) @@ -129,7 +133,7 @@ (defmethod medium-copy-area ((from-medium xt-medium) from-x from-y width height - (pixmap tk::pixmap) to-x to-y) + (pixmap xt-pixmap) to-x to-y) ;;; What about the graphics exposure event problem (let ((transform (sheet-native-transformation (medium-sheet from-medium)))) (convert-to-device-coordinates transform from-x from-y) @@ -140,30 +144,4 @@ window copy-gc from-x from-y width height pixmap to-x to-y)))) -;;; I dont understand the need for these methods -;;; Also what is the xt-pixmap class below. -#+ignore -(defmethod medium-copy-area - ((from-medium xt-medium) from-x from-y width height - (pixmap tk::pixmap) to-x to-y) - (let ((transform (sheet-native-transformation (medium-sheet from-medium)))) - (convert-to-device-coordinates transform from-x from-y) - (convert-to-device-distances transform width height) - (let ((window (medium-drawable from-medium)) - (copy-gc (make-instance 'tk::gcontext :drawable window))) - (tk::copy-area - window copy-gc from-x from-y width height - pixmap to-x to-y)))) - -#+ignore -(defmethod medium-copy-area - ((pixmap tk::pixmap) from-x from-y width height - (to-medium xt-medium) to-x to-y) - (let ((transform (sheet-native-transformation (medium-sheet to-medium)))) - (convert-to-device-coordinates transform to-x to-y) - (let ((window (medium-drawable to-medium)) - (copy-gc (make-instance 'tk::gcontext :drawable window))) - (tk::copy-area - pixmap copy-gc from-x from-y width height - window to-x to-y)))) diff --git a/tk-silica/xt-silica.lisp b/tk-silica/xt-silica.lisp index fa31e138c523657d03aac3cb6babb852f6087912..f2e87b0a82466bd59245383069dbb09a34b6804f 100644 --- a/tk-silica/xt-silica.lisp +++ b/tk-silica/xt-silica.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xt-silica.lisp,v 1.81 1993/05/05 01:40:38 cer Exp $ +;; $fiHeader: xt-silica.lisp,v 1.82 93/05/13 16:25:07 cer Exp $ (in-package :xm-silica) @@ -126,7 +126,8 @@ (port-depth port) (x11:xdefaultdepth display (tk::display-screen-number display)) (port-visual-class port) (tk::screen-root-visual-class (tk::default-screen display)) (slot-value port 'silica::default-palette) - (make-xt-palette port (tk::default-colormap (port-display port)))) + (make-palette port :colormap + (tk::default-colormap (port-display port)))) (let* ((screen (x11:xdefaultscreenofdisplay display)) (bs-p (not (zerop (x11::screen-backing-store screen)))) (su-p (not (zerop (x11::screen-save-unders screen)))) @@ -432,7 +433,11 @@ :native-x native-x :native-y native-y :modifier-state - (state->modifiers state))))))) + (state->modifiers state)))) + (:focus-in + (allocate-event 'focus-in-event :sheet sheet)) + (:focus-out + (allocate-event 'focus-out-event :sheet sheet))))) (when clim-event (distribute-event port clim-event)))) @@ -608,6 +613,10 @@ (getf initargs :height) (fix-coordinate (- bottom top))))) initargs) +(defmethod initialize-shell ((port xt-port) sheet widget) + (declare (ignore sheet widget)) + nil) + ;; If we are creating a top level sheet then we have to create a shell for it (defmethod find-widget-parent ((port xt-port) sheet) (let ((ma (sheet-mirrored-ancestor sheet))) @@ -617,9 +626,13 @@ (let ((frame (pane-frame sheet))) (when frame (setf (getf initargs :name) (string (frame-name frame)) - (getf initargs :title) (frame-pretty-name frame)))) - (apply #'make-instance class :parent (find-shell-parent port sheet) initargs)) - (sheet-mirror-for-parenting ma)))) + (getf initargs :title) (frame-pretty-name + frame))) + (let ((shell (apply #'make-instance class + :parent (find-shell-parent port sheet) initargs))) + (initialize-shell port sheet shell) + shell))) + (sheet-mirror-for-parenting ma)))) (defmethod sheet-mirror-for-parenting ((sheet basic-sheet)) ;; There might be a situation where a sheet is mirrored by a whil @@ -646,21 +659,19 @@ (defmethod find-shell-class-and-initargs ((port xt-port) (sheet t)) (values 'top-level-shell - ;; Need this so that an interactive pane can have children - ;; but still accept the focus - `(:keyboard-focus-policy :pointer))) + '(:input t))) (defmethod find-shell-class-and-initargs :around ((port xt-port) (sheet pane)) (let* ((palette (frame-manager-palette (frame-manager (pane-frame sheet))))) - (multiple-value-bind - (class initargs) + (multiple-value-bind (class initargs) (call-next-method) (values class - `(:allow-shell-resize ,(and (pane-frame sheet) - (clim-internals::frame-resizable (pane-frame sheet))) - ,@initargs - ,@(and (not (eq (port-default-palette port) palette)) - `(:colormap ,(palette-colormap palette)))))))) + `(:allow-shell-resize + ,(and (pane-frame sheet) + (clim-internals::frame-resizable (pane-frame sheet))) + ,@(and (not (eq (port-default-palette port) palette)) + `(:colormap ,(palette-colormap palette))) + ,@initargs))))) (defmethod enable-mirror ((port xt-port) (sheet t)) diff --git a/tk/ol-funs.lisp b/tk/ol-funs.lisp index bd91c0641fb2a9fe08081dfa7d9026647042ebaf..0dde2d712053948cfb738c4da41bcc1892601a7e 100644 --- a/tk/ol-funs.lisp +++ b/tk/ol-funs.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: ol-funs.lisp,v 1.8 92/12/14 15:03:59 cer Exp $ +;; $fiHeader: ol-funs.lisp,v 1.9 93/03/31 10:40:00 cer Exp $ ;; ;; This file contains compile time only code -- put in clim-debug.fasl. @@ -70,6 +70,20 @@ :arg-checking nil :return-type :void) +(defforeign 'ol_call_accept_focus + :entry-point (ff:convert-to-lang "OlCallAcceptFocus") + :call-direct t + :arguments '(foreign-address integer) + :arg-checking nil + :return-type :unsigned-integer) + +(defforeign 'ol_can_accept_focus + :entry-point (ff:convert-to-lang "OlCanAcceptFocus") + :call-direct t + :arguments '(foreign-address integer) + :arg-checking nil + :return-type :unsigned-integer) + (defforeign 'ol_set_input_focus :entry-point (ff:convert-to-lang "OlSetInputFocus") :call-direct t @@ -77,6 +91,20 @@ :arg-checking nil :return-type :void) +(defforeign 'ol_move_focus + :entry-point (ff:convert-to-lang "OlMoveFocus") + :call-direct t + :arguments '(foreign-address fixnum integer) + :arg-checking nil + :return-type :void) + +(defforeign 'ol_get_current_focus_widget + :entry-point (ff:convert-to-lang "OlGetCurrentFocusWidget") + :call-direct t + :arguments '(foreign-address) + :arg-checking nil + :return-type :unsigned-integer) + (defforeign 'ol_menu_post :entry-point (ff:convert-to-lang "OlMenuPost") :call-direct t diff --git a/tk/resources.lisp b/tk/resources.lisp index 80354b8fe7828378daab2d8152f6f42db19cd4d1..b2cc0b67cfbd6b279e06aaff5bc27f274cdf4e8c 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.lisp,v 1.44 93/04/16 09:45:49 cer Exp $ +;; $fiHeader: resources.lisp,v 1.45 93/05/13 16:24:38 cer Exp $ (in-package :tk) @@ -562,6 +562,12 @@ (defmethod convert-resource-out ((parent t) (type (eql 'boolean)) value) (if value 1 0)) +;; so why does ol descide to call this resource type boolean rather +;; than bool? Who knows? -cim + +(defmethod convert-resource-out ((parent t) (type (eql 'bool)) value) + (if value 1 0)) + (defmethod convert-resource-out ((parent t) (type (eql 'string)) value) (string-to-char* value)) diff --git a/tk/xlib.lisp b/tk/xlib.lisp index 3d3bf912b97b05619c902e57b011f6fee3ba03aa..2a942d2a8aabcf37505c17c432a00fa54f07473b 100644 --- a/tk/xlib.lisp +++ b/tk/xlib.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xlib.lisp,v 1.44 1993/05/05 01:40:19 cer Exp $ +;; $fiHeader: xlib.lisp,v 1.45 93/05/13 16:24:40 cer Exp $ (in-package :tk) @@ -491,6 +491,17 @@ 'screen :display display)) +(defun get-input-focus (display) + (with-ref-par + ((focus 0) + (revert-to 0)) + (x11:xgetinputfocus display focus revert-to) + (values (aref focus 0) (aref revert-to 0)))) + +(defun set-input-focus (display focus &optional (revert-to 0) (time 0)) + (x11:xsetinputfocus display focus revert-to time)) + + (defun query-pointer (window) (with-ref-par ((root 0) diff --git a/tk/xm-funs.lisp b/tk/xm-funs.lisp index 90d44ac41fd1ede070c9a20604c5f8e3972b5929..4f284bf138ed132df9064642a7c2a4c9aaadf936 100644 --- a/tk/xm-funs.lisp +++ b/tk/xm-funs.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xm-funs.lisp,v 1.8 93/04/27 14:36:00 cer Exp $ +;; $fiHeader: xm-funs.lisp,v 1.9 93/05/05 01:40:21 cer Exp $ ;; ;; This file contains compile time only code -- put in clim-debug.fasl. @@ -156,8 +156,19 @@ :arg-checking nil :return-type :void) +(defforeign 'xm_get_focus_widget + :entry-point (ff:convert-to-lang "XmGetFocusWidget") + :call-direct t + :arguments '(foreign-address) + :arg-checking nil + :return-type :unsigned-integer) - +(defforeign 'xm_is_traversable + :entry-point (ff:convert-to-lang "XmIsTraversable") + :call-direct t + :arguments '(foreign-address) + :arg-checking nil + :return-type :unsigned-integer) (defforeign 'xm_font_list_append_entry :entry-point (ff:convert-to-lang "XmFontListAppendEntry") @@ -175,8 +186,6 @@ :arg-checking nil :return-type :unsigned-integer) - - (defforeign 'xm_font_list_entry_get_font :entry-point (ff:convert-to-lang "XmFontListEntryGetFont") :call-direct t diff --git a/tk/xt-funs.lisp b/tk/xt-funs.lisp index 7f45c20ab6c2ba9dbf7521614001c4603e7a0902..c755e0a79c9fc61c17d5ff88bc1309d6cd65e0db 100644 --- a/tk/xt-funs.lisp +++ b/tk/xt-funs.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xt-funs.lisp,v 1.16 93/01/11 15:46:02 colin Exp $ +;; $fiHeader: xt-funs.lisp,v 1.17 93/05/13 16:24:42 cer Exp $ ;; ;; This file contains compile time only code -- put in clim-debug.fasl. @@ -369,6 +369,12 @@ :arg-checking nil :return-type :unsigned-integer) +(defforeign 'xt_set_keyboard_focus + :entry-point (ff:convert-to-lang "XtSetKeyboardFocus") + :call-direct t + :arguments '(foreign-address foreign-address) + :arg-checking nil + :return-type :unsigned-integer) (ff:defforeign 'init_clim_gc_cursor_stuff :call-direct t diff --git a/utils/designs.lisp b/utils/designs.lisp index f366ad5ecf0a8a705c631cff8b7b456fd67afd33..cd808a44e3d4b5bd130ed7b8dc0c23454585bc2a 100644 --- a/utils/designs.lisp +++ b/utils/designs.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-UTILS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: designs.lisp,v 1.13 92/11/19 14:25:41 cer Exp $ +;; $fiHeader: designs.lisp,v 1.14 92/12/03 10:30:37 cer Exp $ (in-package :clim-utils) @@ -320,7 +320,7 @@ (palette-full-palette condition))))) ) ;eval-when -(defmethod add-color-to-palette ((palette basic-palette) &rest colors) +(defmethod add-colors-to-palette ((palette basic-palette) &rest colors) (declare (dynamic-extent colors)) (let ((colors-done nil)) (dolist (color colors) @@ -333,7 +333,7 @@ (deallocate-color color palette)) (error condition)))))) -(defmethod remove-color-from-palette ((palette basic-palette) &rest colors) +(defmethod remove-colors-from-palette ((palette basic-palette) &rest colors) (declare (dynamic-extent colors)) (dolist (color colors) (deallocate-color color palette))) diff --git a/utils/packages.lisp b/utils/packages.lisp index 2cf1764fc24503b9e56cdbb43592c8e3b41cdce6..9b943c578511e782344e4544901d9acdfda13ebc 100644 --- a/utils/packages.lisp +++ b/utils/packages.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CL-USER; Base: 10; Lowercase: Yes -*- -;; $fiHeader: packages.lisp,v 1.52 93/04/02 18:41:13 cer Exp $ +;; $fiHeader: packages.lisp,v 1.53 93/04/27 14:36:16 cer Exp $ (in-package #-ANSI-90 :user #+ANSI-90 :common-lisp-user) @@ -1760,6 +1760,9 @@ fetch-clipping-region find-graft find-port + focus-event + focus-in-event + focus-out-event graft graft-height graft-orientation @@ -1819,6 +1822,8 @@ note-sheet-disowned note-sheet-enabled note-sheet-grafted + note-sheet-gain-focus + note-sheet-lose-focus note-sheet-region-changed note-sheet-transformation-changed permanent-medium-sheet-output-mixin @@ -2071,7 +2076,7 @@ pattern-width ;; Palettes - add-color-to-palette + add-colors-to-palette frame-manager-palette frame-palette make-palette @@ -2081,7 +2086,7 @@ palette-full palettep port-default-palette - remove-color-from-palette + remove-colors-from-palette ;; Extended output beep