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
000ab326
Commit
000ab326
authored
32 years ago
by
cer
Browse files
Options
Downloads
Patches
Plain Diff
Initial revision
parent
2c24cbef
No related branches found
No related tags found
No related merge requests found
Changes
1
Hide whitespace changes
Inline
Side-by-side
Showing
1 changed file
demo/plot.lisp
+412
-0
412 additions, 0 deletions
demo/plot.lisp
with
412 additions
and
0 deletions
demo/plot.lisp
0 → 100644
+
412
−
0
View file @
000ab326
;; -*- mode: common-lisp; package: clim-user -*-
;;
;; -[]-
;;
;; copyright (c) 1985, 1986 Franz Inc, Alameda, CA All rights reserved.
;; copyright (c) 1986-1992 Franz Inc, Berkeley, CA All rights reserved.
;;
;; The software, data and information contained herein are proprietary
;; to, and comprise valuable trade secrets of, Franz, Inc. They are
;; given in confidence by Franz, Inc. pursuant to a written license
;; agreement, and may be stored and used only in accordance with the terms
;; of such license.
;;
;; Restricted Rights Legend
;; ------------------------
;; Use, duplication, and disclosure of the software, data and information
;; contained herein by any agency, department or entity of the U.S.
;; Government are subject to restrictions of Restricted Rights for
;; Commercial Software developed at private expense as specified in FAR
;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
;; applicable.
;;
;; $fiHeader$
(
in-package
:clim-user
)
;;; Clim based plotting package
;;-- How does incremental redisplay fit into all of this.
;;-- What happens if we use it and redisplay is not called at the
;;-- outer level
(
defmacro
plotting-data
((
stream
&rest
options
)
&body
body
)
;; For each X value we want to specify the Y values
;; Specify labels for each X value
;; Specify label for each set of Y values
;; Specify the size of the graph we want draw.
;; Range of values for the axiss
(
let
((
point-plotting-continuation
(
gensym
))
(
plot-data-continuation
(
gensym
)))
`
(
flet
((
plotting-data-body
(
,
point-plotting-continuation
,
plot-data-continuation
)
;; Perhaps we can also have a way of
;; specify all the points in one go
(
flet
((
plot-point
(
x
&rest
ys
)
(
apply
,
point-plotting-continuation
x
ys
))
(
plot-data
(
array
)
(
funcall
,
plot-data-continuation
array
)))
,@
body
)))
(
invoke-plotting-data
,
stream
#'
plotting-data-body
,@
options
))))
;; We should make presentations of these types
(
define-presentation-type
graph-plot
())
(
define-presentation-type
graph-region
())
(
define-presentation-method
presentation-typep
(
object
(
type
graph-region
))
(
typep
object
'standard-rectangle
))
(
define-command-table
plot-command-table
)
(
define-presentation-translator
select-graph-region
(
graph-plot
graph-region
plot-command-table
:gesture
:select
)
(
x
y
window
)
(
let
((
nx
x
)
(
ny
y
)
(
ox
x
)
(
oy
y
))
(
with-output-recording-options
(
window
:record
nil
)
(
flet
((
draw-it
()
(
draw-rectangle*
window
nx
ny
ox
oy
:filled
nil
:ink
+flipping-ink+
)))
(
draw-it
)
(
tracking-pointer
(
window
)
(
:pointer-motion
(
x
y
)
(
draw-it
)
(
setq
nx
x
ny
y
)
(
draw-it
))
(
:pointer-button-press
(
x
y
)
(
draw-it
)
(
setq
nx
x
ny
y
)
(
return
(
make-rectangle*
ox
oy
nx
ny
))))))))
;; Define a presentation translator from a graph-plot to a graph-region.
;; In that way we trivially write a command that will zoom into a
;; particular region of the graph.
(
define-presentation-type
graph-point
())
(
define-presentation-type
graph-line
())
(
define-presentation-type
graph-axis
())
(
defun
invoke-plotting-data
(
stream
continuation
&key
x-labels
y-labels
y-labelling
x-min
y-min
x-max
y-max
width
height
)
(
let
((
points
nil
))
(
flet
((
point-collector
(
x
&rest
ys
)
(
push
(
list*
x
ys
)
points
))
(
plot-data-collector
(
data
)
(
setq
points
data
)))
(
funcall
continuation
#'
point-collector
#'
plot-data-collector
))
(
etypecase
points
((
array
t
(
*
*
))
nil
)
(
list
(
setq
points
(
make-array
(
list
(
length
points
)
(
length
(
car
points
)))
:initial-contents
(
nreverse
points
)))))
(
multiple-value-setq
(
width
height
)
(
default-width-and-height
stream
width
height
))
(
multiple-value-setq
(
x-min
y-min
x-max
y-max
y-labelling
)
(
default-graph-axis
points
x-min
y-min
x-max
y-max
y-labelling
))
(
let
((
transform
(
let
((
scaling-transform
(
make-scaling-transformation
(
/
width
(
-
x-max
x-min
))
(
/
height
(
-
y-max
y-min
)))))
(
multiple-value-bind
(
ox
oy
)
(
transform-position
scaling-transform
x-min
y-min
)
(
compose-transformations
(
make-translation-transformation
(
-
ox
)
(
-
oy
))
scaling-transform
)))))
(
with-new-output-record
(
stream
'standard-sequence-output-record
)
(
with-output-as-presentation
(
stream
nil
'graph-plot
:single-box
:position
)
(
formatting-item-list
(
stream
:n-columns
2
)
(
formatting-cell
(
stream
)
(
with-room-for-graphics
(
stream
)
(
draw-axis
stream
width
height
x-min
y-min
x-max
y-max
x-labels
y-labels
points
transform
y-labelling
)
(
draw-data
stream
width
height
x-min
y-min
x-max
y-max
points
transform
)))
(
formatting-cell
(
stream
)
(
draw-caption
stream
y-labels
))))))))
(
defun
draw-caption
(
stream
y-labels
)
(
updating-output
(
stream
:unique-id
'captions
:cache-value
(
copy-list
y-labels
)
:cache-test
#'
equalp
)
(
let
((
n-lines
(
length
y-labels
))
(
ascent
(
text-style-ascent
(
medium-text-style
stream
)
stream
))
(
descent
(
text-style-descent
(
medium-text-style
stream
)
stream
))
(
i
0
))
(
surrounding-output-with-border
(
stream
)
(
formatting-table
(
stream
)
(
dolist
(
label
y-labels
)
(
formatting-row
(
stream
)
(
formatting-cell
(
stream
)
(
draw-rectangle*
stream
0
0
20
(
+
ascent
descent
)
:ink
+background-ink+
)
(
draw-line*
stream
0
(
/
ascent
2
)
20
(
/
ascent
2
)
:ink
(
make-contrasting-inks
n-lines
i
)
:line-dashes
(
make-contrasting-dash-patterns
n-lines
i
)))
(
formatting-cell
(
stream
)
(
write-string
label
stream
)))
(
incf
i
)))))))
(
defun
draw-axis
(
stream
width
height
x-min
y-min
x-max
y-max
x-labels
y-labels
points
transform
y-labelling
)
;; Y Axis
(
updating-output
(
stream
:unique-id
'y-axis
:cache-value
(
list
width
height
x-min
y-min
x-max
y-max
y-labelling
)
:cache-test
#'
equalp
)
(
with-output-as-presentation
(
stream
nil
'graph-axis
)
(
draw-line*
stream
0
0
0
height
)
(
do
((
y
y-min
(
+
y-labelling
y
)))
((
>=
y
y-max
))
(
multiple-value-bind
(
tx
ty
)
(
transform-position
transform
x-min
y
)
(
draw-line*
stream
(
-
tx
2
)
ty
(
+
tx
2
)
ty
)
(
let
((
label
(
format
nil
"~3d"
y
)))
(
multiple-value-bind
(
width
height
ignore-x
ignore-y
baseline
)
(
text-size
stream
label
)
(
declare
(
ignore
ignore-x
ignore-y
))
(
draw-text*
stream
label
(
-
tx
width
2
)
ty
)))))))
;; X Axis labelling
(
updating-output
(
stream
:unique-id
'x-axis
:cache-value
(
list
width
height
x-min
y-min
x-max
y-max
(
copy-list
x-labels
))
:cache-test
#'
equalp
)
(
with-output-as-presentation
(
stream
nil
'graph-axis
)
(
draw-line*
stream
0
0
width
0
)
(
let
((
i
0
))
(
dolist
(
label
x-labels
)
(
multiple-value-bind
(
tx
ty
)
(
transform-position
transform
(
aref
points
i
0
)
y-min
)
(
draw-line*
stream
tx
(
-
ty
2
)
tx
(
+
ty
2
))
(
multiple-value-bind
(
width
height
ignore-x
ignore-y
baseline
)
(
text-size
stream
label
)
(
declare
(
ignore
ignore-x
ignore-y
))
(
draw-text*
stream
label
(
-
tx
(
/
width
2
))
(
-
ty
height
3
))
(
incf
i
))))))))
(
defun
draw-data
(
stream
width
height
x-min
y-min
x-max
y-max
points
transform
)
(
destructuring-bind
(
rows
columns
)
(
array-dimensions
points
)
(
let*
(
(
n-lines
(
1-
columns
)))
(
dotimes
(
i
n-lines
)
(
updating-output
(
stream
:unique-id
`
(
plot-line
,
i
)
:id-test
#'
equal
:cache-value
(
list
x-min
y-min
x-max
y-max
width
height
(
let
((
r
nil
))
(
dotimes
(
j
rows
(
nreverse
r
))
(
push
(
aref
points
j
0
)
r
)
(
push
(
aref
points
j
(
1+
i
))
r
)))))
(
let
(
last-tx
last-ty
)
(
with-output-as-presentation
(
stream
(
1+
i
)
'graph-line
)
(
draw-lines*
stream
(
let
((
r
nil
))
(
dotimes
(
j
rows
(
nreverse
r
))
(
let
((
x
(
aref
points
j
0
))
(
y
(
aref
points
j
(
1+
i
))))
(
multiple-value-bind
(
tx
ty
)
(
transform-position
transform
x
y
)
(
when
last-tx
(
push
last-tx
r
)
(
push
last-ty
r
)
(
push
tx
r
)
(
push
ty
r
))
(
setq
last-tx
tx
last-ty
ty
)))))
:ink
(
make-contrasting-inks
n-lines
i
)
:line-dashes
(
make-contrasting-dash-patterns
n-lines
i
))))
(
dotimes
(
j
rows
)
(
let
((
x
(
aref
points
j
0
))
(
y
(
aref
points
j
(
1+
i
))))
(
multiple-value-bind
(
tx
ty
)
(
transform-position
transform
x
y
)
(
with-output-as-presentation
(
stream
(
list
(
1+
i
)
j
)
'graph-point
)
(
draw-circle*
stream
tx
ty
4
:filled
t
))))))))))
(
defun
default-width-and-height
(
stream
width
height
)
(
values
400
300
))
(
defun
default-graph-axis
(
points
x-min
y-min
x-max
y-max
y-labelling
)
(
destructuring-bind
(
rows
columns
)
(
array-dimensions
points
)
(
setq
x-min
(
aref
points
0
0
)
x-max
x-min
)
(
setq
y-min
(
aref
points
0
1
)
y-max
y-min
)
(
dotimes
(
i
rows
)
(
let
((
x
(
aref
points
i
0
)))
(
clim-utils::minf
x-min
x
)
(
clim-utils::maxf
x-max
x
)
(
dotimes
(
j
(
1-
columns
))
(
let
((
y
(
aref
points
i
(
1+
j
))))
(
clim-utils::minf
y-min
y
)
(
clim-utils::maxf
y-max
y
))))))
(
values
x-min
y-min
x-max
y-max
(
or
y-labelling
(
float
(
/
(
-
y-max
y-min
)
10
)))))
;; Actual demo code.
(
define-application-frame
plot-demo
()
(
(
y-labelling
:initform
5
)
(
plot-data
:initform
#2a
((
1960
5
11
14
)
(
1970
8
15
16
)
(
1980
14
18
15.5
)
(
1990
19
21
15.2
)
(
2000
24
22
15.4
)))
(
x-labels
:initform
'
(
"60"
"70"
"80"
"90"
"2000"
))
(
y-labels
:initform
'
(
"Mexico City"
"Tokyo"
"New York"
))
)
(
:command-table
(
plot-demo
:inherit-from
(
plot-command-table
)))
(
:panes
(
graph-window
:application
:display-function
'display-graph
:incremental-redisplay
t
:scroll-bars
:both
:width
:compute
:height
:compute
)
(
data-window
:application
:display-function
'display-data
:incremental-redisplay
t
:scroll-bars
:both
:width
:compute
:height
:compute
)
(
command
:interactor
:height
'
(
5
:line
)))
(
:layouts
(
:default
(
vertically
()
graph-window
data-window
command
))))
(
defmethod
frame-standard-output
((
fr
plot-demo
))
(
get-frame-pane
fr
'command
))
(
define-presentation-type
data-point
())
(
define-presentation-type
x-label
())
(
define-presentation-type
y-label
())
(
defmethod
display-data
((
frame
plot-demo
)
stream
&key
&allow-other-keys
)
(
with-slots
(
y-labels
x-labels
plot-data
)
frame
(
formatting-table
(
stream
)
;; Headers
(
formatting-row
(
stream
)
(
updating-output
(
stream
:unique-id
`
(
-1
,
-1
)
:id-test
#'
equal
:cache-value
nil
:cache-test
#'
equalp
)
(
formatting-cell
(
stream
)
stream
))
; Dummy corner
(
updating-output
(
stream
:unique-id
`
(
-1
,
0
)
:id-test
#'
equal
:cache-value
nil
:cache-test
#'
equalp
)
(
formatting-cell
(
stream
)
stream
))
; Over the X values
(
let
((
i
0
))
(
dolist
(
label
y-labels
)
(
updating-output
(
stream
:unique-id
`
(
-1
,
(
+
2
i
))
:id-test
#'
equal
:cache-value
label
:cache-test
#'
equalp
)
(
formatting-cell
(
stream
)
(
with-output-as-presentation
(
stream
i
'y-label
)
(
write-string
label
stream
))))
(
incf
i
))))
(
destructuring-bind
(
rows
columns
)
(
array-dimensions
plot-data
)
(
dotimes
(
i
rows
)
(
let
((
label
(
nth
i
x-labels
)))
(
formatting-row
(
stream
)
(
updating-output
(
stream
:unique-id
`
(
,
i
-1
)
:id-test
#'
equal
:cache-value
label
:cache-test
#'
equalp
)
(
formatting-cell
(
stream
)
(
with-output-as-presentation
(
stream
i
'x-label
)
(
write-string
label
stream
))))
(
dotimes
(
j
columns
)
(
let
((
n
(
aref
plot-data
i
j
)))
(
updating-output
(
stream
:unique-id
`
(
,
i
,
j
)
:id-test
#'
equal
:cache-value
n
:cache-test
#'
equal
)
(
formatting-cell
(
stream
)
(
with-output-as-presentation
(
stream
(
list
i
j
)
'data-point
)
(
with-output-as-presentation
(
stream
n
'number
)
(
format
stream
"~2D"
n
))))))))))))))
(
define-plot-demo-command
(
com-edit-x-label
:name
t
:menu
t
)
((
i
'x-label
:gesture
:select
))
(
with-application-frame
(
frame
)
(
setf
(
nth
i
(
slot-value
frame
'x-labels
))
(
accept
'string
:default
(
nth
i
(
slot-value
frame
'x-labels
))))))
(
define-plot-demo-command
(
com-edit-y-label
:name
t
:menu
t
)
((
i
'y-label
:gesture
:select
))
(
with-application-frame
(
frame
)
(
setf
(
nth
i
(
slot-value
frame
'y-labels
))
(
accept
'string
:default
(
nth
i
(
slot-value
frame
'y-labels
))))))
(
define-plot-demo-command
(
com-edit-data-point
:name
t
:menu
t
)
((
point
'data-point
:gesture
:select
))
(
with-application-frame
(
frame
)
(
destructuring-bind
(
i
j
)
point
(
setf
(
aref
(
slot-value
frame
'plot-data
)
i
j
)
(
accept
'number
:default
(
aref
(
slot-value
frame
'plot-data
)
i
j
))))))
(
defmethod
display-graph
((
frame
plot-demo
)
stream
&key
&allow-other-keys
)
(
with-slots
(
y-labelling
plot-data
x-labels
y-labels
)
frame
(
plotting-data
(
stream
:y-labelling
y-labelling
:x-labels
x-labels
:y-labels
y-labels
)
(
plot-data
plot-data
))))
(
define-plot-demo-command
com-describe-graph-line
((
line
'graph-line
:gesture
:select
))
(
describe
line
))
(
define-plot-demo-command
com-describe-graph-point
((
point
'graph-point
:gesture
:select
))
(
describe
point
))
(
define-plot-demo-command
(
com-describe-region
:name
t
)
((
region
'graph-region
))
(
describe
region
))
(
define-plot-demo-command
(
com-redisplay
:name
t
)
()
(
window-clear
(
get-frame-pane
*application-frame*
'graph-window
))
(
window-clear
(
get-frame-pane
*application-frame*
'data-window
)))
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