#lang scheme
(require 2htdp/universe
         "posn.ss"
         "structs.ss")

;; My implementation is subtly different because I conflate action objs and bullet objs

(define-struct body (posn velocity 
                          speed-change speed-change-frames
                          dir-change dir-change-frames
                          accel accel-frames
                          previous-fire params action) #:mutable)

(define top-label "top")
(define height 600)
(define width 800)
(define tick-rate 4/60)

(define (on-screen? p)
  (define cp (posn->cartesian-posn p))
  (and (< 0 (cartesian-posn-x cp) width)
       (< 0 (cartesian-posn-y cp) height)))

(define current-rank (make-parameter 1))
(define current-params (make-parameter (vector)))

(define-struct simulation (frames bullets))

(define Expression->value
  (match-lambda
    [(struct Expression (value-f))
     (value-f (current-rank) (current-params))]))
(define (value->Expression v)
  (make-Expression (lambda (rank params) v)))

(define (Expression-fun f e)
  (value->Expression (f (Expression->value e))))
(define (Expression-zero? e)
  (zero? (Expression->value e)))

(define term-fun
  (match-lambda*
    [(list f (struct term (how-long-e)))
     (make-term (Expression-fun f how-long-e))]))
(define times-fun
  (match-lambda*
    [(list f (struct times (how-long-e)))
     (make-times (Expression-fun f how-long-e))]))
(define times-zero?
  (match-lambda
    [(struct times (how-long-e))
     (Expression-zero? how-long-e)]))

(define-struct saved-params (pvector inner))
(define (load-params params)
  (apply vector 
         (map (match-lambda
                [(struct param (expr))
                 (Expression->value expr)])
              params)))

(define (posn-speed p)
  (polar-posn-r (posn->polar-posn p)))
(define (body-speed b)
  (posn-speed (body-velocity b)))
(define (body-previous-fire-speed b)
  (posn-speed (body-previous-fire b)))

(define (posn-direction p)
  (polar-posn-theta (posn->polar-posn p)))
(define (body-direction b)
  (posn-direction (body-velocity b)))
(define (body-previous-fire-direction b)
  (posn-direction (body-previous-fire b)))

(define (speed->value rel seq s)
  (match s
    [(struct speed (type expr))
     (define v (Expression->value expr))
     (case type
       [(absolute)
        v]
       [(relative)
        (+ v rel)]
       [(sequence)
        (+ v seq)])]))
(define (direction->value aim rel seq d)
  (match d
    [(struct direction (type expr))
     (define v (degrees->radians (Expression->value expr)))
     (case type
       [(aim)
        (+ v aim)]
       [(absolute)
        v]
       [(relative)
        (+ v rel)]
       [(sequence)
        (+ v seq)])]))

(define (aim-at p1 p2)
  (define cp1 (posn->cartesian-posn p1))
  (define cp2 (posn->cartesian-posn p2))
  (define dx
    (- (cartesian-posn-x cp1)
       (cartesian-posn-x cp2)))
  (define dy
    (- (cartesian-posn-y cp1)
       (cartesian-posn-y cp2)))
  (atan dy dx))

(define (place-at-posn i p s)
  (define cp (posn->cartesian-posn p))
  (place-image i
               (cartesian-posn-x cp)
               (cartesian-posn-y cp)
               s))

(define (simulate bml)
  (define bullets (make-hash))
  (define actions (make-hash))
  (define fires (make-hash))
  
  (define bullet-or-ref->bullet
    (match-lambda
      [(? bullet? b) 
       (values b (current-params))]
      [(struct bulletRef (label params))
       (values (hash-ref bullets label)
               (load-params params))]))
  
  (define target-posn 
    (make-cartesian-posn 
     (/ width 2)
     (/ height 2)))
  
  (define bs empty)
  (define (act! a b)
    (match a
      [(struct repeat (times inner))
       (define new-times (times-fun (compose round sub1) times))
       (if (times-zero? new-times)
           inner
           (make-action (new-label 'repeat)
                        (list inner
                              (make-repeat new-times inner))))]
      [(struct fire (label direction speed bullet-or-ref))
       (define-values (bullet params) (bullet-or-ref->bullet bullet-or-ref))
       (define prv-speed (body-previous-fire-speed b))
       (define aim-rad (aim-at target-posn (body-posn b)))
       (define the-speed
         (if speed
             (speed->value prv-speed prv-speed speed)
             (if (bullet-speed bullet)
                 (speed->value prv-speed prv-speed (bullet-speed bullet))
                 1)))
       (define the-dir
         (if direction
             (direction->value aim-rad (body-direction b) (body-previous-fire-direction b) direction)
             (if (bullet-direction bullet)
                 (direction->value aim-rad (body-direction b) (body-previous-fire-direction b) (bullet-direction bullet))
                 aim-rad)))
       (define new-velocity
         (make-polar-posn the-speed the-dir))
       (set-body-previous-fire! b new-velocity)
       (set! bs
             (list*
              (make-body (body-posn b) new-velocity 
                         0 0
                         0 0
                         (make-cartesian-posn 0 0) 0
                         (make-polar-posn 0 0)
                         params
                         (make-action (new-label 'bullet) (bullet-actions bullet)))
              bs))
       #f]
      [(struct fireRef (label params))
       (act! (make-saved-params (load-params params) 
                                (hash-ref fires label)) b)]
      
      [(struct changeSpeed (speed term))
       (define term-v (round (Expression->value (term-how-many term))))
       (define speed-v (speed->value (body-speed b) 0 speed))
       (define change-in-speed
         (/ (- speed-v (body-speed b))
            term-v))
       
       (set-body-speed-change! b change-in-speed)
       (set-body-speed-change-frames! b term-v)
       #f]
      [(struct changeDirection (direction term))
       (define term-v (round (Expression->value (term-how-many term))))
       (define aim-rad (aim-at target-posn (body-posn b)))
       (define direction-v (direction->value aim-rad (body-direction b) 0 direction))
       (define change-in-direction
         (if (eq? 'sequence (direction-type direction))
             direction-v
             (/ (- direction-v (body-direction b))
                term-v)))
                   
       (set-body-dir-change! b change-in-direction)
       (set-body-dir-change-frames! b term-v)
       #f]
      [(struct accel (hor vert term))
       (define term-v (round (Expression->value (term-how-many term))))
       (define dx
         (if hor
             (local [(define dx-v (Expression->value (horizontal-units hor)))]
               (case (horizontal-type hor)
                 [(absolute)
                  (/ (- dx-v (cartesian-posn-x (body-accel b)))
                     term-v)]
                 [(relative)
                  (/ dx-v term-v)]
                 [(sequence)
                  dx-v]))
             0))
       (define dy
         (if vert
             (local [(define dy-v (Expression->value (vertical-units vert)))]
               (case (vertical-type vert)
                 [(absolute)
                  (/ (- dy-v (cartesian-posn-y (body-accel b)))
                     term-v)]
                 [(relative)
                  (/ dy-v term-v)]
                 [(sequence)
                  dy-v]))
             0))

       (set-body-accel! b (make-cartesian-posn dx dy))
       (set-body-accel-frames! b term-v)
       #f]
      [(struct wait (frames))
       (define new-frames (Expression-fun (compose round sub1) frames))
       (if (Expression-zero? new-frames)
           #f
           (make-wait new-frames))]
      [(struct vanish ())
       (set! bs (remq b bs))
       #f]
      [(struct action (label steps))
       (if (empty? steps)
           #f
           (local [(define new-step (act! (first steps) b))]
             (if new-step
                 (make-action label (list* new-step (rest steps)))
                 (if (empty? (rest steps))
                     #f
                     (make-action label (rest steps))))))]
      [(struct actionRef (label params))
       (act! (make-saved-params (load-params params) 
                                (hash-ref actions label)) b)]
      [(struct saved-params (params inner))
       (define new-inner
         (parameterize ([current-params params])
           (act! inner b)))
       (if new-inner
           (make-saved-params params new-inner)
           #f)]
      [#f
       #f]))
  (define (body-move! b)
    (define new-action 
      (parameterize ([current-params (body-params b)])
        (act! (body-action b) b)))
    (unless (zero? (body-speed-change-frames b))
      (set-body-speed-change-frames! b (sub1 (body-speed-change-frames b)))
      (set-body-velocity! b (posn+ (body-velocity b) (make-polar-posn (body-speed-change b) 0))))
    (unless (zero? (body-dir-change-frames b))
      (set-body-dir-change-frames! b (sub1 (body-dir-change-frames b)))
      (set-body-velocity! b (posn+ (body-velocity b) (make-polar-posn 0 (body-dir-change b)))))
    (unless (zero? (body-accel-frames b))
      (set-body-accel-frames! b (sub1 (body-accel-frames b)))
      (set-body-velocity! b (posn+ (body-velocity b) (body-accel b))))
    (set-body-posn! b (posn+ (body-posn b) (body-velocity b)))
    (set-body-action! b new-action))
  
  (define (stop-bullets? frame) 
    (and (> frame 10) (= 1 (length bs)))
    (empty? bs))
  (define (draw-bullets frame)
    #;(printf "~n")
    (for/fold ([s (place-at-posn (circle 3 'outline "red")
                                 target-posn
                                 (place-image (text (format "Bullets: ~a" (length bs))
                                                    12 "black")
                                              0 0
                                              (empty-scene width height)))])
      ([b (in-list bs)])
      (place-at-posn (circle 2 'solid "black")
                     (body-posn b)
                     s)))
  (define (tick-bullets frame)
    (define next-frame (add1 frame))
    (for ([b (in-list bs)])
      (body-move! b))
    (set! bs
          (filter (lambda (b)
                    (on-screen? (body-posn b)))
                  bs))
    next-frame)
  (define (move-target frame x y me)
    (set! target-posn (make-cartesian-posn x y))
    frame)
  
  (define top-posn 
    (case (bulletml-type bml)
      [(vertical)
       (make-cartesian-posn (/ width 2) 10)]
      [(horizontal)
       (make-cartesian-posn (- width 10) (/ height 2))]
      [else
       (make-cartesian-posn (/ width 2) 10)]))
  
  (for ([e (in-list (bulletml-contents bml))])
    (match e
      [(? bullet?)
       (hash-set! bullets (bullet-label e) e)]
      [(? action?)
       (hash-set! actions (action-label e) e)]
      [(? fire?)
       (hash-set! fires (fire-label e) e)]))
  
  (set! bs (list* (make-body top-posn (make-polar-posn 0 0)
                             0 0 
                             0 0
                             (make-cartesian-posn 0 0) 0
                             (make-polar-posn 0 0) (vector)
                             (hash-ref actions top-label))
                  bs))
  
  (big-bang
   0
   (on-tick tick-bullets
            tick-rate)
   (on-draw draw-bullets)
   (on-mouse move-target)
   (stop-when stop-bullets?)))

(provide/contract
 [current-rank (parameter/c (real-in 0 1))]
 [simulate (bulletml? . -> . void)])