;;;; -*- mode: scheme -*- ;;;;

(load-option 'format)

;;;; COMMONLISP IMITATORS

(define (first l) (car l))	; Enable a more mnemonic function

(define (second l) (cadr l))	; Enable a more mnemonic function

(define (third l) (caddr l))	; Enable a more mnemonic function

(define (rest l) (cdr l))	; Enable a more mnemonic function

;;;; SEMANTIC TRANSITION TREE TRANSLATOR

(define (define-tree tree)
  (eval `(lambda (word-list) ,(translate-tree tree))
	(the-environment)))

(define (translate-tree tree)
  "
  Purpose:	Translate grammar specification into an executable expression
  Remarks:	Contains a COND clause for every grammar element
		See the grammar data file for sample use
  "
  (cond ((null? tree) '(list #t word-list))
        ((eq? 'branch (first tree))
	 (translate-branches (cdr tree)))
        ((list? (first tree))
	 (translate-subtree-call (first tree) (cdr tree)))
        ((eq? 'rtn (first tree))
	 (if (null? (cdr tree))
	     `(list #t word-list)
	     `(list (begin ,@(cdr tree)) word-list)))
        ((eq? 'if-end-rtn (first tree))
	 (if (null? (cdr tree))
	     `(if (null? word-list)
		  (list #t '())
		  #f)
	     `(if (null? word-list)
		  (list (begin ,@(cdr tree)) '())
		  #f)))
        (else `(if (null? word-list)
		   #f
		   (let ((current-word (first word-list))
			 (word-list (cdr word-list)))
		     (if (eq? current-word ',(first tree))
			 ,(translate-tree (cdr tree))
			 #f))))))

(define (translate-branches branches)
  "
  Purpose:	Translate grammar branch specification
		into an executable OR expression
  "
  `(or ,@(map translate-tree branches)))

(define (translate-subtree-call call-description rest-of-tree)
  "
  Purpose:	Translate grammar subtree-call specification
		into an executable function calll expression
  "
  (cond ;; Handle function call without assigning result:
        ((null? (cdr call-description))
	 ;; Rest of tree embedded in LET:
	 `(let ((result (,(first call-description) word-list)))
	    (if result
                ;; WORD-LIST rebound to words remaining after call
		(let ((word-list (second result)))
		  ,(translate-tree rest-of-tree))
		#f)))
        ;; Handle function call with result assigned to variable:
	((and (eq? '--> (second call-description))
	      (list? (cddr call-description)))
	 ;; Rest of tree embedded in LET:
	 `(let ((result (,(first call-description) word-list)))
	    (if result
 		;; Result assigns LET variable;
                ;; WORD-LIST rebound to words remaining after call;		
		(let ((,(third call-description) (first result))
		      (word-list (second result)))
		  ,(translate-tree rest-of-tree))
		#f)))
	;; Grammar form not known:
	(else (error "Unrecognized subtree syntax" call-description))))

;;;; TOP-LEVEL INTERFACE

;(define (run)
;  "
;  Purpose:	Applies function representing top level tree to
;		a list read by READ-SENTENCE
;  Remark:	Input sentences is to be in the form of sentence terminated
;		by a "carriage return"
;  Caution:	This version works in some versions of MIT Scheme, 
;		but does not work in Scheme-to-C
;  "
;  (define (loop)
;    (format #t "~%~%> ")
;    (let ((result (main (read-sentence))))
;      (if (not (and (list? result) (eq? 'quit (first result))))
;	  (loop))))
;  (format #t "~%~%Welcome! Please type a question with a \"carriage return\"")
;  (loop))
;
;(define (read-sentence)
;  (define (read-words)
;    "
;    Purpose:	Converts string into a list of words
;    "
;    (let ((word (read)))
;      (if (eof-object? word)
;	  '()
;	  (cons word (read-words)))))
;  (let* ((terminators (char-set #\newline #\linefeed))
;	 (sentence (read-string terminators)))
;    (read-char)
;    (set! sentence (string-trim-right sentence char-set:alphanumeric))
;    (with-input-from-string sentence read-words)))


;;;; ALTERNATE TOP-LEVEL INTERFACE

(define (run)
  "
  Purpose:	Applies function representing top level tree to
		a list read by READ
  Remark:	Input sentences is to be in the form of a list of words
  "
  (define (loop)
    (format #t "~%~%> ")
    (let ((result (main (read))))
      (if (not (and (list? result) (eq? 'quit (first result))))
	  (loop))))
  (format #t "~%~%Welcome! Please type a parenthesized question.")
  (loop))