feat: basic automation

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