;;; $Id: atomic-tree.scm,v 1.9 2005/02/18 02:39:10 leavens Exp $
;;; Trees of atomic items, using the grammar:
;;;    <(tree-of  T)> ::= ( {<(atomic-expression-of T)>}* )
;;;    <(atomic-expression-of T)> ::= <T> | <(tree-of  T)>
;;; where the T's are required to be atomic and not null.
;;; This is equivalent to:
;;;    <(tree-of T)> ::= () 
;;;                |  ( <T> . <(tree-of T)> )
;;;                |  ( <(tree-of T)> . <(tree-of T)> )
;;; See the file atomic-expression.scm for atomic-expressions.
;;; See the file atomic-exp.scm for a grammar that doesn't use a tree ADT.

(module atomic-tree (lib "typedscm.ss" "lib342")

(provide tree-of tree tree-empty tree-add tree-add-atom tree-add-tree
	 tree-null? tree-first-atomic? tree-first-tree?
	 tree-first tree-first-atom tree-first-tree tree-rest parse-tree
	 ;; all-from atomic-expression.scm
	 atomic-expression-of atom->atomic-expression tree->atomic-expression
	 atomic-expression-atom? atomic-expression-tree?
	 atomic-expression->atom atomic-expression->tree
	 parse-atomic-expression atomic?)

(deftype tree-of
  (forall (T) (-> ((type-predicate-for T)) (type-predicate-for (tree-of T)))))
(deftype tree
  (forall (T) (-> ((atomic-expression-of T)...) (tree-of T))))
(deftype tree-empty
  (forall (T) (-> () (tree-of T))))
(deftype tree-add
  (forall (T) (-> ((atomic-expression-of T) (tree-of T)) (tree-of T))))
(deftype tree-add-atom
  (forall (T) (-> (T (tree-of T)) (tree-of T))))
(deftype tree-add-tree
  (forall (T) (-> ((tree-of T) (tree-of T)) (tree-of T))))
(deftype tree-null?
  (forall (T) (-> ((tree-of T)) boolean)))
(deftype tree-first-atomic?
  (forall (T) (-> ((tree-of T)) boolean)))
(deftype tree-first-tree?
  (forall (T) (-> ((tree-of T)) boolean)))
(deftype tree-first
  (forall (T) (-> ((tree-of T)) (atomic-expression-of T))))
(deftype tree-first-atom
  (forall (T) (-> ((tree-of T)) T)))
(deftype tree-first-tree
  (forall (T) (-> ((tree-of T)) (tree-of T))))
(deftype tree-rest
  (forall (T) (-> ((tree-of T)) (tree-of T))))
(deftype parse-tree (-> (datum) (tree-of datum)))

(require (lib "atomic-expression.scm" "lib342"))

(defrep (forall (T) (tree-of T) (list-of (atomic-expression-of T))))

(define tree-of
  (forall (T?)
    (list-of (atomic-expression-of T?))))
		  
(define tree
  (lambda aes
    aes))

(define tree-empty
  (lambda ()
    '()))

(define tree-add
  cons)

(define tree-add-atom
  (lambda (e tr)
    (tree-add (atom->atomic-expression e) tr)))

(define tree-add-tree
  (lambda (e tr)
    (tree-add (tree->atomic-expression e) tr)))

(define tree-null?
  null?)

(define tree-first-atomic?
  (lambda (tr)
    (atomic-expression-atom? (car tr))))

(define tree-first-tree?
  (lambda (tr)
    (atomic-expression-tree? (car tr))))

(define tree-first
  car)

(define tree-first-atom
  (lambda (tr)
    (atomic-expression->atom (tree-first tr))))

(define tree-first-tree
  (lambda (tr)
    (atomic-expression->tree (tree-first tr))))

(define tree-rest
  cdr)

(define parse-tree
  (lambda (d)
    (has-type-trusted
      (tree-of datum)
      (if (list? d)
	  (map parse-atomic-expression d)
	  (error "parse-tree: bad syntax: " d)))))

) ;; end module