1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
|
############################################################################
#
# File: barchart.icn
#
# Subject: Procedures for dynamically growing barchart
#
# Author: Gregg M. Townsend
#
# Date: August 14, 1996
#
############################################################################
#
# This file is in the public domain.
#
############################################################################
#
# These procedures draw barcharts that can grow dynamically.
#
# barchart(win, x, y, dx, dy, sf, n, l, w, b) creates a barchart.
#
# setbar(bc, n, v) sets the value of a bar.
#
# rebar(bc, sf) redraws a barchart with a new scaling factor.
#
############################################################################
#
# barchart(win, x, y, dx, dy, sf, n, l, w, b) -- establish a barchart
#
# win window
# x,y position of base of first bar
# dx,dy distance to base of second bar (either dx or dy should be
# zero)
# sf scaling (pixels per unit of value, + or -, need not be
# integer)
# n number of bars
# l,w length (maximum) and width of one bar
# b logarithmic base, if bars are to be scaled logarithmically
#
# barchart() establishes structures for building a barchart. Any of the
# eight possible orthogonal orientations can be selected depending on the
# signs of dx, dy, and sf.
#
# The absolute value of sf establishes a linear scaling from barchart
# values to number of pixels. Scaling is handled such that a value of 1
# makes the first mark on a bar and then each increment of sf lengthens
# the bar by one pixel. If a bar would exceed the limit then the entire
# chart is rescaled so that only half the range is then used.
#
# setbar(bc, n, v) - set bar n of barchart bc to represent value v
#
# It is assumed that v>0 and that bars never shrink; but they may grow.
#
# rebar(bc, sf) - redraw barchart with new scaling factor sf.
#
# sf is assumed to be of the same sign as the previous scaling factor.
#
# Example:
#
# Suppose "scores" is a list of scores ranging from 0 to 100.
# This code fragment dynamically draws a histogram using 21 bins.
#
# The call to barchart() specifies:
# The lower left-hand corner of the barchart is (10, 190).
# The next bar is 10 pixels to its right, which would be (20, 190).
# The bars grow upward, to smaller y values, so the scaling factor
# is negative; each score will grow its bar by 5 pixels.
# Each bar grows to a maximum length of 180 pixels; the width is 8.
# No base is given, so scaling is linear.
#
# bc := barchart(win, 10, 190, 10, 0, -5, 21, 180, 8)
# b := list(21, 0) # histogram bins
# every n := !scores do {
# i := n / 5 # bin (and bar) number
# b[i] +:= 1 # increment bin count
# setbar(bc, i, b[i]) # update display
# }
#
############################################################################
#
# Requires: Version 9 graphics
#
############################################################################
record BC_rec(win, x, y, dx, dy, sf, n, l, w, b, len, val, round)
procedure barchart(win, x, y, dx, dy, sf, n, l, w, b) #: draw barchart
local bc
bc := BC_rec(win, x, y, dx, dy, sf, n, l, w, b)
bc.len := list(n, 0)
bc.val := list(n)
if sf > 0 then
bc.round := 0.99999
else
bc.round := -0.99999
rebar(bc, sf) # clear area
return bc
end
## setbar(bc, n, v) - set bar n of barchart bc to represent value v
#
# It is assumed that v>0 and that bars never shrink; but they may grow.
procedure setbar(bc, n, v) #: set bar value on barchart
local x, y, o, oldlen, newlen, incr
v := log(v, \bc.b)
oldlen := bc.len[n] | fail
newlen := integer(v * bc.sf + bc.round)
if abs(newlen) > bc.l then {
# need to rescale first
rebar(bc, 0.5 * bc.sf * real(bc.l) / real(abs(newlen-1)))
return setbar(bc, n, v)
}
# lengthen the bar
if (incr := newlen - oldlen) ~= 0 then {
if bc.dx ~= 0 then {
# horizontal baseline
x := bc.x + (n - 1) * bc.dx
y := bc.y + oldlen
if incr < 0 then
FillRectangle(bc.win, x, y + incr, bc.w, -incr)
else
FillRectangle(bc.win, x, y, bc.w, incr)
}
else {
# vertical baseline
x := bc.x + oldlen
y := bc.y + (n - 1) * bc.dy
if incr < 0 then
FillRectangle(bc.win, x + incr, y, -incr, bc.w)
else
FillRectangle(bc.win, x, y, incr, bc.w)
}
bc.len[n] := newlen
bc.val[n] := v
}
return
end
## rebar(bc, sf) - redraw barchart with new scaling factor sf.
#
# sf is assumed to be of the same sign as the previous scaling factor.
procedure rebar(bc, sf) #: redraw barchart
local i, l, x, y, dx, dy
if bc.sf > 0 then
l := bc.l
else
l := -bc.l
x := bc.x
y := bc.y
if bc.dx ~= 0 then {
dx := bc.n * bc.dx
dy := l
}
else {
dx := l
dy := bc.n * bc.dy
}
# force all values positive (negative is wrong, but works under OpenWindows!)
if dx < 0 then {
x +:= dx
dx := -dx
}
if dy < 0 then {
y +:= dy
dy := -dy
}
EraseArea(bc.win, x, y, dx, dy)
bc.len := list(bc.n, 0)
bc.sf := sf
every i := 1 to *bc.len do
setbar(bc, i, \bc.val[i])
return
end
# ## test program
# #
# # usage: barchart [dx [dy [sf]]]
# #
# # background is deliberately different in order to see what gets cleared
#
# procedure main(args)
# local dx, dy, sf, win, n, l, bc, i
# dx := args[1] | 5
# dy := args[2] | 0
# sf := args[3] | -1
# win := open("bars", "g", "width=500", "height=500")
# l := list(50, 0)
# bc := barchart(win, 250, 250, dx, dy, sf, *l, 200, 4)
# Fg(win, "papayawhip")
# FillRectangle(win, 0, 0, 500, 500)
# Fg(win, "black")
# every 1 to 5000 do {
# i := ?5 + ?5 + integer(10 * log(1+20*?0)) # nonuniform random bar
# setbar(bc, i, l[i] +:= 1)
# flush(win)
# }
# while not upto('qQ', reads(win))
# end
|
