diff --git a/formal.scm b/formal.scm index 929b353..1eb57a2 100644 --- a/formal.scm +++ b/formal.scm @@ -133,6 +133,10 @@ base (if (zero? num) "" num)))))) +(define (placeholder-saturate f) + ;; map iota is bad but convenient (macro so needed) + (apply f (map proof-variable (iota (procedure-arity f))))) + ;; i think i prefer the turnstile to therefore (define (argument-pp arg port) (define prems (argument-premises arg)) @@ -140,41 +144,70 @@ (format port "~{~a\n~}~{⊢ ~a\n~}" prems concls)) -(define (general-argument-pp arg% port) - ;; map iota is bad but convenient (macro so needed) - (define arg (apply arg% (map proof-variable (iota (procedure-arity arg%))))) - (argument-pp arg port)) +(define (general-argument-pp arg port) + (argument-pp (placeholder-saturate arg) port)) + +(define (cartesian-exponent xs n) + (assert (and (integer? n) (>= n 0))) + (case n + [0 '()] + [1 (map list xs)] + [else + (let ([exp-1 (cartesian-exponent xs (sub1 n))]) + (apply append + (map (lambda (xs2) + (map (lambda (x) + (cons x xs2)) + xs)) + exp-1)))])) (define (proof-valid? proof%) (define (gensyms n xs) (if (zero? n) ;; less confusing to apply (proof g0 g1 ...) (reverse xs) - (gensyms (sub1 n) (cons (gensym) xs)))) + (gensyms (sub1 n) + (cons (gensym (symbol->string (proof-variable (sub1 n)))) xs)))) (define proof (apply proof% (gensyms (procedure-arity proof%) '()))) (define arg (proof-argument proof)) ;; reversing here lets us recover a nice order at the end (define prems (reverse (argument-premises arg))) (define goals (argument-conclusions arg)) + (define (fail concl rule) + (printf "Failed to apply rule:\n") + (argument-pp rule #t) + (printf "Proof state:\n~{~a\n~}⊢ ~a\n" + (reverse prems) concl) + #f) + + (define (handle-general-step concl rule) + (define targets + (apply append prems (map (lambda (p) (if (pair? p) (cdr p) '())) prems))) + (ormap + (lambda (ts) (follows? prems concl (apply rule ts))) + (cartesian-exponent targets (procedure-arity rule)))) + (call/1cc (lambda (return) (for-each (lambda (step) - (let ([concl (step-conclusion step)] - [rule (step-rule step)]) - (unless (follows? prems concl rule) - (printf "Failed to apply rule:\n") - (argument-pp rule #t) - (printf "Proof state:\n~{~a\n~}⊢ ~a\n" - (reverse prems) concl) - (return #f)) - (set! prems (cons concl prems)))) + (define concl (step-conclusion step)) + (define rule (step-rule step)) + (define ok? + (if (procedure? rule) + (handle-general-step concl rule) + (follows? prems concl rule))) + (if ok? + (set! prems (cons concl prems)) + (begin + (fail concl (if (procedure? rule) (placeholder-saturate rule) rule)) + (return #f)))) (proof-steps proof)) (when (or (member #f prems) (premises<=? goals prems)) (return #t)) - (format #t "Proof incomplete:\n~{~a\n~}~{⊢ ~a\n~}\n" - prems goals)))) + (format #t "Unsolved goals:\n~{~a\n~}~{⊢ ~a\n~}\n" + prems (filter (lambda (g) (not (member g prems))) goals))))) ;; TODO: i can just guess lol ;; this really isn't far from the macroless version.... @@ -187,3 +220,11 @@ [q (simplification p q)] [(pand q p) (conjunction q p)])) +(define and-comm-ez + (proof (p q) + (argument (p q) + [(pand p q)] + [(pand q p)]) + [p simplification] + [q simplification] + [(pand q p) conjunction]))