Skip to content
Snippets Groups Projects
Commit b58659d8 authored by cer's avatar cer
Browse files

Initial revision

parent 28d9fd56
No related branches found
No related tags found
No related merge requests found
;;; -*- 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)))
;;; -*- 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))))))))
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment