1(define (mk-loc place x y) (list place x y))
2(define (loc-mk place x y) (list place x y))
3
4(define (loc-place loc) (car loc))
5(define (loc-x loc) (cadr loc))
6(define (loc-y loc) (caddr loc))
7
8;; eval-loc -- given a loc where the place is a tag, return one where the place
9;; is bound to the kernel object referred to by the tag
10(define (eval-loc loc)
11  (mk-loc (eval (loc-place loc))
12          (loc-x loc)
13          (loc-y loc)))
14
15(define (loc-op a b op)
16  (mk-loc (loc-place a)
17          (op (loc-x a) (loc-x b))
18          (op (loc-y a) (loc-y b))))
19(define (loc-sum a b) (loc-op a b +))
20(define (loc-distance a b)
21  (kern-get-distance a b))
22(define (loc-city-block-distance a b)
23  (+ (abs (- (loc-x a)
24             (loc-x b)))
25     (abs (- (loc-y a)
26             (loc-y b)))))
27
28
29(define (loc-addx loc dx)
30  (mk-loc (loc-place loc) (+ (loc-x loc) dx) (loc-y loc)))
31
32(define (loc-addy loc dy)
33  (mk-loc (loc-place loc) (loc-x loc) (+ (loc-y loc) dy)))
34
35;; loc-opposite-x -- return a list of locs AWAY from the given loc in the given
36;; x direction
37(define (loc-opposite-x loc dx)
38  (if (= 0 dx)
39      nil
40      (list (loc-addx loc dx)
41            (loc-addx (loc-addy loc -1) dx)
42            (loc-addx (loc-addy loc  1) dx))))
43
44;; loc-opposite-y -- return a list of locs AWAY from the given loc in the given
45;; y direction
46(define (loc-opposite-y loc dy)
47  (if (= 0 dy)
48      nil
49      (list (loc-addy loc dy)
50            (loc-addy (loc-addx loc -1) dy)
51            (loc-addy (loc-addx loc  1) dy))))
52
53;; loc-wrap -- wrap location around edges of a wrapping map
54(define (loc-wrap loc)
55  (let ((place (loc-place loc)))
56    (if (not (kern-place-is-wrapping? place))
57        loc
58        (mk-loc place
59                (modulo (loc-x loc) (kern-place-get-width place))
60                (modulo (loc-y loc) (kern-place-get-height place))))))
61
62;; loc-add -- vector sum of locations (auto wraps)
63(define (loc-add . locs)
64  ;;(println "loc-add " locs)
65  (if (null? locs)
66      nil
67      (loc-wrap (mk-loc (loc-place (car locs))
68                        (foldr (lambda (dx loc) (+ dx (loc-x loc))) 0 locs)
69                        (foldr (lambda (dy loc) (+ dy (loc-y loc))) 0 locs)))))
70
71;; loc-diff -- vector difference of two locations; on wrapping maps there are
72;; two solutions, the shortest is returned
73(define (loc-diff a b)
74  (let ((place (loc-place a)))
75    (if (kern-place-is-wrapping? place)
76        (let ((w (kern-place-get-width place)))
77          (mk-loc place
78                  (mdist (loc-x a) (loc-x b) w)
79                  (mdist (loc-y a) (loc-y b) w)))
80        (mk-loc place
81                (- (loc-x b) (loc-x a))
82                (- (loc-y b) (loc-y a))))))
83
84
85(define (loc-to-cardinal-dir loc)
86  (let ((x (loc-x loc))
87        (y (loc-y loc)))
88    (if (> x 0)
89        ;; eastern half
90        (if (> y 0)
91          ;; southeast quarter
92          (if (> x y)
93              east
94              south)
95          ;; northeast quarter
96          (if (> x (abs y))
97              east
98              north))
99        ;; western half
100        (if (> y 0)
101            ;; southwest quarter
102            (if (> (abs x) y)
103                west
104                south)
105            ;; northwest quarter
106            (if (> (abs x) (abs y))
107                west
108                north)))))
109
110
111
112;; ----------------------------------------------------------------------------
113;; loc-grid-distance -- return the distance needed to walk between two points
114;;
115;; REVISIT: this has a form almost identical to the loc-adjacent? proc below
116;;
117;; ----------------------------------------------------------------------------
118(define (loc-grid-distance a b)
119  (let ((place (loc-place a)))
120    (if (kern-place-is-wrapping? place)
121        (let ((w (kern-place-get-width place)))
122          (+ (mdist (loc-x a) (loc-x b) w)
123             (mdist (loc-y a) (loc-y b) w)))
124        (+ (abs (- (loc-x a) (loc-x b)))
125           (abs (- (loc-y a) (loc-y b)))))))
126
127(define (loc-closer? a b c)
128  (< (loc-grid-distance a c)
129     (loc-grid-distance b c)))
130
131;; loc-canonical -- return "canonical" form of vector (ie, one of the four
132;; cardinal directions)
133(define (loc-canonical loc)
134  (define (norm a)
135    (cond ((> a 0) 1)
136          ((< a 0) -1)
137          (else 0)))
138  (mk-loc (loc-place loc)
139          (norm (loc-x loc))
140          (norm (loc-y loc))))
141
142;; loc-sdiv -- scalar division
143(define (loc-sdiv loc s)
144  (mk-loc (loc-place loc)
145          (/ (loc-x loc s))
146          (/ (loc-y loc s))))
147
148;; loc-smul -- scaler multiplication
149(define (loc-smul loc s)
150  ;;(println "loc-smul " loc " " s)
151  (mk-loc (loc-place loc)
152          (* (loc-x loc) s)
153          (* (loc-y loc) s)))
154
155;; loc-norm -- convert loc to normal form (where at least one component has
156;; length 1)
157(define (loc-norm loc)
158  ;;(println "loc-norm " loc)
159  (let ((s (min (abs (loc-x loc))
160                     (abs (loc-y loc)))))
161    (if (<= s 1)
162        loc
163        (loc-sdiv loc s))))
164
165(define (loc-zero? loc)
166  (and (= 0 (loc-x loc))
167       (= 0 (loc-y loc))))
168
169(define (loc-equal? a b)
170  (and (eqv? (loc-place a) (loc-place b))
171       (= (loc-x a) (loc-x b))
172       (= (loc-y a) (loc-y b))))
173
174;; convert loc to short directional vector
175(define (loc-to-delta loc)
176  (if (loc-zero? loc)
177      loc
178      (if (> (abs (loc-x loc)) (abs (loc-y loc)))
179          (mk-loc (loc-place loc) (if (> (loc-x loc) 0) 1 -1) 0)
180          (mk-loc (loc-place loc) 0 (if (> (loc-y loc) 0) 1  -1)))))
181
182;; ----------------------------------------------------------------------------
183;; loc-enum-rect -- given a rectangular region of a place return a flat list of
184;; all locations in that rectangle. Useful in conjunction with map.
185;; ----------------------------------------------------------------------------
186(define (loc-enum-rect place x y w h)
187  (define (enum-row x w)
188    (if (= 0 w)
189        nil
190        (cons (mk-loc place x y)
191              (enum-row (+ x 1) (- w 1)))))
192  (if (= 0 h)
193      nil
194      (append (enum-row x w)
195              (loc-enum-rect place x (+ y 1) w (- h 1)))))
196
197;; Helper procedure. Checks if location b is a neighbor of location a as judged
198;; by is-adjacent?.
199(define (loc-adjacent-generic? a b is-adjacent?)
200  (let ((place (loc-place a)))
201    (if (kern-place-is-wrapping? place)
202        (let ((w (kern-place-get-width place)))
203          (is-adjacent? (mdist (loc-x a) (loc-x b) w)
204                 (mdist (loc-y a) (loc-y b) w)))
205        (is-adjacent? (abs (- (loc-x a) (loc-x b)))
206               (abs (- (loc-y a) (loc-y b)))))))
207
208;; Checks if location b is one of the 4 neighbors of location a
209(define (loc-4-adjacent? a b)
210  (loc-adjacent-generic? a
211                         b
212                         (lambda (dx dy)
213                           (or (and (= 1 dx) (= 0 dy))
214                               (and (= 0 dx) (= 1 dy))))))
215
216;; Checks if location b is one of the 8 neighbors of location a
217(define (loc-8-adjacent? a b)
218  (loc-adjacent-generic? a
219                        b
220                        (lambda (dx dy)
221                          (and (<= 1 dx) (<= 1 dy)))))
222
223(define (mk-lvect dx dy dz) (list dx dy dz))
224(define (lvect-dx lvect) (car lvect))
225(define (lvect-dy lvect) (cadr lvect))
226(define (lvect-dz lvect) (caddr lvect))
227
228;; Convert a direction code to a location vector
229(define (direction-to-lvect dir)
230  (cond ((= dir east)      (mk-lvect  1  0  0))
231        ((= dir west)      (mk-lvect -1  0  0))
232        ((= dir north)     (mk-lvect  0 -1  0))
233        ((= dir south)     (mk-lvect  0  1  0))
234        ((= dir northwest) (mk-lvect -1 -1  0))
235        ((= dir northeast) (mk-lvect  1 -1  0))
236        ((= dir southwest) (mk-lvect -1  1  0))
237        ((= dir southeast) (mk-lvect  1 -1  0))
238        ((= dir up)        (mk-lvect  0  0  1))
239        ((= dir down)      (mk-lvect  0  0 -1))
240        ))
241
242(define (loc-offset loc dir)
243  ;;(println "    loc-offset:" loc "," dir)
244  (define (get-place place dz)
245    ;;(println "     get-place:" place "," dz)
246    (cond ((= dz 0) place)
247          (else (kern-place-get-neighbor place dir))))
248  (let* ((vec (direction-to-lvect dir))
249         (place (get-place (loc-place loc) (lvect-dz vec))))
250    (cond ((null? place) nil)
251          (else
252           (mk-loc place
253                   (+ (loc-x loc) (lvect-dx vec))
254                   (+ (loc-y loc) (lvect-dy vec)))))))
255
256;; cardinal directions to lists
257
258; order is N W E S
259(define (cardinal-dir-num dir)
260	(/ (- dir 1) 2))
261
262(define (get-cardinal-ref avector dir)
263	;;(println "gcrc " avector)
264	(vector-ref avector
265		(cardinal-dir-num dir))
266		)
267
268(define (get-cardinal-lref alist dir)
269	;;(println "gcrl " alist)
270	(list-ref alist
271		(cardinal-dir-num dir))
272		)
273
274