(define (relation->constraints path-base name-base)
  (define (r->c expression tms-node name-extension)
    (let* ((name (string-append name-extension name-base))
	   (e->c (expression->constraints path-base name))
	   (r->c (relation->constraints path-base name))
	   (make-connector (connector-maker path-base name))
	   (make-constraint (constraint-maker path-base name))
	   (make-logical-constraint
	    (logical-constraint-maker path-base name))
	   (make-tms-node (tms-node-maker path-base name)))
      (cond ((equality? expression)
	     (if (not tms-node)
		 (if (compound-expression? (lhs expression))
		     (if (compound-expression? (rhs expression))
			 (let ((conn (make-connector "=")))
			   (e->c (lhs expression) conn "lhs:")
			   (e->c (rhs expression) conn "rhs:"))
			 (let ((rhs-conn
				(e->c (rhs expression) #f "rhs:")))
			   (e->c (lhs expression) rhs-conn "lhs:")))
		     (let ((lhs-conn (e->c (lhs expression) #f "lhs:")))
		       (e->c (rhs expression) lhs-conn "rhs:")))
		 (let ((lhs-conn (e->c (lhs expression) #f "lhs:"))
		       (rhs-conn (e->c (rhs expression) #f "rhs:")))
		   (make-constraint "=" equality-constraint
				    (list lhs-conn rhs-conn) tms-node))))
	    ((comparison? expression)
	     (let ((lhs-conn (e->c (lhs expression) #f "lhs:"))
		   (rhs-conn (e->c (rhs expression) #f "rhs:")))
	       (if (not tms-node)
		   (make-constraint (symbol->string (operator expression))
				    (predicate-constraint
				     (safe-predicate (eval (operator expression)
							   generic-environment)))
				    (list lhs-conn rhs-conn))
		   (make-constraint (symbol->string (operator expression))
				    (predicate-constraint
				     (safe-predicate (eval (operator expression)
							   generic-environment)))
				    (list lhs-conn rhs-conn)
				    tms-node))))
	    ((iff? expression)
	     (let ((tms-node (or tms-node (make-tms-node "iff:"))))
	       (r->c (lhs expression) tms-node "lhs:")
	       (r->c (rhs expression) tms-node "rhs:")
	       (eq-put! path-base name tms-node)))
	    ((and? expression)
	     (let ((tms-res (or tms-node (make-tms-node "and-result:")))
		   (tms-a1 (make-tms-node "and-a1:"))
		   (tms-a2 (make-tms-node "and-a2:")))
	       (make-logical-constraint "and:" and-constraint
				(list tms-res tms-a1 tms-a2))
	       (r->c (lhs expression) tms-a1 "lhs:")
	       (r->c (rhs expression) tms-a2 "rhs:")
	       (eq-put! path-base (string->symbol name) tms-res)))

	    ((try? expression)
	     (let* ((try-sym (string->symbol name))
		    (try-object (generate-uninterned-symbol "try:")))
	       (eq-put! try-object 'type 'try-object)
	       (eq-put! try-object 'parent path-base)
	       (eq-put! try-object 'name try-sym)
	       (eq-put! path-base try-sym try-object)
	       (let ((to-try
		      (map (lambda (assumption-name subexpr n)
			     (let* ((m (string-append (number->string n) ":"))
				    (tms-node
				     (make-tms-node (string-append "T:" m))))
			       (r->c subexpr tms-node (string-append "R:" m))
			       (eq-put! tms-node 'parent try-object)
			       (eq-put! tms-node 'name assumption-name)
			       (eq-put! try-object assumption-name tms-node)
			       tms-node))
			   (map car (operands expression))
			   (map cadr (operands expression))
			   (iota (length (operands expression))))))
		 (eq-put! try-object 'alternatives to-try)
		 (eq-adjoin! (top-level path-base) 
			     'assumables
			     (list try-sym to-try)))))
	    (else
	     (error "Unknown relation" expression (name-of path-base))))))
  r->c)

(define (expression->constraints path-base name-base)
  (let ((lookup> (>>lookup path-base))
	(lookup: (:>lookup path-base)))
    (define (e->c expression value-connector name-extension)
      (let* ((name (string-append name-extension name-base))
	     (e->c (expression->constraints path-base name))
	     (make-connector (connector-maker path-base name))
	     (make-constraint (constraint-maker path-base name)))
	(cond ((or (number? expression)
		   (symbol? expression)
		   (dimensioned-number? expression))
	       (if value-connector
		   (begin
		     (make-constraint "v:"
				      (constant-constraint
				       (numerical-value expression))
				      (list value-connector))
		     value-connector)
		   (let ((v (make-connector "v:")))
		     (make-constraint "c:"
				      (constant-constraint
				       (numerical-value expression))
				      (list v))
		     v)))
	      ((>>? expression)
	       (if value-connector
		   (begin
		     (make-constraint "="
				      equality-constraint
				      (list value-connector
					    (lookup> expression)))
		     value-connector)
		   (lookup> expression)))
	      ((:>? expression)
	       (if value-connector
		   (begin
		     (make-constraint "="
				      equality-constraint
				      (list value-connector
					    (lookup: expression)))
		     value-connector)
		   (lookup: expression)))

	      ((sum? expression)
	       (let ((arg-conns
		      (map (lambda (rand n)
			     (e->c rand #f
				   (string-append (number->string n) ":")))
			   (operands expression)
			   (iota (length (operands expression)))))
		     (value-conn
		      (or value-connector (make-connector "v:"))))
		 (make-constraint "+"
				  n-ary-adder-constraint
				  (cons value-conn arg-conns))
		 value-conn))
	      ((difference? expression)
	       (let ((arg-conns
		      (map (lambda (rand n)
			     (e->c rand #f
				   (string-append (number->string n) ":")))
			   (operands expression)
			   (iota (length (operands expression)))))
		     (value-conn
		      (or value-connector (make-connector "v:"))))
		 (if (> (length (operands expression)) 1)
		     (make-constraint "-"
				      n-ary-adder-constraint
				      (cons (car arg-conns)
					    (cons value-conn (cdr arg-conns))))
		     (make-constraint "-"
				      negate-constraint
				      (cons value-conn arg-conns)))
		 value-conn))
	      ((product? expression)
	       (let ((arg-conns
		      (map (lambda (rand n)
			     (e->c rand #f
				   (string-append (number->string n) ":")))
			   (operands expression)
			   (iota (length (operands expression)))))
		     (value-conn
		      (or value-connector (make-connector "v:"))))
		 (make-constraint "*"
				  n-ary-multiplier-constraint
				  (cons value-conn arg-conns))
		 value-conn))
	      ((quotient? expression)
	       (let ((arg-conns
		      (map (lambda (rand n)
			     (e->c rand #f
				   (string-append (number->string n) ":")))
			   (operands expression)
			   (iota (length (operands expression)))))
		     (value-conn
		      (or value-connector (make-connector "v:"))))
		 (make-constraint "/"
				  n-ary-multiplier-constraint
				  (cons (car arg-conns)
					(cons value-conn (cdr arg-conns))))
		 value-conn))

	      ((exp? expression)
	       (let ((arg-conn (e->c (car (operands expression)) #f "0:"))
		     (value-conn
		      (or value-connector (make-connector "v:"))))
		 (make-constraint "exp:"
				  exp-constraint
				  (list value-conn arg-conn))
		 value-conn))
	      ((log? expression)
	       (let ((arg-conn (e->c (car (operands expression)) #f "0:"))
		     (value-conn
		      (or value-connector (make-connector "v:"))))
		 (make-constraint "exp:"
				  exp-constraint
				  (list arg-conn value-conn))
		 value-conn))
	      ((square? expression)
	       (let ((arg-conn (e->c (car (operands expression)) #f "0:"))
		     (value-conn
		      (or value-connector (make-connector "v:"))))
		 (make-constraint "square:"
				  square-constraint
				  (list value-conn arg-conn))
		 value-conn))
	      ((sqrt? expression)
	       (let ((arg-conn (e->c (car (operands expression)) #f "0:"))
		     (value-conn
		      (or value-connector (make-connector "v:"))))
		 (make-constraint "square:"
				  square-constraint
				  (list arg-conn value-conn))
		 value-conn))
	      ((derivative? expression)
	       (let ((arg-conn (e->c (car (operands expression)) #f "0:"))
		     (value-conn
		      (or value-connector (make-connector "v:"))))
		 (make-constraint "derivative:"
				  derivative-constraint
				  (list value-conn arg-conn))
		 value-conn))
	      ((integral? expression)
	       (let ((arg-conn (e->c (car (operands expression)) #f "0:"))
		     (value-conn
		      (or value-connector (make-connector "v:"))))
		 (make-constraint "integral:"
				  integral-constraint
				  (list arg-conn value-conn))
		 value-conn))
	      (else (error "Unknown expression type" expression))
	      )))
    e->c))

(define (connector-maker path-base name-base)
  (let ((cn (constraint-network path-base)))
    (define (make-connector name)
      (let ((fullname (string->symbol (string-append name name-base))))
	;;(write-line `(connector ,fullname))
	(let ((me (create-connector cn fullname)))
	  (eq-rem! cn fullname)
	  (eq-put! me 'name fullname)
	  (eq-put! me 'parent path-base)
	  (eq-put! me 'print-name name)
	  (eq-put! path-base fullname me)
	  me)))
    make-connector))

(define (constraint-maker path-base name-base)
  (let ((cn (constraint-network path-base)))
    (define (make-constraint name type participants #!optional tms-node)
      (let ((fullname (string->symbol (string-append name name-base))))
	#|(if (default-object? tms-node) 
	    (write-line `(constraint ,fullname ,@participants))
	    (write-line `(constraint ,fullname ,@participants ,tms-node))
	    )|#
	(let ((me
	       (if (default-object? tms-node) 
		   (create-constraint cn fullname type participants)
		   (create-constraint cn fullname type participants tms-node))))
	  (eq-rem! cn fullname)
	  (eq-put! me 'name fullname)
	  (eq-put! me 'parent path-base)
	  (eq-put! me 'print-name name)
	  (eq-put! path-base fullname me)
	  me)))
    make-constraint))

(define (tms-node-maker path-base name-base)
  (let ((tms (cn-tms (constraint-network path-base))))
    (define (make-tms-node name)
      (let ((fullname (string->symbol (string-append name name-base))))
	;;(write-line `(tms-node ,fullname))
	(let ((me (tms-create-node tms fullname)))
	  (eq-rem! tms fullname)
	  (eq-put! me 'name fullname)
	  (eq-put! me 'parent path-base)
	  (eq-put! me 'print-name name)
	  (eq-put! path-base fullname me)
	  me)))
    make-tms-node))

(define (logical-constraint-maker path-base name-base)
  (let ((cn (constraint-network path-base)))
    (define (make-logical-constraint name type participants)
      (let ((fullname (string->symbol (string-append name name-base))))
	;;(write-line `(logical-constraint ,fullname ,@participants))
	(let ((me (create-logical-constraint cn fullname type participants)))
	  (eq-rem! cn fullname)
	  (eq-put! me 'name fullname)
	  (eq-put! me 'parent path-base)
	  (eq-put! me 'print-name name)
	  (eq-put! path-base fullname me)
	  me)))
    make-logical-constraint))

(define (>>lookup path-base)
  (lambda (exp)
    (let ((val ((eq-path (cdr exp)) path-base)))
      (assert val)
      val)))

(define (:>lookup path-base)
  (lambda (exp)
    (let ((base-name (name-of path-base))
	  (prefix (cadr exp))
	  (model-name (caddr exp)))
      (let ((val
	     ((eq-path
	       (append prefix base-name (list model-name)))
	      (top-level path-base))))
	(assert val)
	val))))

(define (dimensioned-number? exp)
  (and (pair? exp)
       (eq? (car exp) 'dimensioned)))

(define (numerical-value exp)
  (cond ((number? exp) exp)
	((symbol? exp) (eval exp generic-environment))
	((dimensioned-number? exp)
	 (eval (cadr exp) generic-environment))
	(else (error "Unknown number type" exp))))

(define (>>? exp)
  (and (pair? exp)
       (eq? (car exp) '>>)))

(define (:>? exp)
  (and (pair? exp)
       (eq? (car exp) ':>)))

(define (lhs exp)
  (cadr exp))

(define (rhs exp)
  (caddr exp))

(define (compound-expression? exp)
  (and (pair? exp)
       (not (eq? (car exp) '>>))
       (not (eq? (car exp) 'dimensioned))))

(define (comparison? exp)
  (and (pair? exp)
       (memq (car exp) '( > < >= <= approx= ))))

(define (approx=? exp)
  (and (pair? exp)
       (eq? (car exp) 'approx=)))

(define (and? exp)
  (and (pair? exp)
       (eq? (car exp) 'and)))

(define (iff? exp)
  (and (pair? exp)
       (eq? (car exp) 'iff)))

(define (integral? exp)
  (and (pair? exp)
       (eq? (car exp) 'integral)))

(define (try? exp)
  (and (pair? exp)
       (eq? (car exp) 'try)))

(define approx= values-equal?)