diff --git a/stdlib/tactics/base.rkt b/stdlib/tactics/base.rkt index 5333360..b7b8139 100644 --- a/stdlib/tactics/base.rkt +++ b/stdlib/tactics/base.rkt @@ -4,149 +4,183 @@ (provide proof define-theorem - define-lemma define-tactic (for-syntax - hole proof-state proof-state-env proof-state-goals - proof-state-current-goal - proof-state-current-proof - proof-state-original-goal - print-proof-state - current-theorem - empty-proof + proof-state-proof + proof-state-theorem + new-proof new-proof-state - push-env - ctxt? - proof-complete? - update-current-proof - update-current-goal + proof-state-proof-complete? + proof-state-goal-ref + proof-state-current-goal-ref + proof-state-current-goal-set + proof-state-env-ref + proof-state-env-ref-by-type + proof-state-extend-env + proof-state-fill-proof-hole + proof-state-extend-proof-context + current-hole-pretty-symbol + print-proof-state lookup-tactic)) -;; NB: The design of Cur currently seems to prevent intermediate type-checking -;; NB: during a tactic-based proof, unless I were to either reimplement the -;; NB: type-checker or extend it with a notion of holes. -;; TODO: A notion of holes my be useful in general... +#| NB: + | The design of Cur currently seems to prevent intermediate type-checking + | during a tactic-based proof, unless I were to either reimplement the + | type-checker or extend it with a notion of holes. + | TODO: A noation of holes may be useful in general. + |# -;; NB: Per below, note that Cur already has contexts. The issue with -;; NB: type-checking intermediate results has to do with the fact that Cur -;; NB: contexts are not exposed properly, nor is type-checking defined on -;; NB: them. +#| NB: + | Per below, note that Cur already has contexts. The issue with + | type-checking intermediate results has to do with the fact that Cur + | contexts are not exposed properly, nor is type-checking defined on + | them. + |# -;;; ====================================================================== -;;; Tactic support +;; ------------------------------------------------------------------------ +;;; Proof state interface -;;; A Goal is a syntax object representing a Cur proposition (type). - -;;; A Expr is a syntax object representing Cur expression (term). - -;;; A Hole is a procedure of type - -;;; A Ctxt is a procedure (Either Ctxt Expr) -> (Either Ctxt Expr) -;;; representing a Cur expression with a hole. - -;;; A Environment is a map from Symbol to Goal. - -;;; The compile-time proof-state interface. +#| + | A Goal, aka, Theorem is a syntax object representing a Cur proposition (type). + | + | A Expr is a syntax object representing Cur expression (term). + | + | A Hole is a procedure of type + | + | A Proof is (Either Ctxt Expr) + | + | A Ctxt is a procedure Proof -> Proof representing a Cur expression + | with a hole. + | + | A Environment is a map from Symbol to Theorems. + | + | A Proof-State is a struct containing: + | env: An Environment, the assumptions introduced during a tactic + | script. + | goals: A map from Natural to Goal, the goals necessary to finish + | this proof + | current-goal: A Natural, the index into goals of the current Goal + | to be proved. + | proof: A Proof, representing the proof so far. when the proof is + | an Expr, the proof is complete. + | theorem: A Theorem, the original statement of the theorem this proof is + | attempting to prove. + |# ;;; TODO: I'm partially implementing lens here. ;;; TODO: Interface is mildly inconsistent. (begin-for-syntax + (define-struct proof-state (env goals current-goal proof theorem)) + + (define new-proof values) + + (define (new-proof-state prop) + (proof-state + (make-immutable-hash) + (dict-set (make-immutable-hash) 0 prop) + 0 + new-proof + prop)) + + ;; Given a Proof-State, return #t if the current-proof is complete + ;; (i.e. is a Expr and not a Ctxt), #f otherwise. + (define (proof-state-proof-complete? ps) (not (procedure? (proof-state-proof ps)))) + + ;;; Extra accessors + + ;; Return the goal with index i in proof-state-goals + (define (proof-state-goal-ref ps i) + (dict-ref (proof-state-goals ps) i)) + + ;; Return the current-goal from proof-state-goals + (define (proof-state-current-goal-ref ps) + (proof-state-goal-ref ps (proof-state-current-goal ps))) + + ;; Return the theorem named by name in the local environment + (define (proof-state-env-ref ps name) + (dict-ref (proof-state-env ps) name)) + + ;; Return the name of an assumption with type thm, or #f. + (define (proof-state-env-ref-by-type ps thm) + (for/first ([(k v) (in-dict (proof-state-env ps))] + #:when (cur-equal? v thm)) + k)) + + ;;; Functional updators + + (define (maybe-syntax->symbol name) + (if (syntax? name) + (syntax->datum name) + name)) + + ;; Extend the local environment with a new assumption, name, of type thm. Name can be a syntax + ;; object or a symbol. + (define (proof-state-extend-env ps name thm) + (struct-copy proof-state ps + [env (dict-set (proof-state-env ps) (maybe-syntax->symbol name) thm)])) + + ;; Updates the current-goal to pf + (define (proof-state-current-goal-set ps pf) + (struct-copy proof-state ps + [goals (dict-set (proof-state-goals ps) (proof-state-current-goal ps) pf)])) + + ;; Fill the current proof hole with pf + (define (proof-state-fill-proof-hole ps pf) + ;; TODO: Check for proof completion? + ;; TODO: What about multiple holes? + (struct-copy proof-state ps + [proof ((proof-state-proof ps) pf)])) + + ;; Place the current proof in the context ctxt. + (define (proof-state-extend-proof-context ps ctxt) + (struct-copy proof-state ps + [proof (ctxt (proof-state-proof ps))])) + ;; How to display a hole, for pretty printing. - (define hole 'hole) - - ;; A Proof-State is a struct containing: - ;; env: An Environment, the assumptions introduced during a tactic - ;; script. - ;; goals: A map from Natural to Goal, the goals necessary to finish - ;; this proof - ;; current-goal: A Natural, the index into goals of the current Goal - ;; to be proved. - ;; current-proof: A (Either Ctxt Expr), representing the proof so far. - ;; current-proof is an Expr, the proof is complete. - (define-struct proof-state (env goals current-goal current-proof - original-goal)) + (define current-hole-pretty-symbol (make-parameter 'hole)) + ;; A pretty printer for proof-state (define (print-proof-state ps) (for ([(k v) (in-dict (proof-state-env ps))]) (printf "~n~a : ~a~n" k (syntax->datum v))) (printf "--------------------------------~n") (cond - [(proof-state-current-goal ps) => + [(proof-state-current-goal-ref ps) + => (lambda (x) (printf "~a~n~n" (syntax->datum x)))] - [else (printf "Goal complete!~n~n")])) + [else (printf "Goal complete!~n~n")]))) - ;; The current theorem; used internally to achieve a Coq-like notation - ;; for defining theorems and tactic-based proofs. - (define current-theorem (make-parameter #f)) +;; ----------------------------------------------------------------------- +;;; Syntax for tactic-based proofs similar to Coq. - (define empty-proof values) - - (define (new-proof-state prop) - (proof-state (make-immutable-hash) (make-immutable-hash) prop - empty-proof prop)) - - ;; push-env adds a mapping from name to P in (proof-state-env ps). - ;; Proof-State -> Symbol -> Goal -> Proof-State - (define (push-env ps name P) - (struct-copy proof-state ps - [env (hash-set (proof-state-env ps) name P)])) - - ;; TODO: Cur already has contexts; perhaps they should be exposed? - ;; Ctxt -> (Either Ctxt Expr) -> (Either Ctxt Expr) - ;; C1[C2] - (define (plug-ctxt C1 C2) (C1 C2)) - - (define ctxt? procedure?) - - ;; Given a Proof-State, return #t if the current-proof is complete - ;; (i.e. is a Expr and not a Ctxt), #f otherwise. - (define (proof-complete? ps) (not (ctxt? (proof-state-current-proof ps)))) - - ;; Given a Proof-State ps and Ctxt pf, plug pf into the current Ctxt - ;; and return the modified Proof-State. - (define (update-current-proof ps pf) - ;; TODO: Check for proof completion? - (struct-copy proof-state ps - [current-proof (plug-ctxt (proof-state-current-proof ps) pf)])) - - ;; Given a Proof-State ps and a Goal, update the current goal and - ;; return the modified Proof-State. - (define (update-current-goal ps goal) - (struct-copy proof-state ps - [current-goal goal])) +#| + | A tactic is a phase 1 Racket function that manipulates the current proof state. + | Tactic : Any ... Proof-State -> Proof-State + | + | Examples: + | + | (define-tactic command-name function) + | (define-tactic (command-name args ... ps) body) + |# +(define-syntax define-tactic (make-rename-transformer #'define-for-syntax)) +(begin-for-syntax ;; Takes a symbol or syntax object naming a tactic, and returns the ;; procedure for that tactic. (define (lookup-tactic syn) (eval (if (syntax? syn) - ;; Ensure eval gets the right environment + ;; NB: Ensure eval gets the right environment (datum->syntax (current-theorem) (syntax->datum syn)) syn)))) -;;; ====================================================================== - -;; A tactic is a Racket function that manipulates the current proof state. -;; Tactic : Args ... Proof-State -> Proof-State - -;;; Syntax for defining tactics. -;; (define-tactic command-name function) -;; (define-tactic (command-name args ... Proof-State) body) -;; TODO: Srsly? -(define-syntax (define-tactic syn) - (syntax-case syn () - [(_ (name args ... ps) body ...) - (quasisyntax/loc syn - (define-for-syntax (name args ... ps) body ...))] - [(_ name function) - (quasisyntax/loc syn - (define-for-syntax name function))])) - -;; (define-goal-tactic command-name function) -;; (define-goal-tactic (command-name args ... ctx goal-list current-goal) body) +(begin-for-syntax + ;; The current theorem; used internally to achieve a Coq-like notation + ;; for defining theorems and tactic-based proofs. + (define current-theorem (make-parameter #f))) ;; Define a theorem, with similar semantics to Coq theorems in that you ;; can define the theorem then define the proof next. @@ -157,29 +191,28 @@ #'(define name prop)])) ;; Aliases for theorems. -;; TODO: I think there's some define-syntax-rename thing that would -;; TODO: prevent eta expanding these. -(define-syntax-rule (define-lemma s ...) (define-theorem s ...)) +;; (define-syntax define-lemma (make-rename-transformer #'define-theorem)) (begin-for-syntax ;; Given a list of tactics and their arguments, run the tactic script ;; on the current theorem, returning the proof if the proof is valid. (define (run-tactic-script f* args*) (unless (current-theorem) - (raise-syntax-error 'proof + (raise-syntax-error + 'proof "You can't use proof without a first using define-theorem")) (let* ([t (current-theorem)] - [pf (proof-state-current-proof - ;; Thread proof state through tactic calls, and eval - ;; at compile-time. - (for/fold ([ps (new-proof-state t)]) - ([f f*] [args args*]) - (apply (lookup-tactic f) (append args (list ps)))))]) - (when (ctxt? pf) - (raise-syntax-error 'qed "Proof contains holes" (pf hole))) - (unless (type-check/syn? pf t) - (raise-syntax-error 'qed "Invalid proof" pf t)) - pf))) + [ps ;; Thread proof state through tactic calls, and eval + ;; at compile-time. + (for/fold ([ps (new-proof-state t)]) + ([f f*] [args args*]) + (apply (lookup-tactic f) (append args (list ps))))] + [pf (proof-state-proof ps)]) + (unless (proof-state-proof-complete? ps) + (raise-syntax-error 'qed "Proof contains holes" (pf (current-hole-pretty-symbol)))) + (unless (type-check/syn? pf t) + (raise-syntax-error 'qed "Invalid proof" pf t)) + pf))) ;; The proof macro starts a proof environment. Every proof should begin ;; with it. diff --git a/stdlib/tactics/sartactics.rkt b/stdlib/tactics/sartactics.rkt index 362dd67..f0bf3e2 100644 --- a/stdlib/tactics/sartactics.rkt +++ b/stdlib/tactics/sartactics.rkt @@ -1,7 +1,7 @@ #lang s-exp "../../redex-curnel.rkt" (require "base.rkt" - (prefix-in basic: "basic.rkt") + (prefix-in basic: "standard.rkt") (for-syntax racket/syntax)) (provide @@ -94,7 +94,7 @@ (printf "Starting interactive tactic session. Prepared to be sassed:~n") (printf "Type (quit) to quit.~n") (let loop ([ps ps] [cmds '()]) - (if (proof-complete? ps) + (if (proof-state-proof-complete? ps) (basic:print ps) (print ps)) (let ([cmd (read-syntax)]) diff --git a/stdlib/tactics/basic.rkt b/stdlib/tactics/standard.rkt similarity index 72% rename from stdlib/tactics/basic.rkt rename to stdlib/tactics/standard.rkt index 37f8b33..b3f5ce6 100644 --- a/stdlib/tactics/basic.rkt +++ b/stdlib/tactics/standard.rkt @@ -13,33 +13,28 @@ by-assumption interactive)) -;;; TACTICS -;;; A tactic is a function from proof state to proof state - -;; TODO: Tactics probably should not error for failure. Perhaps return -;; TODO: proof state unmodified, or raise an exception. +#| TODO: + | Tactics should probably not error on failure. Perhaps Maybe monad, or list monad, or return proof + | state unmodified, or raise exception, or ... + |# (define-tactic (intro name ps) - ;; TODO: Maybe cur-expand current-goal by default - (syntax-parse (cur-expand (proof-state-current-goal ps)) + ;; TODO: Provide cur-match, which wraps syntax-parse and uses cur-expand. + (syntax-parse (cur-expand (proof-state-current-goal-ref ps)) [(forall (x:id : P:expr) body:expr) - (update-current-goal - (update-current-proof - ;; TODO: Should hide syntax-e in push-env - (push-env ps (syntax-e name) #'P) - (lambda (x) #`(λ (#,x : P) #,x))) - #'body)] + (let* ([ps (proof-state-extend-env ps name #'P)] + [ps (proof-state-current-goal-set ps #'body)] + [ps (proof-state-fill-proof-hole ps (lambda (x) #`(lambda (#,name : P) #,x)))]) + ps)] [_ (error 'intro "Can only intro when current goal is of the form (∀ (x : P) body)")])) -(begin-for-syntax - (define (assumption ps type) - (for/first ([(k v) (in-dict (proof-state-env ps))] - #:when (cur-equal? v type)) - k))) - (define-tactic (by-assumption ps) (cond - [(assumption ps (cur-expand (proof-state-current-goal ps))) - => (curry update-current-proof (update-current-goal ps #f))] + [(proof-state-env-ref-by-type ps (proof-state-current-goal-ref ps)) + => + (lambda (x) + (let* ([ps (proof-state-fill-proof-hole ps x)] + [ps (proof-state-current-goal-set ps #f)]) + ps))] [else (error 'by-assumption "Cannot find an assumption that matches the goal")])) ;; TODO: requires more support from curnel @@ -49,19 +44,17 @@ ;; Do the obvious thing (define-tactic (obvious ps) - (syntax-parse (cur-expand (proof-state-current-goal ps)) + (syntax-parse (cur-expand (proof-state-current-goal-ref ps)) [(forall (x : P) t) (obvious (intro #'x ps))] [t:expr (cond - [(assumption ps #'t) (by-assumption ps)] + ;; TODO: This would be cleaner if I could say "try all these things and do whichever works". + [(proof-state-env-ref-by-type ps #'t) (by-assumption ps)] ;[(inductive? ps #'t) (by-constructor ps)] [else (error 'obvious "This is not all that obvious to me.")])])) -(define-tactic (restart ps) - (struct-copy proof-state ps - [current-goal (proof-state-original-goal ps)] - [current-proof empty-proof])) +(define-tactic (restart ps) (new-proof-state (proof-state-theorem ps))) (define-tactic (print ps) (print-proof-state ps) ps) @@ -80,6 +73,8 @@ [(quit) (begin (printf "Your tactic script:~n") + ;; TODO: Using clever trickery, could problem write a version of interactive that actually + ;; modifies the file. (pretty-print (reverse (map syntax->datum cmds))) (newline) ps)] @@ -127,7 +122,7 @@ (proof (obvious)) ;; TODO: Fix this unit test so it doesn't require interaction (define-theorem meow4 (forall (x : bool) bool)) - #;(proof + (proof (interactive)) ;; TODO: Add check-cur-equal? for unit testing? #;(check-pred (curry cur-equal? '(lambda (x : bool) x)))