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