;    6.844                                             2/24/03
;;                 tree-proof->subst-proof
;;                     by Steve McCamant

;; Given a purported tree proof of "e = f", return a list of steps in
;; a substitution proof of the same fact, inclusive of "e" but
;; exclusive of "f".
(define (ts-steps tproof)
  (let* ((rule (tree-proof-rule tproof))
	 (hypo-proofs (tree-proof-hypotheses tproof))
	 (hypos (map tree-proof-conclusion hypo-proofs))
	 (sub-steps (map ts-steps hypo-proofs)))
    (cond ((eq? rule 'transitivity)
	   (append (first sub-steps) (second sub-steps)))
	  ((eq? rule 'congruence-for+)
	   (let ((left-to    (equation-rhs (first hypos)))
		 (right-from (equation-lhs (second hypos))))
	     (append (map (lambda (left) (make-sum left right-from))
			  (first sub-steps))
		     (map (lambda (right) (make-sum left-to right))
			  (second sub-steps)))))
	  ((eq? rule 'congruence-for*)
	   (let ((left-to    (equation-rhs (first hypos)))
		 (right-from (equation-lhs (second hypos))))
	     (append (map (lambda (left) (make-product left right-from))
			  (first sub-steps))
		     (map (lambda (right) (make-product left-to right))
			  (second sub-steps)))))
	  ((eq? rule 'congruence-for-)
	   (map (lambda (expr) (make-negation expr)) (first sub-steps)))
	  ((eq? rule 'reflexivity) '())
	  ((eq? rule 'symmetry)
	   (cons (equation-lhs (tree-proof-conclusion tproof))
		 (reverse (cdr (first sub-steps)))))
	  (#t (list (equation-lhs (tree-proof-conclusion tproof)))))))

;; Given a separator and a list, return a new list in which elements
;; that were adjacent in the input are separated by the separaror.
(define (list-join sep l)
  (if (or (null? l) (null? (cdr l)))
      l
      (cons (car l) (cons sep (list-join sep (cdr l))))))

;; Convert a correct tree proof into a substitution proof.
(define (tree-proof->subst-proof tree-proof)
  (list-join
   '=
   (append (ts-steps tree-proof)
	   (list (equation-rhs (tree-proof-conclusion tree-proof))))))

;; Given a substitution proof, remove the top level of parentheses
;; around each arithmetic equation, to make the result slightly less
;; cluttered.
(define (remove-top-parens subst-proof)
  (apply append (map (lambda (x) (if (list? x) x (list x))) subst-proof)))


;                         ABSTRACT SYNTAX

(define tree-proof-conclusion car)
(define tree-proof-rule cadr)
(define tree-proof-hypotheses cddr)

(define equation-lhs car)
(define equation-rhs caddr)
(define (make-equation lhs rhs) (list lhs '= rhs))

(define sum-left-term car)
(define sum-right-term caddr)
(define (make-sum left right) (list left '+ right))

(define product-left-factor car)
(define product-right-factor caddr)
(define (make-product left right) (list left '* right))

(define negation-subtrahend cadr)
(define (make-negation expr) (list '- expr))


;                                EXAMPLES

;Tree-proof from the Notes, Fig.1

(define Fig1-tree-proof
  '((((f + g) + (- g)) = f)
      transitivity
      ((((f + g) + (- g)) = (0 + f))
         transitivity
         ((((f + g) + (- g)) = (f + (g + (- g)))) associativity-of+)
         (((f + (g + (- g))) = (0 + f))
            transitivity
            (((f + (g + (- g))) = (f + 0))
                congruence-for+
                ((f = f) reflexivity)
                (((g + (- g)) = 0) inverse-for+))
            (((f + 0) = (0 + f)) commutativity-for+)))
      (((0 + f) = f) identity-for+)))

;; A tree-proof version of the proof, from Fig 2 of the notes, that
;; "0 = e * 0".
(define fig2-tree-proof
  (let*
      ((step1 `((e = e) reflexivity))
       (step2 `(((0 + 1) = 1) identity-for+))
       (step3 `(((e * (0 + 1) = (e * 1))) congruence-for+ ,step1 ,step2))
       (step4 `(((e * 1) = (e * (0 + 1))) symmetry ,step3))
       (step5 `(((e * (0 + 1)) = ((e * 0) + (e * 1))) distributivity))
       (step6 `(((e * 1) = ((e * 0) + (e * 1))) transitivity ,step4 ,step5))
       (step7 `(((-(e * 1)) = (-(e * 1))) reflexivity))
       (step8 `((((e * 1) + (-(e * 1))) = (((e * 0) + (e * 1)) + (-(e * 1))))
		congruence-for+ ,step6 ,step7))
       (step9 '(((((e * 0) + (e * 1)) + (- (e * 1))) = (e * 0))
		transitivity
		(((((e * 0) + (e * 1)) + (- (e * 1))) = (0 + (e * 0)))
		 transitivity
		 (((((e * 0) + (e * 1)) + (- (e * 1))) 
		   = ((e * 0) + ((e * 1) + (- (e * 1))))) associativity-for+)
		 ((((e * 0) + ((e * 1) + (- (e * 1)))) = (0 + (e * 0)))
		  transitivity
		  ((((e * 0) + ((e * 1) + (- (e * 1)))) = ((e * 0) + 0))
		   congruence-for+
		   (((e * 0) = (e * 0)) reflexivity)
		   ((((e * 1) + (- (e * 1))) = 0) inverse-for+))
		  ((((e * 0) + 0) = (0 + (e * 0))) commutativity-for+)))
		(((0 + (e * 0)) = (e * 0)) identity-for+)))
       (step10 `((((e * 1) + (-(e * 1))) = (e * 0))
		 transitivity ,step8 ,step9))
       (step11 `((((e * 1) + (-(e * 1))) = 0) inverse-for+))
       (step12 `((0 = ((e * 1) + (-(e * 1)))) symmetry ,step11))
       (step13 `((0 = (e * 0)) transitivity ,step12 ,step10)))
    step13))

;(tree-proof->subst-proof fig1-tree-proof)
;Value 6: (((f + g) + (- g)) = (f + (g + (- g))) = (f + 0) = (0 + f) = f)

;(remove-top-parens (tree-proof->subst-proof fig1-tree-proof))
;Value 7: ((f + g) + (- g) = f + (g + (- g)) = f + 0 = 0 + f = f)

;(remove-top-parens (tree-proof->subst-proof fig2-tree-proof))

#|
;Value 34: (0 = (e * 1) + (- (e * 1)) = (e * (0 + 1)) + (- (e * 1)) = ((e * 0) + (e * 1)) + (- (e * 1)) = (e * 0) + ((e * 1) + (- (e * 1))) = (e * 0) + 0 = 0 + (e * 0) = e * 0)

REFORMATTED BY HAND:
(
0  =     (e *    1)      + (- (e * 1))
   =     (e * (0 + 1))   + (- (e * 1))
   = ((e * 0) + (e * 1)) + (- (e * 1))
   =  (e * 0) + ((e * 1) + (- (e * 1)))
   =  (e * 0) +          0
   =     0    +       (e * 0)
   =                   e * 0
)
|#