diff --git a/clim/drag-and-drop.lisp b/clim/drag-and-drop.lisp new file mode 100644 index 0000000000000000000000000000000000000000..763850a64509315f435b83c048a00f3e40b2f3aa --- /dev/null +++ b/clim/drag-and-drop.lisp @@ -0,0 +1,291 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- + +(in-package :clim-internals) + +"Copyright (c) 1991, 1992 Symbolics, Inc. All rights reserved." + + +;;; Direct manipulation ("click and drag", "drag and drop") translators + +(defclass drag-and-drop-translator (presentation-translator) + ((destination-type :initarg :destination-type + :reader presentation-translator-destination-type) + (feedback :initform nil :initarg :feedback + :reader presentation-translator-feedback) + (highlighting :initform nil :initarg :highlighting + :reader presentation-translator-highlighting) + ;; The body, tester, and documentation supplied by the programmer. + ;; DEFINE-DRAG-AND-DROP-TRANSLATOR uses the other body, tester, + ;; and documentaiton slots for its own purposes + (real-body :initarg :real-body + :reader presentation-translator-real-body) + (real-tester :initform nil :initarg :real-tester + :reader presentation-translator-real-tester) + (real-documentation :initform nil :initarg :real-documentation + :reader presentation-translator-real-documentation))) + +(defmethod print-object ((object drag-and-drop-translator) stream) + (if *print-escape* + (print-unreadable-object (object stream :type t :identity t) + (with-slots (name from-type destination-type to-type) object + (format stream "~S (~S x ~S -> ~S)" + name from-type destination-type to-type))) + (print-unreadable-object (object stream :type t :identity t) + (with-slots (name from-type to-type) object + (format stream "~S" name))))) + +(defmacro define-drag-and-drop-translator + (name + (from-type to-type destination-type command-table + &key (gesture ':select) tester + documentation (menu t) priority + feedback highlighting) + arglist + &body body) + #+Genera (declare (zwei:indentation 1 3 3 1)) + (with-warnings-for-definition name define-presentation-translator + (multiple-value-bind (body-function body-name) + (write-translator-function (cons arglist body) name 'real-body + '(destination-object destination-presentation)) + (multiple-value-bind (tester-function tester-name) + (when tester + (write-translator-function tester name 'real-tester + '(destination-object destination-presentation))) + (multiple-value-bind (doc-function doc-name) + (if (stringp documentation) + (values nil documentation) + (when documentation + (write-translator-function + documentation name 'real-doc + '(destination-object destination-presentation stream)))) + (multiple-value-bind (feedback-function feedback-name) + (if (symbolp feedback) + (values nil (or feedback 'frame-drag-and-drop-feedback)) + (write-drag-and-drop-function + feedback name 'feedback + '(frame presentation stream initial-x initial-y new-x new-y state))) + (multiple-value-bind (highlighting-function highlighting-name) + (if (symbolp highlighting) + (values nil (or highlighting 'frame-drag-and-drop-highlighting)) + (write-drag-and-drop-function + highlighting name 'highlighting + '(frame presentation stream state))) + `(progn + (define-presentation-translator-1 ,name + (,from-type ,to-type ,command-table + :gesture ,gesture + :tester nil + :tester-definitive t + :documentation "Drag presentation" + :pointer-documentation "Drag presentation" + :menu ,menu + :priority ,priority + :translator-class drag-and-drop-translator + :destination-type ',destination-type + :real-body ',body-name + :feedback ',feedback-name + :highlighting ',highlighting-name + ,@(when tester `(:real-tester ',tester-name)) + ,@(when documentation `(:real-documentation ',doc-name))) + ,*translator-function-arglist* + (invoke-drag-and-drop-translator ,@*translator-function-arglist*)) + ,body-function + ,tester-function + ,doc-function + ,feedback-function + ,highlighting-function)))))))) + +(defun write-drag-and-drop-function (function translator-name clause-name args) + (let ((function-name (gensymbol translator-name clause-name)) + (arglist (first function)) + (body (rest function))) + (multiple-value-bind (arglist ignores) + (canonicalize-and-match-lambda-lists args arglist) + (values `(defun ,function-name ,arglist + ,@(and ignores `((declare (ignore ,@ignores)))) + ,@body) + function-name)))) + +;; All the drag-and-drop translators that satisfy the current from-type, +;; to-type, and gesture will get here. However, the translator now being +;; run is not necessarily the right one. What we do here is to track the +;; pointer until the destination presentation has been reached, choose the +;; correct translator and run it. +(defun invoke-drag-and-drop-translator (object presentation context-type + frame event window x y) + (let* ((command-table (frame-command-table frame)) + (translators + (let ((all-translators + (find-presentation-translators + (presentation-type presentation) context-type command-table))) + ;; This find all translators that could conceivably apply + (mapcan #'(lambda (translator) + (when (and (typep translator 'drag-and-drop-translator) + (test-presentation-translator + translator presentation context-type + frame window x y :event event)) + (list translator))) + all-translators))) + (destination-types + ;; So we can let TRACKING-POINTER do the work of finding applicable + ;; destination presentations... + (mapcar #'presentation-translator-destination-type translators)) + ;; Get the feedback and highlighting functions + ;;--- This should really check to make sure that the feedback and + ;;--- highlighting functions are the same for the set of translators + (feedback + (and translators (presentation-translator-feedback (first translators)))) + (highlighting + (and translators (presentation-translator-highlighting (first translators)))) + (initial-x x) + (initial-y y) + last-x last-y + (from-presentation presentation) + ;; The presentation we finally landed on, and the event used + (destination nil) + (destination-event nil) + ;; Defeat the normal gesture processing stuff + (*input-wait-handler* nil) + (*input-wait-test* nil) + (*pointer-button-press-handler* nil)) + (read-gesture :stream window :timeout 0) ;eat the initial mouse click + (unhighlight-highlighted-presentation window) + (when (null translators) + (return-from invoke-drag-and-drop-translator nil)) + (flet ((find-translator (destination) + (let* ((translator + (find (presentation-type destination) translators + :key #'presentation-translator-destination-type + :test #'presentation-subtypep)) + (tester + (and translator (presentation-translator-real-tester translator)))) + (when (or (null tester) + (funcall tester + object presentation context-type + frame event window x y + (presentation-object destination) destination)) + translator)))) + (declare (dynamic-extent #'find-translator)) + (macrolet ((feedback (x y state) + `(funcall feedback frame from-presentation window + initial-x initial-y ,x ,y ,state)) + (highlight (presentation state) + `(when ,presentation + (funcall highlighting frame ,presentation window + ,state)))) + (block drag-presentation + (tracking-pointer (window :context-type `((or ,@destination-types)) + :multiple-window t :highlight nil) + (:presentation-button-press (presentation event) + (highlight destination :unhighlight) + (setq destination presentation + destination-event event) + (return-from drag-presentation)) + (:pointer-button-press (event) + (highlight destination :unhighlight) + (setq destination nil + destination-event event) + (return-from drag-presentation)) + (:presentation (presentation window x y) + (when last-x + (feedback last-x last-y :unhighlight)) + (setq last-x x + last-y y) + (feedback x y :highlight) + (when (not (eq presentation destination)) + (highlight destination :unhighlight) + (setq destination presentation) + (highlight presentation :highlight) + #+++ignore ;--- documentation + (let ((translator (find-translator destination))) + (when translator + (let ((documentation + (presentation-translator-real-documentation translator))) + (if (stringp documentation) + (write-string documentation doc-stream) + (funcall documentation + (presentation-object presentation) presentation context-type + frame event window x y + (presentation-object destination) destination + doc-stream))))))) + (:pointer-motion (window x y) + (highlight destination :unhighlight) + (setq destination nil) + (when last-x + (feedback last-x last-y :unhighlight)) + (setq last-x x + last-y y) + (feedback x y :highlight)))) + (when last-x + (feedback last-x last-y :unhighlight))) + ;; The user has put down the presentation, figure out what to do + ;;--- What if there is more than one translator? + (let ((translator (find-translator destination))) + (when translator + (multiple-value-bind (result-object result-type options) + (funcall (presentation-translator-real-body translator) + object presentation context-type + frame event window x y + (presentation-object destination) destination) + (setq result-type (or result-type (evacuate-list context-type))) + ;; Find the tag to throw to, and do so + (dolist (this-context *input-context*) + (let* ((context-type (input-context-type this-context)) + (tag (input-context-tag this-context))) + (when (presentation-subtypep result-type context-type) + (throw tag + (values result-object + result-type + (or destination-event event) + options))))))))))) + +;; NEW-X and NEW-Y are in stream coordinates. +(defmethod frame-drag-and-drop-feedback ((frame application-frame) presentation stream + initial-x initial-y new-x new-y state) + (declare (ignore initial-x initial-y state)) ;we'll just use XOR + (multiple-value-bind (width height) (bounding-rectangle-size presentation) + (with-output-recording-options (stream :record nil) + (with-identity-transformation (stream) + (draw-rectangle* stream new-x new-y (+ new-x width) (+ new-y height) + :filled nil :ink +flipping-ink+ :line-dashes #(4 4)))))) + +(defmethod frame-drag-and-drop-highlighting ((frame application-frame) presentation stream + state) + (ecase state + (:highlight + (set-highlighted-presentation stream presentation)) + (:unhighlight + (unhighlight-highlighted-presentation stream)))) + +;; Used to extract all presentations of a certain type in a "surrounded region" +#+++ignore +(defun presentations-of-type-in-region (type stream region &optional (sort t)) + (let ((collection nil)) + (labels ((collect (record x-offset y-offset) + (if (presentationp record) + (when (presentation-typep (presentation-object record) type) + (pushnew record collection)) + (multiple-value-bind (xoff yoff) + (output-record-start-cursor-position record) + (map-over-output-records-overlapping-region #'collect + record region (+ x-offset xoff) (+ y-offset yoff)))))) + (declare (dynamic-extent #'collect)) + (collect (stream-output-history stream) 0 0) + (when (and collection sort) + (setq collection (sort-presentations-by-position collection))) + collection))) + +#+++ignore +(defun sort-presentations-by-position (presentations) + (flet ((position-lessp (p1 p2) + (unless (eq (output-record-parent p1) (output-record-parent p2)) + ;;--- Convert to absolute coordinates if they don't share parents + ) + (multiple-value-bind (x1 y1) (bounding-rectangle-position p1) + (multiple-value-bind (x2 y2) (bounding-rectangle-position p2) + (if (= y1 y2) + (< x1 x2) + (< y1 y2)))))) + (declare (dynamic-extent #'position-lessp)) + (sort presentations #'position-lessp))) + diff --git a/clim/noting-progress.lisp b/clim/noting-progress.lisp new file mode 100644 index 0000000000000000000000000000000000000000..5680c2a6e18e2a9fb38fb53ad4032faa6711b977 --- /dev/null +++ b/clim/noting-progress.lisp @@ -0,0 +1,138 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- + +(in-package :clim-internals) + +"Copyright (c) 1991, 1992 Symbolics, Inc. All rights reserved." + + +(defvar *progress-notes* ()) +(defvar *current-progress-note*) + +(defclass progress-note () + ((name :accessor progress-note-name :initarg :name) + (stream :initarg :stream) + (frame :initarg :frame) + (numerator :initform 0) + (denominator :initform 1) + ;; Keep the flicker down as much as possible + (name-displayed :initform nil) + (bar-length :initform 0))) + +(define-constructor make-progress-note progress-note (name stream frame) + :name name :stream stream :frame frame) + +(defmethod (setf progress-note-name) :after (name (note progress-note)) + (declare (ignore name)) + (with-slots (name-displayed bar-length frame) note + (setq name-displayed nil + bar-length 0) + (frame-manager-display-progress-note (frame-manager frame) note))) + +(defun add-progress-note (name stream) + (check-type name string) + (when (or (null stream) (eq stream 't)) + (setq stream (frame-pointer-documentation-output *application-frame*))) + (let ((note (make-progress-note name stream *application-frame*))) + (without-interrupts + (push note *progress-notes*)) + note)) + +(defun remove-progress-note (note) + (frame-manager-clear-progress-note (frame-manager (slot-value note 'frame)) note) + (without-interrupts + (setq *progress-notes* (delete note *progress-notes*)))) + +(defmethod progress-note-fraction-done ((note progress-note)) + (with-slots (numerator denominator) note + (/ numerator denominator))) + +(defmacro noting-progress ((stream name &optional (note-var '*current-progress-note*)) + &body body) + (check-type note-var symbol) + `(let (,note-var) + (unwind-protect + (progn + (setq ,note-var (add-progress-note ,name ,stream)) + ,@body) + (remove-progress-note ,note-var)))) + +(defun note-progress (numerator &optional (denominator 1) (note *current-progress-note*)) + (when note + (when (and (= denominator 1) (rationalp numerator)) + (let ((num (numerator numerator)) + (denom (denominator numerator))) + (setq numerator num + denominator denom))) + (setf (slot-value note 'numerator) numerator + (slot-value note 'denominator) denominator)) + (frame-manager-display-progress-note (frame-manager (slot-value note 'frame)) note) + nil) + +(defun note-progress-in-phases (numerator + &optional (denominator 1) + (phase-number 1) (n-phases 1) + (note *current-progress-note*)) + (note-progress (+ (* denominator (1- phase-number)) numerator) + (* denominator n-phases) + note) + nil) + +(defmacro dolist-noting-progress ((var listform name + &optional stream (note-var '*current-progress-note*)) + &body body) + (let ((count-var '#:count) + (total-var '#:total) + (list-var '#:list)) + `(noting-progress (,stream ,name ,note-var) + (let* ((,list-var ,listform) + (,total-var (length ,list-var)) + (,count-var 0)) + (dolist (,var ,list-var) + ,@body + (incf ,count-var) + (note-progress ,count-var ,total-var)))))) + +(defmacro dotimes-noting-progress ((var countform name + &optional stream (note-var '*current-progress-note*)) + &body body) + (let ((count-var '#:count)) + `(let ((,count-var ,countform)) + (noting-progress (,stream ,name ,note-var) + (dotimes (,var ,count-var) + ,@body + ;; We want the progress bar to advance after the first iteration + ;; even though DOTIMES is zero-based, so add one to the numerator. + (note-progress (1+ ,var) ,count-var)))))) + + +(defmethod frame-manager-clear-progress-note + ((framem standard-frame-manager) (note progress-note)) + (with-slots (stream) note + (when stream + (window-clear stream)))) + +(defmethod frame-manager-display-progress-note + ((framem standard-frame-manager) (note progress-note)) + (with-slots (name stream numerator denominator name-displayed bar-length) note + (when stream + (let* ((stream-width (bounding-rectangle-width stream)) + (line-height (stream-line-height stream)) + (new-bar-length (floor (* stream-width numerator) denominator))) + (unless name-displayed + (window-clear stream)) + (with-output-recording-options (stream :record nil) + (with-end-of-line-action (stream :allow) + (with-end-of-page-action (stream :allow) + (unless name-displayed + (stream-set-cursor-position stream 0 0) + (write-string name stream) + (setq name-displayed t)) + (when (< new-bar-length bar-length) + (draw-line* stream + 0 (+ line-height 2) bar-length (+ line-height 2) + :line-thickness 2 :ink +background-ink+)) + (draw-line* stream + 0 (+ line-height 2) new-bar-length (+ line-height 2) + :line-thickness 2) + (setq bar-length new-bar-length) + (force-output stream))))))))