-
Notifications
You must be signed in to change notification settings - Fork 0
/
params
114 lines (86 loc) · 1.97 KB
/
params
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
get-order get-current
requires utils
wordlist: params
params first definitions
: scale:: create 1 , 1 , does> 2@ */ ;
: gcd ( a b -- gcd) ?dup if tuck mod recurse then ;
: reduce ( n d -- n2 d2)
2dup gcd dup>r / swap r> / swap ;
: setscale ( n d xt -- )
>r reduce r>
>pf @ 2! ;
global{
scale:: mapscale
scale:: /mapscale
}global
\ #arg1 2 3 4
\ arg 0 1 2 3
\ forth pixelpath map1 scale
: default2 s" testmap.bmp" ;
\ miles per pixel
: default3 \ furlong default
8 1 ['] mapscale setscale
1 8 ['] /mapscale setscale
;
: rindex ( caddr len char -- pos|-1)
swap times ( caddr char)
over i + c@ ( caddr char test)
over = if 2drop i unloop exit then
iterate
2drop -1
;
: -suffix ( caddr len -- caddr len2)
2dup [char] . rindex
dup -1 <> if nip else drop then
;
: arg2
#args 3 < if default2 else 2 arg then
-suffix
;
: arg3 ( -- n )
#args 4 < if default3 else
0. 3 arg $>s
dup 0< if abs 1 swap 8 * else 8 then
2dup ['] /mapscale setscale
swap ['] mapscale setscale
then
;
global{
\ pad is caddr3
: +suffix ( caddr1 len1 caddr2 len2 -- caddr3 len3)
pad 1024 erase
2swap
2dup pad swap move ( caddr2 len2 cadd1 len1)
nip ( caddr2 len2 len1)
dup>r pad + ( caddr2 len2 caddr3b| len1)
>r 2dup r> swap move ( caddr2 len2 |len1)
nip r> + pad swap 1024 max
;
\ Note the cell+ .... zmove!
: (fix$) ( caddr1 len -- caddr2 len)
2dup align here swap ( caddr1 len caddr1 caddr2 len)
zmove ( caddr1 len)
here over ( caddr1 len caddr2 len)
cell+ allot ( caddr1 len caddr2 )
-rot nip
;
: fix$ ( caddr len <name> -- )
(fix$)
create , ,
does> 2@
;
: .$ ( addr -- ) 2@ type ;
2variable basename
: b+" basename 2@ [char] " parse +suffix fix$ ;
arg2 basename 2!
b+" .bmp" mapname
b+" .cities" cityfile
b+" .trade.pgm" tradepgm
b+" .domain.pgm" domainpgm
b+" .days.pgm" dayspgm
b+" .tradevol.bin" tradevolfile
b+" .cities.bin" citytradefile
mapname type
arg3
}global
set-current set-order