(use-modules (chickadee)
             (chickadee data quadtree)
             (chickadee math)
             (chickadee math matrix)
             (chickadee math rect)
             (chickadee math vector)
             (chickadee graphics color)
             (chickadee graphics font)
             (chickadee graphics path)
             (chickadee graphics sprite)
             (chickadee graphics texture)
             (chickadee scripting)
             (ice-9 format)
             (ice-9 match)
             (srfi srfi-1)
             (srfi srfi-9)
             (statprof))

(define-record-type <actor>
  (make-actor position velocity bounding-box)
  actor?
  (position actor-position)
  (velocity actor-velocity)
  (bounding-box actor-bounding-box))

(define texture #f)
(define batch #f)
(define start-time 0.0)
(define avg-frame-time 16)
(define actor-count 250)
(define actors
  (list-tabulate actor-count
                 (lambda (n)
                   (let ((x (* (random:uniform) 624.0))
                         (y (* (random:uniform) 464.0)))
                     (make-actor (vec2 x y)
                                 (vec2 (* (- (random:uniform) 0.5) 3.0)
                                       (* (- (random:uniform) 0.5) 3.0))
                                 (rect x y 16.0 16.0))))))
(define quadtree (make-quadtree (make-rect 0.0 0.0 640.0 480.0) #:max-size 4 #:max-depth 4))
(define canvas (make-empty-canvas))
(define paused? #f)
(define matrix (make-identity-matrix4))
(define stats-text-pos (vec2 4.0 464.0))
(define stats-text #f)

(for-each (lambda (actor)
            (quadtree-insert! quadtree (actor-bounding-box actor) actor))
          actors)

(define (quadtree-nodes quadtree)
  (if (quadtree-leaf? quadtree)
      (list quadtree)
      (cons quadtree
            (append (quadtree-nodes (quadtree-q1 quadtree))
                    (quadtree-nodes (quadtree-q2 quadtree))
                    (quadtree-nodes (quadtree-q3 quadtree))
                    (quadtree-nodes (quadtree-q4 quadtree))))))

(define (paint-canvas)
  (let ((painter (with-style ((stroke-color tango-scarlet-red))
                   (apply superimpose
                          (map (lambda (node)
                                 (let ((rect (quadtree-bounds node)))
                                   (stroke
                                    (rectangle (vec2 (rect-x rect)
                                                     (rect-y rect))
                                               (rect-width rect)
                                               (rect-height rect)))))
                               (quadtree-nodes quadtree))))))
    (set-canvas-painter! canvas painter)))

(define (stats-message)
  (format #f "  actors: ~d  fps: ~1,2f"
          actor-count (/ 1.0 avg-frame-time)))

(define (load)
  (set! *random-state* (random-state-from-platform))
  (set! texture (load-image "images/shot.png"))
  (set! batch (make-sprite-batch texture #:capacity actor-count))
  (paint-canvas)
  (script
   (forever
    (set! stats-text (stats-message))
    (sleep 60))))

(define (draw alpha)
  (sprite-batch-clear! batch)
  (for-each (lambda (actor)
              (sprite-batch-add* batch (actor-bounding-box actor) matrix))
            actors)
  (draw-canvas canvas)
  (draw-sprite-batch batch)
  (draw-text stats-text stats-text-pos #:color black)
  (let ((current-time (elapsed-time)))
    (set! avg-frame-time
          (+ (* (- current-time start-time) 0.1)
             (* avg-frame-time 0.9)))
    (set! start-time current-time)))

(define (clamp-x x)
  (clamp 0.0 624.0 x))

(define (clamp-y y)
  (clamp 0.0 464.0 y))

(define (update dt)
  (update-agenda 1)
  (unless paused?
    ;; Move
    (for-each (lambda (actor)
                (let ((p (actor-position actor))
                      (v (actor-velocity actor))
                      (r (actor-bounding-box actor)))
                  (quadtree-delete! quadtree r actor)
                  ;; Move by velocity, clamping to the edge of the
                  ;; window.
                  (set-vec2-x! p (clamp-x (+ (vec2-x p) (vec2-x v))))
                  (set-vec2-y! p (clamp-y (+ (vec2-y p) (vec2-y v))))
                  (set-rect-x! r (vec2-x p))
                  (set-rect-y! r (vec2-y p))
                  ;; Check for and resolve collision.
                  (quadtree-find
                   quadtree r
                   (lambda (other)
                     ;; Calculate overlap.
                     (let* ((ro (actor-bounding-box other))
                            (xo (max (- (min (rect-right r) (rect-right ro))
                                        (max (rect-left r) (rect-left ro)))
                                     0.0))
                            (yo (max (- (min (rect-top r) (rect-top ro))
                                        (max (rect-bottom r) (rect-bottom ro)))
                                     0.0)))
                       (if (or (= xo 0.0) (= yo 0.0))
                           #f          ; no collision
                           (let ((vo (actor-velocity other)))
                             ;; Resolve the collsion with the least
                             ;; possible movement.  Bounce the
                             ;; colliding actors off of each other by
                             ;; reversing the x or y component of the
                             ;; velocity vectors.
                             (if (< xo yo)
                                 (let* ((xdiff (- (rect-x r) (rect-x ro)))
                                        (xsign (/ xdiff (abs xdiff))))
                                   (set-vec2-x! p (clamp-x (+ (vec2-x p) (* xo xsign))))
                                   (set-vec2-x! v (* (vec2-x v) -1.0))
                                   (set-vec2-x! vo (* (vec2-x vo) -1.0)))
                                 (let* ((ydiff (- (rect-y r) (rect-y ro)))
                                        (ysign (/ ydiff (abs ydiff))))
                                   (set-vec2-y! p (clamp-y (+ (vec2-y p) (* yo ysign))))
                                   (set-vec2-y! v (* (vec2-y v) -1.0))
                                   (set-vec2-y! vo (* (vec2-y vo) -1.0))))
                             (set-rect-x! r (vec2-x p))
                             (set-rect-y! r (vec2-y p))
                             #t)))))
                  ;; Bounce off the window edges.
                  (when (or (= (vec2-x p) 0.0)
                            (= (vec2-x p) 624.0))
                    (set-vec2-x! v (* (vec2-x v) -1.0)))
                  (when (or (= (vec2-y p) 0.0)
                            (= (vec2-y p) 464.0))
                    (set-vec2-y! v (* (vec2-y v) -1.0)))
                  (quadtree-insert! quadtree r actor)))
              actors)
    (paint-canvas)))

(define (key-press key modifiers repeat?)
  (case key
    ((q)
     (abort-game))
    ((space)
     (set! paused? (not paused?)))))

(run-game #:window-title "quadtree"
          #:load load
          #:draw draw
          #:update update
          #:key-press key-press)