feat: functional!

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