#lang scheme/gui

(require "animated-canvas.ss")

(define frame (instantiate frame% ("Scheme Boids 2D")))

(define canvas (instantiate animated-canvas% (frame)
                 (style '(border no-autoclear))
                 (min-width 800) (min-height 600)))
(send (send canvas get-dc) set-brush "black" 'solid)
(send (send canvas get-dc) set-pen "black" 0 'solid)

(define-struct boid
  (id
   position-x position-y
   velocity-x velocity-y)
  #:mutable)

(define n-boids 10)
(define boids (build-vector n-boids
                            (lambda (i)
                              (make-boid
                               i
                               (random (send canvas min-width))
                               (random (send canvas min-height))
                               (random 10) 
                               (random 10)))))
(define boid-size 10)

(define (distance-between boid1 boid2)
  (sqrt (+ (expt (- (boid-position-x boid2) (boid-position-x boid1)) 2)
           (expt (- (boid-position-y boid2) (boid-position-y boid1)) 2))))

(define (draw-boids)
  (let ((dc (send canvas get-dc)))
    (send dc clear)
    (do ((i 0 (+ i 1)))
      ((= i n-boids) (void))
      (let ((boid (vector-ref boids i)))
        (send dc draw-ellipse
              (boid-position-x boid) (boid-position-y boid)
              boid-size boid-size)))
    (send canvas swap-bitmaps)))

(define (rule1 boid)
  (let ((x 0)
        (y 0))
    (do ((i 0 (+ i 1)))
      ((= i n-boids) (void))
      (unless (= i (boid-id boid))
        (set! x (+ x (boid-position-x (vector-ref boids i))))
        (set! y (+ y (boid-position-y (vector-ref boids i))))))
    (set! x (/ x (- n-boids 1)))
    (set! y (/ y (- n-boids 1)))
    (values (* (- x (boid-position-x boid)) .01)
            (* (- y (boid-position-y boid)) .01))))

(define (rule2 boid)
  (let ((x 0)
        (y 0)
        (n 0))
    (do ((i 0 (+ i 1)))
      ((= i n-boids) (void))
      (unless (= i (boid-id boid))
        (when (<= (distance-between boid (vector-ref boids i)) 40.0)
          (set! n (+ n 1))
          (set! x (+ x (- (boid-position-x boid)
                          (boid-position-x (vector-ref boids i)))))
          (set! y (+ y (- (boid-position-y boid)
                          (boid-position-y (vector-ref boids i))))))))
    (when (> n 0)
      (set! x (/ x n))
      (set! y (/ y n)))
    (values x y)))

(define (rule3 boid)
  (yield)
  (let ((x 0)
        (y 0))
    (do ((i 0 (+ i 1)))
      ((= i n-boids) (void))
      (unless (= i (boid-id boid))
        (set! x (+ x (boid-velocity-x (vector-ref boids i))))
        (set! y (+ y (boid-velocity-y (vector-ref boids i))))))
    (set! x (/ x (- n-boids 1)))
    (set! y (/ y (- n-boids 1)))
    (values (* (- x (boid-velocity-x boid)) .125)
            (* (- y (boid-velocity-y boid)) .125))))

(define (move-boids)
  (do ((i 0 (+ i 1)))
    ((= i n-boids) (void))
    (let ((boid (vector-ref boids i)))
      (let-values (((v1-x v1-y) (rule1 boid))
                   ((v2-x v2-y) (rule2 boid))
                   ((v3-x v3-y) (rule3 boid)))
        (set-boid-velocity-x! boid (+ (boid-velocity-x boid)
                                      v1-x v2-x v3-x))
        (set-boid-position-x! boid (+ (boid-position-x boid)
                                      (boid-velocity-x boid)))
        (cond ((< (boid-position-x boid) 0)
               (set-boid-velocity-x! boid 4))
              ((>= (boid-position-x boid) (send canvas min-width))
               (set-boid-velocity-x! boid -4)))
        (set-boid-velocity-y! boid (+ (boid-velocity-y boid)
                                      v1-y v2-y v3-y))
        (set-boid-position-y! boid (+ (boid-position-y boid)
                                      (boid-velocity-y boid)))
        (cond ((< (boid-position-y boid) 0)
               (set-boid-velocity-y! boid 4))
              ((>= (boid-position-y boid) (send canvas min-height))
               (set-boid-velocity-y! boid -4)))
        ))))

(define (main)
  (let loop ()
    (let ((t (current-milliseconds)))
      (draw-boids)
      (move-boids)
      (sleep/yield (max 0.0 (/ (- 30.0 (- (current-milliseconds) t)) 1000.0)))
      (loop))))

(send frame show #t)
(main)