;;; -*- mode:Scheme -*- 
;;;; this is grules.scm

;;; Processes the format of the grammar rules into the standard
;;; format for the backchainer.

;;; Top level call to process rules
(define (remember-grammar-rules . rules)
  (for-each remember-grammar-rule rules))

(define (remember-grammar-rule rule)
  (remember-rule (make-grammar-rule rule)))

;;; Converts ((S) -> (NP ?agr) (VP ?agr))
;;; into (np.vp.->.s                          - name
;;;       if (NP ?agr ?np-syn ?s0 ?s1)        - rhs
;;;          (VP ?agr ?vp-syn ?s1 ?s2)
;;;     then (S (s ?np-syn ?vp-syn) ?s0 ?s2)) - lhs
(define (make-grammar-rule rule)
  (let ((lhs (extract-from-rule ':grule (cons ':grule rule)))
	(rhs (extract-from-rule '-> rule)))
    `(,(make-grammar-rule-name rhs lhs)
      ,@(make-grammar-rule-body rhs lhs)
      )))

;;; Construct a rule name by concatenating categories.
(define (make-grammar-rule-name rhs lhs)
  (symbol-append
   (append (map first rhs)
	   '(->)
	   (list (first (first lhs))))))

;;; Adds the entry to build parse tree and the vars to implement the
;;; difference lists for words.
(define (make-grammar-rule-body rhs lhs)
  (let ((n 0)				; keep track of word index
        (rhs-symbols '()))              ; used to build parse tree
    (define (rule-rhs clauses ns)
      (if (> ns n) (set! n ns))
      (cond ((null? clauses) 
	     '())
	    (else
	     (cond ((eq? (first (first clauses)) ':test)
		    (cons (second (first clauses))
			  (rule-rhs (rest clauses) ns)))
		   (else
		    ;; For a typical clause, e.g. (NP ?agr)
		    ;; this generates (NP ?agr ?np-syn ?s_n ?s_n+1)
		    (let* ((cat (first (first clauses)))
			   (new-symbol
			    (let ((s (make-var-symbol
				      cat 
				      (symbol-append (list '-syn ns)))))
			      (set! rhs-symbols (cons s rhs-symbols))
			      s)))
		      (cons
		       (append (first clauses)
			       `(,new-symbol
				 ,(make-var-symbol 's ns)
				 ,(make-var-symbol 's (+ ns 1))))
		       (rule-rhs (rest clauses) (+ ns 1)))))))))
    ;; On the left of a rule, go from (S) 
    ;; to (S <list of x-syn symbols> ?s_0 ?s_n)
    (define (rule-lhs clauses ns)
      (if (> (length clauses) 1)
	  (printf "LHS of rule %a has %a clauses, ignoring all but first."
		  clauses (length clauses)))
      (let ((cat (first (first clauses))))
	 (append (first clauses)
		 `((,cat ,@(reverse rhs-symbols))
		   ,(make-var-symbol 's 0)
		   ,(make-var-symbol 's ns)))))
    ;; the top-level rule body.
    (let* ((rrhs (rule-rhs rhs 0))
	   (rlhs (rule-lhs lhs n)))
    `(if ,@rrhs then ,rlhs))
    ))

;; Construct a variable symbol (see above).
(define (make-var-symbol root . other)
  (if (null? other)
      (string->symbol (string-append "?" (symbol->string root)))
      (string->symbol (string-append "?" 
				     (symbol->string root)
				     (to-string (first other)))
		      )))

;;; Append a list of symbols, used to construct rule name.
(define (symbol-append symbols)
  (define (loop x l)
    (if (null? l) x
	(loop (string-append x "." (car l))
	      (cdr l))))
  (let ((strings (map to-string symbols)))
    (string->symbol (loop (car strings) (cdr strings)))))

(define (to-string x)
  (cond ((string? x) x)
	((number? x) (number->string x))
	((symbol? x) (symbol->string x))
	(else (error "Cannot convert to string:" x))))