compile.ss
#lang scheme
(require (prefix-in ml: "ml.ss")
         (prefix-in dl: "dl.ss"))

(define top-label "top")

(define E->E
  (match-lambda
    [(struct ml:Expression (v))
     (dl:make-Expression v)]))

(define-syntax-rule (define-compile id ml:s1 dl:make-s1)
  (define id
    (match-lambda
      [#f #f]
      [(struct ml:s1 (type degs))
       (dl:make-s1 type (E->E degs))])))

(define-compile ml:direction->dl:direction ml:direction dl:make-direction)
(define-compile ml:speed->dl:speed ml:speed dl:make-speed)
(define-compile ml:horizontal->dl:horizontal ml:horizontal dl:make-horizontal)
(define-compile ml:vertical->dl:vertical ml:vertical dl:make-vertical)

(define (dl:make-seqn* as)
  (define fas (filter (lambda (x) x) as))
  (match fas
    [(list) #f]
    [(list a) a]
    [as
     (dl:make-seqn as)]))

(define (dl:make-stalled-params* p i)
  (if i
      (dl:make-stalled-params p i)
      #f))

(define (dl:make-repeat* t a)
  (if a
      (dl:make-repeat t a)
      #f))

(define (compile-bulletml bml)
  (define ml:bullets (make-hash))
  (define ml:actions (make-hash))
  (define ml:fires (make-hash))
  
  (define dl:bullets (make-hash))
  (define dl:actions (make-hash))
  (define dl:fires (make-hash))
  
  (define (lookup-action l)
    (hash-ref! dl:actions l
               (lambda ()
                 (ml:action->dl:action (hash-ref ml:actions l)))))
  (define (lookup-fire l)
    (hash-ref! dl:fires l
               (lambda ()
                 (ml:fire->dl:fire (hash-ref ml:fires l)))))
  (define (lookup-bullet l)
    (hash-ref! dl:bullets l
               (lambda ()
                 (ml:bullet->dl:bullet (hash-ref ml:bullets l)))))
  
  (define ml:fire->dl:fire
    (match-lambda
      [(struct ml:fire (_ dir speed bullet))
       (dl:make-fire (ml:direction->dl:direction dir)
                     (ml:speed->dl:speed speed)
                     (ml:bullet-or-ref->dl:bullet bullet))]))
  (define ml:bullet->dl:bullet
    (match-lambda
      [(struct ml:bullet (_ dir speed acts))
       (dl:make-bullet (ml:direction->dl:direction dir)
                       (ml:speed->dl:speed speed)
                       (vector)
                       (dl:make-seqn*
                        (map ml:action->dl:action acts)))]))
  (define ml:bullet-or-ref->dl:bullet
    (match-lambda
      [(? ml:bullet? b)
       (ml:bullet->dl:bullet b)]
      [(struct ml:bulletRef (label ml:params))
       (define dl:params 
         (list->vector (map (compose E->E ml:param-value) ml:params)))
       (define dl:bul
         (lookup-bullet label))
       
       (struct-copy dl:bullet dl:bul
                    [params dl:params])]))
  (define ml:action->dl:action
    (match-lambda
      [(struct ml:repeat (times a))
       (dl:make-repeat* (E->E (ml:times-how-long times))
                        (ml:action->dl:action a))]
      [(? ml:fire? f)
       (ml:fire->dl:fire f)]
      [(struct ml:fireRef (label params))
       (dl:make-stalled-params
        (list->vector (map (compose E->E ml:param-value) params))
        (lookup-fire label))]
      [(struct ml:changeSpeed (speed term))
       (dl:make-changeSpeed (ml:speed->dl:speed speed)
                            (E->E (ml:term-how-many term)))]
      [(struct ml:changeDirection (dir term))
       (dl:make-changeDirection (ml:direction->dl:direction dir)
                                (E->E (ml:term-how-many term)))]
      [(struct ml:accel (hor vert term))
       (dl:make-accel (ml:horizontal->dl:horizontal hor)
                      (ml:vertical->dl:vertical vert)
                      (E->E (ml:term-how-many term)))]
      [(struct ml:wait (frames))
       (dl:make-wait (E->E frames))]
      [(struct ml:vanish ())
       (dl:make-vanish)]
      [(struct ml:action (_ sa))
       (dl:make-seqn* (map ml:action->dl:action sa))]
      [(struct ml:actionRef (label params))
       (dl:make-stalled-params*
        (list->vector (map (compose E->E ml:param-value) params))
        (lookup-action label))]))
  
  (define type (ml:bulletml-type bml))
  
  (for ([e (in-list (ml:bulletml-contents bml))])
    (match e
      [(? ml:bullet?)
       (hash-set! ml:bullets (ml:bullet-label e) e)]
      [(? ml:action?)
       (hash-set! ml:actions (ml:action-label e) e)]
      [(? ml:fire?)
       (hash-set! ml:fires (ml:fire-label e) e)]))
  
  (dl:make-bulletdl (case type
                      [(none) 'vertical]
                      [else type])
                    (lookup-action top-label)))

(provide/contract
 [compile-bulletml (ml:bulletml? . -> . dl:bulletdl?)])