(module apf mzscheme

  (require (lib "etc.ss")
           (lib "list.ss")
  (provide traverse
           id TP idA
           union-id union-TP union-idA union-TU
           everywhere one-step

  ;; Subtypes is (listof (list Symbol:sub Symbol:super))
  (define SUBTYPES '((cons list)
                     (empty list)
                     (true boolean);ean)
                     (false boolean);ean)
                     (cons.first any-field)
                     (cons.rest any-field)))
  (define (add-subtypes! types)
    (set! SUBTYPES (append types SUBTYPES)))
  ;; PARSABLES is a list of rules for the parsing grammar
  (define PARSABLES '())
  (define (add-parsable! rule)
    (set! PARSABLES (cons rule PARSABLES)))

  ;; CONCRETES is a (listof (list Symbol (listof Symbol)))
  ;; It is a list of (DataType, FieldNames) pairs
  (define CONCRETES '((cons (first rest))))
  (define (add-concrete! lst)
    (set! CONCRETES (cons lst CONCRETES)))
  ;; get-fields: Symbol -> (listof Symbol)
  ;; Get the list of field names for the given type
  (define (get-fields type)
    (letrec ((get* (lambda (lst)
                     (cond [(null? lst) lst]
                           [(symbol=? (caar lst) type) (cadar lst)]
                           [else (get* (cdr lst))]))))
      (get* CONCRETES)))
  ;; parse: Symbol InputPort -> Any
  ;; Parse a data-structure given the start symbol from an input port
  (define (parse sym port)
    (gen-parse PARSABLES sym port))

  ;; parse-string: Symbol String -> Any
  ;; Parse a data-structure given the start symbol from a String
  (define (parse-string sym str)
    (parse sym (open-input-string str)))

  ;; creator: Symbol -> Symbol
  ;; Returns the structure creator symbol for the given type/symbol
  (define (creator sym)
     (string-append "make-" (symbol->string sym))))
  ;; type-pred: Symbol -> Symbol
  ;; Returns the predicate symbol for a given type/symbol
  (define (type-pred sym)
     (string-append (symbol->string sym) "?")))
  ;; field-names: (listof [String | (list Symbol Symbol)] -> (lsitof Symbol)
  ;; Grab just the field name symbols from a list of syntax and field defs
  (define (field-names lst)
    (map car (filter (lambda (e) (not (string? e))) lst)))
  ;; parsables: (listof [String | (list Symbol Symbol)] -> (lsitof [String|Symbol])
  ;; Grab just the field name symbols from a list of syntax and field defs
  (define (parsables lst)
    (map (lambda (e) (if (string? e) e
                         (cadr e))) lst))
  ;; concrete: Symbol (listof (list Symbol Symbol)) -> Unit
  ;; Defines a concrete Product Type (using a structure def)
  (define-syntax concrete
    (syntax-rules ()
      ((concrete name lst) (define-prod 'name 'lst))))
  ;; The real function...
  (define (define-prod name lst)
    (let ((fields (field-names lst)))
      ;;(display name)(newline)
      (eval `(define-struct ,name ,fields ,(make-inspector)))
      ;; When we define the Constructor, we could also check each
      ;;   of the fields for "type" consistency...
      (eval `(define ,(cons name fields)
               ,(cons (creator name) fields)))
      (define-fields name fields)
      (add-parsable! (make-prod-rule name (parsables lst)))
      (add-keywords! (filter string? lst))
      (add-concrete! (list name fields))))
  ;; define-fields: Symbol (listof Symbol) -> Unit
  ;; Define types to encode each field during traversal for Augmentor functions
  (define (define-fields type fields)
     (create-sub-relate 'any-field
                        (map (lambda (fn)
                               (let ((ftn (field-type-name type fn)))
                                 (eval `(define-struct ,ftn () ,(make-inspector)))
  ;; field-type-name: Symbol Symbol -> Symbol
  ;; Computes the encoded name of the type that represents the field of
  ;;   the given type... essentially just: "type.fieldname"
  (define (field-type-name type field)
    (string->symbol (string-append (symbol->string type) "."
                                   (symbol->string field))))
  ;; create-pred: Symbol -> Function
  ;; Create a function which calles the given type's predicate, used
  ;;   in the creation of a sum-type's predicate function
  (define (create-pred sym)
    (lambda (s) (list (type-pred s) sym)))
  ;; create-sub-relate: Symbol (listof Symbol) -> (listof (list Symbol Symbol))
  ;; Creates a list of (subtype supertype) pairs for the non-reflexive, 
  ;;   anti-symetric 'subtype' relation (just 'lessthan')
  (define (create-sub-relate name subs)
    (if (null? subs) '()
        (cons (list (car subs) name)
              (create-sub-relate name (cdr subs)))))
  ;; abstract: Symbol (listof Symbol) -> Unit
  ;; Defines an abstract Sum Type (flat inheritence)
  (define-syntax abstract
    (syntax-rules ()
      ((abstract name lst) (define-sum 'name 'lst))))
  ;; The real function...
  (define (define-sum name lst)
    (eval `(define (,(type-pred name) t)
             ,(cons 'or (map (create-pred 't) lst))))
    (add-subtypes! (create-sub-relate name lst))
    (add-parsable! (make-sum-rule name lst)))
  ;; info: Struct-Instance -> (values Symbol Number (Struct Number -> Any))
  ;; Grabs the relevant fields of the struct-type-info of the given structure,
  ;;   which are: type-name, num-fields, and accessor-function
  (define (info str)
    (let*-values (((si d) (struct-info str))
                  ((name fields d1 acc d2 d3 d4 d5) (struct-type-info si)))
      (values name fields acc)))
  ;; type-symbol: Any -> Symbol
  (define (type-symbol f)
    (cond [(symbol? f) 'symbol]
          [(number? f) 'number]
          [(string? f) 'string]
          [(char? f) 'char]
          [(boolean? f) (if f 'true 'false)]
          [(empty? f) 'empty]
          [(cons? f) 'cons]
          [(struct? f)
           (let-values (((n f acc) (info f))) n)]
          [else 'any]))
  ;; type-symbols: (listof Any) -> (listof Symbol)
  ;; Reflect on the list and return the corresponding types (as symbols)
  (define (type-symbols fl)
    (map type-symbol fl))
  ;; trav-fields: Struct (Stuct -> Any) Number Number -> (listof Any)
  ;; Traverse each of the fields using the accessor function, creating
  ;;   a list of the return values
  (define (trav-fields tsym str flds acc i max B A C targ)
    ;(display (string-append " Traverse: " (symbol->string tsym) " # " (number->string i)))
    (if (= i max)
        (if (apf-none? targ) '() (list (apf-some-arg targ)))
        (cons (let ((fld (acc str i))
                    (uparg (update-arg (field-type-name tsym (car flds)) str targ A)))
                (if (C str i)
                    (do-traverse fld B A C uparg)
              (trav-fields tsym str (cdr flds) acc (+ i 1) max B A C targ))))

  (define (update-arg f-type str targ A)
    (if (apf-none? targ) targ
        (let* ((ft-inst (eval (list (creator f-type))))
               (oarg (apf-some-arg targ))
               (narg (delta A (list str ft-inst oarg) -1)))
          (make-apf-some narg))))
  ;; Some/None for Optional Arguments
  (define-struct apf-none ())
  (define-struct apf-some (arg))
  ;; A ControlFunc is a function of the type:
  ;;     Symbol Number -> Boolean
  ;; It returns whether the given field should be traversed
  ;; make-bypass: (listof (list Symbol Symbol)) -> ControlFunc
  (define-syntax make-bypass
    (syntax-rules ()
      ((make-bypass edges ...) (make-bypass-f '(edges ...)))))
  ;; The real function...
  (define (make-bypass-f loedge)
    (let ((loenum (map find-field-num loedge)))
      (lambda (str num)
        (not (check-field-num loenum (type-symbol str) num)))))
  ;; find-field-num: (list Symbol Symbol) -> (list Symbol Number)
  ;; Replace the field name in the edge with its number in the structure
  (define (find-field-num edge)
    (let* ((par (first edge))
           (name (second edge))
           (entries (lookup CONCRETES (lambda (t) (symbol=? t par)) car cadr)))
      (if (empty? entries) 
          (begin (error 'find-field-num "Type Not Found: ~s" par))
          (let ((idx (index-of (lambda (s) (symbol=? s name))
                               (first entries))))
            (if (< idx 0) (error 'find-field-num "Field Not Found: ~s" name)
                (list par idx))))))
  ;; check-field-num: (listof (list Symbol Number)) Symbol Number -> Boolean
  ;; Find the Symbol/Number pair in the given List
  (define (check-field-num loedge sym num)
    (if (empty? loedge) false
        (or (and (symbol=? (caar loedge) sym)
                 (= (cadar loedge) num))
            (check-field-num (cdr loedge) sym num))))
  ;; everywhere: Symbol Number -> Boolean
  ;; Sends the Traversal through every field
  (define (everywhere type fnum) true)
  ;; one-step: Symbol Number -> Boolean
  ;; Returns false, which sets up the "one-step" traversal
  (define (one-step type fnum) false)

  ;; traverse : Any (listof Function) ... -> Any
  ;; Main entry point for traversal.  Chooses the most obvious traversal
  ;;   function based on the number of arguments (see below for the cases)
  (define (traverse str B . others)
    (let ([len (length others)])
      (cond [(= len 0) (traverse-b str B)]
            [(= len 1) (traverse-bc str B (car others))]
            [(= len 2) (traverse-ba str B (car others) (cadr others))]
            [(= len 3) (traverse-bac str B (car others) (cadr others) (caddr others))]
            [else (error 'traverse "Wrong Number of Arguments, must be 2,3,4, or 5")])))
  ;; Traverse with just a Builder
  (define (traverse-b str B)
    (do-traverse str B idA everywhere (make-apf-none)))
  ;; Traverse with just a Builder and Argument modifier
  (define (traverse-ba str B A arg)
    (do-traverse str B A everywhere (make-apf-some arg)))
  ;; Traverse with just a Builder + Control
  (define (traverse-bc str B C)
    (do-traverse str B idA C (make-apf-none)))
  ;; Traverse with a Builder and Argument modifier + Control
  (define (traverse-bac str B A C arg)
    (do-traverse str B A C (make-apf-some arg)))
  ;; cons-accessor: Cons Number -> Any
  (define (cons-accessor c i)
    (cond [(= i 0) (first c)]
          [(= i 1) (rest c)]
          [else (error 'cons-accessor "Cons only has two Fields!!")]))
  (define-struct any-field ())
  (define (make-cons x y) (cons x y))
  (define-struct cons.first () (make-inspector))
  (define-struct cons.rest () (make-inspector))
  (define (make-empty) empty)
  (define (any? x) #t)
  ;; do-traverse: Any (listof Function) (listof Function) ControlFunc
  ;;                  (apf-none or apf-some) -> Any
  ;; Run the APF Traversal on a Struct or Atomic data, applying the
  ;;   Builder/Augmentos function sets during traversal with wrapped traversal argument
  (define (do-traverse str B A C targ)
    (let ((argl (if (apf-none? targ) '() (list (apf-some-arg targ)))))
      (if (or (struct? str) (cons? str) (null? str))
          (let-values (((nm f acc) (cond [(struct? str) (info str)]
                                         [(cons? str) (values 'cons 2 cons-accessor)]
                                         [(null? str) (values 'empty 0 empty)])))
            (let ((flds (trav-fields nm str (get-fields nm) acc 0 f B A C targ)))
              (delta B (cons str flds) -1)))
          (delta B (cons str argl) 0))))
  ;; A Function is:  (list (list Symbol) func/lambda)
  ;; func-arity: Function -> Number
  ;; Get the number of arguments this Function should take
  (define (func-arity f) (length (func-types f)))
  ;; func-func: Function -> (listof Symbol)
  ;; Get the types this Function accepts
  (define (func-types f) (car f))
  ;; func-func: Function -> func/lambda
  ;; Get the scheme function corresponding to this Function
  (define (func-func f) (cadr f))
  ;; delta: (listof Function) (listof Any) -> Any
  ;; Apply the 'best' Function to the arguments
  (define (delta lof lobj deflt)
    (let* ((types (type-symbols lobj))
           (filt (func-filter lof types (length lobj))))
      (if (null? filt)
          (if (< deflt 0)
              (begin (display "No Applicable FUNCTION Found for:")(newline)
                     (display types)(newline)(newline)
                     ;(map write lobj)(newline)(newline)
                     (display "In funcset:")(newline)
                     (map (lambda (f) (display "   ")(display f)(newline)) lof)
                     (error 'delta "BAD"))
              (list-ref lobj deflt))
          (let ((sorted (func-sort filt)))
            (func-apply (car sorted) lobj)))))
  ;; func-apply: Function (listof Any) -> Any
  ;; Apply the given Function to a subsequence of the given argument list
  (define (func-apply func lobj)
    (apply (func-func func) 
           (trim-list lobj (func-arity func))))
  ;; func-filter: (listof Function) (listof Symbols) Number -> (listof Function)
  ;; Filter the Functions to only those that are applicable to the given
  ;;   types (represented as Symbols)
  (define (func-filter lof lots len)
    (filter (lambda (fun)
              (and (<= (func-arity fun) len)
                   (applicable? lots (func-types fun))))
  ;; applicable: (lsitof Symbol) (listof Symbol) -> Boolean
  ;; Return whether the formal argument types are applicable to the
  ;;   actual argument types (represented as Symbols)
  (define (applicable? aats fats)
    (or (null? fats)
        (let ((aa (car aats))
              (fa (car fats)))
          (and (or (type=? aa fa)
                   (subtype? aa fa))
               (applicable? (cdr aats) (cdr fats))))))
  ;; subtype?: Symbol Symbol -: Boolean
  ;; Is the first type (rep. by a Symbol) a subtype of the second
  (define (subtype? s1 s2)
    (and (not (type=? s1 s2))
         (or (type=? s2 'any)
             (let ((supt (lookup SUBTYPES (lambda (s) (symbol=? s1 s)) car cadr)))
               (if (null? supt) #f
                   (or (ormap (lambda (sym) (symbol=? sym s2)) supt)
                       (ormap (lambda (sym) (subtype? sym s2)) supt)))))))
  ;; func-sort: (listof Function) -> (listof Function)
  ;; Sort a list of Functions by 'specificity'
  (define (func-sort lof) (sort lof func-less?))
  ;; more-specific?: (listof Symbol) (listof Symbol) Number -> Boolean
  (define (more-specific? ft1 ft2 n1 n2)
    (cond [(and (= n1 0) (= n2 0)) false]
          [(= n2 0) true]
          [(= n1 0) false]
          [else (or (subtype? (car ft1) (car ft2))
                    (and (type=? (car ft1) (car ft2))
                         (more-specific? (cdr ft1) (cdr ft2) (- n1 1) (- n2 1))))]))

  ;; func-less?: Function Function -> Boolean
  ;; Is Function 1 (really, the types it accepts) more specific than Function 2
  (define (func-less? f1 f2)
    (let ((n1 (func-arity f1))
          (n2 (func-arity f2)))
      (more-specific? (func-types f1) (func-types f2) n1 n2)))
  ;; type=? : symbol symbol -> Boolean
  ;; Compare two type symbols for equality
  (define type=? symbol=?)
  ;; symbol-for: Symbol String -> Symbol
  ;; Create a symbol by appending a string to a given one...
  (define (symbol-for sym str)
    (string->symbol (string-append (symbol->string sym) str)))
  ;; def-list... Helper for annoying lists
  (define-syntax def-list
    (syntax-rules ()
      ((def-list prefix type term) (define-list 'prefix 'type term))))
  ;; The real function...
  (define (define-list prefix type term)
      (symbol-for prefix "-list")
      (list (symbol-for prefix "-empty")
            (symbol-for prefix "-cons")))
    (define-prod (symbol-for prefix "-empty") (list term))
      (symbol-for prefix "-cons")
      `((first ,type)
        (rest ,(symbol-for prefix "-list")))))
  ;; Syntax for function set definitions...
  ;; (funcset ((type-1 type-2 ...) (formal-1 formal-2 ...) Expression)
  ;;               ( ... another ... ) ...)
  (define-syntax funcset
    (syntax-rules ()
      ((funcset) '())
      ((funcset ((types ...) (ids ...) expr) rest ...)
       (if (not (= (length '(types ...))
                   (length '(ids ...))))
           (error "The number of types and arguments don't match")
           (cons `((types ...) ,(lambda (ids ...) expr)) (funcset rest ...))))
      ((funcset (() () expr) rest ...)
       (cons `(() ,(lambda () expr)) (funcset rest ...)))
      ;((funcset ((types ...) (ids ...) expr))
      ; (list `((types ...) ,(lambda (ids ...) expr))))
      ;((funcset (() () expr))
      ; (list `(() ,(lambda () expr))))
  ;; idA implementation
  (define idA (funcset ((any any-field any) (o f a) a)))
  (define-syntax union-idA
    (syntax-rules () ((union-idA funcs ...) (union-func (funcset funcs ...) idA))))

  ;; id implementation
  (define id (funcset ((symbol)  (o) o)
                       ((number)  (o) o)
                       ((string)  (o) o)
                       ((char)    (o) o)
                       ((boolean) (o) o)))
  (define-syntax union-id
    (syntax-rules () ((union-idA funcs ...) (union-func (funcset funcs ...) id))))
  ;; Default Constructor... calls the constructor for the first argument
  ;;   on the other arguments (as many as are needed)
  (define (construct . lst)
    (let ((p (car lst)))
      (if (or (struct? p) (cons? p) (null? p))
          (let-values (((n f a) (cond [(struct? p) (info p)]
                                      [(cons? p) (values 'cons 2 0)]
                                      [(null? p) (values 'empty 0 0)])))
            (let* ((args (trim-list (cdr lst) f))
                   (wrap (map (lambda (s) (if (symbol? s) '(quote s) s))
              (apply (eval (creator n)) args)))
          ;; Else

  ;; Generate one "function" with 'i' arguments
  (define (func-Bc type i)
    (list (repeat-list type i)

  ;; Create a fold function using the given functions...
  (define (make-fold f d)
    (lambda (old . lst)
      (if (null? lst) d
          (let ((r (reverse lst)))
            (foldr f (car r) (cdr r))))))
  ;; Generate one TU "function" with 'i' arguments
  (define (func-TU type fun def i)
    (list (cons 'any (repeat-list type i))
          (make-fold fun def)))
  ;; Make TU functions for the given type, using the function 
  ;;   to fold two results, and 'def' as the default value for
  ;;   invocations that are not matched.
  (define (build-a-TU type fun def)
    (letrec ((build (lambda (i)
                      (if (> i 10) '()
                          (cons (func-TU type fun def i)
                                (build (+ i 1)))))))
      (build 0)))

  (define-syntax build-TU
    (syntax-rules () ((union-TU type fun def)
                      (build-a-TU 'type fun def))))

  (define-syntax union-TU
    (syntax-rules () ((union-TU type fun def funcs ...)
                      (union-func (funcset funcs ...) (build-a-TU 'type fun def)))))
  ;; Extends the second function 'object' with the first
  (define (union-func F1 F2)
    (append F1 F2))
  ;; Default Builder... reconstructs the structure(s)
  (define TP 
    (letrec ((build-Bc (lambda (type i max)
                         (if (> i max) '()
                             (cons (func-Bc type i)
                                   (build-Bc type (+ i 1) max))))))
      (union-func (build-Bc 'any 1 10) id)))
  (define-syntax union-TP
    (syntax-rules () ((union-TP funcs ...) (union-func (funcset funcs ...) TP))))
  ;; **** End of Module...