Skip to content
GitLab
Explore
Sign in
Register
Primary navigation
Search or go to…
Project
C
clim-tos
Manage
Activity
Members
Labels
Plan
Issues
Issue boards
Milestones
Wiki
Code
Merge requests
Repository
Branches
Commits
Tags
Repository graph
Compare revisions
Snippets
Build
Pipelines
Jobs
Pipeline schedules
Artifacts
Deploy
Releases
Container Registry
Model registry
Operate
Environments
Monitor
Incidents
Service Desk
Analyze
Value stream analytics
Contributor analytics
CI/CD analytics
Repository analytics
Model experiments
Help
Help
Support
GitLab documentation
Compare GitLab plans
Community forum
Contribute to GitLab
Provide feedback
Terms and privacy
Keyboard shortcuts
?
Snippets
Groups
Projects
Show more breadcrumbs
Alastair Bridgewater
clim-tos
Commits
b58659d8
Commit
b58659d8
authored
32 years ago
by
cer
Browse files
Options
Downloads
Patches
Plain Diff
Initial revision
parent
28d9fd56
No related branches found
No related tags found
No related merge requests found
Changes
2
Hide whitespace changes
Inline
Side-by-side
Showing
2 changed files
clim/drag-and-drop.lisp
+291
-0
291 additions, 0 deletions
clim/drag-and-drop.lisp
clim/noting-progress.lisp
+138
-0
138 additions, 0 deletions
clim/noting-progress.lisp
with
429 additions
and
0 deletions
clim/drag-and-drop.lisp
0 → 100644
+
291
−
0
View file @
b58659d8
;;; -*- 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
)))
This diff is collapsed.
Click to expand it.
clim/noting-progress.lisp
0 → 100644
+
138
−
0
View file @
b58659d8
;;; -*- 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
))))))))
This diff is collapsed.
Click to expand it.
Preview
0%
Loading
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Save comment
Cancel
Please
register
or
sign in
to comment