#lang racket

(require 2htdp/universe)
(require "../semantics/first-order.rkt")
(require racket/stxparam)
(require (for-syntax "../utilities.rkt"))
(require (for-syntax racket/list))
(require (for-syntax syntax/stx))

;; Simple simulations
(provide animate)

;; Interactions

(provide (rename-out (big-bang-wrapper big-bang)))
;; Order of error-checking:
;;   1. Check to make sure that all clause keywords are valid identifiers
;;      (If this test doesn't pass, the parser is broken).
;;   2. Check for invalid clauses (parser shouldn't generate them,
;;      but we'll be defensive).
;;   3. Check for duplicate clauses.
;;   4. Generate the clauses.

(define-syntax (big-bang-wrapper stx)
  ;; Clause dependency list
  (define CDL
    '((to_draw draw_width draw_height)
      (on_tick tick_rate tick_limit)
      (on_key)
      (on_pad)
      (on_release)
      (on_mouse)
      (stop_when last_scene)
      (check_with)
      (should_record)
      (on_receive)
      (state)
      (name)
      (register)))
      
      
  ;; Main clause keyword list
  (define MCKWL
    '(to_draw on_tick on_key on_pad on_release stop_when check_with should_record state name register on_receive))
  ; valid clause keyword list
  (define VCKWL '(init
                  to_draw draw_width draw_height
                  on_tick tick_rate tick_limit
                  on_key
                  on_pad
                  on_release
                  stop_when last_scene
                  check_with
                  should_record
                  state
                  name
                  register
                  on_receive))
  ;; function to convert from the Pyret clause keywords to the
  ;; racket clause keywords
  (define (convert s)
    (case s
      [(to_draw) 'to-draw]
      [(on_tick) 'on-tick]
      [(stop_when) 'stop-when]
      [(on_key) 'on-key]
      [(on_pad) 'on-pad]
      [(on_release) 'on-release]
      [(stop_when) 'stop-when]
      [(should_record) 'record?]
      [(state) 'state]
      [(name) 'name]
      [(register) 'register]
      [(on_receive) 'on-receive]
      [else (error 'convert "pyret: internal error: invalid input")]))
  ;; check1 :: stx-list -> stx-list
  ;;
  ;; Consumes a list of clauses, checks to make sure that each piece
  ;; of syntax in keyword position is a valid identifier, and if so,
  ;; returns a list of the clause keywords (as syntax), so that
  ;; we can check to make sure there are no duplicates, or invalid
  ;; keywords.
  (define (check1 sl)
    (define (check c)
      (syntax-case c ()
        [(clause-car clause-cdr)
         (identifier? (syntax clause-car))
         c]
        [(clause-car clause-cdr)
         (raise-pyret-error/stx
          "big_bang: first element of a clause must be a keyword"
          (syntax clause-car))]
        [else
         (raise-pyret-error/stx
          "big-bang-wrapper: invalid clause"
          c)]))
    (map check sl))
  ;; check2 :: stx-list -> stx-list
  ;;
  ;; Consumes a list of clauses (which have been run through check1)
  ;; and checks to make sure that there are no invalid clauses. If not,
  ;; it returns the list it was given.
  (define (check2 sl)
    (define (check-kw clause)
      (let ([clause-kw (syntax-e (stx-car clause))])
        (if (member clause-kw VCKWL)
            clause
            (raise-pyret-error/stx
             (format "big_bang: ~a clauses are not allowed when using big_bang"
                     clause-kw)
             (stx-car clause)))))
    (map check-kw sl))
  ;; check3 :: stx-list -> stx-list
  ;;
  ;; No duplicate clauses
  (define (check3 sl)
    (define (filter-proc target-clause)
      (lambda (current-clause)
        (let ([target-kw (syntax-e (stx-car target-clause))]
              [current-kw (syntax-e (stx-car current-clause))])
          (equal? target-kw current-kw))))
    (define (map-proc clause)
      (let ([result (filter (filter-proc clause) sl)])
        (if (> (length result) 1)
            (let ([clause-kw (syntax-e (stx-car clause))]
                  [example-clause (stx-car (stx-cdr result))])
              (raise-pyret-error/stx
                (format "big_bang: found a duplicate ~a clause" clause-kw)
                (stx-car example-clause)))
            clause)))
    (map map-proc sl))
  ;; find-deps :: symbol (listof symbol) stx-list -> (list stx-list stx-list)
  ;;
  ;; Given a keyword, and its dependencies, it attempts to find as
  ;; many dependency expressions as it can. It is up to the caller
  ;; ta make sure the list is either empty, or contains all needed clauses.
  (define (find-deps kw dkws stx)
    (let loop ([left-to-find dkws] [stx stx] [found-clauses empty])
      (cond
        [(empty? left-to-find)
         (list stx found-clauses)]
        [else
         (let ([f (first left-to-find)]
               [r (rest left-to-find)])
           (let ([result (wrip-out stx f)])
             (let ([next-stx (first result)]
                   [found (first (rest result))])
               (if found
                   (loop r next-stx (append found-clauses (list found)))
                   (loop r next-stx found-clauses)))))])))
  ;; make-clauses :: symbol (list stx-list stx-list) -> (list stx-list stx-list)
  ;;
  ;; Requires a symbol, and a list containing the current clause-list we're
  ;; considering, and the clauses that we have made thus far. It uses
  ;; find-deps to get the dependencies. It is meant to be used in the context
  ;; of foldl.
  (define (make-clauses sym vals)
    (define (get-clause-dependencies kw)
      (lambda (l)
        (equal? kw (first l))))
    (define (convert/stx stx-id)
      (datum->syntax #'this
                     (convert (syntax-e stx-id))
                     stx-id))
    (let ([kw-dl (rest (findf (get-clause-dependencies sym) CDL))]
          [clause-list (first vals)]
          [generated-clauses (second vals)])
      (let* ([main-result (wrip-out clause-list sym)]
             [next-cl (first main-result)]
             [found (second main-result)])
        (let* ([deps-result (find-deps sym kw-dl next-cl)]
               [next-cl (first deps-result)]
               [found-deps (second deps-result)]
               [len-found-deps (length found-deps)])
          (cond
            [(equal? found #f)
             ; we didn't find the main keyword we were looking for
             (cond
               [(empty? found-deps)
                ; we didn't find any dependencies either -- good
                ; this means that the entire clause family is not
                ; present in the big-bang, and we can continue
                (list next-cl generated-clauses)]
               [else
                ; YIKES -- we found dependent clauses, but not the
                ; one they depend on!
                (let* ([example (first found-deps)]
                       [found-kw (stx-car example)])
                  (raise-pyret-error/stx
                    (format 
                     (string-append "found a ~a clause, "
                                    "which requires the ~a clause, "
                                    "but no ~a clause was found")
                     (syntax-e found-kw)
                     sym
                     sym)
                    found-kw))])]
            [else
             ; We did find the main keyword we're looking for
             (let ([main-kw-stx (first found)]
                   [main-kw-expr-stx (first (rest found))])
               (cond
                 [(empty? found-deps)
                  ; we did not find any dependencies, which is fine
                  (list next-cl 
                        (append generated-clauses 
                                (list
                                 (list (convert/stx main-kw-stx)
                                       main-kw-expr-stx))))]
                 [(equal? len-found-deps (length kw-dl))
                  ; we found all dependencies, which is also fine
                  (list next-cl
                        (append generated-clauses
                                (list
                                 (cons (convert/stx main-kw-stx)
                                       (cons main-kw-expr-stx
                                             (map (λ (c) (stx-car (stx-cdr c)))
                                                  found-deps))))))]
                 [else
                  (case sym
                    ; of course there has to be one special case I miss
                    [(on_tick)
                     (if (equal? (syntax-e (stx-car (first found-deps))) 'tick_rate)
                         ; good
                         (list next-cl
                               (append generated-clauses
                                       (list
                                        (cons (convert/stx main-kw-stx)
                                              (cons main-kw-expr-stx
                                                    (map (λ (c) (stx-car (stx-cdr c)))
                                                         found-deps))))))
                         (raise-pyret-error/stx
                           "big_bang: found a tick_limit clause, which requires a tick_rate clause"
                           (stx-car (first found-deps))))]
                    [else
                     ; YIKES -- we found some dependencies, but not all
                     (raise-pyret-error/stx
                      (format
                       (string-append
                        "big_bang: when using the ~a clause, either all, "
                        "or none, of the following clauses must be used: "
                        (foldl (λ (sym str) (string-append str " " (symbol->string sym)))
                               ""
                               kw-dl))
                       sym)
                      main-kw-stx)])]))])))))
  ;; wrip-out :: (listof syntax) symbol -> (list stx-list (or/c syntax #f))
  ;;
  ;; Consumes the current clause-list (i.e., a stx-list corresponding
  ;; to the datum '((to_draw draw-expr) ...) ), and a symbol, indicating
  ;; which keyword to look for. It then returns a list, which contains the
  ;; given clause-list (without the matched clause-list), along with the
  ;; matched clause as the second element of the list. If the clause was not
  ;; found, the second element of the list is #f.
  ;;
  ;; Examples (with syntax lists represented as data):
  ;; (wrip-out '((on_tick tick-expr) .... (to_draw draw-expr) (draw_width width-expr) ....) 'to_draw)
  ;; --> (list '((on_tick tick-expr) .... (draw_width width-expr) ....) '(to_draw draw-expr))
  ;; (wrip-out '((on_tick tick-expr)) 'to_draw)
  ;; --> (list '((on_tick tick-expr)) #f)
  (define (wrip-out clause-list target)
    (let loop ([seen '()]
               [togo clause-list])
      (cond
        [(stx-null? togo)
         ;; haven't seen it
         (list seen #f)]
        [else
         (let ([f (stx-car togo)]
               [r (stx-cdr togo)])
           (syntax-case f ()
             [(clause-kw clause-expr)
              (identifier? (syntax clause-kw))
              (cond
                [(equal? target (syntax-e (syntax clause-kw)))
                 ;; found it
                 (list (append seen r) 
                       (list (syntax clause-kw) (syntax clause-expr)))]
                [else
                 ;; recur
                 (loop (append seen (list f)) r)])]
             [else
              (error 'wrip-out
                     "pyret: internal error: wrip-out did not get a valid clause")]))])))
  
  (syntax-case stx ()
    [(bbw [clause-kw clause-expr] ...)
     (let ([clause-list
            ; let's here it for function composition!
            (check3 
             (check2 
              (check1 
               (stx->list 
                (syntax ([clause-kw clause-expr] ...))))))])
       (let* ([init-result (wrip-out clause-list 'init)]
              [next-stx (first init-result)]
              [init (second init-result)])
         (unless init
           (raise-pyret-error/stx
              "big_bang: a big_bang requires an `init` clause"
              stx))
         (let ([init-expr (second init)])
           (let* ([result (foldl make-clauses (list next-stx empty) MCKWL)]
                  [next-stx (first result)]
                  [generated-clauses (second result)])
             (unless (stx-null? next-stx)
               (error 'big-bang-wrapper "pyret: internal error: clauses have been left over"))
             (with-syntax ([clauses generated-clauses]
                           [ie init-expr])
               (syntax/loc stx
                 (make-big-bang ie clauses)))))))]
    [else
     (raise-pyret-error/stx
      "pyret: internal error: the parser has generated an invalid big_bang"
      stx)]))

(define-syntax (make-big-bang stx)
  (syntax-case stx ()
    [(_ init ([clause-kw clause-expr ...] ...))
     (let ([clause-list (syntax->list (syntax ([clause-kw clause-expr ...] ...)))])
       (if (findf (lambda (c) (equal? 'to-draw (first c)))
                  (map syntax->datum clause-list))
           (syntax/loc stx
             (syntax-parameterize ([be-first-order #f])
               (big-bang init [clause-kw clause-expr ...] ...)))
           (raise-pyret-error/stx
              "big_bang: expects a to_draw clause"
              stx)))]))