diff --git a/formal.scm b/formal.scm index bd05012..9f0e0e0 100644 --- a/formal.scm +++ b/formal.scm @@ -1,4 +1,5 @@ -;; (equal? (make-pand 1 2) (make-pand 1 2)) => #f +;; okay, i'll keep these procedures for the sake of nesting + (define (make-pand p q) `(and ,p ,q)) (define pand @@ -47,26 +48,38 @@ ;; [(forall var p) (forall (var) p)])) (define-record-type argument - (fields premises conclusion) + (fields premises conclusions) (nongenerative argument)) (define-syntax argument (syntax-rules () - [(_ (var* ...) (premise* ...) conclusion) + [(_ (var* ...) (premise* ...) (conclusion* ...)) (lambda (var* ...) - (make-argument (list premise* ...) conclusion))])) + (make-argument (list premise* ...) (list conclusion* ...)))])) (define modus-ponens (argument (p q) - ((p-> p q) - p) - q)) + [(p-> p q) + p] + [q])) (define modus-tollens (argument (p q) - ((p-> p q) - (~ q)) - (~ p))) + [(p-> p q) + (~ q)] + [(~ p)])) + +;; YES: multiple conclusions (no more simplification-{l,r}) +(define simplification + (argument (p q) + [(pand p q)] + [p q])) + +(define conjunction + (argument (p q) + [p + q] + [(pand p q)])) ;; (follows (P* ... (-> p q) p Q* ...) q modus-ponens) => #t ;; iterative argument @@ -79,17 +92,71 @@ (and (andmap (lambda (prem) (member prem p2)) p1) #t)) -(define (follows? p q by) - (and (equal? q (argument-conclusion by)) - (premises<=? (argument-premises by) p))) +(define (follows? prems q by) + (and (member q (argument-conclusions by)) + (premises<=? (argument-premises by) prems))) -(define (argument-extend arg rule) - (if (premises<=? (argument-premises rule) (argument-premises arg)) - (make-argument ))) +(define-record-type step + (fields conclusion rule) + (nongenerative step)) +(define-record-type proof + (fields argument steps) + (nongenerative proof)) +(define-syntax proof + (syntax-rules () + [(_ (var* ...) arg (conclusion* rule*) ...) + (lambda (var* ...) + (make-proof (arg var* ...) + (list (make-step conclusion* rule*) ...)))])) +;; bleh +;; huh, procedure-arity-mask can handle 1000+ no problem +;; returns the lowest arity +(define (procedure-arity proc) + (define mask (procedure-arity-mask proc)) + (let loop ([i 0]) + (if (logbit? i mask) + i + (loop (add1 i))))) + +(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)))) + (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)) + + (call/1cc + (lambda (return) + (for-each + (lambda (step) + (let ([concl (step-conclusion step)] + [rule (step-rule step)]) + (unless (follows? prems concl rule) + (format #t "fool, ~a does not follow from ~a and ~a!\n" + concl (reverse prems) rule) + (return #f)) + (set! prems (cons concl prems)))) + (proof-steps proof)) + (when (premises<=? goals prems) + (return #t)) + (format #t "forgetting something? you're trying to prove ~a, but you've only got ~a\n" + goals prems)))) + +;; TODO: i can just guess lol +(define and-comm + (proof (p q) + (argument (p q) + [(pand p q)] + [(pand q p)]) + [p (simplification p q)] + [q (simplification p q)] + [(pand q p) (conjunction q p)])) -(define-record-type proof-state - (fields knowns goals) - (nongenerative proof-state))