; 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 ) |#