;
; Preprocessor for Forest Rewriter
; Chris Pressey, sometime late January 2006
;

; Copyright (c)2008 Cat's Eye Technologies.  All rights reserved.
;
; Redistribution and use in source and binary forms, with or without
; modification, are permitted provided that the following conditions
; are met:
;
; 1. Redistributions of source code must retain the above copyright
;    notices, this list of conditions and the following disclaimer.
; 2. Redistributions in binary form must reproduce the above copyright
;    notices, this list of conditions, and the following disclaimer in
;    the documentation and/or other materials provided with the
;    distribution.
; 3. Neither the names of the copyright holders nor the names of their
;    contributors may be used to endorse or promote products derived
;    from this software without specific prior written permission. 
;
; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
; ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES INCLUDING, BUT NOT
; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
; FOR A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE
; COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
; BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
; LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
; ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
; POSSIBILITY OF SUCH DAMAGE.

;
; The goal here is to allow the compound-rules to be specified in a nicer,
; more flexible syntax, and preprocess them so that they are in a form that
; this engine can handle (eventually they should be compiled to super-efficient
; sequential code that "knows" which rewrites are likely immediately after
; other rewrites occur; but, first things first.)
;
; The most important part of this is *sorting* the rules by *specificity*
; so that the most specific rules are applied first.
;
; Ideally this would solve all our problems.  But it might not, so we probably
; want a stable sorting algorithm that preserves the relative order specified
; by the programmer.
;
; Another reason to do this is to do type checking and other static analysis.
; e.g. a variable which appears on some RHS of a compound-rule, must also
; appear on some LHS of that compound-rule.
;

;
; The terms and compound-rules, before preprocessing, look like this:
;
; (
;   (                                            ; list of named terms
;     (ast: ())                                  ; a named terms
;     (stab: ())
;     (out: ())
;   )
;   (                                            ; list of compound-rules
;     ((ast: foo => bar) (stab: bee => hive))    ; a compound-rule
;   )
; )


;
; Let's borrow Aardappel's specificity ordering here: var < num < sym < list
;
(define more-general-pattern-than?
  (lambda (pattern-a pattern-b)
    (cond ((null? pattern-a)
            #t)
          ((null? pattern-b)
            #f)
          ((and (list? pattern-a) (list? pattern-b))
            (or (more-general-pattern-than? (car pattern-a) (car pattern-b))
                (more-general-pattern-than? (cdr pattern-a) (cdr pattern-b))))
          (else
            (< (term-specificity pattern-a) (term-specificity pattern-b))))))

(define term-specificity
  (lambda (term)
    (cond ((pattern-var? term)
            1)
          ((number? term)
            2)
          ((symbol? term)
            3)
          (else                ; list, most likely
            4))))

(define more-general-rule-than?
  (lambda (rule-a rule-b)
    (let* ((pattern-a (vector-ref rule-a 1))
           (pattern-b (vector-ref rule-b 1)))
      (more-general-pattern-than? pattern-a pattern-b))))

(define sort-compound-rule
  (lambda (compound-rule)
    (mergesort compound-rule more-general-rule-than?)))

;
; Returns a list like: ((ast: . 1) (stab: . 2) (out: . 3))
; so that we can access a term's position in the vector given its name
;
(define form-term-map
  (lambda (named-terms-depic n acc)
    (cond ((null? named-terms-depic)
            (reverse acc))
          (else
            (let* ((named-term-depic (car named-terms-depic))
                   (name             (car named-term-depic))
                   (pair             (cons name n))
                   (new-acc          (cons pair acc)))
              (form-term-map (cdr named-terms-depic) (+ n 1) new-acc))))))

(define preprocess-named-terms
  (lambda (named-terms-depic acc)
    (cond ((null? named-terms-depic)
            (list->vector (reverse acc)))
          (else
            (let* ((named-term-depic (car named-terms-depic))
                   (term             (cadr named-term-depic))
                   (new-acc          (cons term acc)))
              (preprocess-named-terms (cdr named-terms-depic) new-acc))))))

;
; ((ast: foo => bar) (stab: bee => hive))
;
(define preprocess-compound-rule
  (lambda (compound-rule-depic term-map acc)
    (cond ((null? compound-rule-depic)
            (reverse acc))
          (else
            (let* ((rule-depic       (car compound-rule-depic))
                   (rule-term-name   (car rule-depic))
                   (rule-term-index  (cdr (assq rule-term-name term-map)))
                   (rule-pattern     (cadr rule-depic))
                   (rule-replacement (cadddr rule-depic))
                   (rule             (vector rule-term-index rule-pattern rule-replacement))
                   (new-acc          (cons rule acc)))
              (preprocess-compound-rule (cdr compound-rule-depic) term-map new-acc))))))

(define preprocess-compound-rules
  (lambda (compound-rules-depic term-map acc)
    (cond ((null? compound-rules-depic)
            (reverse acc))
          (else
            (let* ((compound-rule-depic  (car compound-rules-depic))
                   (compound-rule        (preprocess-compound-rule compound-rule-depic term-map '()))
                   (sorted-compound-rule (sort-compound-rule compound-rule))
                   (new-acc              (cons sorted-compound-rule acc)))
              (preprocess-compound-rules (cdr compound-rules-depic) term-map new-acc))))))

(define preprocess
  (lambda (depic)
    (let* ((named-terms-depic    (car depic))
           (compound-rules-depic (cadr depic))
           (term-map             (form-term-map named-terms-depic 0 '()))
           (term-vector          (preprocess-named-terms named-terms-depic '()))
           (compound-rules       (preprocess-compound-rules compound-rules-depic term-map '())))
      (vector term-vector compound-rules))))