;;; -*- 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			; update *rules*
   (convert-vars			; map ?x to (? x)
    (cond				; three kinds of rules
     ((eq? (first rule) ':grule) (make-grammar-rule rule))
     ((eq? (first rule) ':wrule) (make-word-rule rule))
     (else rule)			; vanilla rule type
     ))))

;;; Converts (:wrule the (Det ?any))
;;; into (the if then (Det ?any (Det the) (the . ?s) ?s)
(define (make-word-rule rule)
  (let* ((word (second rule))
	 (etc (third rule))
	 (cat (first etc)))
    `(,(make-word-rule-name word cat)
      if then ,(append etc `((,cat ,word) (,word . ?s) ?s)))))

(define (make-word-rule-name word cat)
 (symbol-append (list word cat)))

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

;;; Construct a rule name by concatenating categories.
(define (make-grammar-rule-name lhs rhs)
  (symbol-append
   (append (map (lambda (x)
		  (cond ((eq? (first x) ':word) (second x))
			(else (first x))))
		lhs)
	   '(->)
	   (list (first (first rhs))))))

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

;; Construct a variable symbol (see above).
(define (make-var-symbol root . other)
  (if (null? other)
      (string->symbol (sprintf #f "?%a" root))
      (string->symbol (sprintf #f "?%a%a" root (first other)))))

;; Turn the var symbols ?x into Schemish (? x).
(define (convert-vars rule)
  (cond ((null? rule) '())
	((symbol? rule)
	 (let* ((str (symbol->string rule))
		(str-l (string-length str)))
	   (if (eq? #\? (string-ref str 0))
	       (list '? (string->symbol (substring str 1 str-l)))
	       rule)))
	((pair? rule)
	 (cons (convert-vars (first rule))
	       (convert-vars (rest rule))))))

;;; Append a list of symbols, used to construct rule name.
(define (symbol-append symbols)
  (cond ((null? (rest symbols)) (first symbols))
	(else
	 (string->symbol
	  (sprintf #f "%a.%a" 
		  (first symbols) (symbol-append (rest symbols)))))))