streamline collision calculation by doing the hit detection inside th…

…e quadtree

cannon.rkt

@@ -96,7 +96,6 @@
     (let/ec done
       (for ((o (in-list (qt-retrieve qt (obj-x ownship) (obj-y ownship) (ship-radar ownship))))
             #:when (and (or (spaceship? o) (missile? o) (probe? o) (cannonball? o) (mine? o))
-                        ((distance ownship o) . <= . (ship-radar ownship))
                         ((faction-check (ship-faction ownship) (ship-faction o)) . < . 0)))
         (define t (target-angle ownship ownship o o CANNON_SPEED 30.0))
         (define spread (atan (/ (ship-radius o)
@@ -115,7 +114,6 @@
     (define any-closer?
       (for/or ((o (in-list (qt-retrieve qt (obj-x ownship) (obj-y ownship) (ship-radar ownship))))
                #:when (and (or (spaceship? o) (missile? o) (probe? o) (mine? o))
-                           ((distance ownship o) . <= . (ship-radar ownship))
                            ((faction-check (ship-faction ownship) (ship-faction o)) . < . 0)))
         ; get our relative motion to target
         (define vx (- (obj-dx ownship) (obj-dx o)))

missile.rkt

@@ -113,17 +113,16 @@
   (for ((o (in-list (qt-retrieve qt (obj-x m) (obj-y m) (ship-radar m))))
         #:when (missile-target? o))
     (define d (distance o m))
-    (when (d . <= . (ship-radar m))
-      (define foe? ((faction-check (ship-faction m) (ship-faction o)) . < . 0))
-      (when foe?
-        ; linearly incentivize flying towards enemies in general
-        (set! f (- f d)))
-
-      (define hd (hit-distance o m))
-      (define maxd (+ hd AI_HIT_CLOSE))
-      (when (d . < . maxd)
-        (define z (- maxd d))  ; meters inside maxd
-        (set! f (+ f (* z z (if foe? 1.0 -1.0))))
-        (when (d . < . (+ hd (/ AI_HIT_CLOSE 2)))
-          (set! live? #f)))))
+    (define foe? ((faction-check (ship-faction m) (ship-faction o)) . < . 0))
+    (when foe?
+      ; linearly incentivize flying towards enemies in general
+      (set! f (- f d)))
+
+    (define hd (hit-distance o m))
+    (define maxd (+ hd AI_HIT_CLOSE))
+    (when (d . < . maxd)
+      (define z (- maxd d))  ; meters inside maxd
+      (set! f (+ f (* z z (if foe? 1.0 -1.0))))
+      (when (d . < . (+ hd (/ AI_HIT_CLOSE 2)))
+        (set! live? #f))))
   (values f live?))

physics.rkt

@@ -228,11 +228,11 @@
 ; numeric priority that controls the order that objects are seen by collide!
 (define (priority o)
   (cond ((nebula? o) 0)
-        ((explosion? o) 1)
-        ((plasma? o) 2)
-        ((cannonball? o) 3)
-        ((missile? o) 4)
-        ((mine? o) 5)
+        ((mine? o) 1)
+        ((explosion? o) 2)
+        ((plasma? o) 3)
+        ((cannonball? o) 4)
+        ((missile? o) 5)
         ((spaceship? o) 6)
         ((probe? o) 6)
         ((spacesuit? o) 6)
@@ -245,19 +245,19 @@
   (cond
     ((and (nebula? a)
           (not (nebula? b)))
-     (define d (distance a b))
-     (define n (- 1.0 (linear-fade d (* (nebula-radius a) 0.7) (nebula-radius a))))
+     (define d (distance2 a b))
+     (define rad (* (nebula-radius a) (nebula-radius a)))
+     (define n (- 1.0 (linear-fade d (* rad 0.7) rad)))
      (set-obj-neb! b (min (obj-neb b) n)))
-    ((and (mine? a) (ship-tool a 'engine))
-     (cond ((spaceship? b)
-            (define d (distance a b))
-            (when (d . < . (+ (ship-radar a) (ship-radius b)))
-              (define xy_acc (tool-val (ship-tool a 'engine)))
-              (define r (theta a b))
-              (define ddx (* xy_acc (cos r)))
-              (define ddy (* xy_acc (sin r)))
-              (set-posvel-dx! (obj-posvel a) (+ (obj-dx a) (* ddx dt)))
-              (set-posvel-dy! (obj-posvel a) (+ (obj-dy a) (* ddy dt)))))))))
+    ((and (mine? a)
+          (spaceship? b)
+          (ship-tool a 'engine))
+     (define xy_acc (tool-val (ship-tool a 'engine)))
+     (define r (theta a b))
+     (define ddx (* xy_acc (cos r)))
+     (define ddy (* xy_acc (sin r)))
+     (set-posvel-dx! (obj-posvel a) (+ (obj-dx a) (* ddx dt)))
+     (set-posvel-dy! (obj-posvel a) (+ (obj-dy a) (* ddy dt))))))
 
 ; called on every pair of objects that might be colliding
 ; called only once for each pair
@@ -267,62 +267,64 @@
   (collide-common! a b dt)
   (when (server?)
     (cond
+      ((mine? a)
+       ; mines are special because we put them into the quadtree with radar radius
+       ; so they can move towards ships, but for collision purposes we need
+       ; to check the actual distance
+       (cond
+         ((and (or (spaceship? b) (mine? b))
+               (hit? a b (hit-distance a b)))
+          (mine-hit-ship! space a b))
+         ((and (probe? b)
+               (hit? a b (hit-distance a b)))
+          (ship-hit-ship! space a b))
+         ((and (explosion? b)
+               (hit? a b (+ (ship-radius a) (explosion-radius b))))
+          (list (chdam (ob-id a) (explosion-damage b dt) #t)))
+         ((and (plasma? b)
+               (hit? a b (+ (ship-radius a) (plasma-radius space b))))
+          (plasma-hit-ship! space a b))
+         ((and (cannonball? b)
+               (hit? a b (hit-distance a b)))
+          (cb-hit-ship! space b a))
+         ((and (missile? b)
+               (hit? a b (hit-distance a b)))
+          (missile-hit-ship! space a b))))
       ((explosion? a)
        (cond ((plasma? b)
-              (when ((distance a b) . < . (+ (plasma-radius space b) (explosion-radius a)))
-                (list (chdam (ob-id b) (explosion-damage a dt) #t))))
+              (list (chdam (ob-id b) (explosion-damage a dt) #t)))
              ((or (cannonball? b)
-                  (mine? b)
                   (missile? b)
                   (spaceship? b)
                   (probe? b))
-              (when ((distance a b) . < . (+ (ship-radius b) (explosion-radius a)))
-                (list (chdam (ob-id b) (explosion-damage a dt) #t))))))
+              (list (chdam (ob-id b) (explosion-damage a dt) #t)))))
       ((plasma? a)
        (cond ((or (spaceship? b)
                   (probe? b)
                   (missile? b)
-                  (mine? b)
                   (cannonball? b))
-              (when ((distance a b) . < . (+ (ship-radius b) (plasma-radius space a)))
-                (plasma-hit-ship! space b a)))))
+              (plasma-hit-ship! space b a))))
       ((cannonball? a)
        (cond ((cannonball? b)
-              (when ((distance a b) . < . (hit-distance a b))
-                (cb-hit-cb! space a b)))
+              (cb-hit-cb! space a b))
              ((or (spaceship? b)
                   (missile? b)
-                  (mine? b)
                   (probe? b))
-              (when ((distance a b) . < . (hit-distance a b))
-                (cb-hit-ship! space a b)))))
+              (cb-hit-ship! space a b))))
       ((missile? a)
        (cond ((missile? b)
-              (when ((distance a b) . < . (hit-distance a b))
-                (missile-hit-missile! space a b)))
+              (missile-hit-missile! space a b))
              ((or (spaceship? b)
-                  (mine? b)
                   (probe? b))
-              (when ((distance a b) . < . (hit-distance a b))
-                (missile-hit-ship! space b a)))))
-      ((mine? a)
-       (cond ((or (spaceship? b) (mine? b))
-              (define d (distance a b))
-              (when (d . < . (hit-distance a b))
-                (mine-hit-ship! space a b)))
-             ((probe? b)
-              (define d (distance a b))
-              (when (d . < . (hit-distance a b))
-                (ship-hit-ship! space a b)))))
+              (missile-hit-ship! space b a))))
       ((or (spaceship? a)
            (probe? a)
            (spacesuit? a))
        (cond
          ((or (spaceship? b)
               (probe? b)
               (spacesuit? b))
-          (when ((distance a b) . < . (hit-distance a b))
-            (ship-hit-ship! space a b))))))))
+          (ship-hit-ship! space a b)))))))
 
 
 (define (add-to-qt! ownspace qt o)

pilot.rkt

@@ -30,9 +30,8 @@
       (define d (distance ship o))
       (define hd (hit-distance ship o))
       (define maxd (+ hd AI_HIT_CLOSE))
-      (when (d . < . maxd)
-        (define z (- maxd d))  ; meters inside maxd
-        (set! f (- f (* z z))))))
+      (define z (max 0.0 (- maxd d)))  ; meters inside maxd
+      (set! f (- f (* z z)))))
 
 
   (case (and strat (strategy-name strat))
@@ -252,8 +251,7 @@
   ; only worry about ships that are close to us
   (define ships (filter (lambda (o)
                           (and (spaceship? o)
-                               (not (= (ob-id ownship) (ob-id o)))
-                               ((distance ownship o) . <= . 500.0)))
+                               (not (= (ob-id ownship) (ob-id o)))))
                         (qt-retrieve qt (obj-x ownship) (obj-y ownship) 500.0)))
 
   (define-values (predict-secs fit-per-sec)

quadtree.rkt

@@ -12,6 +12,15 @@
 ; o is object
 ; r is radius
 
+(define (qt-hit? a b)
+  (define d (+ (qtobj-r a) (qtobj-r b)))
+  ((qt-distance2 a b) . < . (* d d)))
+
+(define (qt-distance2 a b)
+  (define dx (- (qtobj-x a) (qtobj-x b)))
+  (define dy (- (qtobj-y a) (qtobj-y b)))
+  (+ (* dx dx) (* dy dy)))
+
 (struct quadtree (objs x y w h subtrees) #:mutable #:prefab)
 
 (define (qt-new x y w h)
@@ -74,22 +83,25 @@
     ((and bot? right?) 3)
     (else -1)))
 
-; return list of potentially colliding objects
+; return list of colliding objects
 (define (qt-retrieve qt x y r)
   (define qto (qtobj 'unused (exact->inexact x) (exact->inexact y) (exact->inexact r)))
   (map qtobj-o (qt-retrieve-internal qt qto)))
 
 (define (qt-retrieve-internal qt qto)
   (define idx (get-index qt qto))
+  (define lst (filter (lambda (o)
+                        (qt-hit? qto o))
+                      (quadtree-objs qt)))
   (cond
     ((null? (quadtree-subtrees qt))
-     (quadtree-objs qt))
+     lst)
     ((= idx -1)
-     (apply append (quadtree-objs qt)
+     (apply append lst
             (for/list ((qtst (in-list (quadtree-subtrees qt))))
               (qt-retrieve-internal qtst qto))))
     (else
-     (append (quadtree-objs qt)
+     (append lst
              (qt-retrieve-internal (list-ref (quadtree-subtrees qt) idx) qto)))))
 
 ; call coll! with every pair of objects that might collide
@@ -100,7 +112,8 @@
       ; test a against all other objects at this level, then all the parent objects
       (for* ((lst (cons (cdr objs) parent-obj-list))
              (b lst))
-        (coll! (qtobj-o a) (qtobj-o b)))
+        (when (qt-hit? a b)
+          (coll! (qtobj-o a) (qtobj-o b))))
       (loop (cdr objs))))
 
   (for ((st (quadtree-subtrees qt)))

scenarios/asteroid-search.rkt

@@ -258,8 +258,7 @@
            (for ((a (qt-retrieve qt (obj-x s) (obj-y s) (+ (/ (ship-radar s) 3.0) 50.0)))
                  #:when (and (obj-alive? a)
                              (spaceship? a)
-                             (assoc "Empire" (ship-overlays a))
-                             ((distance s a) . < . (+ (ship-radius a) (/ (ship-radar s) 3.0)))))
+                             (assoc "Empire" (ship-overlays a))))
              ; remove the overlay
              (append! changes (chstat (ob-id a) 'overlay (cons "Empire" #f)))
              (when (not (null? (ship-cargo a)))
@@ -278,8 +277,7 @@
           ((upgrade? s)
            (for ((a (qt-retrieve qt (obj-x s) (obj-y s) (upgrade-radius ownspace s)))
                  #:when (and (obj-alive? a)
-                             (spaceship? a)
-                             (close? s a (+ (ship-radius a) (upgrade-radius ownspace s)))))
+                             (spaceship? a)))
              (append! changes (upgrade-hit-ship ownspace a s))))))
 
       ; check if the good guys docked

scenarios/base-defense.rkt

@@ -49,7 +49,7 @@
                                                    (tool-probe 10.0)
                                                    (tool-missile 5.0 10.0)
                                                    (tool-cannon 21.0)
-                                                   (tool-mine 25.0)
+                                                   (tool-mine 30.0)
                                                    (tool-warp 200.0 80.0)
                                                    (tool-regen 1.0)))))
 
@@ -124,8 +124,7 @@
                         (upgrade? s)))
       (for ((a (qt-retrieve qt (obj-x s) (obj-y s) (upgrade-radius ownspace s)))
             #:when (and (obj-alive? a)
-                        (spaceship? a)
-                        (close? s a (+ (ship-radius a) (upgrade-radius ownspace s)))))
+                        (spaceship? a)))
         (append! changes (upgrade-hit-ship ownspace a s))))
 
     (for ((fo (space-orders real-orders)))

scenarios/racketcon2018.rkt

@@ -84,7 +84,7 @@
                      #:hull 100 #:mass 50 #:drag 0.3
                      #:tools (append (tools-pilot 35.0 #f 1.0)
                                      (list (tool-pbolt 8.0)
-                                           (tool-mine 25.0)
+                                           (tool-mine 30.0)
                                            (tool-warp 250.0 50.0)
                                            (tool-missile 5.0 10.0)
                                            (tool-regen 1.0)))))

scenarios/testing.rkt

@@ -63,19 +63,24 @@
 
   (define f (new-blue-fighter 0 0))
 
-  #;(define nebulas (nebula-polygon (cons -1000 -1000)
-                                  (cons -1000 1000)
-                                  (cons 1000 1000)
-                                  (cons 1000 -1000)))
-
-  ;(define n (nebula (next-id) 0 #t (posvel 0 100.0 100.0 0.0 0.0 0.0 0.02) 500.0))
+  (define nebulas
+    (let ((r (new region%)))
+      (send r set-ellipse -500 -500 500 500)
+      (nebula-region r)))
+
+  (define ss (make-ship "spacesuit"
+             "Spacesuit"
+             "spacesuit"
+             #:x 100 #:y 0
+             #:hull 1 #:drag 0.5 #:mass 1
+             #:radar 150 #:visible 150))
 
   (set-space-objects! ownspace
                       (append 
-                       (list b1 b2 ;f
+                       (list b1 b2 ss
                              (new-red-fighter 300 0)
                              (new-red-fighter 800 200))
-                       ;nebulas
+                       nebulas
                        (space-objects ownspace)))
 
   (define real-orders (space 0 0 0 0 '() '() '()))  ; only care about orders

utils.rkt

@@ -416,7 +416,7 @@
   (+ a (* (- b a) (random))))
 
 
-(define (close? a b d)
+(define (hit? a b d)
   ((distance2 a b) . < . (* d d)))
 
 (define (distance2 a b)
@@ -467,9 +467,8 @@
   (for ((e (in-list (qt-retrieve qt (obj-x ownship) (obj-y ownship) (ship-radar ownship))))
         #:when (and (filterf? e)
                     ((faction-check (ship-faction ownship) (ship-faction e)) . < . 0)))
-    (define d (distance ownship e))
-    (when (and (d . < . (ship-radar ownship))
-               (or (not ne) (d . < . ne-dist)))
+    (define d (distance2 ownship e))
+    (when (or (not ne) (d . < . ne-dist))
       (set! ne e)
       (set! ne-dist d)))
   ne)
@@ -482,8 +481,7 @@
 
   (for ((o (in-list (qt-retrieve qt (obj-x ship) (obj-y ship) (+ (ship-radius ship) max-dist))))
         #:when (and (spaceship? o)
-                    (not (= (ob-id ship) (ob-id o)))
-                    ((distance ship o) . < . (+ (hit-distance ship o) max-dist))))
+                    (not (= (ob-id ship) (ob-id o)))))
 
     (define a (angle-frto (angle-add pi (posvel-r (obj-posvel ship))) (theta ship o)))
     (when ((abs a) . < . max-ang)