;;;
;;; COMPREHENSIONS
;;;

(module comprehensions "mzscheme2.rkt"
  (provide (all-defined))
  
  (require "generators.scm")
  (require-for-syntax "generators.scm")
  (require-for-syntax "expansion.scm")
  (require-for-template "mzscheme2.rkt")
  
  ; This is the model comprehension
  
  #;(define-syntax (list-ec stx)
      (syntax-case stx ()
        [(_ body)
         #'(list body)]
        [(_ clause ... body)
         (begin
           (check-all-clauses-are-generators-or-filters #'(clause ...) 'list-ec)
           (when (and (null? (syntax->list #'(clause (... ...))))
                      (generator-clause? #'body))
             (raise-syntax-error
              'list-ec 
              (string-append "Generator used in body position. "
                             "Expected (list <generator-or-filter> ... <expr>), got: ")
              #'body))
           #`(let ([result '()])
               #,((expand-clauses #'(clause ...))
                  #'(set! result (cons body result)))
               (reverse result)))]
        [_
         (raise-syntax-error
          'name-ec
          "expected (list-ec <generator-or-filter> ... <expr>), got: "
          st)]))
  
  (define-syntax (define-comprehension stx)
    (syntax-case stx ()
      [(_ name-ec inserter body expansion)
       #'(define-syntax (name-ec st)
           (syntax-case st ()
             [(_ clause (... ...) body)
              (begin
                (check-all-clauses-are-generators-or-filters #'(clause (... ...)) 'name-ec)
                (when (and (null? (syntax->list #'(clause (... ...))))
                           (generator-clause? #'body))
                  (raise-syntax-error
                   'name-ec (format 
                             (string-append 
                              "Generator used in body position. "
                              "Expected (~a <generator-or-filter> ... <expr>), got: ")
                             'name-ec)
                   #'body))
                (let ([inserter (expand-clauses #'(clause (... ...)))])
                  expansion))]
             [_
              (raise-syntax-error
               'name-ec
               (format "expected (~a <generator-or-filter> ... <expr>), got: " 'name-ec)
               st)]))]
      [else
       (raise-syntax-error
        'define-comprehension
        "expected (define-comprehension <name> <inserter> <body> <expansion>) "
        stx)]))
  
  
  (define-comprehension list-ec 
    insert-payload-in-loop body
    #`(let ([result '()])
        #,(insert-payload-in-loop 
           #'(set! result (cons body result)))
        (reverse result)))
  
  (define-comprehension do-ec
    insert-payload-in-loop body
    (insert-payload-in-loop 
     #'body))
  
  (define-syntax (define-derived-comprehension stx)
    (syntax-case stx ()
      [(_ name-ec (literal ...) (pattern clauses-to-check template) ...)
       #'(define-syntax (name-ec st)
           (define (raise-error)
             (raise-syntax-error
              'name-ec
              (format "expected (~a <generator-or-filter> ... <expr>), got: " 'name-ec)
              st))
           (syntax-case st ()
             [(name clause (... ...) body)
              (begin
                (syntax-case #'(name clause (... ...) body) (literal ...)
                  [pattern 
                   (begin
                     (check-all-clauses-are-generators-or-filters #'clauses-to-check 'name-ec)
                     #'template)]
                  ...
                  [_else (raise-error)]))]
             [_ (raise-error)]))]
      [else
       (raise-syntax-error
        'define-derived-comprehension
        "expected (define-derived-comprehension name-ec (literal ...) (pattern template) ...), got: "
        stx)]))
  
  (define-derived-comprehension append-ec ()
    ((append-ec  etc ... body)
     (etc ...)
     (apply append (list-ec etc ... body))))
  
  (define-derived-comprehension string-ec ()
    ((string-ec etc ... body)
     (etc ...)
     (list->string (list-ec etc ... body)) ))
  
  (define-derived-comprehension string-append-ec ()
    ((string-append-ec etc ... body)
     (etc ...)
     (apply string-append (list-ec etc ... body)) ))
  
  (define-derived-comprehension vector-ec ()
    ((vector-ec etc ... body)
     (etc ...)
     (list->vector (list-ec etc ... body)) ))
  
  
  (define-derived-comprehension vector-of-length-ec (nested)
    ((vector-of-length-ec k (nested q1 ...) q etc1 etc ... body)
     (q1 ... q etc ... body)
     (vector-of-length-ec k (nested q1 ... q) etc1 etc ... body) )
    ((vector-of-length-ec k q1 q2             etc1 etc ... body)
     (q1 q2 etc1 etc ... body)
     (vector-of-length-ec k (nested q1 q2)    etc1 etc ... body) )
    ((vector-of-length-ec k body)
     ()
     (vector-of-length-ec k (nested) body) )
    ((vector-of-length-ec k qualifier body)
     (qualifier)
     (let ((len k))
       (let ((vec (make-vector len))
             (i 0) )
         (do-ec qualifier
                (if (< i len)
                    (begin (vector-set! vec i body)
                           (set! i (+ i 1)) )
                    (error "vector is too short for the comprehension") ))
         (if (= i len)
             vec
             (error "vector is too long for the comprehension") )))))
  
  
  (define-derived-comprehension fold3-ec (nested)
    ((fold3-ec x0 (nested q1 ...) q etc ... expr f1 f2)
     (q1 ... q)
     (fold3-ec x0 (nested q1 ... q) etc ... expr f1 f2) )
    ((fold3-ec x0 q1 q2 etc ... expr f1 f2)
     (q1 q2 etc ...)
     (fold3-ec x0 (nested q1 q2) etc ... expr f1 f2) )
    ((fold3-ec x0 expression f1 f2)
     ()
     (fold3-ec x0 (nested) expression f1 f2) )
    
    ((fold3-ec x0 qualifier expression f1 f2)
     (qualifier)
     (let ((result #f) (empty #t))
       (do-ec qualifier
              (let ((value expression)) ; don't duplicate
                (if empty
                    (begin (set! result (f1 value))
                           (set! empty #f) )
                    (set! result (f2 value result)) )))
       (if empty x0 result) )))
  
  (define-derived-comprehension fold-ec (nested)
    ((fold-ec x0 (nested q1 ...) q  etc1 etc ... body f2)
     (q q1 ... etc1 etc2 etc ...)
     (fold-ec x0 (nested q1 ... q)  etc1 etc ... body f2) )
    ((fold-ec x0 q1 q2 etc ... body f2)
     (q1 q2 etc ...)
     (fold-ec x0 (nested q1 q2) etc ... body f2) )
    ((fold-ec x0 body f2)
     ()
     (fold-ec x0 (nested) body f2) )
    ((fold-ec x0 qualifier body f2)
     (qualifier)
     (let ((result x0))
       (do-ec qualifier (set! result (f2 body result)))
       result )))
  
  (define-derived-comprehension sum-ec ()
    ((sum-ec etc ... body)
     (etc ...)
     (fold-ec (+) etc ... body +) ))
  
  (define-derived-comprehension product-ec ()
    ((product-ec etc ... body)
     (etc ...)
     (fold-ec (*) etc ... body *) ))
  
  
  (define-syntax (min-ec2 stx)
    (define (check clauses body)
      (check-all-clauses-are-generators-or-filters clauses 'min-ec)
      (when (and (null? (syntax->list clauses))
                 (generator-clause? body))
        (raise-syntax-error
         'min-ec (string-append 
                  "Generator used in body position. "
                  "Expected (min-ec <generator-or-filter> ... <expr>), got: ")
         body)))
      
    (syntax-case stx (on-new-min)
      [(_ clause ... (on-new-min on-min-expr ...) body)
       (begin
         (check #'(clause ...) #'body)
         (let ([insert-body (expand-clauses #'(clause ...))])
           #`(let ([minimum +inf.0])
               #,(insert-body 
                  #'(let ([x body])
                      (when (< x minimum)
                        (set! minimum x)
                        on-min-expr ...
                        x)))
               minimum)))]
      [(_ clause ... body)
       (syntax/loc stx (min-ec clause ... (on-new-min (void)) body))]
      [_
       (raise-syntax-error
        'min-ec
        (format "expected (~a <generator-or-filter> ... <expr>), got: " 'name-ec)
        stx)]))
  
  #;(define-derived-comprehension min-ec ()
      ((min-ec etc ... body)
       (etc ...)
       (fold3-ec (min) etc ... body min min)))
  
  (define-derived-comprehension min-ec (on-new-min)
    ((min-ec etc ... (on-new-min on-expr ...) body)
     (etc ...)
     (fold3-ec (min) etc ... body min (lambda (new old)
                                        (if (< new old)
                                            (begin
                                              on-expr ...
                                              new)
                                            old))))
    ((min-ec etc ... body)
     (etc ...)
     (fold3-ec (min) etc ... body min min)))
  
  (define-syntax (max-ec stx)
    (define (check clauses body)
      (check-all-clauses-are-generators-or-filters clauses 'max-ec)
      (when (and (null? (syntax->list clauses))
                 (generator-clause? body))
        (raise-syntax-error
         'max-ec (string-append 
                  "Generator used in body position. "
                  "Expected (min-ec <generator-or-filter> ... <expr>), got: ")
         body)))
      
    (syntax-case stx (on-new-max)
      [(_ clause ... (on-new-max on-max-expr ...) body)
       (begin
         (check #'(clause ...) #'body)
         (let ([insert-body (expand-clauses #'(clause ...))])
           #`(let ([maximum -inf.0])
               #,(insert-body 
                  #'(let ([x body])
                      (when (> x maximum)
                        (set! maximum x)
                        on-max-expr ...
                        x)))
               maximum)))]
      [(_ clause ... body)
       (syntax/loc stx (max-ec clause ... (on-new-max (void)) body))]
      [_
       (raise-syntax-error
        'max-ec
        (format "expected (~a <generator-or-filter> ... <expr>), got: " 'name-ec)
        stx)]))
  
  
  #;(define-derived-comprehension max-ec ()
    ((max-ec etc ... body)
     (etc ...)
     (fold3-ec (max) etc ... body max max) ))
  
  (define-derived-comprehension last-ec (nested)
    ((last-ec default (nested q1 ...) q etc ... body)
     (q1 ... q etc ...)
     (last-ec default (nested q1 ... q) etc ... body) )
    ((last-ec default q1 q2             etc ... body)
     (q1 q2 etc ...)
     (last-ec default (nested q1 q2)    etc ... body) )
    ((last-ec default body)
     ()
     (last-ec default (nested) body) )
    
    ((last-ec default qualifier body)
     (qualifier)
     (let ((result default))
       (do-ec qualifier (set! result body))
       result )))
  
  
  (define-derived-comprehension first-ec (nested)
    ((first-ec default (nested q1 ...) q etc ... body)
     (q1 ... q etc ...)
     (first-ec default (nested q1 ... q) etc ... body) )
    ((first-ec default q1 q2             etc ... body)
     (q1 q2 etc ...)
     (first-ec default (nested q1 q2)    etc ... body) )
    ((first-ec default body)
     ()
     (first-ec default (nested) body) )
    
    ((first-ec default qualifier body)
     (qualifier)
     (let ((result default) (stop #f))
       (ec-guarded-do-ec 
        stop 
        (nested qualifier)
        (begin (set! result body)
               (set! stop #t) ))
       result )))
  
  ; (ec-guarded-do-ec stop (nested q ...) cmd)
  ;   constructs (do-ec q ... cmd) where the generators gen in q ... are
  ;   replaced by (:until gen stop).
  
  (require (prefix mz: mzscheme))
  
  (define-derived-comprehension ec-guarded-do-ec (nested if mz:if not and or begin)
    ((ec-guarded-do-ec stop (nested (nested q1 ...) q2 ...) cmd)
     (q1 ... q2 ...)
     (ec-guarded-do-ec stop (nested q1 ... q2 ...) cmd) )
    
    ((ec-guarded-do-ec stop (nested (if test) q ...) cmd)
     (q ...)
     (when test (ec-guarded-do-ec stop (nested q ...) cmd)) )
    
    ((ec-guarded-do-ec stop (nested (mz:if test) q ...) cmd)
     (q ...)
     (when test (ec-guarded-do-ec stop (nested q ...) cmd)) )
    
    ((ec-guarded-do-ec stop (nested (not test) q ...) cmd)
     (q ...)
     (when (not test) (ec-guarded-do-ec stop (nested q ...) cmd)) )
    
    ((ec-guarded-do-ec stop (nested (and test ...) q ...) cmd)
     (q ...)
     (when (and test ...) (ec-guarded-do-ec stop (nested q ...) cmd)) )
    
    ((ec-guarded-do-ec stop (nested (or test ...) q ...) cmd)
     (q ...)
     (when (or test ...) (ec-guarded-do-ec stop (nested q ...) cmd)) )
    
    ((ec-guarded-do-ec stop (nested (begin etc ...) q ...) cmd)
     (q ...)
     (begin etc ... (ec-guarded-do-ec stop (nested q ...) cmd)) )
    
    ((ec-guarded-do-ec stop (nested gen q ...) cmd)
     (q ...)
     (do-ec 
      (:until gen stop) 
      (ec-guarded-do-ec stop (nested q ...) cmd) ))
    
    ((ec-guarded-do-ec stop (nested) cmd)
     ()
     (do-ec cmd) ))
  
  ; ==========================================================================
  ; The early-stopping comprehensions any?-ec every?-ec
  ; ==========================================================================
  
  (define-derived-comprehension any?-ec (nested)
    ((any?-ec (nested q1 ...) q etc ... body)
     (q etc ...)
     (any?-ec (nested q1 ... q) etc ... body) )
    ((any?-ec q1 q2             etc ... body)
     (q1 q2 etc ...)
     (any?-ec (nested q1 q2)    etc ... body) )
    ((any?-ec expression)
     ()
     (any?-ec (nested) expression) )
    
    ((any?-ec qualifier expression)
     (qualifier)
     (first-ec #f qualifier (if expression) #t) ))
  
  
  (define-derived-comprehension every?-ec (nested)
    ((every?-ec (nested q1 ...) q etc ... body)
     (q1 ... q etc ...)
     (every?-ec (nested q1 ... q) etc ... body) )
    ((every?-ec q1 q2             etc ... body)
     (q1 q2 etc ...)
     (every?-ec (nested q1 q2)    etc ... body) )
    ((every?-ec expression)
     ()
     (every?-ec (nested) expression) )
    
    ((every?-ec qualifier expression)
     (qualifier)
     (first-ec #t qualifier (if (not expression)) #f) ))
  
  )
