├── Frap.v
├── Var.v
├── _CoqProject.fraplib
├── Makefile.fraplib
├── .gitignore
├── DeepInterp.ml
├── DeeperInterp.ml
├── DeeperWithFailInterp.ml
├── Makefile
├── _CoqProject
├── index.html
├── ModelChecking_sol.v
├── LICENSE
├── README.md
├── Relations.v
├── Invariant.v
├── SubsetTypes_template.v
├── ModelCheck.v
├── Foundations_template.v
├── LogicProgramming_template.v
├── Imp.v
├── BasicSyntax_template.v
├── Foundations.v
├── Interpreters_template.v
├── TransitionSystems_template.v
├── ProofByReflection_template.v
├── Polymorphism_template.v
├── HoareLogic_template.v
├── LambdaCalculusAndTypeSoundness_template.v
├── FrapWithoutSets.v
├── IntroToProofScripting_template.v
├── Interpreters.v
└── SepCancel.v


/Frap.v:
--------------------------------------------------------------------------------
1 | Require Export FrapWithoutSets.
2 | 
3 | Module Export SN := SetNotations(FrapWithoutSets).
4 | 


--------------------------------------------------------------------------------
/Var.v:
--------------------------------------------------------------------------------
1 | From Stdlib Require Import String.
2 | 
3 | 
4 | Notation var := string.
5 | Definition var_eq : forall x y : var, {x = y} + {x <> y} := string_dec.
6 | 
7 | Infix "==v" := var_eq (no associativity, at level 50).
8 | 


--------------------------------------------------------------------------------
/_CoqProject.fraplib:
--------------------------------------------------------------------------------
 1 | -R . Frap
 2 | -arg -w -arg -undeclared-scope
 3 | Map.v
 4 | Var.v
 5 | Sets.v
 6 | Relations.v
 7 | Invariant.v
 8 | ModelCheck.v
 9 | Imp.v
10 | AbstractInterpret.v
11 | FrapWithoutSets.v
12 | Frap.v
13 | SepCancel.v
14 | 


--------------------------------------------------------------------------------
/Makefile.fraplib:
--------------------------------------------------------------------------------
 1 | .PHONY: coq
 2 | 
 3 | coq: Makefile.coq
 4 | 	$(MAKE) -f Makefile.coq
 5 | 
 6 | Makefile.coq: Makefile _CoqProject *.v
 7 | 	coq_makefile -f _CoqProject -o Makefile.coq
 8 | 
 9 | clean:: Makefile.coq
10 | 	$(MAKE) -f Makefile.coq clean
11 | 	rm -f Makefile.coq
12 | 


--------------------------------------------------------------------------------
/.gitignore:
--------------------------------------------------------------------------------
 1 | *~
 2 | *.aux
 3 | *.idx
 4 | *.log
 5 | *.out
 6 | *.pdf
 7 | *.toc
 8 | *.bbl
 9 | *.blg
10 | *.ilg
11 | *.ind
12 | Makefile.coq
13 | Makefile.coq.conf
14 | *.glob
15 | *.d
16 | *.vo
17 | *.vok
18 | *.vos
19 | frap.tgz
20 | .coq-native
21 | Deep.ml*
22 | Deeper.ml*
23 | DeeperWithFail.ml*
24 | *.dir-locals.el
25 | *.cache
26 | fraplib
27 | fraplib.tgz
28 | 


--------------------------------------------------------------------------------
/DeepInterp.ml:
--------------------------------------------------------------------------------
 1 | open Deep
 2 | 
 3 | let rec i2n n =
 4 |   match n with
 5 |   | 0 -> O
 6 |   | _ -> S (i2n (n - 1))
 7 | 
 8 | let interp c =
 9 |   let h : (nat, nat) Hashtbl.t = Hashtbl.create 0 in
10 |   Hashtbl.add h (i2n 0) (i2n 2);
11 |   Hashtbl.add h (i2n 1) (i2n 1);
12 |   Hashtbl.add h (i2n 2) (i2n 8);
13 |   Hashtbl.add h (i2n 3) (i2n 6);
14 | 
15 |   let rec interp' (c : 'a cmd) : 'a =
16 |     match c with
17 |     | Return v -> v
18 |     | Bind (c1, c2) -> interp' (c2 (interp' c1))
19 |     | Read a ->
20 |       Obj.magic (try
21 |                    Hashtbl.find h a
22 |         with Not_found -> O)
23 |     | Write (a, v) -> Obj.magic (Hashtbl.replace h a v)
24 | 
25 |   in h, interp' c
26 | 


--------------------------------------------------------------------------------
/DeeperInterp.ml:
--------------------------------------------------------------------------------
 1 | open Deeper
 2 | 
 3 | let rec i2n n =
 4 |   match n with
 5 |   | 0 -> O
 6 |   | _ -> S (i2n (n - 1))
 7 | 
 8 | let interp c =
 9 |   let h : (nat, nat) Hashtbl.t = Hashtbl.create 0 in
10 |   Hashtbl.add h (i2n 0) (i2n 2);
11 |   Hashtbl.add h (i2n 1) (i2n 1);
12 |   Hashtbl.add h (i2n 2) (i2n 8);
13 |   Hashtbl.add h (i2n 3) (i2n 6);
14 | 
15 |   let rec interp' (c : 'a cmd) : 'a =
16 |     match c with
17 |     | Return v -> v
18 |     | Bind (c1, c2) -> interp' (c2 (interp' c1))
19 |     | Read a ->
20 |       Obj.magic (try
21 |                    Hashtbl.find h a
22 |         with Not_found -> O)
23 |     | Write (a, v) -> Obj.magic (Hashtbl.replace h a v)
24 |     | Loop (i, b) ->
25 |       match Obj.magic (interp' (Obj.magic (b i))) with
26 |       | Done r -> r
27 |       | Again r -> interp' (Loop (r, b))
28 | 
29 |   in h, interp' c
30 | 


--------------------------------------------------------------------------------
/DeeperWithFailInterp.ml:
--------------------------------------------------------------------------------
 1 | open DeeperWithFail
 2 | 
 3 | let rec i2n n =
 4 |   match n with
 5 |   | 0 -> O
 6 |   | _ -> S (i2n (n - 1))
 7 | 
 8 | let interp c =
 9 |   let h : (nat, nat) Hashtbl.t = Hashtbl.create 0 in
10 |   Hashtbl.add h (i2n 0) (i2n 2);
11 |   Hashtbl.add h (i2n 1) (i2n 1);
12 |   Hashtbl.add h (i2n 2) (i2n 8);
13 |   Hashtbl.add h (i2n 3) (i2n 6);
14 | 
15 |   let rec interp' (c : 'a cmd) : 'a =
16 |     match c with
17 |     | Return v -> v
18 |     | Bind (c1, c2) -> interp' (c2 (interp' c1))
19 |     | Read a ->
20 |       Obj.magic (try
21 |                    Hashtbl.find h a
22 |         with Not_found -> O)
23 |     | Write (a, v) -> Obj.magic (Hashtbl.replace h a v)
24 |     | Loop (i, b) ->
25 |       begin match Obj.magic (interp' (Obj.magic (b i))) with
26 |       | Done r -> r
27 |       | Again r -> interp' (Loop (r, b))
28 |       end
29 |     | Fail -> failwith "Fail"
30 | 
31 |   in h, interp' c
32 | 


--------------------------------------------------------------------------------
/Makefile:
--------------------------------------------------------------------------------
 1 | .PHONY: all lib coq install
 2 | 
 3 | all: frap_book.pdf coq
 4 | 
 5 | frap_book.pdf: frap_book.tex Makefile
 6 | 	pdflatex frap_book
 7 | 	pdflatex frap_book
 8 | 	makeindex frap_book
 9 | 	pdflatex frap_book
10 | 	pdflatex frap_book
11 | 
12 | coq: Makefile.coq
13 | 	$(MAKE) -f Makefile.coq
14 | 
15 | lib: Makefile.coq
16 | 	$(MAKE) -f Makefile.coq Frap.vo AbstractInterpret.vo SepCancel.vo
17 | 
18 | Makefile.coq: Makefile _CoqProject *.v
19 | 	rocq makefile -f _CoqProject -o Makefile.coq
20 | 
21 | clean:: Makefile.coq
22 | 	$(MAKE) -f Makefile.coq clean
23 | 	rm -f Makefile.coq
24 | 
25 | frap.tgz: Makefile _CoqProject *.v *.tex *.html
26 | 	git archive --format=tar.gz HEAD >frap.tgz
27 | 
28 | fraplib.tgz: Makefile
29 | 	rm -rf fraplib
30 | 	mkdir fraplib
31 | 	cp LICENSE fraplib/
32 | 	cp Makefile.fraplib fraplib/Makefile
33 | 	cp _CoqProject.fraplib fraplib/_CoqProject
34 | 	cp Relations.v fraplib/
35 | 	cp Map.v fraplib/
36 | 	cp Var.v fraplib/
37 | 	cp Invariant.v fraplib/
38 | 	cp ModelCheck.v fraplib/
39 | 	cp FrapWithoutSets.v fraplib/
40 | 	cp Sets.v fraplib/
41 | 	cp Frap.v fraplib/
42 | 	cp Imp.v fraplib/
43 | 	cp AbstractInterpret.v fraplib/
44 | 	cp SepCancel.v fraplib/
45 | 	tar cf fraplib.tgz fraplib/*
46 | 
47 | WHERE=chlipala.net:sites/chlipala/adam/frap/
48 | 
49 | install: index.html frap_book.pdf frap.tgz fraplib.tgz
50 | 	rsync frap_book.pdf $(WHERE)
51 | 	rsync frap.tgz $(WHERE)
52 | 	rsync fraplib.tgz $(WHERE)
53 | 	rsync index.html $(WHERE)
54 | 


--------------------------------------------------------------------------------
/_CoqProject:
--------------------------------------------------------------------------------
 1 | -R . Frap
 2 | -arg -w -arg -undeclared-scope
 3 | Map.v
 4 | Var.v
 5 | Sets.v
 6 | Relations.v
 7 | Invariant.v
 8 | ModelCheck.v
 9 | Imp.v
10 | AbstractInterpret.v
11 | FrapWithoutSets.v
12 | Frap.v
13 | BasicSyntax_template.v
14 | BasicSyntax.v
15 | Polymorphism_template.v
16 | Polymorphism.v
17 | DataAbstraction_template.v
18 | DataAbstraction.v
19 | Interpreters_template.v
20 | Interpreters.v
21 | FirstClassFunctions_template.v
22 | FirstClassFunctions.v
23 | RuleInduction_template.v
24 | RuleInduction.v
25 | TransitionSystems_template.v
26 | TransitionSystems.v
27 | IntroToProofScripting_template.v
28 | IntroToProofScripting.v
29 | ModelChecking_template.v
30 | ModelChecking.v
31 | ProofByReflection_template.v
32 | ProofByReflection.v
33 | OperationalSemantics_template.v
34 | OperationalSemantics.v
35 | LogicProgramming_template.v
36 | LogicProgramming.v
37 | AbstractInterpretation.v
38 | CompilerCorrectness_template.v
39 | CompilerCorrectness.v
40 | SubsetTypes_template.v
41 | SubsetTypes.v
42 | LambdaCalculusAndTypeSoundness_template.v
43 | LambdaCalculusAndTypeSoundness.v
44 | EvaluationContexts_template.v
45 | EvaluationContexts.v
46 | DependentInductiveTypes_template.v
47 | DependentInductiveTypes.v
48 | TypesAndMutation.v
49 | HoareLogic_template.v
50 | HoareLogic.v
51 | AutomatedTheoremProving_template.v
52 | AutomatedTheoremProving.v
53 | SymbolicExecution.v
54 | DeepAndShallowEmbeddings_template.v
55 | DeepAndShallowEmbeddings.v
56 | SepCancel.v
57 | SeparationLogic_template.v
58 | SeparationLogic.v
59 | Connecting.v
60 | ProgramDerivation_template.v
61 | ProgramDerivation.v
62 | SharedMemory.v
63 | ConcurrentSeparationLogic_template.v
64 | ConcurrentSeparationLogic.v
65 | MessagesAndRefinement.v
66 | SessionTypes.v
67 | Foundations_template.v
68 | Foundations.v
69 | 


--------------------------------------------------------------------------------
/index.html:
--------------------------------------------------------------------------------
 1 | <html>
 2 | <head>
 3 | <link rel="stylesheet" type="text/css" href="/style.css">
 4 | <title>Formal Reasoning About Programs</title>
 5 | </head><body>
 6 | <h1>Formal Reasoning About Programs</h1>
 7 | <h2><a href="http://adam.chlipala.net/">Adam Chlipala</a></h2>
 8 | 
 9 | <div class="summary" style="overflow: hidden">
10 | 
11 | <p>This is the web site for the early stages of a book introducing both machine-checked proof with <a href="https://rocq-prover.org/">the Rocq proof assistant</a> and approaches to formal reasoning about program correctness.</p>
12 | 
13 | <h2>Grab a Draft</h2>
14 | <ul>
15 |   <li><a href="https://github.com/achlipala/frap">Source on GitHub</a></li>
16 |   <li><a href="frap_book.pdf">Quasi-latest PDF draft</a></li>
17 |   <li><a href="frap.tgz">Quasi-latest source-code tarball</a></li>
18 |   <li><a href="fraplib.tgz">Quasi-latest source-code tarball, library only</a> (warning: the author really does not recommend using it in serious projects!)</li>
19 | </ul>
20 | </div>
21 | 
22 | <div class="project">
23 | <h2>Use in classes</h2>
24 | 
25 | <h3>Classes where FRAP is/was a primary text</h3>
26 | <ul>
27 |   <li>6.512 at MIT (<a href="https://frap.csail.mit.edu/">Fall 2025</a>, Spring 2023 [as 6.822], Spring 2021 [as 6.822], Spring 2020 [as 6.822], Spring 2018 [as 6.822], Spring 2017 [as 6.887], Spring 2016 [as 6.887])</li>
28 |   <ul>
29 |     <li><a href="https://github.com/mit-frap/spring23">Spring 2023 exercises</a></li>
30 |     <li><a href="https://github.com/mit-frap/spring22">Spring 2022 exercises</a></li>
31 |     <li><a href="https://github.com/mit-frap/spring21">Spring 2021 exercises</a></li>
32 |     <li><a href="https://github.com/mit-frap/spring20">Spring 2020 exercises</a></li>
33 |     <li><a href="https://github.com/mit-frap/spring18">Spring 2018 exercises</a></li>
34 |     <li><a href="https://github.com/mit-frap/spring17">Spring 2017 exercises</a></li>
35 |     <li><a href="https://github.com/mit-frap/spring16">Spring 2016 exercises</a></li>
36 |   </ul>
37 |   <li>EECS 755 at U. Kansas (<a href="http://perry.alexander.name/eecs755/">Spring 2020</a>)</li>
38 |   <li>CS6225 at IIT Madras (<a href="http://kcsrk.info/cs6225_s20_iitm/">Spring 2020</a>)</li>
39 |   <li>CSE 505 at U. Washington (<a href="https://sites.google.com/cs.washington.edu/cse-505-18au">Fall 2018</a>)</li>
40 | </ul>
41 | 
42 | </div>
43 | 
44 | </body></html>
45 | 


--------------------------------------------------------------------------------
/ModelChecking_sol.v:
--------------------------------------------------------------------------------
 1 | Theorem factorial_ok_2 :
 2 |   invariantFor (factorial_sys 2) (fact_correct 2).
 3 | Proof.
 4 |   simplify.
 5 |   eapply invariant_weaken.
 6 |   (* We begin like in last chapter, by strengthening to an inductive
 7 |    * invariant. *)
 8 | 
 9 |   apply multiStepClosure_ok.
10 |   (* The difference is that we will use multi-step closure to find the invariant
11 |    * automatically.  Note that the invariant appears as an existential variable,
12 |    * whose name begins with a question mark. *)
13 |   simplify.
14 |   rewrite fact_init_is.
15 |   (* It's important to phrase the current candidate invariant explicitly as a
16 |    * finite set, before continuing.  Otherwise, it won't be obvious how to take
17 |    * the one-step closure. *)
18 | 
19 |   (* Compute which states are reachable after one step. *)
20 |   eapply MscStep.
21 |   apply oneStepClosure_split; simplify.
22 |   invert H; simplify.
23 |   apply singleton_in.
24 |   apply oneStepClosure_empty.
25 |   simplify.
26 | 
27 |   (* Compute which states are reachable after two steps. *)
28 |   eapply MscStep.
29 |   apply oneStepClosure_split; simplify.
30 |   invert H; simplify.
31 |   apply singleton_in.
32 |   apply oneStepClosure_split; simplify.
33 |   invert H; simplify.
34 |   apply singleton_in.
35 |   apply oneStepClosure_empty.
36 |   simplify.
37 | 
38 |   (* Compute which states are reachable after three steps. *)
39 |   eapply MscStep.
40 |   apply oneStepClosure_split; simplify.
41 |   invert H; simplify.
42 |   apply singleton_in.
43 |   apply oneStepClosure_split; simplify.
44 |   invert H; simplify.
45 |   apply singleton_in.
46 |   apply oneStepClosure_split; simplify.
47 |   invert H; simplify.
48 |   apply singleton_in.
49 |   apply oneStepClosure_empty.
50 |   simplify.
51 | 
52 |   (* Now the candidate invariatn is closed under single steps.  Let's prove
53 |    * it. *)
54 |   apply MscDone.
55 |   apply prove_oneStepClosure; simplify.
56 |   propositional.
57 |   propositional; invert H0; try equality.
58 |   invert H; equality.
59 |   invert H1; equality.
60 | 
61 |   (* Finally, we prove that our new invariant implies the simpler, noninductive
62 |    * one that we started with. *)
63 |   simplify.
64 |   propositional; subst; simplify; propositional.
65 |   (* [subst]: remove all hypotheses like [x = e] for variables [x], simply
66 |    *   replacing all uses of [x] by [e]. *)
67 | Qed.
68 | 
69 | Theorem twoadd2_ok :
70 |   invariantFor (parallel twoadd_sys twoadd_sys) (twoadd_correct (private := _)).
71 | Proof.
72 |   eapply invariant_weaken.
73 |   eapply invariant_simulates.
74 |   apply withInterference_abstracts.
75 |   apply withInterference_parallel.
76 |   apply twoadd_ok.
77 |   apply twoadd_ok.
78 | 
79 |   unfold twoadd_correct.
80 |   invert 1.
81 |   assumption.
82 | Qed.
83 | 


--------------------------------------------------------------------------------
/LICENSE:
--------------------------------------------------------------------------------
 1 | "Formal Reasoning About Programs" code license information
 2 | <http://adam.chlipala.net/frap/>
 3 | ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 4 | 
 5 | CAUTION: Most of the source files in this distribution are NOT
 6 | open-source in the usual sense.  See the comment at the beginning of
 7 | each source file for its license, which is Creative Commons, oriented
 8 | more toward free distribution of books than the usual collaborative
 9 | model of open-source software.  The author really is trying to keep
10 | you from remixing your own versions of the book.
11 | 
12 | However, a few of the library modules used here are sufficiently
13 | useful that they are released separately under a BSD license, included
14 | below.  However, the author's advice is: please don't use these
15 | library modules in real projects.  They are not designed for any use
16 | beside getting the reader up and running quickly in reading the book,
17 | sacrificing practicality (and minimal use of axioms) for simplicity.
18 | 
19 | The following license applies ONLY to the source files:
20 | Relations.v
21 | Map.v
22 | Var.v
23 | Invariant.v
24 | ModelCheck.v
25 | FrapWithoutSets.v
26 | Sets.v
27 | Frap.v
28 | AbstractInterpret.v
29 | SepCancel.v
30 | 
31 | ~~~~~~~~~~~
32 | BSD LICENSE
33 | ~~~~~~~~~~~
34 | 
35 | Copyright (c) 2016-2020, Adam Chlipala
36 | All rights reserved.
37 | 
38 | Redistribution and use in source and binary forms, with or without
39 | modification, are permitted provided that the following conditions are met:
40 | 
41 | - Redistributions of source code must retain the above copyright notice,
42 |   this list of conditions and the following disclaimer.
43 | - Redistributions in binary form must reproduce the above copyright notice,
44 |   this list of conditions and the following disclaimer in the documentation
45 |   and/or other materials provided with the distribution.
46 | - The names of contributors may not be used to endorse or promote products
47 |   derived from this software without specific prior written permission.
48 | 
49 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
50 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
51 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
52 | ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
53 | LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 
54 | CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
55 | SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
56 | INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
57 | CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
58 | ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
59 | POSSIBILITY OF SUCH DAMAGE.
60 | 


--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
 1 | # Formal Reasoning About Programs
 2 | 
 3 | This is an in-progress, open-source book by [Adam Chlipala](http://adam.chlipala.net/) simultaneously introducing [the Coq proof assistant](http://coq.inria.fr/) and techniques for proving correctness of programs.  That is, the game is doing completely rigorous, machine-checked mathematical proofs, showing that programs meet their specifications.
 4 | 
 5 | Just run `make` here to build everything, including the book `frap_book.pdf` and the accompanying Coq source modules.  Alternatively, run `make lib` to build just the book library, not the chapter example files or PDF.
 6 | 
 7 | # Code associated with the different chapters
 8 | 
 9 | The main narrative, also present in the book PDF, presents standard program-proof ideas, without rigorous proofs.  Matching Coq files here show how to make it rigorous.  Interleaved with that narrative, there are also other lectures' worth of material, for building up more practical background on Coq itself.  That secondary track appears in this list, too, at a higher level of indentation.
10 | 
11 | * Chapter 2: `BasicSyntax.v`
12 |   * `Polymorphism.v`: polymorphism and generic data structures
13 | * Chapter 3: `DataAbstraction.v`
14 | * Chapter 4: `Interpreters.v`
15 |   * `FirstClassFunctions.v`: functions as data; continuations and continuation-passing style
16 | * Chapter 5: `RuleInduction.v`
17 | * Chapter 6: `TransitionSystems.v`
18 |   * `IntroToProofScripting.v`: writing scripts to find proofs in Coq
19 | * Chapter 7: `ModelChecking.v`
20 |   * `ProofByReflection.v`: writing verified proof procedures in Coq
21 | * Chapter 8: `OperationalSemantics.v`
22 |   * `LogicProgramming.v`: 'eauto' and friends, to automate proofs via logic programming
23 | * Chapter 9: `AbstractInterpretation.v`
24 | * Chapter 10: `CompilerCorrectness.v`
25 | * Chapter 11: `LambdaCalculusAndTypeSoundness.v`
26 | * Chapter 12: `EvaluationContexts.v`
27 | * Chapter 13: `TypesAndMutation.v`
28 | * Chapter 14: `HoareLogic.v`
29 | * Chapter 15: `DeepAndShallowEmbeddings.v`
30 | * Chapter 16: `SeparationLogic.v`
31 | * Chapter 17: `Connecting.v`
32 | * Chapter 18: `ProgramDerivation.v`
33 | * Chapter 19: `SharedMemory.v`
34 | * Chapter 20: `ConcurrentSeparationLogic.v`
35 | * Chapter 21: `MessagesAndRefinement.v`
36 | * Chapter 22: `SessionTypes.v`
37 | 
38 | There are also two supplementary files that are independent of the main narrative, for introducing programming with dependent types, a distinctive Coq feature that we neither use nor recommend for the problem sets, but which many students find interesting (and useful in other contexts).
39 | * `SubsetTypes.v`: a first introduction to dependent types by attaching predicates to normal types (used after `CompilerCorrectness.v` in the last course offering)
40 | * `DependentInductiveTypes.v`: building type dependency into datatype definitions (used after `LambdaCalculusAndTypeSoundness.v` in the last course offering)
41 | 


--------------------------------------------------------------------------------
/Relations.v:
--------------------------------------------------------------------------------
  1 | Set Implicit Arguments.
  2 | 
  3 | 
  4 | Section trc.
  5 |   Variable A : Type.
  6 |   Variable R : A -> A -> Prop.
  7 | 
  8 |   Inductive trc : A -> A -> Prop :=
  9 |   | TrcRefl : forall x, trc x x
 10 |   | TrcFront : forall x y z,
 11 |     R x y
 12 |     -> trc y z
 13 |     -> trc x z.
 14 | 
 15 |   Hint Constructors trc : core.
 16 | 
 17 |   Theorem trc_one : forall x y, R x y
 18 |     -> trc x y.
 19 |   Proof.
 20 |     eauto.
 21 |   Qed.
 22 | 
 23 |   Hint Resolve trc_one : core.
 24 | 
 25 |   Theorem trc_trans : forall x y, trc x y
 26 |     -> forall z, trc y z
 27 |       -> trc x z.
 28 |   Proof.
 29 |     induction 1; eauto.
 30 |   Qed.
 31 | 
 32 |   Hint Resolve trc_trans : core.
 33 | 
 34 |   Inductive trcEnd : A -> A -> Prop :=
 35 |   | TrcEndRefl : forall x, trcEnd x x
 36 |   | TrcBack : forall x y z,
 37 |     trcEnd x y
 38 |     -> R y z
 39 |     -> trcEnd x z.
 40 | 
 41 |   Hint Constructors trcEnd : core.
 42 | 
 43 |   Lemma TrcFront' : forall x y z,
 44 |     R x y
 45 |     -> trcEnd y z
 46 |     -> trcEnd x z.
 47 |   Proof.
 48 |     induction 2; eauto.
 49 |   Qed.
 50 | 
 51 |   Hint Resolve TrcFront' : core.
 52 | 
 53 |   Theorem trc_trcEnd : forall x y, trc x y
 54 |     -> trcEnd x y.
 55 |   Proof.
 56 |     induction 1; eauto.
 57 |   Qed.
 58 | 
 59 |   Hint Resolve trc_trcEnd : core.
 60 | 
 61 |   Lemma TrcBack' : forall x y z,
 62 |     trc x y
 63 |     -> R y z
 64 |     -> trc x z.
 65 |   Proof.
 66 |     induction 1; eauto.
 67 |   Qed.
 68 | 
 69 |   Hint Resolve TrcBack' : core.
 70 | 
 71 |   Theorem trcEnd_trans : forall x y, trcEnd x y
 72 |     -> forall z, trcEnd y z
 73 |       -> trcEnd x z.
 74 |   Proof.
 75 |     induction 1; eauto.
 76 |   Qed.
 77 | 
 78 |   Hint Resolve trcEnd_trans : core.
 79 |   
 80 |   Theorem trcEnd_trc : forall x y, trcEnd x y
 81 |     -> trc x y.
 82 |   Proof.
 83 |     induction 1; eauto.
 84 |   Qed.
 85 | 
 86 |   Hint Resolve trcEnd_trc : core.
 87 | 
 88 |   Inductive trcLiteral : A -> A -> Prop :=
 89 |   | TrcLiteralRefl : forall x, trcLiteral x x
 90 |   | TrcTrans : forall x y z, trcLiteral x y
 91 |     -> trcLiteral y z
 92 |     -> trcLiteral x z
 93 |   | TrcInclude : forall x y, R x y
 94 |     -> trcLiteral x y.
 95 | 
 96 |   Hint Constructors trcLiteral : core.
 97 | 
 98 |   Theorem trc_trcLiteral : forall x y, trc x y
 99 |     -> trcLiteral x y.
100 |   Proof.
101 |     induction 1; eauto.
102 |   Qed.
103 | 
104 |   Theorem trcLiteral_trc : forall x y, trcLiteral x y
105 |     -> trc x y.
106 |   Proof.
107 |     induction 1; eauto.
108 |   Qed.
109 | 
110 |   Hint Resolve trc_trcLiteral trcLiteral_trc : core.
111 | 
112 |   Theorem trcEnd_trcLiteral : forall x y, trcEnd x y
113 |     -> trcLiteral x y.
114 |   Proof.
115 |     induction 1; eauto.
116 |   Qed.
117 | 
118 |   Theorem trcLiteral_trcEnd : forall x y, trcLiteral x y
119 |     -> trcEnd x y.
120 |   Proof.
121 |     induction 1; eauto.
122 |   Qed.
123 | 
124 |   Hint Resolve trcEnd_trcLiteral trcLiteral_trcEnd : core.
125 | End trc.
126 | 
127 | Notation "R ^*" := (trc R) (at level 0).
128 | Notation "*^ R" := (trcEnd R) (at level 0).
129 | 
130 | Hint Constructors trc : core.
131 | 


--------------------------------------------------------------------------------
/Invariant.v:
--------------------------------------------------------------------------------
  1 | Require Import Relations.
  2 | 
  3 | Set Implicit Arguments.
  4 | 
  5 | 
  6 | Record trsys state := {
  7 |   Initial : state -> Prop;
  8 |   Step : state -> state -> Prop
  9 | }.
 10 | 
 11 | Definition invariantFor {state} (sys : trsys state) (invariant : state -> Prop) :=
 12 |   forall s, sys.(Initial) s
 13 |             -> forall s', sys.(Step)^* s s'
 14 |                           -> invariant s'.
 15 | 
 16 | Theorem use_invariant : forall {state} (sys : trsys state) (invariant : state -> Prop) s s',
 17 |   invariantFor sys invariant
 18 |   -> sys.(Step)^* s s'
 19 |   -> sys.(Initial) s
 20 |   -> invariant s'.
 21 | Proof.
 22 |   firstorder.
 23 | Qed.
 24 | 
 25 | Theorem invariant_weaken : forall {state} (sys : trsys state)
 26 |   (invariant1 invariant2 : state -> Prop),
 27 |   invariantFor sys invariant1
 28 |   -> (forall s, invariant1 s -> invariant2 s)
 29 |   -> invariantFor sys invariant2.
 30 | Proof.
 31 |   unfold invariantFor; intuition eauto.
 32 | Qed.
 33 | 
 34 | Theorem invariant_induction : forall {state} (sys : trsys state)
 35 |   (invariant : state -> Prop),
 36 |   (forall s, sys.(Initial) s -> invariant s)
 37 |   -> (forall s, invariant s -> forall s', sys.(Step) s s' -> invariant s')
 38 |   -> invariantFor sys invariant.
 39 | Proof.
 40 |   unfold invariantFor; intros.
 41 |   assert (invariant s) by eauto.
 42 |   clear H1.
 43 |   induction H2; eauto.
 44 | Qed.
 45 | 
 46 | 
 47 | (** * General parallel composition *)
 48 | 
 49 | Record threaded_state shared private := {
 50 |   Shared : shared;
 51 |   Private : private
 52 | }.
 53 | 
 54 | Inductive parallel1 shared private1 private2
 55 |   (init1 : threaded_state shared private1 -> Prop)
 56 |   (init2 : threaded_state shared private2 -> Prop)
 57 |   : threaded_state shared (private1 * private2) -> Prop :=
 58 | | Pinit : forall sh pr1 pr2,
 59 |   init1 {| Shared := sh; Private := pr1 |}
 60 |   -> init2 {| Shared := sh; Private := pr2 |}
 61 |   -> parallel1 init1 init2 {| Shared := sh; Private := (pr1, pr2) |}.
 62 | 
 63 | Inductive parallel2 shared private1 private2
 64 |           (step1 : threaded_state shared private1 -> threaded_state shared private1 -> Prop)
 65 |           (step2 : threaded_state shared private2 -> threaded_state shared private2 -> Prop)
 66 |           : threaded_state shared (private1 * private2)
 67 |             -> threaded_state shared (private1 * private2) -> Prop :=
 68 | | Pstep1 : forall sh pr1 pr2 sh' pr1',
 69 |   step1 {| Shared := sh; Private := pr1 |} {| Shared := sh'; Private := pr1' |}
 70 |   -> parallel2 step1 step2 {| Shared := sh; Private := (pr1, pr2) |}
 71 |                {| Shared := sh'; Private := (pr1', pr2) |}
 72 | | Pstep2 : forall sh pr1 pr2 sh' pr2',
 73 |   step2 {| Shared := sh; Private := pr2 |} {| Shared := sh'; Private := pr2' |}
 74 |   -> parallel2 step1 step2 {| Shared := sh; Private := (pr1, pr2) |}
 75 |                {| Shared := sh'; Private := (pr1, pr2') |}.
 76 | 
 77 | Definition parallel shared private1 private2
 78 |            (sys1 : trsys (threaded_state shared private1))
 79 |            (sys2 : trsys (threaded_state shared private2)) := {|
 80 |   Initial := parallel1 sys1.(Initial) sys2.(Initial);
 81 |   Step := parallel2 sys1.(Step) sys2.(Step)
 82 | |}.
 83 | 
 84 | 
 85 | (** * Switching to multistep versions of systems *)
 86 | 
 87 | Lemma trc_idem : forall A (R : A -> A -> Prop) x1 x2,
 88 |     R^*^* x1 x2
 89 |     -> R^* x1 x2.
 90 | Proof.
 91 |   induction 1; eauto using trc_trans.
 92 | Qed.
 93 | 
 94 | Theorem invariant_multistepify : forall {state} (sys : trsys state)
 95 |   (invariant : state -> Prop),
 96 |   invariantFor sys invariant
 97 |   -> invariantFor {| Initial := Initial sys; Step := (Step sys)^* |} invariant.
 98 | Proof.
 99 |   unfold invariantFor; simpl; intuition eauto using trc_idem.
100 | Qed.
101 | 


--------------------------------------------------------------------------------
/SubsetTypes_template.v:
--------------------------------------------------------------------------------
  1 | (** Formal Reasoning About Programs <http://adam.chlipala.net/frap/>
  2 |   * Supplementary Rocq material: subset types
  3 |   * Author: Adam Chlipala
  4 |   * License: https://creativecommons.org/licenses/by-nc-nd/4.0/
  5 |   * Much of the material comes from CPDT <http://adam.chlipala.net/cpdt/> by the same author. *)
  6 | 
  7 | Require Import FrapWithoutSets.
  8 | (* We import a pared-down version of the book library, to avoid notations that
  9 |  * clash with some we want to use here. *)
 10 | 
 11 | Set Implicit Arguments.
 12 | Set Asymmetric Patterns.
 13 | 
 14 | 
 15 | (** * Introducing Subset Types *)
 16 | 
 17 | Definition pred (n : nat) : nat :=
 18 |   match n with
 19 |   | O => O
 20 |   | S n' => n'
 21 |   end.
 22 | 
 23 | From Stdlib Require Extraction.
 24 | Extraction pred.
 25 | 
 26 | 
 27 | 
 28 | 
 29 | 
 30 | 
 31 | 
 32 | 
 33 | 
 34 | 
 35 | 
 36 | 
 37 | 
 38 | 
 39 | (** * Decidable Proposition Types *)
 40 | 
 41 | Print sumbool.
 42 | 
 43 | Notation "'Yes'" := (left _ _).
 44 | Notation "'No'" := (right _ _).
 45 | Notation "'Reduce' x" := (if x then Yes else No) (at level 50).
 46 | 
 47 | Definition eq_nat_dec : forall n m : nat, {n = m} + {n <> m}.
 48 | Admitted.
 49 | 
 50 | Compute eq_nat_dec 2 2.
 51 | Compute eq_nat_dec 2 3.
 52 | 
 53 | Extraction eq_nat_dec.
 54 | 
 55 | 
 56 | 
 57 | 
 58 | 
 59 | 
 60 | 
 61 | 
 62 | 
 63 | Section In_dec.
 64 |   Variable A : Set.
 65 |   Variable A_eq_dec : forall x y : A, {x = y} + {x <> y}.
 66 | 
 67 |   (* The final function is easy to write using the techniques we have developed
 68 |    * so far. *)
 69 | 
 70 |   Definition In_dec : forall (x : A) (ls : list A), {In x ls} + {~ In x ls}.
 71 |   Admitted.
 72 | End In_dec.
 73 | 
 74 | Compute In_dec eq_nat_dec 2 (1 :: 2 :: nil).
 75 | Compute In_dec eq_nat_dec 3 (1 :: 2 :: nil).
 76 | 
 77 | Extraction In_dec.
 78 | 
 79 | 
 80 | 
 81 | 
 82 | 
 83 | 
 84 | 
 85 | 
 86 | 
 87 | 
 88 | 
 89 | 
 90 | 
 91 | (** * Partial Subset Types *)
 92 | 
 93 | Inductive maybe (A : Set) (P : A -> Prop) : Set :=
 94 | | Unknown : maybe P
 95 | | Found : forall x : A, P x -> maybe P.
 96 | 
 97 | Notation "{{ x | P }}" := (maybe (fun x => P)).
 98 | Notation "??" := (Unknown _).
 99 | Notation "[| x |]" := (Found _ x _).
100 | 
101 | 
102 | 
103 | 
104 | 
105 | 
106 | 
107 | 
108 | 
109 | 
110 | 
111 | Print sumor.
112 | 
113 | Notation "!!" := (inright _ _).
114 | Notation "[|| x ||]" := (inleft _ [x]).
115 | 
116 | 
117 | 
118 | 
119 | 
120 | 
121 | 
122 | 
123 | 
124 | 
125 | (** * Monadic Notations *)
126 | 
127 | Notation "x <- e1 ; e2" := (match e1 with
128 |                             | Unknown => ??
129 |                             | Found x _ => e2
130 |                            end)
131 | (right associativity, at level 60).
132 | 
133 | Definition doublePred : forall n1 n2 : nat, {{p | n1 = S (fst p) /\ n2 = S (snd p)}}.
134 | Admitted.
135 | 
136 | 
137 | 
138 | 
139 | 
140 | 
141 | 
142 | 
143 | 
144 | 
145 | 
146 | 
147 | 
148 | Notation "x <-- e1 ; e2" := (match e1 with
149 |                              | inright _ => !!
150 |                              | inleft (exist x _) => e2
151 |                              end)
152 | (right associativity, at level 60).
153 | 
154 | Definition doublePred' : forall n1 n2 : nat,
155 |   {p : nat * nat | n1 = S (fst p) /\ n2 = S (snd p)}.
156 | Admitted.
157 | 
158 | 
159 | 
160 | 
161 | 
162 | 
163 | 
164 | 
165 | 
166 | 
167 | 
168 | 
169 | 
170 | 
171 | 
172 | 
173 | (** * A Type-Checking Example *)
174 | 
175 | Inductive exp :=
176 | | Nat (n : nat)
177 | | Plus (e1 e2 : exp)
178 | | Bool (b : bool)
179 | | And (e1 e2 : exp).
180 | 
181 | Inductive type := TNat | TBool.
182 | 
183 | Inductive hasType : exp -> type -> Prop :=
184 | | HtNat : forall n,
185 |   hasType (Nat n) TNat
186 | | HtPlus : forall e1 e2,
187 |   hasType e1 TNat
188 |   -> hasType e2 TNat
189 |   -> hasType (Plus e1 e2) TNat
190 | | HtBool : forall b,
191 |   hasType (Bool b) TBool
192 | | HtAnd : forall e1 e2,
193 |   hasType e1 TBool
194 |   -> hasType e2 TBool
195 |   -> hasType (And e1 e2) TBool.
196 | 
197 | Definition typeCheck : forall e : exp, {{t | hasType e t}}.
198 | Admitted.
199 | 
200 | Compute typeCheck (Nat 0).
201 | Compute typeCheck (Plus (Nat 1) (Nat 2)).
202 | Compute typeCheck (Plus (Nat 1) (Bool false)).
203 | 
204 | Extraction typeCheck.
205 | 


--------------------------------------------------------------------------------
/ModelCheck.v:
--------------------------------------------------------------------------------
  1 | From Stdlib Require Import Classical.
  2 | Require Import Invariant Relations Sets.
  3 | 
  4 | Set Implicit Arguments.
  5 | 
  6 | 
  7 | Definition oneStepClosure_current {state} (sys : trsys state)
  8 |            (invariant1 invariant2 : state -> Prop) :=
  9 |   forall st, invariant1 st
 10 |              -> invariant2 st.
 11 | 
 12 | Definition oneStepClosure_new {state} (sys : trsys state)
 13 |            (invariant1 invariant2 : state -> Prop) :=
 14 |   forall st st', invariant1 st
 15 |                  -> sys.(Step) st st'
 16 |                  -> invariant2 st'.
 17 | 
 18 | Definition oneStepClosure {state} (sys : trsys state)
 19 |            (invariant1 invariant2 : state -> Prop) :=
 20 |   oneStepClosure_current sys invariant1 invariant2
 21 |   /\ oneStepClosure_new sys invariant1 invariant2.
 22 | 
 23 | Theorem prove_oneStepClosure : forall state (sys : trsys state) (inv1 inv2 : state -> Prop),
 24 |   (forall st, inv1 st -> inv2 st)
 25 |   -> (forall st st', inv1 st -> sys.(Step) st st' -> inv2 st')
 26 |   -> oneStepClosure sys inv1 inv2.
 27 | Proof.
 28 |   unfold oneStepClosure; tauto.
 29 | Qed.
 30 | 
 31 | Inductive multiStepClosure {state} (sys : trsys state)
 32 |   : (state -> Prop) -> (state -> Prop) -> (state -> Prop) -> Prop :=
 33 | | MscDone : forall inv,
 34 |     multiStepClosure sys inv (constant nil) inv
 35 | | MscStep : forall inv worklist inv' inv'',
 36 |     oneStepClosure sys worklist inv'
 37 |     -> multiStepClosure sys (inv \cup inv') (inv' \setminus inv) inv''
 38 |     -> multiStepClosure sys inv worklist inv''.
 39 | 
 40 | Lemma adding_irrelevant : forall A (s : A) inv inv',
 41 |     s \in (inv \cup inv') \setminus (inv' \setminus inv)
 42 |    -> s \in inv.
 43 | Proof.
 44 |   sets idtac.
 45 |   destruct (classic (inv s)); tauto.
 46 | Qed.
 47 | 
 48 | Lemma multiStepClosure_ok' : forall state (sys : trsys state) (inv worklist inv' : state -> Prop),
 49 |   multiStepClosure sys inv worklist inv'
 50 |   -> (forall st, sys.(Initial) st -> inv st)
 51 |   -> worklist \subseteq inv
 52 |   -> (forall s, s \in inv \setminus worklist
 53 |                       -> forall s', sys.(Step) s s'
 54 |                                     -> s' \in inv)
 55 |   -> invariantFor sys inv'.
 56 | Proof.
 57 |   induction 1; simpl; intuition.
 58 | 
 59 |   apply invariant_induction; simpl; intuition.
 60 |   eapply H1.
 61 |   red.
 62 |   unfold minus.
 63 |   split; eauto.
 64 |   assumption.
 65 |   
 66 |   apply IHmultiStepClosure; clear IHmultiStepClosure.
 67 |   intuition.
 68 |   apply H1 in H4.
 69 |   sets idtac.
 70 |   sets idtac.
 71 |   intuition.
 72 |   apply adding_irrelevant in H4.
 73 |   destruct (classic (s \in worklist)).
 74 |   destruct H.
 75 |   red in H7.
 76 |   eapply H7 in H6.
 77 |   right; eassumption.
 78 |   assumption.
 79 |   left.
 80 |   eapply H3.
 81 |   2: eassumption.
 82 |   sets idtac.
 83 | Qed.
 84 | 
 85 | Theorem multiStepClosure_ok : forall state (sys : trsys state) (inv : state -> Prop),
 86 |   multiStepClosure sys sys.(Initial) sys.(Initial) inv
 87 |   -> invariantFor sys inv.
 88 | Proof.
 89 |   intros; eapply multiStepClosure_ok'; eauto; sets idtac.
 90 | Qed.
 91 | 
 92 | Theorem oneStepClosure_empty : forall state (sys : trsys state),
 93 |   oneStepClosure sys (constant nil) (constant nil).
 94 | Proof.
 95 |   unfold oneStepClosure, oneStepClosure_current, oneStepClosure_new; intuition.
 96 | Qed.
 97 | 
 98 | Theorem oneStepClosure_split : forall state (sys : trsys state) st sts (inv1 inv2 : state -> Prop),
 99 |   (forall st', sys.(Step) st st' -> inv1 st')
100 |   -> oneStepClosure sys (constant sts) inv2
101 |   -> oneStepClosure sys (constant (st :: sts)) (constant (st :: nil) \cup inv1 \cup inv2).
102 | Proof.
103 |   unfold oneStepClosure, oneStepClosure_current, oneStepClosure_new; intuition.
104 | 
105 |   inversion H0; subst.
106 |   unfold union; simpl; tauto.
107 | 
108 |   unfold union; simpl; eauto.
109 | 
110 |   unfold union in *; simpl in *.
111 |   intuition (subst; eauto).
112 | Qed.
113 | 
114 | Theorem singleton_in : forall {A} (x : A) rest,
115 |   (constant (x :: nil) \cup rest) x.
116 | Proof.
117 |   unfold union; simpl; auto.
118 | Qed.
119 | 
120 | Theorem singleton_in_other : forall {A} (x : A) (s1 s2 : set A),
121 |   s2 x
122 |   -> (s1 \cup s2) x.
123 | Proof.
124 |   unfold union; simpl; auto.
125 | Qed.
126 | 
127 | 
128 | (** * Abstraction *)
129 | 
130 | Inductive simulates state1 state2 (R : state1 -> state2 -> Prop)
131 |   (sys1 : trsys state1) (sys2 : trsys state2) : Prop :=
132 | | Simulates :
133 |   (forall st1, sys1.(Initial) st1
134 |                -> exists st2, R st1 st2
135 |                               /\ sys2.(Initial) st2)
136 |   -> (forall st1 st2, R st1 st2
137 |                       -> forall st1', sys1.(Step) st1 st1'
138 |                                       -> exists st2', R st1' st2'
139 |                                                       /\ sys2.(Step) st2 st2')
140 |   -> simulates R sys1 sys2.
141 | 
142 | Inductive invariantViaSimulation state1 state2 (R : state1 -> state2 -> Prop)
143 |   (inv2 : state2 -> Prop)
144 |   : state1 -> Prop :=
145 | | InvariantViaSimulation : forall st1 st2, R st1 st2
146 |   -> inv2 st2
147 |   -> invariantViaSimulation R inv2 st1.
148 | 
149 | Lemma invariant_simulates' : forall state1 state2 (R : state1 -> state2 -> Prop)
150 |   (sys1 : trsys state1) (sys2 : trsys state2),
151 |   (forall st1 st2, R st1 st2
152 |                    -> forall st1', sys1.(Step) st1 st1'
153 |                                    ->  exists st2', R st1' st2'
154 |                                                     /\ sys2.(Step) st2 st2')
155 |   -> forall st1 st1', sys1.(Step)^* st1 st1'
156 |                       -> forall st2, R st1 st2
157 |                                      -> exists st2', R st1' st2'
158 |                                                      /\ sys2.(Step)^* st2 st2'.
159 | Proof.
160 |   induction 2; simpl; intuition eauto.
161 | 
162 |   eapply H in H2.
163 |   firstorder.
164 |   apply IHtrc in H2.
165 |   firstorder; eauto.
166 |   eauto.
167 | Qed.
168 | 
169 | Local Hint Constructors invariantViaSimulation : core.
170 | 
171 | Theorem invariant_simulates : forall state1 state2 (R : state1 -> state2 -> Prop)
172 |   (sys1 : trsys state1) (sys2 : trsys state2) (inv2 : state2 -> Prop),
173 |   simulates R sys1 sys2
174 |   -> invariantFor sys2 inv2
175 |   -> invariantFor sys1 (invariantViaSimulation R inv2).
176 | Proof.
177 |   inversion_clear 1; intros.
178 |   unfold invariantFor; intros.
179 |   apply H0 in H2.
180 |   firstorder.
181 |   apply invariant_simulates' with (sys2 := sys2) (R := R) (st2 := x) in H3; auto.
182 |   firstorder; eauto.
183 | Qed.
184 | 


--------------------------------------------------------------------------------
/Foundations_template.v:
--------------------------------------------------------------------------------
  1 | Require Import Frap.
  2 | From Stdlib Require Import ZArith.
  3 | 
  4 | (** * Simulating System F *)
  5 | 
  6 | (* We will actually replace [Type] from the book with [Prop] here to get
  7 |  * impredicativity. *)
  8 | 
  9 | Definition nat : Prop :=
 10 |   forall A : Prop, (A -> A) -> A -> A.
 11 | Definition zero : nat :=
 12 |   fun (A : Prop) (f : A -> A) (x : A) => x.
 13 | Definition plus1 : nat -> nat :=
 14 |   fun (n : nat) (A : Prop) (f : A -> A) (x : A) => f (n A f x).
 15 | Definition add : nat -> nat -> nat :=
 16 |   fun (n m : nat) => n nat plus1 m.
 17 | Definition mult : nat -> nat -> nat :=
 18 |   fun (n m : nat) => n nat (add m) zero.
 19 | 
 20 | Goal mult (plus1 zero) (add (plus1 (plus1 zero)) (plus1 zero))
 21 |      = plus1 (plus1 (plus1 zero)).
 22 | Proof.
 23 |   reflexivity.
 24 | Qed.
 25 | (* Note that, all along, the tactic [reflexivity] has applied a decidable
 26 |  * definitional equality like the ones we formalize in this chapter, explaining
 27 |  * its ability to do some computation on our behalf. *)
 28 | 
 29 | Definition True : Prop :=
 30 |   forall A : Prop, A -> A.
 31 | Definition I : True :=
 32 |   fun (A : Prop) (x : A) => x.
 33 | 
 34 | Definition False : Prop :=
 35 |   forall A : Prop, A.
 36 | Definition False_elim : False -> forall A : Prop, A :=
 37 |   fun x : False => x.
 38 | 
 39 | 
 40 | (** * Simulating System Fomega *)
 41 | 
 42 | Definition and : Prop -> Prop -> Prop :=
 43 |   fun A1 A2 : Prop => forall A : Prop, (A1 -> A2 -> A) -> A.
 44 | Definition and_intro : forall A1 A2 : Prop, A1 -> A2 -> and A1 A2 :=
 45 |   fun (A1 A2 : Prop) (x1 : A1) (x2 : A2)
 46 |       (A : Prop) (f : A1 -> A2 -> A) => f x1 x2.
 47 | Definition and_elim1 : forall A1 A2 : Prop, and A1 A2 -> A1 :=
 48 |   fun (A1 A2 : Prop) (x : and A1 A2) =>
 49 |     x A1 (fun (x1 : A1) (x2 : A2) => x1).
 50 | Definition and_elim2 : forall A1 A2 : Prop, and A1 A2 -> A2 :=
 51 |   fun (A1 A2 : Prop) (x : and A1 A2) =>
 52 |     x A2 (fun (x1 : A1) (x2 : A2) => x2).
 53 | 
 54 | (* Example of the encoding in action: *)
 55 | Definition and_comm (A B : Prop) (p : and A B) : and B A.
 56 | Admitted.
 57 | 
 58 | Definition or : Prop -> Prop -> Prop :=
 59 |   fun A1 A2 : Prop => forall A : Prop, (A1 -> A) -> (A2 -> A) -> A.
 60 | Definition or_intro1 : forall A1 A2 : Prop, A1 -> or A1 A2 :=
 61 |   fun (A1 A2 : Prop) (x1 : A1)
 62 |       (A : Prop) (f1 : A1 -> A) (f2 : A2 -> A) => f1 x1.
 63 | Definition or_intro2 : forall A1 A2 : Prop, A2 -> or A1 A2 :=
 64 |   fun (A1 A2 : Prop) (x2 : A2)
 65 |       (A : Prop) (f1 : A1 -> A) (f2 : A2 -> A) => f2 x2.
 66 | Definition or_elim : forall A1 A2 : Prop, or A1 A2
 67 |   -> forall A : Prop, (A1 -> A) -> (A2 -> A) -> A :=
 68 |   fun (A1 A2 : Prop) (x : or A1 A2) => x.
 69 | 
 70 | (* Example of the encoding in action: *)
 71 | Definition or_comm (A B : Prop) (p : or A B) : or B A.
 72 | Admitted.
 73 | 
 74 | 
 75 | (** * Simulating the Calculus of Constructions *)
 76 | 
 77 | Definition ex : forall a : Set, (a -> Prop) -> Prop :=
 78 |   fun (a : Set) (f : a -> Prop) => forall A : Prop, (forall x : a, f x -> A) -> A.
 79 | Definition ex_intro : forall (a : Set) (f : a -> Prop) (v : a), f v -> ex a f :=
 80 |   fun (a : Set) (f : a -> Prop) (x : a) (y : f x) (A : Prop)
 81 |       (k : forall x : a, f x -> A) => k x y.
 82 | Definition ex_elim : forall (a : Set) (f : a -> Prop), ex a f
 83 |   -> forall A : Prop, (forall x : a, f x -> A) -> A :=
 84 |   fun (a : Set) (f : a -> Prop) (x : ex a f) => x.
 85 | 
 86 | (* Example of the encoding in action: *)
 87 | Definition quant_commute (a : Set) (f : a -> a -> Prop)
 88 |            (p : ex a (fun x => forall y : a, f x y))
 89 |   : forall y : a, ex a (fun x => f x y).
 90 | Admitted.
 91 | 
 92 | Definition eq : forall a : Set, a -> a -> Prop :=
 93 |   fun (a : Set) (x y : a) => forall f : a -> Prop, f x -> f y.
 94 | Definition eq_refl : forall (a : Set) (x : a), eq a x x :=
 95 |   fun (a : Set) (x : a) (f : a -> Prop) (p : f x) => p.
 96 | Definition eq_sym : forall (a : Set) (x y : a), eq a x y -> eq a y x :=
 97 |   fun (a : Set) (x y : a) (e : eq a x y) =>
 98 |     e (fun v : a => eq a v x) (eq_refl a x).
 99 | 
100 | 
101 | (** * Illustrating Rocq's own rules for inductive definitions *)
102 | 
103 | (** ** Strict positivity *)
104 | 
105 | Fail Inductive Omega : Set :=
106 | | Make (_ : Omega -> False).
107 | 
108 | Section Omega.
109 |   Variable Omega : Set.
110 |   Variable Make : (Omega -> False) -> Omega.
111 |   Variable Out : Omega -> (Omega -> False).
112 | 
113 |   Definition contra : False.
114 |   Admitted.
115 | End Omega.
116 | 
117 | (** * Universe levels in constructor arguments *)
118 | 
119 | Inductive dyn : Type :=
120 | | Dyn (A : Type) (v : A).
121 | 
122 | Definition zero' : dyn := Dyn nat zero.
123 | Fail Definition zero'' : dyn := Dyn dyn zero'.
124 | (* Universe inconsistency!  The relevant check is working.
125 |  * Note how the error message reveals that Rocq internally is tracking universe
126 |  * levels, though we get to write [Type] without levels. *)
127 | 
128 | (** * Large eliminations *)
129 | 
130 | Inductive exists_positive (P : Z -> Prop) : Prop :=
131 | | ExP (x : Z) (pos : (x > 0)%Z) (p : P x).
132 | 
133 | Definition exists_positive_to_exists (P : Z -> Prop) (e : exists_positive P) : ex Z P :=
134 |   match e with
135 |   | ExP _ x _ p => ex_intro Z P x p
136 |   end.
137 | 
138 | Fail Definition exists_positive_out (P : Z -> Prop) (e : exists_positive P) : Z :=
139 |   match e with
140 |   | ExP _ x _ _ => x
141 |   end.
142 | (* Technically, this one isn't really a large elimination.  The problem we run
143 |  * into here is a restriction on information flow from from proofs into
144 |  * non-[Prop] universes, so that extraction can work properly despite erasing
145 |  * proofs. *)
146 | 
147 | Fail Definition exists_positive_out (P : Z -> Prop) (e : exists_positive P) : Type :=
148 |   match e with
149 |   | ExP _ _ _ _ => dyn
150 |   end.
151 | (* This one is a true large elimination. *)
152 | 
153 | 
154 | (** * Seeing what the Rocq proof engine is up to *)
155 | 
156 | Goal (exists n : Z, n > 0 /\ n > 1)%Z.
157 | Proof.
158 |   eexists.
159 |   split.
160 |   Show Existentials.
161 |   (* Note one existential for [n] and two for the open subgoals. *)
162 | Abort.
163 | 
164 | (* This next theorem is false!  Let's see how Rocq helps us avoid a bogus
165 |  * proof. *)
166 | Goal forall (A B : Set) (P : A -> B -> Prop),
167 |     (forall x : A, exists y : B, P x y) -> (exists y : B, forall x : A, P x y).
168 | Proof.
169 |   intros.
170 |   eexists.
171 |   intro.
172 |   specialize (H x).
173 |   invert H.
174 |   Fail apply H0.
175 |   (* Phew!  This step failed. *)
176 |   Show Existentials.
177 |   (* Now we can see that [?y] exists in a context that doesn't contain [x0],
178 |    * hence our inability to instantiate [?y = x0]. *)
179 | Abort.
180 | 


--------------------------------------------------------------------------------
/LogicProgramming_template.v:
--------------------------------------------------------------------------------
  1 | (** Formal Reasoning About Programs <http://adam.chlipala.net/frap/>
  2 |   * Supplementary Rocq material: unification and logic programming
  3 |   * Author: Adam Chlipala
  4 |   * License: https://creativecommons.org/licenses/by-nc-nd/4.0/
  5 |   * Much of the material comes from CPDT <http://adam.chlipala.net/cpdt/> by the same author. *)
  6 | 
  7 | Require Import Frap.
  8 | 
  9 | Set Implicit Arguments.
 10 | 
 11 | 
 12 | (** * Introducing Logic Programming *)
 13 | 
 14 | (* Recall the definition of addition from the standard library. *)
 15 | 
 16 | Definition real_plus := Eval compute in plus.
 17 | Print real_plus.
 18 | 
 19 | (* Alternatively, we can define it as a relation. *)
 20 | 
 21 | Inductive plusR : nat -> nat -> nat -> Prop :=
 22 | | PlusO : forall m, plusR O m m
 23 | | PlusS : forall n m r, plusR n m r
 24 |   -> plusR (S n) m (S r).
 25 | 
 26 | (* Let's prove the correspondence. *)
 27 | 
 28 | Theorem plusR_plus : forall n m r,
 29 |   plusR n m r
 30 |   -> r = n + m.
 31 | Proof.
 32 | Admitted.
 33 | 
 34 | Theorem plus_plusR : forall n m,
 35 |   plusR n m (n + m).
 36 | Proof.
 37 | Admitted.
 38 | 
 39 | Example four_plus_three : 4 + 3 = 7.
 40 | Proof.
 41 |   reflexivity.
 42 | Qed.
 43 | 
 44 | Print four_plus_three.
 45 | 
 46 | Example four_plus_three' : plusR 4 3 7.
 47 | Proof.
 48 | Admitted.
 49 | 
 50 | Print four_plus_three'.
 51 | 
 52 | Example five_plus_three : plusR 5 3 8.
 53 | Proof.
 54 | Admitted.
 55 | 
 56 | (* Demonstrating _backtracking_ *)
 57 | Example seven_minus_three : exists x, x + 3 = 7.
 58 | Proof.
 59 |   apply ex_intro with 0.
 60 | Abort.
 61 | 
 62 | Example seven_minus_three' : exists x, plusR x 3 7.
 63 | Proof.
 64 | Admitted.
 65 | 
 66 | (* Backwards! *)
 67 | Example seven_minus_four' : exists x, plusR 4 x 7.
 68 | Proof.
 69 | Admitted.
 70 | 
 71 | Example seven_minus_three'' : exists x, x + 3 = 7.
 72 | Proof.
 73 | Admitted.
 74 | 
 75 | Example seven_minus_four : exists x, 4 + x = 7.
 76 | Proof.
 77 | Admitted.
 78 | 
 79 | Example seven_minus_four_zero : exists x, 4 + x + 0 = 7.
 80 | Proof.
 81 | Admitted.
 82 | 
 83 | Check eq_trans.
 84 | 
 85 | Section slow.
 86 |   Hint Resolve eq_trans : core.
 87 | 
 88 |   Example zero_minus_one : exists x, 1 + x = 0.
 89 |     Time eauto 1.
 90 |     Time eauto 2.
 91 |     Time eauto 3.
 92 |     Time eauto 4.
 93 |     Time eauto 5.
 94 | 
 95 |     debug eauto 3.
 96 |   Abort.
 97 | End slow.
 98 | 
 99 | Example from_one_to_zero : exists x, 1 + x = 0.
100 | Proof.
101 | Admitted.
102 | 
103 | Example seven_minus_three_again : exists x, x + 3 = 7.
104 | Proof.
105 | Admitted.
106 | 
107 | Example needs_trans : forall x y, 1 + x = y
108 |   -> y = 2
109 |   -> exists z, z + x = 3.
110 | Proof.
111 | Admitted.
112 | 
113 | 
114 | (** * Searching for Underconstrained Values *)
115 | 
116 | Print Datatypes.length.
117 | 
118 | Example length_1_2 : length (1 :: 2 :: nil) = 2.
119 | Proof.
120 | Admitted.
121 | 
122 | Print length_1_2.
123 | 
124 | Example length_is_2 : exists ls : list nat, length ls = 2.
125 | Proof.
126 | Abort.
127 | 
128 | Print Forall.
129 | 
130 | Example length_is_2 : exists ls : list nat, length ls = 2
131 |   /\ Forall (fun n => n >= 1) ls.
132 | Proof.
133 | Admitted.
134 | 
135 | Print length_is_2.
136 | 
137 | Definition sum := fold_right plus O.
138 | 
139 | Example length_and_sum : exists ls : list nat, length ls = 2
140 |   /\ sum ls = O.
141 | Proof.
142 | Admitted.
143 | 
144 | Print length_and_sum.
145 | 
146 | Example length_and_sum' : exists ls : list nat, length ls = 5
147 |   /\ sum ls = 42.
148 | Proof.
149 | Admitted.
150 | 
151 | Print length_and_sum'.
152 | 
153 | Example length_and_sum'' : exists ls : list nat, length ls = 2
154 |   /\ sum ls = 3
155 |   /\ Forall (fun n => n <> 0) ls.
156 | Proof.
157 | Admitted.
158 | 
159 | Print length_and_sum''.
160 | 
161 | 
162 | (** * Synthesizing Programs *)
163 | 
164 | Inductive exp : Set :=
165 | | Const (n : nat)
166 | | Var
167 | | Plus (e1 e2 : exp).
168 | 
169 | Inductive eval (var : nat) : exp -> nat -> Prop :=
170 | | EvalConst : forall n, eval var (Const n) n
171 | | EvalVar : eval var Var var
172 | | EvalPlus : forall e1 e2 n1 n2, eval var e1 n1
173 |   -> eval var e2 n2
174 |   -> eval var (Plus e1 e2) (n1 + n2).
175 | 
176 | Local Hint Constructors eval : core.
177 | 
178 | Example eval1 : forall var, eval var (Plus Var (Plus (Const 8) Var)) (var + (8 + var)).
179 | Proof.
180 |   auto.
181 | Qed.
182 | 
183 | Example eval1' : forall var, eval var (Plus Var (Plus (Const 8) Var)) (2 * var + 8).
184 | Proof.
185 |   eauto.
186 | Abort.
187 | 
188 | Example eval1' : forall var, eval var (Plus Var (Plus (Const 8) Var)) (2 * var + 8).
189 | Proof.
190 | Admitted.
191 | 
192 | Example synthesize1 : exists e, forall var, eval var e (var + 7).
193 | Proof.
194 | Admitted.
195 | 
196 | Print synthesize1.
197 | 
198 | (* Here are two more examples showing off our program-synthesis abilities. *)
199 | 
200 | Example synthesize2 : exists e, forall var, eval var e (2 * var + 8).
201 | Proof.
202 | Admitted.
203 | 
204 | Print synthesize2.
205 | 
206 | Example synthesize3 : exists e, forall var, eval var e (3 * var + 42).
207 | Proof.
208 | Admitted.
209 | 
210 | Print synthesize3.
211 | 
212 | Theorem linear : forall e, exists k n,
213 |   forall var, eval var e (k * var + n).
214 | Proof.
215 | Admitted.
216 | 
217 | Section side_effect_sideshow.
218 |   Variable A : Set.
219 |   Variables P Q : A -> Prop.
220 |   Variable x : A.
221 | 
222 |   Hypothesis Px : P x.
223 |   Hypothesis Qx : Q x.
224 | 
225 |   Theorem double_threat : exists y, P y /\ Q y.
226 |   Proof.
227 |     eexists; propositional.
228 |     eauto.
229 |     eauto.
230 |   Qed.
231 | End side_effect_sideshow.
232 | 
233 | 
234 | (** * More on [auto] Hints *)
235 | 
236 | Theorem bool_neq : true <> false.
237 | Proof.
238 | Admitted.
239 | 
240 | Section forall_and.
241 |   Variable A : Set.
242 |   Variables P Q : A -> Prop.
243 | 
244 |   Hypothesis both : forall x, P x /\ Q x.
245 | 
246 |   Theorem forall_and : forall z, P z.
247 |   Proof.
248 |   Admitted.
249 | End forall_and.
250 | 
251 | 
252 | (** * Rewrite Hints *)
253 | 
254 | Section autorewrite.
255 |   Variable A : Set.
256 |   Variable f : A -> A.
257 | 
258 |   Hypothesis f_f : forall x, f (f x) = f x.
259 | 
260 |   Hint Rewrite f_f.
261 | 
262 |   Lemma f_f_f : forall x, f (f (f x)) = f x.
263 |   Proof.
264 |     intros; autorewrite with core; reflexivity.
265 |   Qed.
266 | 
267 |   Section garden_path.
268 |     Variable g : A -> A.
269 |     Hypothesis f_g : forall x, f x = g x.
270 |     Hint Rewrite f_g.
271 | 
272 |     Lemma f_f_f' : forall x, f (f (f x)) = f x.
273 |     Proof.
274 |     Admitted.
275 |   End garden_path.
276 | 
277 |   Lemma in_star : forall x y, f (f (f (f x))) = f (f y)
278 |     -> f x = f (f (f y)).
279 |   Proof.
280 |   Admitted.
281 | 
282 | End autorewrite.
283 | 


--------------------------------------------------------------------------------
/Imp.v:
--------------------------------------------------------------------------------
  1 | Require Import Frap.
  2 | 
  3 | Set Implicit Arguments.
  4 | 
  5 | 
  6 | Inductive arith : Set :=
  7 | | Const (n : nat)
  8 | | Var (x : var)
  9 | | Plus (e1 e2 : arith)
 10 | | Minus (e1 e2 : arith)
 11 | | Times (e1 e2 : arith).
 12 | 
 13 | Inductive cmd :=
 14 | | Skip
 15 | | Assign (x : var) (e : arith)
 16 | | Sequence (c1 c2 : cmd)
 17 | | If (e : arith) (then_ else_ : cmd)
 18 | | While (e : arith) (body : cmd).
 19 | 
 20 | Coercion Const : nat >-> arith.
 21 | Coercion Var : var >-> arith.
 22 | (*Declare Scope arith_scope.*)
 23 | Infix "+" := Plus : arith_scope.
 24 | Infix "-" := Minus : arith_scope.
 25 | Infix "*" := Times : arith_scope.
 26 | Delimit Scope arith_scope with arith.
 27 | Notation "x <- e" := (Assign x e%arith) (at level 75).
 28 | Infix ";;" := Sequence (at level 76). (* This one changed slightly, to avoid parsing clashes. *)
 29 | Notation "'when' e 'then' then_ 'else' else_ 'done'" := (If e%arith then_ else_) (at level 75, e at level 0).
 30 | Notation "'while' e 'loop' body 'done'" := (While e%arith body) (at level 75).
 31 | 
 32 | Definition valuation := fmap var nat.
 33 | Fixpoint interp (e : arith) (v : valuation) : nat :=
 34 |   match e with
 35 |   | Const n => n
 36 |   | Var x =>
 37 |     match v $? x with
 38 |     | None => 0
 39 |     | Some n => n
 40 |     end
 41 |   | Plus e1 e2 => interp e1 v + interp e2 v
 42 |   | Minus e1 e2 => interp e1 v - interp e2 v
 43 |   | Times e1 e2 => interp e1 v * interp e2 v
 44 |   end.
 45 | 
 46 | Inductive eval : valuation -> cmd -> valuation -> Prop :=
 47 | | EvalSkip : forall v,
 48 |   eval v Skip v
 49 | | EvalAssign : forall v x e,
 50 |   eval v (Assign x e) (v $+ (x, interp e v))
 51 | | EvalSeq : forall v c1 v1 c2 v2,
 52 |   eval v c1 v1
 53 |   -> eval v1 c2 v2
 54 |   -> eval v (Sequence c1 c2) v2
 55 | | EvalIfTrue : forall v e then_ else_ v',
 56 |   interp e v <> 0
 57 |   -> eval v then_ v'
 58 |   -> eval v (If e then_ else_) v'
 59 | | EvalIfFalse : forall v e then_ else_ v',
 60 |   interp e v = 0
 61 |   -> eval v else_ v'
 62 |   -> eval v (If e then_ else_) v'
 63 | | EvalWhileTrue : forall v e body v' v'',
 64 |   interp e v <> 0
 65 |   -> eval v body v'
 66 |   -> eval v' (While e body) v''
 67 |   -> eval v (While e body) v''
 68 | | EvalWhileFalse : forall v e body,
 69 |   interp e v = 0
 70 |   -> eval v (While e body) v.
 71 | 
 72 | Inductive step : valuation * cmd -> valuation * cmd -> Prop :=
 73 | | StepAssign : forall v x e,
 74 |   step (v, Assign x e) (v $+ (x, interp e v), Skip)
 75 | | StepSeq1 : forall v c1 c2 v' c1',
 76 |   step (v, c1) (v', c1')
 77 |   -> step (v, Sequence c1 c2) (v', Sequence c1' c2)
 78 | | StepSeq2 : forall v c2,
 79 |   step (v, Sequence Skip c2) (v, c2)
 80 | | StepIfTrue : forall v e then_ else_,
 81 |   interp e v <> 0
 82 |   -> step (v, If e then_ else_) (v, then_)
 83 | | StepIfFalse : forall v e then_ else_,
 84 |   interp e v = 0
 85 |   -> step (v, If e then_ else_) (v, else_)
 86 | | StepWhileTrue : forall v e body,
 87 |   interp e v <> 0
 88 |   -> step (v, While e body) (v, Sequence body (While e body))
 89 | | StepWhileFalse : forall v e body,
 90 |   interp e v = 0
 91 |   -> step (v, While e body) (v, Skip).
 92 | 
 93 | Global Hint Constructors trc step eval : core.
 94 | 
 95 | Lemma step_star_Seq : forall v c1 c2 v' c1',
 96 |   step^* (v, c1) (v', c1')
 97 |   -> step^* (v, Sequence c1 c2) (v', Sequence c1' c2).
 98 | Proof.
 99 |   induct 1; eauto.
100 |   cases y; eauto.
101 | Qed.
102 | 
103 | Global Hint Resolve step_star_Seq : core.
104 | 
105 | Theorem big_small : forall v c v', eval v c v'
106 |   -> step^* (v, c) (v', Skip).
107 | Proof.
108 |   induct 1; eauto 6 using trc_trans.
109 | Qed.
110 | 
111 | Lemma small_big'' : forall v c v' c', step (v, c) (v', c')
112 |                                       -> forall v'', eval v' c' v''
113 |                                                      -> eval v c v''.
114 | Proof.
115 |   induct 1; simplify;
116 |   repeat match goal with
117 |          | [ H : eval _ _ _ |- _ ] => invert1 H
118 |          end; eauto.
119 | Qed.
120 | 
121 | Global Hint Resolve small_big'' : core.
122 | 
123 | Lemma small_big' : forall v c v' c', step^* (v, c) (v', c')
124 |                                      -> forall v'', eval v' c' v''
125 |                                                     -> eval v c v''.
126 | Proof.
127 |   induct 1; eauto.
128 |   cases y; eauto.
129 | Qed.
130 | 
131 | Global Hint Resolve small_big' : core.
132 | 
133 | Theorem small_big : forall v c v', step^* (v, c) (v', Skip)
134 |                                    -> eval v c v'.
135 | Proof.
136 |   eauto.
137 | Qed.
138 | 
139 | Definition trsys_of (v : valuation) (c : cmd) : trsys (valuation * cmd) := {|
140 |   Initial := {(v, c)};
141 |   Step := step
142 | |}.
143 | 
144 | Inductive context :=
145 | | Hole
146 | | CSeq (C : context) (c : cmd).
147 | 
148 | Inductive plug : context -> cmd -> cmd -> Prop :=
149 | | PlugHole : forall c, plug Hole c c
150 | | PlugSeq : forall c C c' c2,
151 |   plug C c c'
152 |   -> plug (CSeq C c2) c (Sequence c' c2).
153 | 
154 | Inductive step0 : valuation * cmd -> valuation * cmd -> Prop :=
155 | | Step0Assign : forall v x e,
156 |   step0 (v, Assign x e) (v $+ (x, interp e v), Skip)
157 | | Step0Seq : forall v c2,
158 |   step0 (v, Sequence Skip c2) (v, c2)
159 | | Step0IfTrue : forall v e then_ else_,
160 |   interp e v <> 0
161 |   -> step0 (v, If e then_ else_) (v, then_)
162 | | Step0IfFalse : forall v e then_ else_,
163 |   interp e v = 0
164 |   -> step0 (v, If e then_ else_) (v, else_)
165 | | Step0WhileTrue : forall v e body,
166 |   interp e v <> 0
167 |   -> step0 (v, While e body) (v, Sequence body (While e body))
168 | | Step0WhileFalse : forall v e body,
169 |   interp e v = 0
170 |   -> step0 (v, While e body) (v, Skip).
171 | 
172 | Inductive cstep : valuation * cmd -> valuation * cmd -> Prop :=
173 | | CStep : forall C v c v' c' c1 c2,
174 |   plug C c c1
175 |   -> step0 (v, c) (v', c')
176 |   -> plug C c' c2
177 |   -> cstep (v, c1) (v', c2).
178 | 
179 | Global Hint Constructors plug step0 cstep : core.
180 | 
181 | Theorem step_cstep : forall v c v' c',
182 |   step (v, c) (v', c')
183 |   -> cstep (v, c) (v', c').
184 | Proof.
185 |   induct 1; repeat match goal with
186 |                    | [ H : cstep _ _ |- _ ] => invert H
187 |                    end; eauto.
188 | Qed.
189 | 
190 | Global Hint Resolve step_cstep : core.
191 | 
192 | Lemma step0_step : forall v c v' c',
193 |   step0 (v, c) (v', c')
194 |   -> step (v, c) (v', c').
195 | Proof.
196 |   invert 1; eauto.
197 | Qed.
198 | 
199 | Global Hint Resolve step0_step : core.
200 | 
201 | Lemma cstep_step' : forall C c0 c,
202 |   plug C c0 c
203 |   -> forall v' c'0 v c', step0 (v, c0) (v', c'0)
204 |   -> plug C c'0 c'
205 |   -> step (v, c) (v', c').
206 | Proof.
207 |   induct 1; simplify; repeat match goal with
208 |                              | [ H : plug _ _ _ |- _ ] => invert1 H
209 |                              end; eauto.
210 | Qed.
211 | 
212 | Global Hint Resolve cstep_step' : core.
213 | 
214 | Theorem cstep_step : forall v c v' c',
215 |   cstep (v, c) (v', c')
216 |   -> step (v, c) (v', c').
217 | Proof.
218 |   invert 1; eauto.
219 | Qed.
220 | 


--------------------------------------------------------------------------------
/BasicSyntax_template.v:
--------------------------------------------------------------------------------
  1 | Require Import Frap.
  2 | 
  3 | (* The following definition closely mirrors a standard BNF grammar for expressions.
  4 |  * It defines abstract syntax trees of arithmetic expressions. *)
  5 | Inductive arith : Set :=
  6 | | Const (n : nat)
  7 | | Plus (e1 e2 : arith)
  8 | | Times (e1 e2 : arith).
  9 | 
 10 | (* Here are a few examples of specific expressions. *)
 11 | Example ex1 := Const 42.
 12 | Example ex2 := Plus (Const 1) (Times (Const 2) (Const 3)).
 13 | 
 14 | (* How many nodes appear in the tree for an expression? *)
 15 | Fixpoint size (e : arith) : nat :=
 16 |   match e with
 17 |   | Const _ => 1
 18 |   | Plus e1 e2 => 1 + size e1 + size e2
 19 |   | Times e1 e2 => 1 + size e1 + size e2
 20 |   end.
 21 | 
 22 | (* Here's how to run a program (evaluate a term) in Rocq. *)
 23 | Compute size ex1.
 24 | Compute size ex2.
 25 | 
 26 | (* What's the longest path from the root of a syntax tree to a leaf? *)
 27 | Fixpoint depth (e : arith) : nat :=
 28 |   match e with
 29 |   | Const _ => 1
 30 |   | Plus e1 e2 => 1 + max (depth e1) (depth e2)
 31 |   | Times e1 e2 => 1 + max (depth e1) (depth e2)
 32 |   end.
 33 | 
 34 | Compute depth ex1.
 35 | Compute depth ex2.
 36 | 
 37 | (* Our first proof!
 38 |  * Size is an upper bound on depth. *)
 39 | Theorem depth_le_size : forall e, depth e <= size e.
 40 | Proof.
 41 | Admitted.
 42 | 
 43 | (* A silly recursive function: swap the operand orders of all binary operators. *)
 44 | Fixpoint commuter (e : arith) : arith :=
 45 |   match e with
 46 |   | Const _ => e
 47 |   | Plus e1 e2 => Plus (commuter e2) (commuter e1)
 48 |   | Times e1 e2 => Times (commuter e2) (commuter e1)
 49 |   end.
 50 | 
 51 | Compute commuter ex1.
 52 | Compute commuter ex2.
 53 | 
 54 | (* [commuter] has all the appropriate interactions with other functions (and itself). *)
 55 | 
 56 | Theorem size_commuter : forall e, size (commuter e) = size e.
 57 | Proof.
 58 | Admitted.
 59 | 
 60 | Theorem depth_commuter : forall e, depth (commuter e) = depth e.
 61 | Proof.
 62 | Admitted.
 63 | 
 64 | Theorem commuter_inverse : forall e, commuter (commuter e) = e.
 65 | Proof.
 66 | Admitted.
 67 | 
 68 | 
 69 | 
 70 | 
 71 | 
 72 | 
 73 | 
 74 | 
 75 | 
 76 | 
 77 | 
 78 | 
 79 | 
 80 | 
 81 | 
 82 | 
 83 | 
 84 | 
 85 | (* Now we go back and add this constructor to [arith]:
 86 |    <<
 87 |   | Var (x : var)
 88 |    >>
 89 | 
 90 | (* Now that we have variables, we can consider new operations,
 91 |  * like substituting an expression for a variable. *)
 92 | Fixpoint substitute (inThis : arith) (replaceThis : var) (withThis : arith) : arith :=
 93 |   match inThis with
 94 |   | Const _ => inThis
 95 |   | Var x => if x ==v replaceThis then withThis else inThis
 96 |   | Plus e1 e2 => Plus (substitute e1 replaceThis withThis) (substitute e2 replaceThis withThis)
 97 |   | Times e1 e2 => Times (substitute e1 replaceThis withThis) (substitute e2 replaceThis withThis)
 98 |   end.
 99 | 
100 | (* An intuitive property about how much [substitute] might increase depth. *)
101 | Theorem substitute_depth : forall replaceThis withThis inThis,
102 |   depth (substitute inThis replaceThis withThis) <= depth inThis + depth withThis.
103 | Proof.
104 |   admit.
105 | Qed.
106 | 
107 | (* A silly self-substitution has no effect. *)
108 | Theorem substitute_self : forall replaceThis inThis,
109 |   substitute inThis replaceThis (Var replaceThis) = inThis.
110 | Proof.
111 |   admit.
112 | Qed.
113 | 
114 | (* We can do substitution and commuting in either order. *)
115 | Theorem substitute_commuter : forall replaceThis withThis inThis,
116 |   commuter (substitute inThis replaceThis withThis)
117 |   = substitute (commuter inThis) replaceThis (commuter withThis).
118 | Proof.
119 |   admit.
120 | Qed.
121 | 
122 | (* *Constant folding* is one of the classic compiler optimizations.
123 |  * We repeatedly find opportunities to replace fancier expressions
124 |  * with known constant values. *)
125 | Fixpoint constantFold (e : arith) : arith :=
126 |   match e with
127 |   | Const _ => e
128 |   | Var _ => e
129 |   | Plus e1 e2 =>
130 |     let e1' := constantFold e1 in
131 |     let e2' := constantFold e2 in
132 |     match e1', e2' with
133 |     | Const n1, Const n2 => Const (n1 + n2)
134 |     | Const 0, _ => e2'
135 |     | _, Const 0 => e1'
136 |     | _, _ => Plus e1' e2'
137 |     end
138 |   | Times e1 e2 =>
139 |     let e1' := constantFold e1 in
140 |     let e2' := constantFold e2 in
141 |     match e1', e2' with
142 |     | Const n1, Const n2 => Const (n1 * n2)
143 |     | Const 1, _ => e2'
144 |     | _, Const 1 => e1'
145 |     | Const 0, _ => Const 0
146 |     | _, Const 0 => Const 0
147 |     | _, _ => Times e1' e2'
148 |     end
149 |   end.
150 | 
151 | (* This is supposed to be an *optimization*, so it had better not *increase*
152 |  * the size of an expression! *)
153 | Theorem size_constantFold : forall e, size (constantFold e) <= size e.
154 | Proof.
155 |   admit.
156 | Qed.
157 | 
158 | (* Business as usual, with another commuting law *)
159 | Theorem commuter_constantFold : forall e, commuter (constantFold e) = constantFold (commuter e).
160 | Proof.
161 |   admit.
162 | Qed.
163 | 
164 | (* To define a further transformation, we first write a roundabout way of
165 |  * testing whether an expression is a constant. *)
166 | Definition isConst (e : arith) : option nat :=
167 |   match e with
168 |   | Const n => Some n
169 |   | _ => None
170 |   end.
171 | 
172 | (* Our next target is a function that finds multiplications by constants
173 |  * and pushes the multiplications to the leaves of syntax trees.
174 |  * This helper function takes a coefficient [multiplyBy] that should be
175 |  * applied to an expression. *)
176 | Fixpoint pushMultiplicationInside' (multiplyBy : nat) (e : arith) : arith :=
177 |   match e with
178 |   | Const n => Const (multiplyBy * n)
179 |   | Var _ => Times (Const multiplyBy) e
180 |   | Plus e1 e2 => Plus (pushMultiplicationInside' multiplyBy e1)
181 |                        (pushMultiplicationInside' multiplyBy e2)
182 |   | Times e1 e2 =>
183 |     match isConst e1 with
184 |     | Some k => pushMultiplicationInside' (k * multiplyBy) e2
185 |     | None => Times (pushMultiplicationInside' multiplyBy e1) e2
186 |     end
187 |   end.
188 | 
189 | (* The overall transformation just fixes the initial coefficient as [1]. *)
190 | Definition pushMultiplicationInside (e : arith) : arith :=
191 |   pushMultiplicationInside' 1 e.
192 | 
193 | (* Let's prove this boring arithmetic property, so that we may use it below. *)
194 | Lemma n_times_0 : forall n, n * 0 = 0.
195 | Proof.
196 |   linear_arithmetic.
197 | Qed.
198 | 
199 | (* A fun fact about pushing multiplication inside:
200 |  * the coefficient has no effect on depth!
201 |  * Let's show that any coefficient is equivalent to coefficient 0. *)
202 | Lemma depth_pushMultiplicationInside'_irrelevance0 : forall e multiplyBy,
203 |   depth (pushMultiplicationInside' multiplyBy e)
204 |   = depth (pushMultiplicationInside' 0 e).
205 | Proof.
206 |   admit.
207 | Qed.
208 | 
209 | (* Let's prove that pushing-inside has only a small effect on depth,
210 |  * considering for now only coefficient 0. *)
211 | Lemma depth_pushMultiplicationInside' : forall e,
212 |   depth (pushMultiplicationInside' 0 e) <= S (depth e).
213 | Proof.
214 |   admit.
215 | Qed.
216 | 
217 | Theorem depth_pushMultiplicationInside : forall e,
218 |   depth (pushMultiplicationInside e) <= S (depth e).
219 | Proof.
220 |   admit.
221 | Qed.
222 | *)
223 | 


--------------------------------------------------------------------------------
/Foundations.v:
--------------------------------------------------------------------------------
  1 | (** Formal Reasoning About Programs <http://adam.chlipala.net/frap/>
  2 |   * Chapter 23: Type-Theoretic Foundations of Proof Assistants
  3 |   * Author: Adam Chlipala
  4 |   * License: https://creativecommons.org/licenses/by-nc-nd/4.0/ *)
  5 | 
  6 | Require Import Frap.
  7 | From Stdlib Require Import ZArith.
  8 | 
  9 | (* This book chapter introduces a lot of language metatheory, which we will
 10 |  * *not* mechanize here because surprisingly much bureaucracy would be required.
 11 |  * Instead, we will port the various examples into Rocq itself. *)
 12 | 
 13 | (** * Simulating System F *)
 14 | 
 15 | (* We will actually replace [Type] from the book with [Prop] here to get
 16 |  * impredicativity. *)
 17 | 
 18 | Definition nat : Prop :=
 19 |   forall A : Prop, (A -> A) -> A -> A.
 20 | Definition zero : nat :=
 21 |   fun (A : Prop) (f : A -> A) (x : A) => x.
 22 | Definition plus1 : nat -> nat :=
 23 |   fun (n : nat) (A : Prop) (f : A -> A) (x : A) => f (n A f x).
 24 | Definition add : nat -> nat -> nat :=
 25 |   fun (n m : nat) => n nat plus1 m.
 26 | Definition mult : nat -> nat -> nat :=
 27 |   fun (n m : nat) => n nat (add m) zero.
 28 | 
 29 | Goal mult (plus1 zero) (add (plus1 (plus1 zero)) (plus1 zero))
 30 |      = plus1 (plus1 (plus1 zero)).
 31 | Proof.
 32 |   reflexivity.
 33 | Qed.
 34 | (* Note that, all along, the tactic [reflexivity] has applied a decidable
 35 |  * definitional equality like the ones we formalize in this chapter, explaining
 36 |  * its ability to do some computation on our behalf. *)
 37 | 
 38 | Definition True : Prop :=
 39 |   forall A : Prop, A -> A.
 40 | Definition I : True :=
 41 |   fun (A : Prop) (x : A) => x.
 42 | 
 43 | Definition False : Prop :=
 44 |   forall A : Prop, A.
 45 | Definition False_elim : False -> forall A : Prop, A :=
 46 |   fun x : False => x.
 47 | 
 48 | 
 49 | (** * Simulating System Fomega *)
 50 | 
 51 | Definition and : Prop -> Prop -> Prop :=
 52 |   fun A1 A2 : Prop => forall A : Prop, (A1 -> A2 -> A) -> A.
 53 | Definition and_intro : forall A1 A2 : Prop, A1 -> A2 -> and A1 A2 :=
 54 |   fun (A1 A2 : Prop) (x1 : A1) (x2 : A2)
 55 |       (A : Prop) (f : A1 -> A2 -> A) => f x1 x2.
 56 | Definition and_elim1 : forall A1 A2 : Prop, and A1 A2 -> A1 :=
 57 |   fun (A1 A2 : Prop) (x : and A1 A2) =>
 58 |     x A1 (fun (x1 : A1) (x2 : A2) => x1).
 59 | Definition and_elim2 : forall A1 A2 : Prop, and A1 A2 -> A2 :=
 60 |   fun (A1 A2 : Prop) (x : and A1 A2) =>
 61 |     x A2 (fun (x1 : A1) (x2 : A2) => x2).
 62 | 
 63 | (* Example of the encoding in action: *)
 64 | Definition and_comm (A B : Prop) (p : and A B) : and B A :=
 65 |   and_intro B A (and_elim2 A B p) (and_elim1 A B p).
 66 | 
 67 | Definition or : Prop -> Prop -> Prop :=
 68 |   fun A1 A2 : Prop => forall A : Prop, (A1 -> A) -> (A2 -> A) -> A.
 69 | Definition or_intro1 : forall A1 A2 : Prop, A1 -> or A1 A2 :=
 70 |   fun (A1 A2 : Prop) (x1 : A1)
 71 |       (A : Prop) (f1 : A1 -> A) (f2 : A2 -> A) => f1 x1.
 72 | Definition or_intro2 : forall A1 A2 : Prop, A2 -> or A1 A2 :=
 73 |   fun (A1 A2 : Prop) (x2 : A2)
 74 |       (A : Prop) (f1 : A1 -> A) (f2 : A2 -> A) => f2 x2.
 75 | Definition or_elim : forall A1 A2 : Prop, or A1 A2
 76 |   -> forall A : Prop, (A1 -> A) -> (A2 -> A) -> A :=
 77 |   fun (A1 A2 : Prop) (x : or A1 A2) => x.
 78 | 
 79 | (* Example of the encoding in action: *)
 80 | Definition or_comm (A B : Prop) (p : or A B) : or B A :=
 81 |   or_elim A B p (or B A) (fun p1 => or_intro2 B A p1) (fun p2 => or_intro1 B A p2).
 82 | 
 83 | 
 84 | (** * Simulating the Calculus of Constructions *)
 85 | 
 86 | Definition ex : forall a : Set, (a -> Prop) -> Prop :=
 87 |   fun (a : Set) (f : a -> Prop) => forall A : Prop, (forall x : a, f x -> A) -> A.
 88 | Definition ex_intro : forall (a : Set) (f : a -> Prop) (v : a), f v -> ex a f :=
 89 |   fun (a : Set) (f : a -> Prop) (x : a) (y : f x) (A : Prop)
 90 |       (k : forall x : a, f x -> A) => k x y.
 91 | Definition ex_elim : forall (a : Set) (f : a -> Prop), ex a f
 92 |   -> forall A : Prop, (forall x : a, f x -> A) -> A :=
 93 |   fun (a : Set) (f : a -> Prop) (x : ex a f) => x.
 94 | 
 95 | (* Example of the encoding in action: *)
 96 | Definition quant_commute (a : Set) (f : a -> a -> Prop)
 97 |            (p : ex a (fun x => forall y : a, f x y))
 98 |   : forall y : a, ex a (fun x => f x y) :=
 99 |   fun y : a => ex_elim a (fun x => forall y : a, f x y) p
100 |                        (ex a (fun x => f x y))
101 |                        (fun (x : a) (p : forall y : a, f x y) =>
102 |                           ex_intro a (fun x => f x y) x (p y)).
103 | 
104 | Definition eq : forall a : Set, a -> a -> Prop :=
105 |   fun (a : Set) (x y : a) => forall f : a -> Prop, f x -> f y.
106 | Definition eq_refl : forall (a : Set) (x : a), eq a x x :=
107 |   fun (a : Set) (x : a) (f : a -> Prop) (p : f x) => p.
108 | Definition eq_sym : forall (a : Set) (x y : a), eq a x y -> eq a y x :=
109 |   fun (a : Set) (x y : a) (e : eq a x y) =>
110 |     e (fun v : a => eq a v x) (eq_refl a x).
111 | 
112 | 
113 | (** * Illustrating Rocq's own rules for inductive definitions *)
114 | 
115 | (** ** Strict positivity *)
116 | 
117 | Fail Inductive Omega : Set :=
118 | | Make (_ : Omega -> False).
119 | 
120 | Section Omega.
121 |   Variable Omega : Set.
122 |   Variable Make : (Omega -> False) -> Omega.
123 |   Variable Out : Omega -> (Omega -> False).
124 | 
125 |   Definition omega : Omega := Make (fun x => (Out x) x).
126 |   Definition contra : False := (Out omega) omega.
127 | End Omega.
128 | 
129 | (** * Universe levels in constructor arguments *)
130 | 
131 | Inductive dyn : Type :=
132 | | Dyn (A : Type) (v : A).
133 | 
134 | Definition zero' : dyn := Dyn nat zero.
135 | Fail Definition zero'' : dyn := Dyn dyn zero'.
136 | (* Universe inconsistency!  The relevant check is working.
137 |  * Note how the error message reveals that Rocq internally is tracking universe
138 |  * levels, though we get to write [Type] without levels. *)
139 | 
140 | (** * Large eliminations *)
141 | 
142 | Inductive exists_positive (P : Z -> Prop) : Prop :=
143 | | ExP (x : Z) (pos : (x > 0)%Z) (p : P x).
144 | 
145 | Definition exists_positive_to_exists (P : Z -> Prop) (e : exists_positive P) : ex Z P :=
146 |   match e with
147 |   | ExP _ x _ p => ex_intro Z P x p
148 |   end.
149 | 
150 | Fail Definition exists_positive_out (P : Z -> Prop) (e : exists_positive P) : Z :=
151 |   match e with
152 |   | ExP _ x _ _ => x
153 |   end.
154 | (* Technically, this one isn't really a large elimination.  The problem we run
155 |  * into here is a restriction on information flow from from proofs into
156 |  * non-[Prop] universes, so that extraction can work properly despite erasing
157 |  * proofs. *)
158 | 
159 | Fail Definition exists_positive_out (P : Z -> Prop) (e : exists_positive P) : Type :=
160 |   match e with
161 |   | ExP _ _ _ _ => dyn
162 |   end.
163 | (* This one is a true large elimination. *)
164 | 
165 | 
166 | (** * Seeing what the Rocq proof engine is up to *)
167 | 
168 | Goal (exists n : Z, n > 0 /\ n > 1)%Z.
169 | Proof.
170 |   eexists.
171 |   split.
172 |   Show Existentials.
173 |   (* Note one existential for [n] and two for the open subgoals. *)
174 | Abort.
175 | 
176 | (* This next theorem is false!  Let's see how Rocq helps us avoid a bogus
177 |  * proof. *)
178 | Goal forall (A B : Set) (P : A -> B -> Prop),
179 |     (forall x : A, exists y : B, P x y) -> (exists y : B, forall x : A, P x y).
180 | Proof.
181 |   intros.
182 |   eexists.
183 |   intro.
184 |   specialize (H x).
185 |   invert H.
186 |   Fail apply H0.
187 |   (* Phew!  This step failed. *)
188 |   Show Existentials.
189 |   (* Now we can see that [?y] exists in a context that doesn't contain [x0],
190 |    * hence our inability to instantiate [?y = x0]. *)
191 | Abort.
192 | 
193 | (* Just in case you weren't convinced the last theorem statement was false: *)
194 | Goal ~forall (A B : Set) (P : A -> B -> Prop),
195 |     (forall x : A, exists y : B, P x y) -> (exists y : B, forall x : A, P x y).
196 | Proof.
197 |   intro Hbad.
198 |   specialize (Hbad bool bool (fun b1 b2 => b1 = b2)).
199 |   assert (forall x : bool, exists y, x = y) as Hobvious.
200 |   intro x.
201 |   exists x.
202 |   reflexivity.
203 |   first_order.
204 |   cases x.
205 |   specialize (H false).
206 |   equality.
207 |   specialize (H true).
208 |   equality.
209 | Qed.
210 | 


--------------------------------------------------------------------------------
/Interpreters_template.v:
--------------------------------------------------------------------------------
  1 | Require Import Frap.
  2 | 
  3 | 
  4 | (* We begin with a return to our arithmetic language from the last chapter,
  5 |  * adding subtraction*, which will come in handy later.
  6 |  * *: good pun, right? *)
  7 | Inductive arith : Set :=
  8 | | Const (n : nat)
  9 | | Var (x : var)
 10 | | Plus (e1 e2 : arith)
 11 | | Minus (e1 e2 : arith)
 12 | | Times (e1 e2 : arith).
 13 | 
 14 | Example ex1 := Const 42.
 15 | Example ex2 := Plus (Var "y") (Times (Var "x") (Const 3)).
 16 | 
 17 | Definition valuation := fmap var nat.
 18 | (* A valuation is a finite map from [var] to [nat]. *)
 19 | 
 20 | (* The interpreter is a fairly innocuous-looking recursive function. *)
 21 | Fixpoint interp (e : arith) (v : valuation) : nat :=
 22 |   match e with
 23 |   | Const n => n
 24 |   | Var x =>
 25 |     (* Note use of infix operator to look up a key in a finite map. *)
 26 |     match v $? x with
 27 |     | None => 0 (* goofy default value! *)
 28 |     | Some n => n
 29 |     end
 30 |   | Plus e1 e2 => interp e1 v + interp e2 v
 31 |   | Minus e1 e2 => interp e1 v - interp e2 v
 32 |                    (* For anyone who's wondering: this [-] sticks at 0,
 33 |                     * if we would otherwise underflow. *)
 34 |   | Times e1 e2 => interp e1 v * interp e2 v
 35 |   end.
 36 | 
 37 | (* Here's an example valuation, using an infix operator for map extension. *)
 38 | Definition valuation0 : valuation :=
 39 |   $0 $+ ("x", 17) $+ ("y", 3).
 40 | 
 41 | Theorem interp_ex1 : interp ex1 valuation0 = 42.
 42 | Proof.
 43 |   simplify.
 44 |   equality.
 45 | Qed.
 46 | 
 47 | Theorem interp_ex2 : interp ex2 valuation0 = 54.
 48 | Proof.
 49 |   unfold valuation0.
 50 |   simplify.
 51 |   equality.
 52 | Qed.
 53 | 
 54 | (* Here's the silly transformation we defined last time. *)
 55 | Fixpoint commuter (e : arith) : arith :=
 56 |   match e with
 57 |   | Const _ => e
 58 |   | Var _ => e
 59 |   | Plus e1 e2 => Plus (commuter e2) (commuter e1)
 60 |   | Minus e1 e2 => Minus (commuter e1) (commuter e2)
 61 |                    (* ^-- NB: didn't change the operand order here! *)
 62 |   | Times e1 e2 => Times (commuter e2) (commuter e1)
 63 |   end.
 64 | 
 65 | (* Instead of proving various odds-and-ends properties about it,
 66 |  * let's show what we *really* care about: it preserves the
 67 |  * *meanings* of expressions! *)
 68 | Theorem commuter_ok : forall v e, interp (commuter e) v = interp e v.
 69 | Proof.
 70 | Admitted.
 71 | 
 72 | (* Let's also revisit substitution. *)
 73 | Fixpoint substitute (inThis : arith) (replaceThis : var) (withThis : arith) : arith :=
 74 |   match inThis with
 75 |   | Const _ => inThis
 76 |   | Var x => if x ==v replaceThis then withThis else inThis
 77 |   | Plus e1 e2 => Plus (substitute e1 replaceThis withThis) (substitute e2 replaceThis withThis)
 78 |   | Minus e1 e2 => Minus (substitute e1 replaceThis withThis) (substitute e2 replaceThis withThis)
 79 |   | Times e1 e2 => Times (substitute e1 replaceThis withThis) (substitute e2 replaceThis withThis)
 80 |   end.
 81 | 
 82 | (* How should we state a correctness property for [substitute]?
 83 | Theorem substitute_ok : forall v replaceThis withThis inThis,
 84 |   ...
 85 | Proof.
 86 | 
 87 | Qed.*)
 88 | 
 89 | (* Let's also defined a pared-down version of the expression-simplificaton
 90 |  * functions from last chapter. *)
 91 | Fixpoint doSomeArithmetic (e : arith) : arith :=
 92 |   match e with
 93 |   | Const _ => e
 94 |   | Var _ => e
 95 |   | Plus (Const n1) (Const n2) => Const (n1 + n2)
 96 |   | Plus e1 e2 => Plus (doSomeArithmetic e1) (doSomeArithmetic e2)
 97 |   | Minus e1 e2 => Minus (doSomeArithmetic e1) (doSomeArithmetic e2)
 98 |   | Times (Const n1) (Const n2) => Const (n1 * n2)
 99 |   | Times e1 e2 => Times (doSomeArithmetic e1) (doSomeArithmetic e2)
100 |   end.
101 | 
102 | Theorem doSomeArithmetic_ok : forall e v, interp (doSomeArithmetic e) v = interp e v.
103 | Proof.
104 | Admitted.
105 | 
106 | 
107 | 
108 | 
109 | 
110 | 
111 | 
112 | 
113 | 
114 | 
115 | 
116 | 
117 | 
118 | 
119 | 
120 | 
121 | 
122 | 
123 | 
124 | 
125 | 
126 | 
127 | (* Of course, we're going to get bored if we confine ourselves to arithmetic
128 |  * expressions for the rest of our journey.  Let's get a bit fancier and define
129 |  * a *stack machine*, related to postfix calculators that some of you may have
130 |  * experienced. *)
131 | Inductive instruction :=
132 | | PushConst (n : nat)
133 | | PushVar (x : var)
134 | | Add
135 | | Subtract
136 | | Multiply.
137 | 
138 | (* What does it all mean?  An interpreter tells us unambiguously! *)
139 | Definition run1 (i : instruction) (v : valuation) (stack : list nat) : list nat :=
140 |   match i with
141 |   | PushConst n => n :: stack
142 |   | PushVar x => (match v $? x with
143 |                   | None => 0
144 |                   | Some n => n
145 |                   end) :: stack
146 |   | Add =>
147 |     match stack with
148 |     | arg2 :: arg1 :: stack' => arg1 + arg2 :: stack'
149 |     | _ => stack (* arbitrary behavior in erroneous case (stack underflow) *)
150 |     end
151 |   | Subtract =>
152 |     match stack with
153 |     | arg2 :: arg1 :: stack' => arg1 - arg2 :: stack'
154 |     | _ => stack (* arbitrary behavior in erroneous case *)
155 |     end
156 |   | Multiply =>
157 |     match stack with
158 |     | arg2 :: arg1 :: stack' => arg1 * arg2 :: stack'
159 |     | _ => stack (* arbitrary behavior in erroneous case *)
160 |     end
161 |   end.
162 | 
163 | (* That function explained how to run one instruction.
164 |  * Here's how to run several of them. *)
165 | Fixpoint run (is : list instruction) (v : valuation) (stack : list nat) : list nat :=
166 |   match is with
167 |   | nil => stack
168 |   | i :: is' => run is' v (run1 i v stack)
169 |   end.
170 | 
171 | (* Instead of writing fiddly stack programs ourselves, let's *compile*
172 |  * arithmetic expressions into equivalent stack programs. *)
173 | Fixpoint compile (e : arith) : list instruction :=
174 |   match e with
175 |   | Const n => PushConst n :: nil
176 |   | Var x => PushVar x :: nil
177 |   | Plus e1 e2 => compile e1 ++ compile e2 ++ Add :: nil
178 |   | Minus e1 e2 => compile e1 ++ compile e2 ++ Subtract :: nil
179 |   | Times e1 e2 => compile e1 ++ compile e2 ++ Multiply :: nil
180 |   end.
181 | 
182 | Theorem compile_ok : forall e v, run (compile e) v nil = interp e v :: nil.
183 | Proof.
184 | Admitted.
185 | 
186 | 
187 | 
188 | 
189 | 
190 | 
191 | 
192 | 
193 | 
194 | 
195 | 
196 | 
197 | 
198 | 
199 | 
200 | 
201 | 
202 | 
203 | 
204 | 
205 | 
206 | 
207 | 
208 | 
209 | 
210 | 
211 | 
212 | 
213 | (* Let's get a bit fancier, moving toward the level of general-purpose
214 |  * imperative languages.  Here's a language of commands, building on the
215 |  * language of expressions we have defined. *)
216 | Inductive cmd :=
217 | | Skip
218 | | Assign (x : var) (e : arith)
219 | | Sequence (c1 c2 : cmd)
220 | | Repeat (e : arith) (body : cmd).
221 | 
222 | Fixpoint selfCompose {A} (f : A -> A) (n : nat) : A -> A :=
223 |   match n with
224 |   | O => fun x => x
225 |   | S n' => fun x => selfCompose f n' (f x)
226 |   end.
227 | 
228 | Fixpoint exec (c : cmd) (v : valuation) : valuation :=
229 |   match c with
230 |   | Skip => v
231 |   | Assign x e => v $+ (x, interp e v)
232 |   | Sequence c1 c2 => exec c2 (exec c1 v)
233 |   | Repeat e body => selfCompose (exec body) (interp e v) v
234 |   end.
235 | 
236 | (* Let's define some programs and prove that they operate in certain ways. *)
237 | 
238 | Example factorial_ugly :=
239 |   Sequence
240 |     (Assign "output" (Const 1))
241 |     (Repeat (Var "input")
242 |             (Sequence
243 |                (Assign "output" (Times (Var "output") (Var "input")))
244 |                (Assign "input" (Minus (Var "input") (Const 1))))).
245 | 
246 | (* Ouch; that code is hard to read.  Let's introduce some notations to make the
247 |  * concrete syntax more palatable.  We won't explain the general mechanisms on
248 |  * display here, but see the Rocq manual for details, or try to reverse-engineer
249 |  * them from our examples. *)
250 | Coercion Const : nat >-> arith.
251 | Coercion Var : var >-> arith.
252 | (*Declare Scope arith_scope.*)
253 | Infix "+" := Plus : arith_scope.
254 | Infix "-" := Minus : arith_scope.
255 | Infix "*" := Times : arith_scope.
256 | Delimit Scope arith_scope with arith.
257 | Notation "x <- e" := (Assign x e%arith) (at level 75).
258 | Infix ";" := Sequence (at level 76).
259 | Notation "'repeat' e 'doing' body 'done'" := (Repeat e%arith body) (at level 75).
260 | 
261 | (* OK, let's try that program again. *)
262 | Example factorial :=
263 |   "output" <- 1;
264 |   repeat "input" doing
265 |     "output" <- "output" * "input";
266 |     "input" <- "input" - 1
267 |   done.
268 | 
269 | (* Now we prove that it really computes factorial.
270 |  * First, a reference implementation as a functional program. *)
271 | Fixpoint fact (n : nat) : nat :=
272 |   match n with
273 |   | O => 1
274 |   | S n' => n * fact n'
275 |   end.
276 | 
277 | Theorem factorial_ok : forall v input,
278 |   v $? "input" = Some input
279 |   -> exec factorial v $? "output" = Some (fact input).
280 | Proof.
281 | Admitted.
282 | 
283 | 
284 | 
285 | 
286 | 
287 | 
288 | 
289 | 
290 | 
291 | 
292 | 
293 | 
294 | 
295 | 
296 | 
297 | 
298 | 
299 | 
300 | 
301 | (* One last example: let's try to do loop unrolling, for constant iteration
302 |  * counts.  That is, we can duplicate the loop body instead of using an explicit
303 |  * loop. *)
304 | 
305 | (* This obvious-sounding fact will come in handy: self-composition gives the
306 |  * same result, when passed two functions that map equal inputs to equal
307 |  * outputs. *)
308 | Lemma selfCompose_extensional : forall {A} (f g : A -> A) n x,
309 |   (forall y, f y = g y)
310 |   -> selfCompose f n x = selfCompose g n x.
311 | Proof.
312 |   induct n; simplify; try equality.
313 | 
314 |   rewrite H.
315 |   apply IHn.
316 |   trivial.
317 | Qed.
318 | 
319 | (*Theorem unroll_ok : forall c v, exec (unroll c) v = exec c v.
320 | Proof.
321 | 
322 | Qed.*)
323 | 


--------------------------------------------------------------------------------
/TransitionSystems_template.v:
--------------------------------------------------------------------------------
  1 | (** Formal Reasoning About Programs <http://adam.chlipala.net/frap/>
  2 |   * Chapter 6: Transition Systems
  3 |   * Author: Adam Chlipala
  4 |   * License: https://creativecommons.org/licenses/by-nc-nd/4.0/ *)
  5 | 
  6 | Require Import Frap.
  7 | 
  8 | Set Implicit Arguments.
  9 | (* This command will treat type arguments to functions as implicit, like in
 10 |  * Haskell or ML. *)
 11 | 
 12 | 
 13 | (* Here's a classic recursive, functional program for factorial. *)
 14 | Fixpoint fact (n : nat) : nat :=
 15 |   match n with
 16 |   | O => 1
 17 |   | S n' => fact n' * S n'
 18 |   end.
 19 | 
 20 | (* But let's reformulate factorial relationally, as an example to explore
 21 |  * treatment of inductive relations in Rocq.  First, these are the states of our
 22 |  * state machine. *)
 23 | Inductive fact_state :=
 24 | | AnswerIs (answer : nat)
 25 | | WithAccumulator (input accumulator : nat).
 26 | 
 27 | (* *Initial* states *)
 28 | Inductive fact_init (original_input : nat) : fact_state -> Prop :=
 29 | | FactInit : fact_init original_input (WithAccumulator original_input 1).
 30 | 
 31 | (** *Final* states *)
 32 | Inductive fact_final : fact_state -> Prop :=
 33 | | FactFinal : forall ans, fact_final (AnswerIs ans).
 34 | 
 35 | (** The most important part: the relation to step between states *)
 36 | Inductive fact_step : fact_state -> fact_state -> Prop :=
 37 | | FactDone : forall acc,
 38 |   fact_step (WithAccumulator O acc) (AnswerIs acc)
 39 | | FactStep : forall n acc,
 40 |   fact_step (WithAccumulator (S n) acc) (WithAccumulator n (acc * S n)).
 41 | 
 42 | (* We care about more than just single steps.  We want to run factorial to
 43 |  * completion, for which it is handy to define a general relation of
 44 |  * *transitive-reflexive closure*, like so. *)
 45 | Inductive trc {A} (R : A -> A -> Prop) : A -> A -> Prop :=
 46 | | TrcRefl : forall x, trc R x x
 47 | | TrcFront : forall x y z,
 48 |   R x y
 49 |   -> trc R y z
 50 |   -> trc R x z.
 51 | 
 52 | (* Transitive-reflexive closure is so common that it deserves a shorthand notation! *)
 53 | Set Warnings "-notation-overridden". (* <-- needed while we play with defining one
 54 |                                       * of the book's notations ourselves locally *)
 55 | Notation "R ^*" := (trc R) (at level 0).
 56 | 
 57 | (* Now let's use it to execute the factorial program. *)
 58 | Example factorial_3 : fact_step^* (WithAccumulator 3 1) (AnswerIs 6).
 59 | Proof.
 60 | Admitted.
 61 | 
 62 | (* It will be useful to give state machines more first-class status, as
 63 |  * *transition systems*, formalized by this record type.  It has one type
 64 |  * parameter, [state], which records the type of states. *)
 65 | Record trsys state := {
 66 |   Initial : state -> Prop;
 67 |   Step : state -> state -> Prop
 68 | }.
 69 | 
 70 | (* The example of our factorial program: *)
 71 | Definition factorial_sys (original_input : nat) : trsys fact_state := {|
 72 |   Initial := fact_init original_input;
 73 |   Step := fact_step
 74 | |}.
 75 | 
 76 | (* A useful general notion for transition systems: reachable states *)
 77 | Inductive reachable {state} (sys : trsys state) (st : state) : Prop :=
 78 | | Reachable : forall st0,
 79 |   sys.(Initial) st0
 80 |   -> sys.(Step)^* st0 st
 81 |   -> reachable sys st.
 82 | 
 83 | (* To prove that our state machine is correct, we rely on the crucial technique
 84 |  * of *invariants*.  What is an invariant?  Here's a general definition, in
 85 |  * terms of an arbitrary transition system. *)
 86 | Definition invariantFor {state} (sys : trsys state) (invariant : state -> Prop) :=
 87 |   forall s, sys.(Initial) s
 88 |             -> forall s', sys.(Step)^* s s'
 89 |                           -> invariant s'.
 90 | (* That is, when we begin in an initial state and take any number of steps, the
 91 |  * place we wind up always satisfies the invariant. *)
 92 | 
 93 | (* Here's a simple lemma to help us apply an invariant usefully,
 94 |  * really just restating the definition. *)
 95 | Lemma use_invariant' : forall {state} (sys : trsys state)
 96 |   (invariant : state -> Prop) s s',
 97 |   invariantFor sys invariant
 98 |   -> sys.(Initial) s
 99 |   -> sys.(Step)^* s s'
100 |   -> invariant s'.
101 | Proof.
102 |   unfold invariantFor.
103 |   simplify.
104 |   eapply H.
105 |   eassumption.
106 |   assumption.
107 | Qed.
108 | 
109 | Theorem use_invariant : forall {state} (sys : trsys state)
110 |   (invariant : state -> Prop) s,
111 |   invariantFor sys invariant
112 |   -> reachable sys s
113 |   -> invariant s.
114 | Proof.
115 |   simplify.
116 |   invert H0.
117 |   eapply use_invariant'.
118 |   eassumption.
119 |   eassumption.
120 |   assumption.
121 | Qed.
122 | 
123 | (* What's the most fundamental way to establish an invariant?  Induction! *)
124 | Lemma invariant_induction' : forall {state} (sys : trsys state)
125 |   (invariant : state -> Prop),
126 |   (forall s, invariant s -> forall s', sys.(Step) s s' -> invariant s')
127 |   -> forall s s', sys.(Step)^* s s'
128 |      -> invariant s
129 |      -> invariant s'.
130 | Proof.
131 |   induct 2; propositional.
132 |   (* [propositional]: simplify the goal according to the rules of propositional
133 |    *   logic. *)
134 | 
135 |   apply IHtrc.
136 |   eapply H.
137 |   eassumption.
138 |   assumption.
139 | Qed.
140 | 
141 | Theorem invariant_induction : forall {state} (sys : trsys state)
142 |   (invariant : state -> Prop),
143 |   (forall s, sys.(Initial) s -> invariant s)
144 |   -> (forall s, invariant s -> forall s', sys.(Step) s s' -> invariant s')
145 |   -> invariantFor sys invariant.
146 | Proof.
147 |   unfold invariantFor; intros.
148 |   eapply invariant_induction'.
149 |   eassumption.
150 |   eassumption.
151 |   apply H.
152 |   assumption.
153 | Qed.
154 | 
155 | Definition fact_invariant (original_input : nat) (st : fact_state) : Prop :=
156 |   True.
157 | (* We must fill in a better invariant. *)
158 | 
159 | Theorem fact_invariant_ok : forall original_input,
160 |   invariantFor (factorial_sys original_input) (fact_invariant original_input).
161 | Proof.
162 | Admitted.
163 | 
164 | (* Therefore, every reachable state satisfies this invariant. *)
165 | Theorem fact_invariant_always : forall original_input s,
166 |   reachable (factorial_sys original_input) s
167 |   -> fact_invariant original_input s.
168 | Proof.
169 |   simplify.
170 |   eapply use_invariant.
171 |   apply fact_invariant_ok.
172 |   assumption.
173 | Qed.
174 | 
175 | (* Therefore, any final state has the right answer! *)
176 | Lemma fact_ok' : forall original_input s,
177 |   fact_final s
178 |   -> fact_invariant original_input s
179 |   -> s = AnswerIs (fact original_input).
180 | Admitted.
181 | 
182 | Theorem fact_ok : forall original_input s,
183 |   reachable (factorial_sys original_input) s
184 |   -> fact_final s
185 |   -> s = AnswerIs (fact original_input).
186 | Proof.
187 |   simplify.
188 |   apply fact_ok'.
189 |   assumption.
190 |   apply fact_invariant_always.
191 |   assumption.
192 | Qed.
193 | 
194 | 
195 | (** * A simple example of another program as a state transition system *)
196 | 
197 | (* We'll formalize this pseudocode for one thread of a concurrent, shared-memory program.
198 |   lock();
199 |   local = global;
200 |   global = local + 1;
201 |   unlock();
202 | *)
203 | 
204 | (* This inductive state effectively encodes all possible combinations of two
205 |  * kinds of *local*state* in a thread:
206 |  * - program counter
207 |  * - values of local variables that may be read eventually *)
208 | Inductive increment_program :=
209 | | Lock
210 | | Read
211 | | Write (local : nat)
212 | | Unlock
213 | | Done.
214 | 
215 | (* Next, a type for state shared between threads. *)
216 | Record inc_state := {
217 |   Locked : bool; (* Does a thread hold the lock? *)
218 |   Global : nat   (* A shared counter *)
219 | }.
220 | 
221 | (* The combined state, from one thread's perspective, using a general
222 |  * definition. *)
223 | Record threaded_state shared private := {
224 |   Shared : shared;
225 |   Private : private
226 | }.
227 | 
228 | Definition increment_state := threaded_state inc_state increment_program.
229 | 
230 | (* Now a routine definition of the three key relations of a transition system.
231 |  * The most interesting logic surrounds saving the counter value in the local
232 |  * state after reading. *)
233 | 
234 | Inductive increment_init : increment_state -> Prop :=
235 | | IncInit :
236 |   increment_init {| Shared := {| Locked := false; Global := O |};
237 |                     Private := Lock |}.
238 | 
239 | Inductive increment_step : increment_state -> increment_state -> Prop :=
240 | | IncLock : forall g,
241 |   increment_step {| Shared := {| Locked := false; Global := g |};
242 |                     Private := Lock |}
243 |                  {| Shared := {| Locked := true; Global := g |};
244 |                     Private := Read |}
245 | | IncRead : forall l g,
246 |   increment_step {| Shared := {| Locked := l; Global := g |};
247 |                     Private := Read |}
248 |                  {| Shared := {| Locked := l; Global := g |};
249 |                     Private := Write g |}
250 | | IncWrite : forall l g v,
251 |   increment_step {| Shared := {| Locked := l; Global := g |};
252 |                     Private := Write v |}
253 |                  {| Shared := {| Locked := l; Global := S v |};
254 |                     Private := Unlock |}
255 | | IncUnlock : forall l g,
256 |   increment_step {| Shared := {| Locked := l; Global := g |};
257 |                     Private := Unlock |}
258 |                  {| Shared := {| Locked := false; Global := g |};
259 |                     Private := Done |}.
260 | 
261 | Definition increment_sys := {|
262 |   Initial := increment_init;
263 |   Step := increment_step
264 | |}.
265 | 
266 | 
267 | (** * Running transition systems in parallel *)
268 | 
269 | (* That last example system is a cop-out: it only runs a single thread.  We want
270 |  * to run several threads in parallel, sharing the global state.  Here's how we
271 |  * can do it for just two threads.  The key idea is that, while in the new
272 |  * system the type of shared state remains the same, we take the Cartesian
273 |  * product of the sets of private state. *)
274 | 
275 | Inductive parallel_init shared private1 private2
276 |   (init1 : threaded_state shared private1 -> Prop)
277 |   (init2 : threaded_state shared private2 -> Prop)
278 |   : threaded_state shared (private1 * private2) -> Prop :=
279 | | Pinit : forall sh pr1 pr2,
280 |   init1 {| Shared := sh; Private := pr1 |}
281 |   -> init2 {| Shared := sh; Private := pr2 |}
282 |   -> parallel_init init1 init2 {| Shared := sh; Private := (pr1, pr2) |}.
283 | 
284 | Inductive parallel_step shared private1 private2
285 |           (step1 : threaded_state shared private1 -> threaded_state shared private1 -> Prop)
286 |           (step2 : threaded_state shared private2 -> threaded_state shared private2 -> Prop)
287 |           : threaded_state shared (private1 * private2)
288 |             -> threaded_state shared (private1 * private2) -> Prop :=
289 | | Pstep1 : forall sh pr1 pr2 sh' pr1',
290 |   (* First thread gets to run. *)
291 |   step1 {| Shared := sh; Private := pr1 |} {| Shared := sh'; Private := pr1' |}
292 |   -> parallel_step step1 step2 {| Shared := sh; Private := (pr1, pr2) |}
293 |                {| Shared := sh'; Private := (pr1', pr2) |}
294 | | Pstep2 : forall sh pr1 pr2 sh' pr2',
295 |   (* Second thread gets to run. *)
296 |   step2 {| Shared := sh; Private := pr2 |} {| Shared := sh'; Private := pr2' |}
297 |   -> parallel_step step1 step2 {| Shared := sh; Private := (pr1, pr2) |}
298 |                {| Shared := sh'; Private := (pr1, pr2') |}.
299 | 
300 | Definition parallel shared private1 private2
301 |            (sys1 : trsys (threaded_state shared private1))
302 |            (sys2 : trsys (threaded_state shared private2)) := {|
303 |   Initial := parallel_init sys1.(Initial) sys2.(Initial);
304 |   Step := parallel_step sys1.(Step) sys2.(Step)
305 | |}.
306 | 
307 | (* Example: composing two threads of the kind we formalized earlier *)
308 | Definition increment2_sys := parallel increment_sys increment_sys.
309 | 
310 | (* Let's prove that the counter is always 2 when the composed program terminates. *)
311 | 
312 | (** We must write an invariant. *)
313 | Inductive increment2_invariant :
314 |   threaded_state inc_state (increment_program * increment_program) -> Prop :=
315 | | Inc2Inv : forall sh pr1 pr2,
316 |   increment2_invariant {| Shared := sh; Private := (pr1, pr2) |}.
317 | (* This isn't it yet! *)
318 | 
319 | (* Now, to show it really is an invariant. *)
320 | Theorem increment2_invariant_ok : invariantFor increment2_sys increment2_invariant.
321 | Proof.
322 | Admitted.
323 | 
324 | (* Now, to prove our final result about the two incrementing threads, let's use
325 |  * a more general fact, about when one invariant implies another. *)
326 | Theorem invariant_weaken : forall {state} (sys : trsys state)
327 |   (invariant1 invariant2 : state -> Prop),
328 |   invariantFor sys invariant1
329 |   -> (forall s, invariant1 s -> invariant2 s)
330 |   -> invariantFor sys invariant2.
331 | Proof.
332 |   unfold invariantFor; simplify.
333 |   apply H0.
334 |   eapply H.
335 |   eassumption.
336 |   assumption.
337 | Qed.
338 | 
339 | (* Here's another, much weaker invariant, corresponding exactly to the overall
340 |  * correctness property we want to establish for this system. *)
341 | Definition increment2_right_answer
342 |   (s : threaded_state inc_state (increment_program * increment_program)) :=
343 |   s.(Private) = (Done, Done)
344 |   -> s.(Shared).(Global) = 2.
345 | 
346 | (** Now we can prove that the system only runs to happy states. *)
347 | Theorem increment2_sys_correct : forall s,
348 |   reachable increment2_sys s
349 |   -> increment2_right_answer s.
350 | Proof.
351 | Admitted.
352 | (*simplify.
353 |   eapply use_invariant.
354 |   apply invariant_weaken with (invariant1 := increment2_invariant).
355 |   (* Note the use of a [with] clause to specify a quantified variable's
356 |    * value. *)
357 | 
358 |   apply increment2_invariant_ok.
359 | 
360 |   simplify.
361 |   invert H0.
362 |   unfold increment2_right_answer; simplify.
363 |   invert H0.
364 |   (* Here we use inversion on an equality, to derive more primitive
365 |    * equalities. *)
366 |   simplify.
367 |   equality.
368 | 
369 |   assumption.
370 | Qed.*)
371 | 


--------------------------------------------------------------------------------
/ProofByReflection_template.v:
--------------------------------------------------------------------------------
  1 | Require Import Frap.
  2 | 
  3 | Set Implicit Arguments.
  4 | Set Asymmetric Patterns.
  5 | Set Universe Polymorphism.
  6 | 
  7 | 
  8 | (** * Proving Evenness *)
  9 | 
 10 | Inductive isEven : nat -> Prop :=
 11 | | Even_O : isEven O
 12 | | Even_SS : forall n, isEven n -> isEven (S (S n)).
 13 | 
 14 | Theorem even_256 : isEven 256.
 15 | Proof.
 16 | Admitted.
 17 | 
 18 | 
 19 | 
 20 | 
 21 | 
 22 | 
 23 | 
 24 | 
 25 | 
 26 | 
 27 | 
 28 | 
 29 | 
 30 | 
 31 | 
 32 | 
 33 | 
 34 | 
 35 | 
 36 | (** * Reifying the Syntax of a Trivial Tautology Language *)
 37 | 
 38 | Theorem true_galore : (True /\ True) -> (True \/ (True /\ (True -> True))).
 39 | Proof.
 40 |   tauto.
 41 | Qed.
 42 | 
 43 | Print true_galore.
 44 | 
 45 | 
 46 | 
 47 | 
 48 | 
 49 | 
 50 | 
 51 | 
 52 | 
 53 | 
 54 | 
 55 | 
 56 | 
 57 | 
 58 | 
 59 | 
 60 | 
 61 | 
 62 | 
 63 | 
 64 | 
 65 | 
 66 | (** * A Monoid Expression Simplifier *)
 67 | 
 68 | Section monoid.
 69 |   Variable A : Set.
 70 |   Variable e : A.
 71 |   Variable f : A -> A -> A.
 72 | 
 73 |   Infix "+" := f.
 74 | 
 75 |   Hypothesis assoc : forall a b c, (a + b) + c = a + (b + c).
 76 |   Hypothesis identl : forall a, e + a = a.
 77 |   Hypothesis identr : forall a, a + e = a.
 78 | 
 79 |   Inductive mexp : Set :=
 80 |   | Ident : mexp
 81 |   | Var : A -> mexp
 82 |   | Op : mexp -> mexp -> mexp.
 83 | 
 84 |   (* Next, we write an interpretation function. *)
 85 | 
 86 |   Fixpoint mdenote (me : mexp) : A :=
 87 |     match me with
 88 |       | Ident => e
 89 |       | Var v => v
 90 |       | Op me1 me2 => mdenote me1 + mdenote me2
 91 |     end.
 92 | 
 93 | 
 94 | 
 95 | 
 96 | 
 97 | 
 98 | 
 99 | 
100 | 
101 | 
102 | 
103 | 
104 | 
105 | 
106 | 
107 | 
108 | 
109 | 
110 | 
111 | 
112 | 
113 | 
114 | 
115 | 
116 | 
117 | 
118 | 
119 | 
120 | 
121 | 
122 | 
123 |   Ltac reify me :=
124 |     match me with
125 |       | e => Ident
126 |       | ?me1 + ?me2 =>
127 |         let r1 := reify me1 in
128 |         let r2 := reify me2 in
129 |           constr:(Op r1 r2)
130 |       | _ => constr:(Var me)
131 |     end.
132 | 
133 |   (*Ltac monoid :=
134 |     match goal with
135 |       | [ |- ?me1 = ?me2 ] =>
136 |         let r1 := reify me1 in
137 |         let r2 := reify me2 in
138 |           change (mdenote r1 = mdenote r2);
139 |             apply monoid_reflect; simplify
140 |     end.
141 | 
142 |   Theorem t1 : forall a b c d, a + b + c + d = a + (b + c) + d.
143 |     simplify; monoid.
144 |     reflexivity.
145 |   Qed.*)
146 | End monoid.
147 | 
148 | 
149 | 
150 | (** * Set Simplification for Model Checking *)
151 | 
152 | (* Let's take a closer look at model-checking proofs like from last class. *)
153 | 
154 | (* Here's a simple transition system, where state is just a [nat], and where
155 |  * each step subtracts 1 or 2. *)
156 | 
157 | Inductive subtract_step : nat -> nat -> Prop :=
158 | | Subtract1 : forall n, subtract_step (S n) n
159 | | Subtract2 : forall n, subtract_step (S (S n)) n.
160 | 
161 | Definition subtract_sys (n : nat) : trsys nat := {|
162 |   Initial := {n};
163 |   Step := subtract_step
164 | |}.
165 | 
166 | Lemma subtract_ok :
167 |   invariantFor (subtract_sys 5)
168 |                (fun n => n <= 5).
169 | Proof.
170 |   eapply invariant_weaken.
171 | 
172 |   apply multiStepClosure_ok.
173 |   simplify.
174 |   (* Here we'll see that the Frap library uses slightly different, optimized
175 |    * versions of the model-checking relations.  For instance, [multiStepClosure]
176 |    * takes an extra set argument, the _worklist_ recording newly discovered
177 |    * states.  There is no point in following edges out of states that were
178 |    * already known at previous steps. *)
179 | 
180 |   (* Now, some more manual iterations: *)
181 |   eapply MscStep.
182 |   closure.
183 |   (* Ew.  What a big, ugly set expression.  Let's shrink it down to something
184 |    * more readable, with duplicates removed, etc. *)
185 |   simplify.
186 |   (* How does the Frap library do that?  Proof by reflection is a big part of
187 |    * it!  Let's develop a baby version of that automation.  The full-scale
188 |    * version is in file Sets.v. *)
189 | Abort.
190 | 
191 | 
192 | 
193 | 
194 | 
195 | 
196 | 
197 | 
198 | 
199 | 
200 | 
201 | 
202 | 
203 | 
204 | 
205 | 
206 | (* Back to our example, which we can now finish without calling [simplify] to
207 |  * reduces trees of union operations. *)
208 | (*Lemma subtract_ok :
209 |   invariantFor (subtract_sys 5)
210 |                (fun n => n <= 5).
211 | Proof.
212 |   eapply invariant_weaken.
213 | 
214 |   apply multiStepClosure_ok.
215 |   simplify.
216 | 
217 |   (* Now, some more manual iterations: *)
218 |   eapply MscStep.
219 |   closure.
220 |   simplify_set.
221 |   (* Success!  One subexpression shrunk.  Now for the other. *)
222 |   simplify_set.
223 |   (* Our automation doesn't handle set difference, so we finish up calling the
224 |    * library tactic. *)
225 |   simplify.
226 | 
227 |   eapply MscStep.
228 |   closure.
229 |   simplify_set.
230 |   simplify_set.
231 |   simplify.
232 | 
233 |   eapply MscStep.
234 |   closure.
235 |   simplify_set.
236 |   simplify_set.
237 |   simplify.
238 | 
239 |   eapply MscStep.
240 |   closure.
241 |   simplify_set.
242 |   simplify_set.
243 |   simplify.
244 | 
245 |   model_check_done.
246 | 
247 |   simplify.
248 |   linear_arithmetic.
249 | Qed.*)
250 | 
251 | 
252 | (** * A Smarter Tautology Solver *)
253 | 
254 | Definition propvar := nat.
255 | 
256 | Inductive formula : Set :=
257 | | Atomic : propvar -> formula
258 | | Truth : formula
259 | | Falsehood : formula
260 | | And : formula -> formula -> formula
261 | | Or : formula -> formula -> formula
262 | | Imp : formula -> formula -> formula.
263 | 
264 | Definition asgn := nat -> Prop.
265 | 
266 | Fixpoint formulaDenote (atomics : asgn) (f : formula) : Prop :=
267 |   match f with
268 |     | Atomic v => atomics v
269 |     | Truth => True
270 |     | Falsehood => False
271 |     | And f1 f2 => formulaDenote atomics f1 /\ formulaDenote atomics f2
272 |     | Or f1 f2 => formulaDenote atomics f1 \/ formulaDenote atomics f2
273 |     | Imp f1 f2 => formulaDenote atomics f1 -> formulaDenote atomics f2
274 |   end.
275 | 
276 | From Stdlib Require Import ListSet.
277 | 
278 | Section my_tauto.
279 |   Variable atomics : asgn.
280 | 
281 |   Definition add (s : set propvar) (v : propvar) := set_add eq_nat_dec v s.
282 | 
283 |   Fixpoint allTrue (s : set propvar) : Prop :=
284 |     match s with
285 |       | nil => True
286 |       | v :: s' => atomics v /\ allTrue s'
287 |     end.
288 | 
289 |   Theorem allTrue_add : forall v s,
290 |     allTrue s
291 |     -> atomics v
292 |     -> allTrue (add s v).
293 |   Proof.
294 |     induct s; simplify; propositional;
295 |       match goal with
296 |         | [ |- context[if ?E then _ else _] ] => destruct E
297 |       end; simplify; propositional.
298 |   Qed.
299 | 
300 |   Theorem allTrue_In : forall v s,
301 |     allTrue s
302 |     -> set_In v s
303 |     -> atomics v.
304 |   Proof.
305 |     induct s; simplify; equality.
306 |   Qed.
307 | 
308 |   Fixpoint forward (known : set propvar) (hyp : formula)
309 |            (cont : set propvar -> bool) : bool :=
310 |     match hyp with
311 |     | Atomic v => cont (add known v)
312 |     | Truth => cont known
313 |     | Falsehood => true
314 |     | And h1 h2 => forward known h1 (fun known' =>
315 |                      forward known' h2 cont)
316 |     | Or h1 h2 => forward known h1 cont && forward known h2 cont
317 |     | Imp _ _ => cont known
318 |     end.
319 | 
320 |   Compute fun cont => forward [] (Atomic 0) cont.
321 |   Compute fun cont => forward [] (Or (Atomic 0) (Atomic 1)) cont.
322 |   Compute fun cont => forward [] (Or (Atomic 0) (And (Atomic 1) (Atomic 2))) cont.
323 |   
324 |   Fixpoint backward (known : set propvar) (f : formula) : bool :=
325 |     match f with
326 |     | Atomic v => if In_dec eq_nat_dec v known then true else false
327 |     | Truth => true
328 |     | Falsehood => false
329 |     | And f1 f2 => backward known f1 && backward known f2
330 |     | Or f1 f2 => backward known f1 || backward known f2
331 |     | Imp f1 f2 => forward known f1 (fun known' => backward known' f2)
332 |     end.
333 | 
334 |   Compute backward [] (Atomic 0).
335 |   Compute backward [0] (Atomic 0).
336 |   Compute backward [0; 2] (Or (Atomic 0) (Atomic 1)).
337 |   Compute backward [2] (Or (Atomic 0) (Atomic 1)).
338 |   Compute backward [2] (Imp (Atomic 0) (Or (Atomic 0) (Atomic 1))).
339 |   Compute backward [2] (Imp (Or (Atomic 0) (Atomic 3)) (Or (Atomic 0) (Atomic 1))).
340 |   Compute backward [2] (Imp (Or (Atomic 1) (Atomic 0)) (Or (Atomic 0) (Atomic 1))).
341 | End my_tauto.
342 | 
343 | Lemma forward_ok : forall atomics hyp f known cont,
344 |     forward known hyp cont = true
345 |     -> (forall known', allTrue atomics known'
346 |                        -> cont known' = true
347 |                        -> formulaDenote atomics f)
348 |     -> allTrue atomics known
349 |     -> formulaDenote atomics hyp
350 |     -> formulaDenote atomics f.
351 | Proof.
352 |   induct hyp; simplify; propositional.
353 | 
354 |   apply H0 with (known' := add known p).
355 |   apply allTrue_add.
356 |   assumption.
357 |   assumption.
358 |   assumption.
359 | 
360 |   eapply H0.
361 |   eassumption.
362 |   assumption.
363 | 
364 |   eapply IHhyp1.
365 |   eassumption.
366 |   simplify.
367 |   eauto.
368 |   assumption.
369 |   assumption.
370 | 
371 |   apply andb_true_iff in H; propositional.
372 |   eapply IHhyp1.
373 |   eassumption.
374 |   assumption.
375 |   assumption.
376 |   assumption.
377 | 
378 |   apply andb_true_iff in H; propositional.
379 |   eapply IHhyp2.
380 |   eassumption.
381 |   assumption.
382 |   assumption.
383 |   assumption.
384 | 
385 |   eapply H0.
386 |   eassumption.
387 |   assumption.
388 | Qed.
389 | 
390 | Lemma backward_ok' : forall atomics f known,
391 |     backward known f = true
392 |     -> allTrue atomics known
393 |     -> formulaDenote atomics f.
394 | Proof.
395 |   induct f; simplify; propositional.
396 | 
397 |   cases (in_dec Nat.eq_dec p known); propositional.
398 |   eapply allTrue_In.
399 |   eassumption.
400 |   unfold set_In.
401 |   assumption.
402 |   equality.
403 | 
404 |   equality.
405 | 
406 |   apply andb_true_iff in H; propositional.
407 |   eapply IHf1.
408 |   eassumption.
409 |   assumption.
410 | 
411 |   apply andb_true_iff in H; propositional.
412 |   eapply IHf2.
413 |   eassumption.
414 |   assumption.
415 | 
416 |   apply orb_true_iff in H; propositional.
417 |   left.
418 |   eapply IHf1.
419 |   eassumption.
420 |   assumption.
421 |   right.
422 |   eapply IHf2.
423 |   eassumption.
424 |   assumption.
425 | 
426 |   eapply forward_ok.
427 |   eassumption.
428 |   simplify.
429 |   eapply IHf2.
430 |   eassumption.
431 |   assumption.
432 |   assumption.
433 |   assumption.
434 | Qed.
435 | 
436 | Theorem backward_ok : forall f,
437 |     backward [] f = true
438 |     -> forall atomics, formulaDenote atomics f.
439 | Proof.
440 |   simplify.
441 |   apply backward_ok' with (known := []).
442 |   assumption.
443 |   simplify.
444 |   propositional.
445 | Qed.
446 | 
447 | (* Find the position of an element in a list. *)
448 | Ltac position x ls :=
449 |   match ls with
450 |   | [] => constr:(@None nat)
451 |   | x :: _ => constr:(Some 0)
452 |   | _ :: ?ls' =>
453 |     let p := position x ls' in
454 |     match p with
455 |     | None => p
456 |     | Some ?n => constr:(Some (S n))
457 |     end
458 |   end.
459 | 
460 | (* Compute a duplicate-free list of all variables in [P], combining it with
461 |  * [acc]. *)
462 | Ltac vars_in P acc :=
463 |   match P with
464 |   | True => acc
465 |   | False => acc
466 |   | ?Q1 /\ ?Q2 =>
467 |     let acc' := vars_in Q1 acc in
468 |     vars_in Q2 acc'
469 |   | ?Q1 \/ ?Q2 =>
470 |     let acc' := vars_in Q1 acc in
471 |     vars_in Q2 acc'
472 |   | ?Q1 -> ?Q2 =>
473 |     let acc' := vars_in Q1 acc in
474 |     vars_in Q2 acc'
475 |   | _ =>
476 |     let pos := position P acc in
477 |     match pos with
478 |     | Some _ => acc
479 |     | None => constr:(P :: acc)
480 |     end
481 |   end.
482 | 
483 | (* Reification of formula [P], with a pregenerated list [vars] of variables it
484 |  * may mention *)
485 | Ltac reify_tauto' P vars :=
486 |   match P with
487 |   | True => Truth
488 |   | False => Falsehood
489 |   | ?Q1 /\ ?Q2 =>
490 |     let q1 := reify_tauto' Q1 vars in
491 |     let q2 := reify_tauto' Q2 vars in
492 |     constr:(And q1 q2)
493 |   | ?Q1 \/ ?Q2 =>
494 |     let q1 := reify_tauto' Q1 vars in
495 |     let q2 := reify_tauto' Q2 vars in
496 |     constr:(Or q1 q2)
497 |   | ?Q1 -> ?Q2 =>
498 |     let q1 := reify_tauto' Q1 vars in
499 |     let q2 := reify_tauto' Q2 vars in
500 |     constr:(Imp q1 q2)
501 |   | _ =>
502 |     let pos := position P vars in
503 |     match pos with
504 |     | Some ?pos' => constr:(Atomic pos')
505 |     end
506 |   end.
507 | 
508 | (* Our final tactic implementation is now fairly straightforward.  First, we
509 |  * [intro] all quantifiers that do not bind [Prop]s.  Then we reify.  Finally,
510 |  * we call the verified procedure through a lemma. *)
511 | 
512 | Ltac my_tauto :=
513 |   repeat match goal with
514 |            | [ |- forall x : ?P, _ ] =>
515 |              match type of P with
516 |                | Prop => fail 1
517 |                | _ => intro
518 |              end
519 |          end;
520 |   match goal with
521 |     | [ |- ?P ] =>
522 |       let vars := vars_in P (@nil Prop) in
523 |       let p := reify_tauto' P vars in
524 |       change (formulaDenote (nth_default False vars) p)
525 |   end;
526 |   apply backward_ok; reflexivity.
527 | 
528 | (* A few examples demonstrate how the tactic works: *)
529 | 
530 | Theorem mt1 : True.
531 | Proof.
532 |   my_tauto.
533 | Qed.
534 | 
535 | Print mt1.
536 | 
537 | Theorem mt2 : forall x y : nat, x = y -> x = y.
538 | Proof.
539 |   my_tauto.
540 | Qed.
541 | 
542 | Print mt2.
543 | 
544 | Theorem mt3 : forall x y z,
545 |   (x < y /\ y > z) \/ (y > z /\ x < S y)
546 |   -> y > z /\ (x < y \/ x < S y).
547 | Proof.
548 |   my_tauto.
549 | Qed.
550 | 
551 | Print mt3.
552 | 
553 | Theorem mt4 : True /\ True /\ True /\ True /\ True /\ True /\ False -> False.
554 | Proof.
555 |   my_tauto.
556 | Qed.
557 | 
558 | Print mt4.
559 | 
560 | Theorem mt4' : True /\ True /\ True /\ True /\ True /\ True /\ False -> False.
561 | Proof.
562 |   tauto.
563 | Qed.
564 | 
565 | Print mt4'.
566 | 


--------------------------------------------------------------------------------
/Polymorphism_template.v:
--------------------------------------------------------------------------------
  1 | Require Import Frap.
  2 | 
  3 | Set Implicit Arguments.
  4 | (* This command sets up automatic inference of tedious arguments. *)
  5 | 
  6 | 
  7 | (* Our first example: the [option] type family.  While Java and friends force
  8 |  * all sorts of different types to include the special value [null], in Rocq we
  9 |  * request that option explicitly by wrapping a type in [option].  Specifically,
 10 |  * any value of type [option A], for some type [A], is either [None] (sort of
 11 |  * like [null]) or [Some v] for a [v] of type [A]. *)
 12 | Inductive option (A : Set) : Set :=
 13 | | None
 14 | | Some (v : A).
 15 | 
 16 | Arguments None {A}.
 17 | (* This command asks Rocq to *infer* the [A] type for each specific use of
 18 |  * [None]. *)
 19 | 
 20 | (* Here are a few example terms using [option]. *)
 21 | Example no_number : option nat := None.
 22 | Example a_number : option nat := Some 42.
 23 | Example no_number_squared : option (option nat) := None.
 24 | Example no_number_squared_inside : option (option nat) := Some None.
 25 | Example a_number_squared : option (option nat) := Some (Some 42).
 26 | 
 27 | (* Pattern matching is the key ingredient for working with inductive definitions
 28 |  * of all sorts.  Here are some examples matching on [option]s. *)
 29 | 
 30 | Definition increment_optional (no : option nat) : option nat :=
 31 |   match no with
 32 |   | None => None
 33 |   | Some n => Some (n + 1)
 34 |   end.
 35 | 
 36 | (* Here we use type [A * B] of *pairs*, inhabited by values [(a, b)], with
 37 |  * [a : A] and [b : B]. *)
 38 | Definition add_optional (po : option (nat * nat)) : option nat :=
 39 |   match po with
 40 |   | None => None
 41 |   | Some (n, m) => Some (n + m)
 42 |   end.
 43 | 
 44 | 
 45 | (** * Lists *)
 46 | 
 47 | (* For functional programming (as in Rocq), the king of all generic data
 48 |  * structures is the *list*. *)
 49 | Inductive list (A : Set) : Set :=
 50 | | nil
 51 | | cons (hd : A) (tl : list A).
 52 | 
 53 | Arguments nil {A}.
 54 | 
 55 | (* [nil] is the empty list, while [cons], standing for "construct," extends a
 56 |  * list of length [n] into one of length [n+1]. *)
 57 | 
 58 | (* Here are some simple lists. *)
 59 | 
 60 | Example nats0 : list nat := nil.
 61 | Example nats1 : list nat := cons 1 nil.
 62 | Example nats2 : list nat := cons 1 (cons 2 nil).
 63 | 
 64 | (* Rocq features a wonderful notation system, to help us write more concise and
 65 |  * readable code after introducing new syntactic forms.  We will not give a
 66 |  * systematic presentation of the notation system, but we will show many
 67 |  * examples, from which it is possible to infer generality by scientific
 68 |  * induction.  And, of course, the interested reader can always check the
 69 |  * notations chapter of the Rocq reference manual. *)
 70 | 
 71 | (* First, our examples can get more readable with an infix operator for [cons]. *)
 72 | 
 73 | Infix "::" := cons.
 74 | 
 75 | Example nats1' : list nat := 1 :: nil.
 76 | Example nats2' : list nat := 1 :: 2 :: nil.
 77 | 
 78 | (* Getting even more fancy, we declare a notation for list literals. *)
 79 | 
 80 | Notation "[ ]" := nil.
 81 | Notation "[ x1 ; .. ; xN ]" := (cons x1 (.. (cons xN nil) ..)).
 82 | 
 83 | Example nats0'' : list nat := [].
 84 | Example nats1'' : list nat := [1].
 85 | Example nats2'' : list nat := [1; 2].
 86 | Example nats3'' : list nat := [1; 2; 3].
 87 | 
 88 | (* Here are some classic recursive functions that operate over lists.
 89 |  * First, here is how to compute the length of a list.  Recall that we put
 90 |  * *implicit* function arguments in curly braces, asking Rocq to infer them at
 91 |  * call sites. *)
 92 | 
 93 | Fixpoint length {A} (ls : list A) : nat :=
 94 |   match ls with
 95 |   | nil => 0
 96 |   | _ :: ls' => 1 + length ls'
 97 |   end.
 98 | 
 99 | (* Concatenation: *)
100 | Fixpoint app {A} (ls1 ls2 : list A) : list A :=
101 |   match ls1 with
102 |   | nil => ls2
103 |   | x :: ls1' => x :: app ls1' ls2
104 |   end.
105 | 
106 | Infix "++" := app.
107 | 
108 | (* Reversal: *)
109 | Fixpoint rev {A} (ls : list A) : list A :=
110 |   match ls with
111 |   | nil => nil
112 |   | x :: ls' => rev ls' ++ [x]
113 |   end.
114 | 
115 | Theorem length_app : forall A (ls1 ls2 : list A),
116 |     length (ls1 ++ ls2) = length ls1 + length ls2.
117 | Proof.
118 | Admitted.
119 | 
120 | (* One of the classic gotchas in functional-programming class is how slow this
121 |  * naive [rev] is.  Each [app] operation requires linear time, so running
122 |  * linearly many [app]s brings us to quadratic time for [rev].  Using a helper
123 |  * function, we can bring [rev] to its optimal linear time. *)
124 | 
125 | Fixpoint rev_append {A} (ls acc : list A) : list A :=
126 |   match ls with
127 |   | nil => acc
128 |   | x :: ls' => rev_append ls' (x :: acc)
129 |   end.
130 | 
131 | (* This function [rev_append] takes an extra *accumulator* argument, in which we
132 |  * gradually build up the original input in reversed order.  The base case just
133 |  * returns the accumulator.  Now reversal just needs to do a [rev_append] with
134 |  * an empty initial accumulator. *)
135 | 
136 | Definition rev' {A} (ls : list A) : list A :=
137 |   rev_append ls [].
138 | 
139 | (* A few test cases can help convince us that this seems to work. *)
140 | 
141 | Compute rev [1; 2; 3; 4].
142 | Compute rev' [1; 2; 3; 4].
143 | Compute rev ["hi"; "bye"; "sky"].
144 | Compute rev' ["hi"; "bye"; "sky"].
145 | 
146 | (* OK, great.  Now it seems worth investing in a correctness proof. *)
147 | 
148 | Theorem rev'_ok : forall A (ls : list A),
149 |     rev' ls = rev ls.
150 | Proof.
151 | Admitted.
152 | 
153 | (** ** Zipping and unzipping *)
154 | 
155 | (* Another classic pair of list operations is zipping and unzipping.
156 |  * These functions convert between pairs of lists and lists of pairs. *)
157 | 
158 | Fixpoint zip {A1 A2} (ls1 : list A1) (ls2 : list A2) : list (A1 * A2) :=
159 |   match ls1, ls2 with
160 |   | x1 :: ls1', x2 :: ls2' => (x1, x2) :: zip ls1' ls2'
161 |   | _, _ => []
162 |   end.
163 | (* Note how, when passed two lengths of different lists, [zip] drops the
164 |  * mismatched suffix of the longer list. *)
165 | 
166 | (* An explicit [Set] annotation is needed here, for obscure type-inference
167 |  * reasons. *)
168 | Fixpoint unzip {A1 A2 : Set} (ls : list (A1 * A2)) : list A1 * list A2 :=
169 |   match ls with
170 |   | [] => ([], [])
171 |   | (x1, x2) :: ls' =>
172 |     let (ls1, ls2) := unzip ls' in
173 |     (x1 :: ls1, x2 :: ls2)
174 |   end.
175 | 
176 | (* A few common-sense properties hold of these definitions. *)
177 | 
178 | Theorem length_zip : forall A1 A2 (ls1 : list A1) (ls2 : list A2),
179 |     length (zip ls1 ls2) = 7.
180 | Proof.
181 | Admitted.
182 | 
183 | (* We write [fst] and [snd] for the first and second projection operators on
184 |  * pairs, respectively. *)
185 | 
186 | Theorem length_unzip1 : forall (A1 A2 : Set) (ls : list (A1 * A2)),
187 |     length (fst (unzip ls)) = length ls.
188 | Proof.
189 | Admitted.
190 | 
191 | Theorem length_unzip2 : forall (A1 A2 : Set) (ls : list (A1 * A2)),
192 |     length (snd (unzip ls)) = length ls.
193 | Proof.
194 | Admitted.
195 | 
196 | Theorem zip_unzip : forall (A1 A2 : Set) (ls : list (A1 * A2)),
197 |     (let (ls1, ls2) := unzip ls in zip ls1 ls2) = ls.
198 | Proof.
199 | Admitted.
200 | 
201 | (* There are also interesting interactions with [app] and [rev]. *)
202 | 
203 | Theorem unzip_app : forall (A1 A2 : Set) (x y : list (A1 * A2)),
204 |     unzip (x ++ y)
205 |     = (let (x1, x2) := unzip x in
206 |        let (y1, y2) := unzip y in
207 |        (x1 ++ y1, x2 ++ y2)).
208 | Proof.
209 | Admitted.
210 | 
211 | Theorem unzip_rev : forall (A1 A2 : Set) (ls : list (A1 * A2)),
212 |     unzip (rev ls) = (let (ls1, ls2) := unzip ls in
213 |                       (rev ls1, rev ls2)).
214 | Proof.
215 | Admitted.
216 | 
217 | 
218 | (** * Binary trees *)
219 | 
220 | (* Another classic datatype is binary trees, which we can define like so. *)
221 | Inductive tree (A : Set) : Set :=
222 | | Leaf
223 | | Node (l : tree A) (d : A) (r : tree A).
224 | 
225 | Arguments Leaf {A}.
226 | 
227 | Example tr1 : tree nat := Node (Node Leaf 7 Leaf) 8 (Node Leaf 9 (Node Leaf 10 Leaf)).
228 | 
229 | (* There is a natural notion of size of a tree. *)
230 | Fixpoint size {A} (t : tree A) : nat :=
231 |   match t with
232 |   | Leaf => 0
233 |   | Node l _ r => 1 + size l + size r
234 |   end.
235 | 
236 | (* There is also a natural sense of reversing a tree, flipping it around its
237 |  * vertical axis. *)
238 | Fixpoint reverse {A} (t : tree A) : tree A :=
239 |   match t with
240 |   | Leaf => Leaf
241 |   | Node l d r => Node (reverse r) d (reverse l)
242 |   end.
243 | 
244 | (* There is a natural relationship between the two. *)
245 | Theorem size_reverse : forall A (t : tree A),
246 |     size (reverse t) = size t.
247 | Proof.
248 | Admitted.
249 | 
250 | (* Another classic tree operation is flattening into lists. *)
251 | Fixpoint flatten {A} (t : tree A) : list A :=
252 |   match t with
253 |   | Leaf => []
254 |   | Node l d r => flatten l ++ d :: flatten r
255 |   end.
256 | (* Note here that operators [++] and [::] are right-associative. *)
257 | 
258 | Theorem length_flatten : forall A (t : tree A),
259 |     length (flatten t) = size t.
260 | Proof.
261 | Admitted.
262 | 
263 | Theorem rev_flatten : forall A (t : tree A),
264 |     rev (flatten t) = flatten (reverse t).
265 | Proof.
266 | Admitted.
267 | 
268 | 
269 | (** * Syntax trees *)
270 | 
271 | (* Trees are particularly important to us in studying program proof, since it is
272 |  * natural to represent programs as *syntax trees*.  Here's a quick example, for
273 |  * a tiny imperative language. *)
274 | 
275 | Inductive expression : Set :=
276 | | Const (n : nat)
277 | | Var (x : var)
278 | | Plus (e1 e2 : expression)
279 | | Minus (e1 e2 : expression)
280 | | Times (e1 e2 : expression)
281 | | GreaterThan (e1 e2 : expression)
282 | | Not (e : expression).
283 | 
284 | Inductive statement : Set :=
285 | | Assign (x : var) (e : expression)
286 | | Sequence (s1 s2 : statement)
287 | | IfThenElse (e : expression) (s1 s2 : statement)
288 | | WhileLoop (e : expression) (s : statement).
289 | 
290 | (* First, here's a quick sample of nifty notations to write
291 |  * almost-natural-looking embedded programs in Rocq. *)
292 | Coercion Const : nat >-> expression.
293 | Coercion Var : string >-> expression.
294 | (*Declare Scope embedded_scope.*)
295 | Infix "+" := Plus : embedded_scope.
296 | Infix "-" := Minus : embedded_scope.
297 | Infix "*" := Times : embedded_scope.
298 | Infix ">" := GreaterThan : embedded_scope.
299 | Infix "<-" := Assign (at level 75) : embedded_scope.
300 | Infix ";" := Sequence (at level 76) : embedded_scope.
301 | Notation "'If' e {{ s1 }} 'else' {{ s2 }}" := (IfThenElse e s1 s2) (at level 75) : embedded_scope.
302 | Notation "'While' e {{ s }}" := (WhileLoop e s) (at level 75) : embedded_scope.
303 | Delimit Scope embedded_scope with embedded.
304 | 
305 | Example factorial :=
306 |   ("answer" <- 1;
307 |    While ("input" > 0) {{
308 |      "answer" <- "answer" * "input";
309 |      "input" <- "input" - 1
310 |    }})%embedded.
311 | 
312 | (* A variety of compiler-style operations can be coded on top of this type.
313 |  * Here's one to count total variable occurrences. *)
314 | 
315 | Fixpoint varsInExpression (e : expression) : nat :=
316 |   match e with
317 |   | Const _ => 0
318 |   | Var _ => 1
319 |   | Plus e1 e2
320 |   | Minus e1 e2
321 |   | Times e1 e2
322 |   | GreaterThan e1 e2 => varsInExpression e1 + varsInExpression e2
323 |   | Not e1 => varsInExpression e1
324 |   end.
325 | 
326 | Fixpoint varsInStatement (s : statement) : nat :=
327 |   match s with
328 |   | Assign _ e => 1 + varsInExpression e
329 |   | Sequence s1 s2 => varsInStatement s1 + varsInStatement s2
330 |   | IfThenElse e s1 s2 => varsInExpression e + varsInStatement s1 + varsInStatement s2
331 |   | WhileLoop e s1 => varsInExpression e + varsInStatement s1
332 |   end.
333 | 
334 | (* We will need to wait for a few more lectures' worth of conceptual progress
335 |  * before we can prove that transformations on programs preserve meaning, but we
336 |  * do already have enough tools that prove that transformations preserve more
337 |  * basic properties, like number of variables.  Here's one such transformation,
338 |  * which flips "then" and "else" cases while also negating "if" conditions. *)
339 | Fixpoint flipper (s : statement) : statement :=
340 |   match s with
341 |   | Assign _ _ => s
342 |   | Sequence s1 s2 => Sequence (flipper s1) (flipper s2)
343 |   | IfThenElse e s1 s2 => IfThenElse (Not e) (flipper s2) (flipper s1)
344 |   | WhileLoop e s1 => WhileLoop e (flipper s1)
345 |   end.
346 | 
347 | Theorem varsIn_flipper : forall s,
348 |     varsInStatement (flipper s) = varsInStatement s.
349 | Proof.
350 | Admitted.
351 | 
352 | (* Just for the sheer madcap fun of it, let's write some translations of
353 |  * programs into our lists from before, with variables as data values. *)
354 | 
355 | Fixpoint listifyExpression (e : expression) : list var :=
356 |   match e with
357 |   | Const _ => []
358 |   | Var x => [x]
359 |   | Plus e1 e2
360 |   | Minus e1 e2
361 |   | Times e1 e2
362 |   | GreaterThan e1 e2 => listifyExpression e1 ++ listifyExpression e2
363 |   | Not e1 => listifyExpression e1
364 |   end.
365 | 
366 | Fixpoint listifyStatement (s : statement) : list var :=
367 |   match s with
368 |   | Assign x e => x :: listifyExpression e
369 |   | Sequence s1 s2 => listifyStatement s1 ++ listifyStatement s2
370 |   | IfThenElse e s1 s2 => listifyExpression e ++ listifyStatement s1 ++ listifyStatement s2
371 |   | WhileLoop e s1 => listifyExpression e ++ listifyStatement s1
372 |   end.
373 | 
374 | Compute listifyStatement factorial.
375 | 
376 | Theorem length_listifyStatement : forall s,
377 |     length (listifyStatement s) = varsInStatement s.
378 | Proof.
379 | Admitted.
380 | 
381 | (* Other transformations are also possible, like the Swedish-Chef optimization,
382 |  * which turns every variable into "bork".  It saves many bits when most variable
383 |  * names are longer than 4 characters. *)
384 | 
385 | Fixpoint swedishExpression (e : expression) : expression :=
386 |   match e with
387 |   | Const _ => e
388 |   | Var _ => Var "bork"
389 |   | Plus e1 e2 => Plus (swedishExpression e1) (swedishExpression e2)
390 |   | Minus e1 e2 => Minus (swedishExpression e1) (swedishExpression e2)
391 |   | Times e1 e2 => Times (swedishExpression e1) (swedishExpression e2)
392 |   | GreaterThan e1 e2 => GreaterThan (swedishExpression e1) (swedishExpression e2)
393 |   | Not e1 => Not (swedishExpression e1)
394 |   end.
395 | 
396 | Fixpoint swedishStatement (s : statement) : statement :=
397 |   match s with
398 |   | Assign _ e => Assign "bork" (swedishExpression e)
399 |   | Sequence s1 s2 => Sequence (swedishStatement s1) (swedishStatement s2)
400 |   | IfThenElse e s1 s2 => IfThenElse (swedishExpression e) (swedishStatement s1) (swedishStatement s2)
401 |   | WhileLoop e s1 => WhileLoop (swedishExpression e) (swedishStatement s1)
402 |   end.
403 | 
404 | Compute swedishStatement factorial.
405 | 
406 | Fixpoint swedishList (ls : list var) : list var :=
407 |   match ls with
408 |   | [] => []
409 |   | _ :: ls => "bork" :: swedishList ls
410 |   end.
411 | 
412 | Lemma listifyStatement_swedishStatement : forall s,
413 |     listifyStatement (swedishStatement s) = swedishList (listifyStatement s).
414 | Proof.
415 | Admitted.
416 | 


--------------------------------------------------------------------------------
/HoareLogic_template.v:
--------------------------------------------------------------------------------
  1 | Require Import Frap.
  2 | 
  3 | 
  4 | (** * Syntax and semantics of a simple imperative language *)
  5 | 
  6 | Inductive exp :=
  7 | | Const (n : nat)
  8 | | Var (x : string)
  9 | | Read (e1 : exp)
 10 | | Plus (e1 e2 : exp)
 11 | | Minus (e1 e2 : exp)
 12 | | Mult (e1 e2 : exp).
 13 | 
 14 | Inductive bexp :=
 15 | | Equal (e1 e2 : exp)
 16 | | Less (e1 e2 : exp).
 17 | 
 18 | Definition heap := fmap nat nat.
 19 | Definition valuation := fmap var nat.
 20 | Definition assertion := heap -> valuation -> Prop.
 21 | 
 22 | Inductive cmd :=
 23 | | Skip
 24 | | Assign (x : var) (e : exp)
 25 | | Write (e1 e2 : exp)
 26 | | Seq (c1 c2 : cmd)
 27 | | If_ (be : bexp) (then_ else_ : cmd)
 28 | | While_ (inv : assertion) (be : bexp) (body : cmd)
 29 | 
 30 | | Assert (a : assertion).
 31 | 
 32 | (* Shorthand notation for looking up in a finite map, returning zero if the key
 33 |  * is not found *)
 34 | Notation "m $! k" := (match m $? k with Some n => n | None => O end) (at level 30).
 35 | 
 36 | (* Start of expression semantics: meaning of expressions *)
 37 | Fixpoint eval (e : exp) (h : heap) (v : valuation) : nat :=
 38 |   match e with
 39 |   | Const n => n
 40 |   | Var x => v $! x
 41 |   | Read e1 => h $! eval e1 h v
 42 |   | Plus e1 e2 => eval e1 h v + eval e2 h v
 43 |   | Minus e1 e2 => eval e1 h v - eval e2 h v
 44 |   | Mult e1 e2 => eval e1 h v * eval e2 h v
 45 |   end.
 46 | 
 47 | (* Meaning of Boolean expressions *)
 48 | Definition beval (b : bexp) (h : heap) (v : valuation) : bool :=
 49 |   match b with
 50 |   | Equal e1 e2 => if eval e1 h v ==n eval e2 h v then true else false
 51 |   | Less e1 e2 => if eval e2 h v <=? eval e1 h v then false else true
 52 |   end.
 53 | 
 54 | (* A big-step operational semantics for commands *)
 55 | Inductive exec : heap -> valuation -> cmd -> heap -> valuation -> Prop :=
 56 | | ExSkip : forall h v,
 57 |   exec h v Skip h v
 58 | | ExAssign : forall h v x e,
 59 |   exec h v (Assign x e) h (v $+ (x, eval e h v))
 60 | | ExWrite : forall h v e1 e2,
 61 |   exec h v (Write e1 e2) (h $+ (eval e1 h v, eval e2 h v)) v
 62 | | ExSeq : forall h1 v1 c1 h2 v2 c2 h3 v3,
 63 |   exec h1 v1 c1 h2 v2
 64 |   -> exec h2 v2 c2 h3 v3
 65 |   -> exec h1 v1 (Seq c1 c2) h3 v3
 66 | | ExIfTrue : forall h1 v1 b c1 c2 h2 v2,
 67 |   beval b h1 v1 = true
 68 |   -> exec h1 v1 c1 h2 v2
 69 |   -> exec h1 v1 (If_ b c1 c2) h2 v2
 70 | | ExIfFalse : forall h1 v1 b c1 c2 h2 v2,
 71 |   beval b h1 v1 = false
 72 |   -> exec h1 v1 c2 h2 v2
 73 |   -> exec h1 v1 (If_ b c1 c2) h2 v2
 74 | | ExWhileFalse : forall I h v b c,
 75 |   beval b h v = false
 76 |   -> exec h v (While_ I b c) h v
 77 | | ExWhileTrue : forall I h1 v1 b c h2 v2 h3 v3,
 78 |   beval b h1 v1 = true
 79 |   -> exec h1 v1 c h2 v2
 80 |   -> exec h2 v2 (While_ I b c) h3 v3
 81 |   -> exec h1 v1 (While_ I b c) h3 v3
 82 | 
 83 | (* Assertions execute only when they are true.  They provide a way to embed
 84 |  * proof obligations within programs. *)
 85 | | ExAssert : forall h v (a : assertion),
 86 |   a h v
 87 |   -> exec h v (Assert a) h v.
 88 | 
 89 | 
 90 | (** * Hoare logic *)
 91 | 
 92 | Inductive hoare_triple : assertion -> cmd -> assertion -> Prop :=
 93 | | HtSkip : forall P, hoare_triple P Skip P
 94 | | HtAssign : forall (P : assertion) x e,
 95 |   hoare_triple P (Assign x e) (fun h v => exists v', P h v' /\ v = v' $+ (x, eval e h v'))
 96 | | HtWrite : forall (P : assertion) (e1 e2 : exp),
 97 |   hoare_triple P (Write e1 e2) (fun h v => exists h', P h' v /\ h = h' $+ (eval e1 h' v, eval e2 h' v))
 98 | | HtSeq : forall (P Q R : assertion) c1 c2,
 99 |   hoare_triple P c1 Q
100 |   -> hoare_triple Q c2 R
101 |   -> hoare_triple P (Seq c1 c2) R
102 | | HtIf : forall (P Q1 Q2 : assertion) b c1 c2,
103 |   hoare_triple (fun h v => P h v /\ beval b h v = true) c1 Q1
104 |   -> hoare_triple (fun h v => P h v /\ beval b h v = false) c2 Q2
105 |   -> hoare_triple P (If_ b c1 c2) (fun h v => Q1 h v \/ Q2 h v)
106 | | HtWhile : forall (I P : assertion) b c,
107 |   (forall h v, P h v -> I h v)
108 |   -> hoare_triple (fun h v => I h v /\ beval b h v = true) c I
109 |   -> hoare_triple P (While_ I b c) (fun h v => I h v /\ beval b h v = false)
110 | | HtAssert : forall P I : assertion,
111 |   (forall h v, P h v -> I h v)
112 |   -> hoare_triple P (Assert I) P
113 | | HtConsequence : forall (P Q P' Q' : assertion) c,
114 |   hoare_triple P c Q
115 |   -> (forall h v, P' h v -> P h v)
116 |   -> (forall h v, Q h v -> Q' h v)
117 |   -> hoare_triple P' c Q'.
118 | 
119 | Lemma hoare_triple_big_step_while: forall (I : assertion) b c,
120 |   (forall h v h' v', exec h v c h' v'
121 |                      -> I h v
122 |                      -> beval b h v = true
123 |                      -> I h' v')
124 |   -> forall h v h' v', exec h v (While_ I b c) h' v'
125 |                        -> I h v
126 |                        -> I h' v' /\ beval b h' v' = false.
127 | Proof.
128 |   induct 2; eauto.
129 | Qed.
130 | 
131 | Theorem hoare_triple_big_step : forall pre c post,
132 |     hoare_triple pre c post
133 |     -> forall h v h' v', exec h v c h' v'
134 |                          -> pre h v
135 |                          -> post h' v'.
136 | Proof.
137 |   induct 1; eauto; invert 1; eauto.
138 | 
139 |   simplify.
140 |   eapply hoare_triple_big_step_while; eauto.
141 | Qed.
142 | 
143 | 
144 | (* BEGIN syntax macros that won't be explained *)
145 | Coercion Const : nat >-> exp.
146 | Coercion Var : string >-> exp.
147 | Notation "*[ e ]" := (Read e) : cmd_scope.
148 | Infix "+" := Plus : cmd_scope.
149 | Infix "-" := Minus : cmd_scope.
150 | Infix "*" := Mult : cmd_scope.
151 | Infix "=" := Equal : cmd_scope.
152 | Infix "<" := Less : cmd_scope.
153 | Definition set (dst src : exp) : cmd :=
154 |   match dst with
155 |   | Read dst' => Write dst' src
156 |   | Var dst' => Assign dst' src
157 |   | _ => Assign "Bad LHS" 0
158 |   end.
159 | Infix "<-" := set (no associativity, at level 70) : cmd_scope.
160 | Infix ";;" := Seq (right associativity, at level 75) : cmd_scope.
161 | Notation "'when' b 'then' then_ 'else' else_ 'done'" := (If_ b then_ else_) (at level 75, b at level 0).
162 | Notation "{{ I }} 'while' b 'loop' body 'done'" := (While_ I b body) (at level 75).
163 | Notation "'assert' {{ I }}" := (Assert I) (at level 75).
164 | Delimit Scope cmd_scope with cmd.
165 | (* END macros *)
166 | 
167 | (* We should draw some attention to the next notation, which defines special
168 |  * lambdas for writing assertions. *)
169 | Notation "h & v ~> e" := (fun h v => e%nat%type) (at level 85, v at level 0).
170 | 
171 | (* And here's the classic notation for Hoare triples. *)
172 | Notation "{{ P }} c {{ Q }}" := (hoare_triple P c%cmd Q) (at level 90, c at next level).
173 | 
174 | (* Special case of consequence: keeping the precondition; only changing the
175 |  * postcondition. *)
176 | Lemma HtStrengthenPost : forall (P Q Q' : assertion) c,
177 |   hoare_triple P c Q
178 |   -> (forall h v, Q h v -> Q' h v)
179 |   -> hoare_triple P c Q'.
180 | Proof.
181 |   simplify; eapply HtConsequence; eauto.
182 | Qed.
183 | 
184 | (* Finally, three tactic definitions that we won't explain.  The overall tactic
185 |  * [ht] tries to prove Hoare triples, essentially by rote application of the
186 |  * rules.  Some other obligations are generated, generally of implications
187 |  * between assertions, and [ht] also makes a best effort to solve those. *)
188 | 
189 | Ltac ht1 :=
190 |   match goal with
191 |   | [  |- {{ _ }} _ {{ ?P }} ] =>
192 |     tryif is_evar P then
193 |       apply HtSkip || apply HtAssign || apply HtWrite || eapply HtSeq
194 |       || eapply HtIf || eapply HtWhile || eapply HtAssert
195 |     else
196 |       eapply HtStrengthenPost
197 |   end.
198 | 
199 | Ltac t := cbv beta; propositional; subst;
200 |           repeat match goal with
201 |                  | [ H : ex _ |- _ ] => invert H; propositional; subst
202 |                  end;
203 |           simplify;
204 |           repeat match goal with
205 |                  | [ _ : context[?a <=? ?b] |- _ ] => destruct (a <=? b); try discriminate
206 |                  | [ H : ?E = ?E |- _ ] => clear H
207 |                  end; simplify; propositional; auto; try equality; try linear_arithmetic.
208 | 
209 | Ltac ht := simplify; repeat ht1; t.
210 | 
211 | 
212 | (** * Some examples of verified programs *)
213 | 
214 | (** ** Swapping the values in two variables *)
215 | 
216 | Theorem swap_ok : forall a b,
217 |   {{_&v ~> v $! "x" = a /\ v $! "y" = b}}
218 |     "tmp" <- "x";;
219 |     "x" <- "y";;
220 |     "y" <- "tmp"
221 |   {{_&v ~> v $! "x" = b /\ v $! "y" = a}}.
222 | Proof.
223 | Admitted.
224 | 
225 | (** ** Computing the maximum of two variables *)
226 | 
227 | Theorem max_ok : forall a b,
228 |   {{_&v ~> v $! "x" = a /\ v $! "y" = b}}
229 |     when "x" < "y" then
230 |       "m" <- "y"
231 |     else
232 |       "m" <- "x"
233 |     done
234 |   {{_&v ~> v $! "m" = max a b}}.
235 | Proof.
236 | Admitted.
237 | 
238 | (** ** Iterative factorial *)
239 | 
240 | Theorem fact_ok : forall n,
241 |   {{_&v ~> v $! "n" = n}}
242 |     "acc" <- 1;;
243 |     {{_&v ~> True}}
244 |     while 0 < "n" loop
245 |       "acc" <- "acc" * "n";;
246 |       "n" <- "n" - 1
247 |     done
248 |   {{_&v ~> v $! "acc" = fact n}}.
249 | Proof.
250 | Admitted.
251 | 
252 | (** ** Selection sort *)
253 | 
254 | (* This is our one example of a program reading/writing memory, which holds the
255 |  * representation of an array that we want to sort in-place. *)
256 | 
257 | (* One simple lemma turns out to be helpful to guide [eauto] properly. *)
258 | Lemma leq_f : forall A (m : fmap A nat) x y,
259 |   x = y
260 |   -> m $! x <= m $! y.
261 | Proof.
262 |   ht.
263 | Qed.
264 | 
265 | Local Hint Resolve leq_f : core.
266 | Local Hint Extern 1 (@eq nat _ _) => linear_arithmetic : core.
267 | Local Hint Extern 1 (_ < _) => linear_arithmetic : core.
268 | Local Hint Extern 1 (_ <= _) => linear_arithmetic : core.
269 | (* We also register [linear_arithmetic] as a step to try during proof search. *)
270 | 
271 | Theorem selectionSort_ok :
272 |   {{_&_ ~> True}}
273 |     "i" <- 0;;
274 |     {{h&v ~> True}}
275 |     while "i" < "n" loop
276 |       "j" <- "i"+1;;
277 |       "best" <- "i";;
278 |       {{h&v ~> True}}
279 |       while "j" < "n" loop
280 |         when *["a" + "j"] < *["a" + "best"] then
281 |           "best" <- "j"
282 |         else
283 |           Skip
284 |         done;;
285 |         "j" <- "j" + 1
286 |       done;;
287 |       "tmp" <- *["a" + "best"];;
288 |       *["a" + "best"] <- *["a" + "i"];;
289 |       *["a" + "i"] <- "tmp";;
290 |       "i" <- "i" + 1
291 |     done
292 |   {{h&v ~> forall i j, i < j < v $! "n" -> h $! (v $! "a" + i) <= h $! (v $! "a" + j)}}.
293 | Proof.
294 | Admitted.
295 | 
296 | 
297 | (** * An alternative correctness theorem for Hoare logic, with small-step semantics *)
298 | 
299 | Inductive step : heap * valuation * cmd -> heap * valuation * cmd -> Prop :=
300 | | StAssign : forall h v x e,
301 |   step (h, v, Assign x e) (h, v $+ (x, eval e h v), Skip)
302 | | StWrite : forall h v e1 e2,
303 |   step (h, v, Write e1 e2) (h $+ (eval e1 h v, eval e2 h v), v, Skip)
304 | | StStepSkip : forall h v c,
305 |   step (h, v, Seq Skip c) (h, v, c)
306 | | StStepRec : forall h1 v1 c1 h2 v2 c1' c2,
307 |   step (h1, v1, c1) (h2, v2, c1')
308 |   -> step (h1, v1, Seq c1 c2) (h2, v2, Seq c1' c2)
309 | | StIfTrue : forall h v b c1 c2,
310 |   beval b h v = true
311 |   -> step (h, v, If_ b c1 c2) (h, v, c1)
312 | | StIfFalse : forall h v b c1 c2,
313 |   beval b h v = false
314 |   -> step (h, v, If_ b c1 c2) (h, v, c2)
315 | | StWhileFalse : forall I h v b c,
316 |   beval b h v = false
317 |   -> step (h, v, While_ I b c) (h, v, Skip)
318 | | StWhileTrue : forall I h v b c,
319 |   beval b h v = true
320 |   -> step (h, v, While_ I b c) (h, v, Seq c (While_ I b c))
321 | | StAssert : forall h v (a : assertion),
322 |   a h v
323 |   -> step (h, v, Assert a) (h, v, Skip).
324 | 
325 | Local Hint Constructors step : core.
326 | 
327 | Definition trsys_of (st : heap * valuation * cmd) := {|
328 |   Initial := {st};
329 |   Step := step
330 | |}.
331 | 
332 | Definition unstuck (st : heap * valuation * cmd) :=
333 |   snd st = Skip
334 |   \/ exists st', step st st'.
335 | 
336 | Lemma hoare_triple_unstuck : forall P c Q,
337 |   {{P}} c {{Q}}
338 |   -> forall h v, P h v
339 |                  -> unstuck (h, v, c).
340 | Proof.
341 |   induct 1; unfold unstuck; simplify; propositional; eauto.
342 | 
343 |   apply IHhoare_triple1 in H1.
344 |   unfold unstuck in H1; simplify; first_order; subst; eauto.
345 |   cases x.
346 |   cases p.
347 |   eauto.
348 | 
349 |   cases (beval b h v); eauto.
350 | 
351 |   cases (beval b h v); eauto.
352 | 
353 |   apply H0 in H2.
354 |   apply IHhoare_triple in H2.
355 |   unfold unstuck in H2; simplify; first_order.
356 | Qed.
357 | 
358 | Lemma hoare_triple_Skip : forall P Q,
359 |   {{P}} Skip {{Q}}
360 |   -> forall h v, P h v -> Q h v.
361 | Proof.
362 |   induct 1; auto.
363 | Qed.
364 | 
365 | Lemma hoare_triple_step : forall P c Q,
366 |   {{P}} c {{Q}}
367 |   -> forall h v h' v' c',
368 |       step (h, v, c) (h', v', c')
369 |       -> P h v
370 |       -> {{h''&v'' ~> h'' = h' /\ v'' = v'}} c' {{Q}}.
371 | Proof.
372 |   induct 1.
373 | 
374 |   invert 1.
375 | 
376 |   invert 1; ht; eauto.
377 | 
378 |   invert 1; ht; eauto.
379 | 
380 |   invert 1; simplify.
381 | 
382 |   eapply HtConsequence; eauto.
383 |   propositional; subst.
384 |   eapply hoare_triple_Skip; eauto.
385 | 
386 |   econstructor; eauto.
387 | 
388 |   invert 1; simplify.
389 |   eapply HtConsequence; eauto; equality.
390 |   eapply HtConsequence; eauto; equality.
391 | 
392 |   invert 1; simplify.
393 |   eapply HtConsequence with (P := h'' & v'' ~> h'' = h' /\ v'' = v').
394 |   apply HtSkip.
395 |   auto.
396 |   simplify; propositional; subst; eauto.
397 | 
398 |   econstructor.
399 |   eapply HtConsequence; eauto.
400 |   simplify; propositional; subst; eauto.
401 |   econstructor; eauto.
402 | 
403 |   invert 1; simplify.
404 |   eapply HtConsequence; eauto.
405 |   econstructor.
406 |   simplify; propositional; subst; eauto.
407 | 
408 |   simplify.
409 |   eapply HtConsequence.
410 |   eapply IHhoare_triple; eauto.
411 |   simplify; propositional; subst; eauto.
412 |   auto.
413 | Qed.
414 | 
415 | Theorem hoare_triple_invariant : forall P c Q h v,
416 |   {{P}} c {{Q}}
417 |   -> P h v
418 |   -> invariantFor (trsys_of (h, v, c)) unstuck.
419 | Proof.
420 |   simplify.
421 |   apply invariant_weaken with (invariant1 := fun st => {{h&v ~> h = fst (fst st)
422 |                                                            /\ v = snd (fst st)}}
423 |                                                          snd st
424 |                                                        {{_&_ ~> True}}).
425 | 
426 |   apply invariant_induction; simplify.
427 | 
428 |   propositional; subst; simplify.
429 |   eapply HtConsequence; eauto.
430 |   equality.
431 | 
432 |   cases s.
433 |   cases s'.
434 |   cases p.
435 |   cases p0.
436 |   simplify.
437 |   eapply hoare_triple_step; eauto.
438 |   simplify; auto.
439 | 
440 |   simplify.
441 |   cases s.
442 |   cases p.
443 |   simplify.
444 |   eapply hoare_triple_unstuck; eauto.
445 |   simplify; auto.
446 | Qed.
447 | 
448 | (* A very simple example, just to show all this in action *)
449 | Definition forever := (
450 |   "i" <- 1;;
451 |   "n" <- 1;;
452 |   {{h&v ~> v $! "i" > 0}}
453 |   while 0 < "i" loop
454 |     "i" <- "i" * 2;;
455 |     "n" <- "n" + "i";;
456 |     assert {{h&v ~> v $! "n" >= 1}}
457 |   done;;
458 | 
459 |   assert {{_&_ ~> False}}
460 |   (* Note that this last assertion implies that the program never terminates! *)
461 | )%cmd.
462 | 
463 | Theorem forever_ok : {{_&_ ~> True}} forever {{_&_ ~> False}}.
464 | Proof.
465 |   ht.
466 | Qed.
467 | 
468 | Theorem forever_invariant : invariantFor (trsys_of ($0, $0, forever)) unstuck.
469 | Proof.
470 |   eapply hoare_triple_invariant.
471 |   apply forever_ok.
472 |   simplify; trivial.
473 | Qed.
474 | 


--------------------------------------------------------------------------------
/LambdaCalculusAndTypeSoundness_template.v:
--------------------------------------------------------------------------------
  1 | (** Formal Reasoning About Programs <http://adam.chlipala.net/frap/>
  2 |   * Chapter 11: Lambda Calculus and Simple Type Soundness
  3 |   * Author: Adam Chlipala
  4 |   * License: https://creativecommons.org/licenses/by-nc-nd/4.0/ *)
  5 | 
  6 | Require Import Frap.
  7 | 
  8 | (* The last few chapters have focused on small programming languages that are
  9 |  * representative of the essence of the imperative languages.  We now turn to
 10 |  * lambda-calculus, the usual representative of functional languages. *)
 11 | 
 12 | Module Ulc.
 13 |   Inductive exp : Set :=
 14 |   | Var (x : var)
 15 |   | Abs (x : var) (body : exp)
 16 |   | App (e1 e2 : exp).
 17 | 
 18 |   Fixpoint subst (rep : exp) (x : var) (e : exp) : exp :=
 19 |     match e with
 20 |     | Var y => if y ==v x then rep else Var y
 21 |     | Abs y e1 => Abs y (if y ==v x then e1 else subst rep x e1)
 22 |     | App e1 e2 => App (subst rep x e1) (subst rep x e2)
 23 |     end.
 24 | 
 25 | 
 26 |   (** * Big-step semantics *)
 27 | 
 28 |   Inductive eval : exp -> exp -> Prop :=
 29 |   | BigAbs : forall x e,
 30 |     eval (Abs x e) (Abs x e)
 31 |   | BigApp : forall e1 x e1' e2 v2 v,
 32 |     eval e1 (Abs x e1')
 33 |     -> eval e2 v2
 34 |     -> eval (subst v2 x e1') v
 35 |     -> eval (App e1 e2) v.
 36 | 
 37 |   Inductive value : exp -> Prop :=
 38 |   | Value : forall x e, value (Abs x e).
 39 | 
 40 |   Local Hint Constructors eval value : core.
 41 | 
 42 |   Theorem value_eval : forall v,
 43 |     value v
 44 |     -> eval v v.
 45 |   Proof.
 46 |     invert 1; eauto.
 47 |   Qed.
 48 | 
 49 |   Local Hint Resolve value_eval : core.
 50 | 
 51 |   Theorem eval_value : forall e v,
 52 |     eval e v
 53 |     -> value v.
 54 |   Proof.
 55 |     induct 1; eauto.
 56 |   Qed.
 57 | 
 58 |   Local Hint Resolve eval_value : core.
 59 | 
 60 |   (* Some notations, to let us write more normal-looking lambda terms *)
 61 |   Coercion Var : var >-> exp.
 62 |   Notation "\ x , e" := (Abs x e) (at level 50).
 63 |   Infix "@" := App (at level 49, left associativity).
 64 | 
 65 |   (* Believe it or not, this is a Turing-complete language!  Here's an example
 66 |    * nonterminating program. *)
 67 |   Example omega := (\"x", "x" @ "x") @ (\"x", "x" @ "x").
 68 | 
 69 | 
 70 |   (** * Church Numerals, everyone's favorite example of lambda terms in
 71 |       * action *)
 72 | 
 73 |   (* Here are two curious definitions. *)
 74 |   Definition zero := \"f", \"x", "x".
 75 |   Definition plus1 := \"n", \"f", \"x", "f" @ ("n" @ "f" @ "x").
 76 | 
 77 |   (* We can build up any natural number [n] as [plus1^n @ zero].  Let's prove
 78 |    * that, in fact, these definitions constitute a workable embedding of the
 79 |    * natural numbers in lambda-calculus. *)
 80 | 
 81 |   (* A term [plus^n @ zero] evaluates to something very close to what this
 82 |    * function returns. *)
 83 |   Fixpoint canonical' (n : nat) : exp :=
 84 |     match n with
 85 |     | O => "x"
 86 |     | S n' => "f" @ ((\"f", \"x", canonical' n') @ "f" @ "x")
 87 |     end.
 88 | 
 89 |   (* This missing piece is this wrapper. *)
 90 |   Definition canonical n := \"f", \"x", canonical' n.
 91 | 
 92 |   (* Let's formalize our definition of what it means to represent a number. *)
 93 |   Definition represents (e : exp) (n : nat) :=
 94 |     eval e (canonical n).
 95 | 
 96 |   (* Zero passes the test. *)
 97 |   Theorem zero_ok : represents zero 0.
 98 |   Proof.
 99 |     unfold zero, represents, canonical.
100 |     simplify.
101 |     econstructor.
102 |   Qed.
103 | 
104 |   (* So does our successor operation. *)
105 |   Theorem plus1_ok : forall e n, represents e n
106 |                                  -> represents (plus1 @ e) (S n).
107 |   Proof.
108 |     unfold plus1, represents, canonical; simplify.
109 |     econstructor.
110 |     econstructor.
111 |     eassumption.
112 |     simplify.
113 |     econstructor.
114 |   Qed.
115 | 
116 |   (* What's basically going on here?  The representation of number [n] is [N]
117 |    * such that, for any function [f]:
118 |    *   N(f) = f^n
119 |    * That is, we represent a number as its repeated-composition operator.
120 |    * So, given a number, we can use it to repeat any operation.  In particular,
121 |    * to implement addition, we can just repeat [plus1]! *)
122 |   Definition add := \"n", \"m", "n" @ plus1 @ "m".
123 | 
124 |   (* Our addition works properly on this test case. *)
125 |   Example add_1_2 : exists v,
126 |       eval (add @ (plus1 @ zero) @ (plus1 @ (plus1 @ zero))) v
127 |       /\ eval (plus1 @ (plus1 @ (plus1 @ zero))) v.
128 |   Proof.
129 |     eexists; propositional.
130 |     repeat (econstructor; simplify).
131 |     repeat econstructor.
132 |   Qed.
133 | 
134 |   (* By the way: since [canonical'] doesn't mention variable "m", substituting
135 |    * for "m" has no effect.  This fact will come in handy shortly. *)
136 |   Lemma subst_m_canonical' : forall m n,
137 |     subst m "m" (canonical' n) = canonical' n.
138 |   Proof.
139 |     induct n; simplify; equality.
140 |   Qed.
141 | 
142 |   (* This inductive proof is the workhorse for the next result, so let's skip
143 |    * ahead there. *)
144 |   Lemma add_ok' : forall m n,
145 |       eval
146 |         (subst (\ "f", (\ "x", canonical' m)) "x"
147 |                (subst (\ "n", (\ "f", (\ "x", "f" @ (("n" @ "f") @ "x")))) "f"
148 |                       (canonical' n))) (canonical (n + m)).
149 |   Proof.
150 |     induct n; simplify.
151 | 
152 |     econstructor.
153 | 
154 |     econstructor.
155 |     econstructor.
156 |     econstructor.
157 |     econstructor.
158 |     econstructor.
159 |     econstructor.
160 |     simplify.
161 |     econstructor.
162 |     econstructor.
163 |     simplify.
164 |     eassumption.
165 | 
166 |     simplify.
167 |     econstructor.
168 |   Qed.
169 | 
170 |   (* [add] properly encodes the usual addition. *)
171 |   Theorem add_ok : forall n ne m me,
172 |       represents ne n
173 |       -> represents me m
174 |       -> represents (add @ ne @ me) (n + m).
175 |   Proof.
176 |     unfold represents; simplify.
177 | 
178 |     econstructor.
179 |     econstructor.
180 |     econstructor.
181 |     eassumption.
182 |     simplify.
183 |     econstructor.
184 |     eassumption.
185 |     simplify.
186 |     econstructor.
187 |     econstructor.
188 |     econstructor.
189 |     econstructor.
190 |     simplify.
191 |     econstructor.
192 |     econstructor.
193 |     rewrite subst_m_canonical'.
194 |     apply add_ok'.
195 |   Qed.
196 | 
197 |   (* Let's repeat the same exercise for multiplication. *)
198 | 
199 |   Definition mult := \"n", \"m", "n" @ (add @ "m") @ zero.
200 | 
201 |   Example mult_1_2 : exists v,
202 |       eval (mult @ (plus1 @ zero) @ (plus1 @ (plus1 @ zero))) v
203 |       /\ eval (plus1 @ (plus1 @ zero)) v.
204 |   Proof.
205 |     eexists; propositional.
206 |     repeat (econstructor; simplify).
207 |     repeat econstructor.
208 |   Qed.
209 | 
210 |   Lemma mult_ok' : forall m n,
211 |       eval
212 |         (subst (\ "f", (\ "x", "x")) "x"
213 |                (subst
214 |                   (\ "m",
215 |                    ((\ "f", (\ "x", canonical' m)) @
216 |                                                    (\ "n", (\ "f", (\ "x", "f" @ (("n" @ "f") @ "x"))))) @ "m")
217 |                   "f" (canonical' n))) (canonical (n * m)).
218 |   Proof.
219 |     induct n; simplify.
220 | 
221 |     econstructor.
222 | 
223 |     econstructor.
224 |     econstructor.
225 |     econstructor.
226 |     econstructor.
227 |     econstructor.
228 |     econstructor.
229 |     simplify.
230 |     econstructor.
231 |     econstructor.
232 |     simplify.
233 |     eassumption.
234 | 
235 |     simplify.
236 |     econstructor.
237 |     econstructor.
238 |     econstructor.
239 |     econstructor.
240 |     simplify.
241 |     econstructor.
242 |     econstructor.
243 |     rewrite subst_m_canonical'.
244 |     apply add_ok'. (* Note the recursive appeal to correctness of [add]. *)
245 |   Qed.
246 | 
247 |   Theorem mult_ok : forall n ne m me,
248 |       represents ne n
249 |       -> represents me m
250 |       -> represents (mult @ ne @ me) (n * m).
251 |   Proof.
252 |     unfold represents; simplify.
253 | 
254 |     econstructor.
255 |     econstructor.
256 |     econstructor.
257 |     eassumption.
258 |     simplify.
259 |     econstructor.
260 |     eassumption.
261 |     simplify.
262 |     econstructor.
263 |     econstructor.
264 |     econstructor.
265 |     econstructor.
266 |     econstructor.
267 |     econstructor.
268 |     simplify.
269 |     econstructor.
270 |     simplify.
271 |     econstructor.
272 |     econstructor.
273 |     simplify.
274 |     rewrite subst_m_canonical'.
275 |     apply mult_ok'.
276 |   Qed.
277 | 
278 | 
279 |   (** * Small-step semantics *)
280 | 
281 |   Inductive step : exp -> exp -> Prop :=
282 |   | Beta : forall x e v,
283 |     value v
284 |     -> step (App (Abs x e) v) (subst v x e)
285 | 
286 |   (* However, we also need bureaucractic rules for pushing evaluation inside
287 |    * applications. *)
288 |   | App1 : forall e1 e1' e2,
289 |       step e1 e1'
290 |       -> step (App e1 e2) (App e1' e2)
291 |   | App2 : forall v e2 e2',
292 |       value v
293 |       -> step e2 e2'
294 |       -> step (App v e2) (App v e2').
295 | 
296 |   Local Hint Constructors step : core.
297 | 
298 |   (* Here we now go through a proof of equivalence between big- and small-step
299 |    * semantics, though we won't spend any further commentary on it. *)
300 | 
301 |   Lemma step_eval' : forall e1 e2,
302 |     step e1 e2
303 |     -> forall v, eval e2 v
304 |       -> eval e1 v.
305 |   Proof.
306 |     induct 1; simplify; eauto.
307 | 
308 |     invert H0.
309 |     econstructor.
310 |     apply IHstep.
311 |     eassumption.
312 |     eassumption.
313 |     assumption.
314 | 
315 |     invert H1.
316 |     econstructor.
317 |     eassumption.
318 |     apply IHstep.
319 |     eassumption.
320 |     assumption.
321 |   Qed.
322 | 
323 |   Local Hint Resolve step_eval' : core.
324 | 
325 |   Theorem step_eval : forall e v,
326 |     step^* e v
327 |     -> value v
328 |     -> eval e v.
329 |   Proof.
330 |     induct 1; eauto.
331 |   Qed.
332 | 
333 |   Local Hint Resolve eval_value : core.
334 | 
335 |   Theorem step_app1 : forall e1 e1' e2,
336 |     step^* e1 e1'
337 |     -> step^* (App e1 e2) (App e1' e2).
338 |   Proof.
339 |     induct 1; eauto.
340 |   Qed.
341 | 
342 |   Theorem step_app2 : forall e2 e2' v,
343 |     value v
344 |     -> step^* e2 e2'
345 |     -> step^* (App v e2) (App v e2').
346 |   Proof.
347 |     induct 2; eauto.
348 |   Qed.
349 | 
350 |   Theorem eval_step : forall e v,
351 |     eval e v
352 |     -> step^* e v.
353 |   Proof.
354 |     induct 1; eauto.
355 | 
356 |     eapply trc_trans.
357 |     apply step_app1.
358 |     eassumption.
359 |     eapply trc_trans.
360 |     eapply step_app2.
361 |     constructor.
362 |     eassumption.
363 |     econstructor.
364 |     constructor.
365 |     eauto.
366 |     assumption.
367 |   Qed.
368 | End Ulc.
369 | 
370 | 
371 | Module Stlc.
372 |   Inductive exp : Set :=
373 |   | Var (x : var)
374 |   | Const (n : nat)
375 |   | Plus (e1 e2 : exp)
376 |   | Abs (x : var) (e1 : exp)
377 |   | App (e1 e2 : exp).
378 | 
379 |   Inductive value : exp -> Prop :=
380 |   | VConst : forall n, value (Const n)
381 |   | VAbs : forall x e1, value (Abs x e1).
382 | 
383 |   Fixpoint subst (e1 : exp) (x : string) (e2 : exp) : exp :=
384 |     match e2 with
385 |       | Var y => if y ==v x then e1 else Var y
386 |       | Const n => Const n
387 |       | Plus e2' e2'' => Plus (subst e1 x e2') (subst e1 x e2'')
388 |       | Abs y e2' => Abs y (if y ==v x then e2' else subst e1 x e2')
389 |       | App e2' e2'' => App (subst e1 x e2') (subst e1 x e2'')
390 |     end.
391 | 
392 |   Inductive step : exp -> exp -> Prop :=
393 |   | Beta : forall x e v,
394 |       value v
395 |       -> step (App (Abs x e) v) (subst v x e)
396 |   | Add : forall n1 n2,
397 |       step (Plus (Const n1) (Const n2)) (Const (n1 + n2))
398 |   | App1 : forall e1 e1' e2,
399 |       step e1 e1'
400 |       -> step (App e1 e2) (App e1' e2)
401 |   | App2 : forall v e2 e2',
402 |       value v
403 |       -> step e2 e2'
404 |       -> step (App v e2) (App v e2')
405 |   | Plus1 : forall e1 e1' e2,
406 |       step e1 e1'
407 |       -> step (Plus e1 e2) (Plus e1' e2)
408 |   | Plus2 : forall v e2 e2',
409 |       value v
410 |       -> step e2 e2'
411 |       -> step (Plus v e2) (Plus v e2').
412 | 
413 |   Definition trsys_of (e : exp) := {|
414 |     Initial := {e};
415 |     Step := step
416 |   |}.
417 |   
418 |   Inductive type :=
419 |   | Nat                  (* Numbers *)
420 |   | Fun (dom ran : type) (* Functions *).
421 | 
422 |   Inductive has_ty : fmap var type -> exp -> type -> Prop :=
423 |   | HtVar : forall G x t,
424 |     G $? x = Some t
425 |     -> has_ty G (Var x) t
426 |   | HtConst : forall G n,
427 |     has_ty G (Const n) Nat
428 |   | HtPlus : forall G e1 e2,
429 |     has_ty G e1 Nat
430 |     -> has_ty G e2 Nat
431 |     -> has_ty G (Plus e1 e2) Nat
432 |   | HtAbs : forall G x e1 t1 t2,
433 |     has_ty (G $+ (x, t1)) e1 t2
434 |     -> has_ty G (Abs x e1) (Fun t1 t2)
435 |   | HtApp : forall G e1 e2 t1 t2,
436 |     has_ty G e1 (Fun t1 t2)
437 |     -> has_ty G e2 t1
438 |     -> has_ty G (App e1 e2) t2.
439 | 
440 |   Local Hint Constructors value step has_ty : core.
441 | 
442 |   (* Some notation to make it more pleasant to write programs *)
443 |   Infix "-->" := Fun (at level 60, right associativity).
444 |   Coercion Const : nat >-> exp.
445 |   Infix "^+^" := Plus (at level 50).
446 |   Coercion Var : var >-> exp.
447 |   Notation "\ x , e" := (Abs x e) (at level 51).
448 |   Infix "@" := App (at level 49, left associativity).
449 | 
450 |   (* Some examples of typed programs *)
451 | 
452 |   Example one_plus_one : has_ty $0 (1 ^+^ 1) Nat.
453 |   Proof.
454 |     repeat (econstructor; simplify).
455 |   Qed.
456 | 
457 |   Example add : has_ty $0 (\"n", \"m", "n" ^+^ "m") (Nat --> Nat --> Nat).
458 |   Proof.
459 |     repeat (econstructor; simplify).
460 |   Qed.
461 | 
462 |   Example eleven : has_ty $0 ((\"n", \"m", "n" ^+^ "m") @ 7 @ 4) Nat.
463 |   Proof.
464 |     repeat (econstructor; simplify).
465 |   Qed.
466 | 
467 |   Example seven_the_long_way : has_ty $0 ((\"x", "x") @ (\"x", "x") @ 7) Nat.
468 |   Proof.
469 |     repeat (econstructor; simplify).
470 |   Qed.
471 | 
472 | 
473 |   (** * Let's prove type soundness. *)
474 | 
475 |   Definition unstuck e := value e
476 |     \/ (exists e' : exp, step e e').
477 | 
478 |   Lemma progress : forall e t,
479 |     has_ty $0 e t
480 |     -> value e
481 |     \/ (exists e' : exp, step e e').
482 |   Proof.
483 |   Admitted.
484 | 
485 |   (* Replacing a typing context with an equal one has no effect (useful to guide
486 |    * proof search as a hint). *)
487 |   Lemma has_ty_change : forall G e t,
488 |     has_ty G e t
489 |     -> forall G', G' = G
490 |       -> has_ty G' e t.
491 |   Proof.
492 |   Admitted.
493 | 
494 |   Local Hint Resolve has_ty_change : core.
495 | 
496 |   Lemma preservation : forall e1 e2,
497 |     step e1 e2
498 |     -> forall t, has_ty $0 e1 t
499 |       -> has_ty $0 e2 t.
500 |   Proof.
501 |   Admitted.
502 | 
503 |   Theorem safety : forall e t, has_ty $0 e t
504 |     -> invariantFor (trsys_of e) unstuck.
505 |   Proof.
506 |     simplify.
507 | 
508 |     (* Step 1: strengthen the invariant.  In particular, the typing relation is
509 |      * exactly the right stronger invariant!  Our progress theorem proves the
510 |      * required invariant inclusion. *)
511 |     apply invariant_weaken with (invariant1 := fun e' => has_ty $0 e' t).
512 | 
513 |     (* Step 2: apply invariant induction, whose induction step turns out to match
514 |      * our preservation theorem exactly! *)
515 |     apply invariant_induction; simplify.
516 |     equality.
517 | 
518 |     eapply preservation.
519 |     eassumption.
520 |     assumption.
521 | 
522 |     simplify.
523 |     eapply progress.
524 |     eassumption.
525 |   Qed.
526 | End Stlc.
527 | 


--------------------------------------------------------------------------------
/FrapWithoutSets.v:
--------------------------------------------------------------------------------
  1 | From Stdlib Require Import Eqdep String NArith Arith Lia Program Bool.
  2 | Require Import Sets Relations Map Var Invariant ModelCheck.
  3 | Export Ascii String Arith Sets Relations Map Var Invariant Bool ModelCheck.
  4 | From Stdlib Require Import List.
  5 | Export List ListNotations.
  6 | Open Scope string_scope.
  7 | Open Scope list_scope.
  8 | 
  9 | Ltac inductN n :=
 10 |   match goal with
 11 |     | [ |- forall x : ?E, _ ] =>
 12 |       match type of E with
 13 |         | Prop =>
 14 |           let H := fresh in intro H;
 15 |             match n with
 16 |               | 1 => dependent induction H
 17 |               | S ?n' => inductN n'
 18 |             end
 19 |         | _ => intro; inductN n
 20 |       end
 21 |   end.
 22 | 
 23 | Ltac same_structure x y :=
 24 |   match x with
 25 |   | ?f ?a1 ?b1 ?c1 ?d1 =>
 26 |     match y with
 27 |     | f ?a2 ?b2 ?c2 ?d2 => same_structure a1 a2; same_structure b1 b2; same_structure c1 c2; same_structure d1 d2
 28 |     | _ => fail 2
 29 |     end
 30 |   | ?f ?a1 ?b1 ?c1 =>
 31 |     match y with
 32 |     | f ?a2 ?b2 ?c2 => same_structure a1 a2; same_structure b1 b2; same_structure c1 c2
 33 |     | _ => fail 2
 34 |     end
 35 |   | ?f ?a1 ?b1 =>
 36 |     match y with
 37 |     | f ?a2 ?b2 => same_structure a1 a2; same_structure b1 b2
 38 |     | _ => fail 2
 39 |     end
 40 |   | ?f ?a1 =>
 41 |     match y with
 42 |     | f ?a2 => same_structure a1 a2
 43 |     | _ => fail 2
 44 |     end
 45 |   | _ =>
 46 |     match y with
 47 |     | ?f ?a1 ?b1 ?c1 ?d1 =>
 48 |       match x with
 49 |       | f ?a2 ?b2 ?c2 ?d2 => same_structure a1 a2; same_structure b1 b2; same_structure c1 c2; same_structure d1 d2
 50 |       | _ => fail 2
 51 |       end
 52 |     | ?f ?a1 ?b1 ?c1 =>
 53 |       match x with
 54 |       | f ?a2 ?b2 ?c2 => same_structure a1 a2; same_structure b1 b2; same_structure c1 c2
 55 |       | _ => fail 2
 56 |       end
 57 |     | ?f ?a1 ?b1 =>
 58 |       match x with
 59 |       | f ?a2 ?b2 => same_structure a1 a2; same_structure b1 b2
 60 |       | _ => fail 2
 61 |       end
 62 |     | ?f ?a1 =>
 63 |       match x with
 64 |       | f ?a2 => same_structure a1 a2
 65 |       | _ => fail 2
 66 |       end
 67 |     | _ => idtac
 68 |     end
 69 |   end.
 70 | 
 71 | Ltac instantiate_obvious1 H :=
 72 |   match type of H with
 73 |   | _ ++ _ = _ ++ _ -> _ => fail 1
 74 |   | ?x = ?y -> _ =>
 75 |     (same_structure x y; specialize (H eq_refl))
 76 |     || (has_evar (x, y); fail 3)
 77 |   | JMeq.JMeq ?x ?y -> _ =>
 78 |     (same_structure x y; specialize (H JMeq.JMeq_refl))
 79 |     || (has_evar (x, y); fail 3)
 80 |   | forall x : ?T, _ =>
 81 |     match type of T with
 82 |     | Prop => fail 1
 83 |     | _ =>
 84 |       let x' := fresh x in
 85 |       evar (x' : T);
 86 |       let x'' := eval unfold x' in x' in specialize (H x''); clear x';
 87 |         instantiate_obvious1 H
 88 |     end
 89 |   end.
 90 | 
 91 | Ltac instantiate_obvious H :=
 92 |   match type of H with
 93 |     | context[@eq string _  _] => idtac
 94 |     | _ => repeat instantiate_obvious1 H
 95 |   end.
 96 | 
 97 | Ltac instantiate_obviouses :=
 98 |   repeat match goal with
 99 |          | [ H : _ |- _ ] => instantiate_obvious H
100 |          end.
101 | 
102 | (** * Interlude: special notations and induction principle for [N] *)
103 | 
104 | (* Note: recurse is an identifier, but we will always use the name "recurse" by convention *)
105 | (*Declare Scope N_recursion_scope.*)
106 | Notation "recurse 'by' 'cases' | 0 => A | n + 1 => B 'end'" :=
107 |   (N.recursion A (fun n recurse => B))
108 |   (at level 11, A at level 200, n at level 0, B at level 200,
109 |    format "'[hv' recurse  'by'  'cases' '//' '|'  0  =>  A '//' '|'  n  +  1  =>  B '//' 'end' ']'")
110 | : N_recursion_scope.
111 | 
112 | Open Scope N_recursion_scope.
113 | 
114 | Lemma indN: forall (P: N -> Prop),
115 |     P 0%N ->                                 (* base case to prove *)
116 |     (forall n: N, P n -> P (n + 1)%N) ->     (* inductive case to prove *)
117 |     forall n, P n.                           (* conclusion to enjoy *)
118 | Proof. setoid_rewrite N.add_1_r. exact N.peano_ind. Qed.
119 | 
120 | Ltac induct e := (induction e using indN || inductN e || dependent induction e); instantiate_obviouses.
121 | 
122 | Ltac invert' H := inversion H; clear H; subst.
123 | 
124 | Ltac invertN n :=
125 |   match goal with
126 |     | [ |- forall x : ?E, _ ] =>
127 |       match type of E with
128 |         | Prop =>
129 |           let H := fresh in intro H;
130 |             match n with
131 |               | 1 => invert' H
132 |               | S ?n' => invertN n'
133 |             end
134 |         | _ => intro; invertN n
135 |       end
136 |   end.
137 | 
138 | Ltac invert e := invertN e || invert' e.
139 | 
140 | Ltac invert0 e := invert e; fail.
141 | Ltac invert1 e := invert0 e || (invert e; []).
142 | Ltac invert2 e := invert1 e || (invert e; [|]).
143 | 
144 | Ltac maps_neq :=
145 |   match goal with
146 |   | [ H : ?m1 = ?m2 |- _ ] =>
147 |     let rec recur E :=
148 |         match E with
149 |         | ?E' $+ (?k, _) => 
150 |           (apply (f_equal (fun m => m $? k)) in H; simpl in *; autorewrite with core in *; simpl in *; congruence)
151 |           || recur E'
152 |         end in
153 |     recur m1 || recur m2
154 | end.
155 | 
156 | Ltac fancy_neq :=
157 |   repeat match goal with
158 |          | _ => maps_neq
159 |          | [ H : @eq (nat -> _) _ _ |- _ ] => apply (f_equal (fun f => f 0)) in H
160 |          | [ H : @eq ?T _ _ |- _ ] =>
161 |            match eval compute in T with
162 |            | fmap _ _ => fail 1
163 |            | _ => invert H
164 |            end
165 |          end.
166 | 
167 | Ltac maps_equal' := progress Frap.Map.M.maps_equal; autorewrite with core; simpl.
168 | 
169 | Ltac removeDups :=
170 |   match goal with
171 |   | [ |- context[constant ?ls] ] =>
172 |     someMatch ls;
173 |     erewrite (@removeDups_ok _ ls)
174 |       by repeat (apply RdNil
175 |                  || (apply RdNew; [ simpl; intuition (congruence || solve [ fancy_neq ]) | ])
176 |                  || (apply RdDup; [ simpl; intuition (congruence || (repeat (maps_equal' || f_equal))) | ]))
177 |   end.
178 | 
179 | Ltac doSubtract :=
180 |   match goal with
181 |   | [ |- context[@minus ?A (@constant ?A1 ?ls) (@constant ?A2 ?ls0)] ] =>
182 |     match A with
183 |     | A1 => idtac
184 |     | _ => change (@constant A1 ls) with (@constant A ls)
185 |     end;
186 |     match A with
187 |     | A2 => idtac
188 |     | _ => change (@constant A2 ls0) with (@constant A ls0)
189 |     end;
190 |     erewrite (@doSubtract_ok A ls ls0)
191 |       by repeat (apply DsNil
192 |                  || (apply DsKeep; [ simpl; intuition (congruence || solve [ fancy_neq ]) | ])
193 |                  || (apply DsDrop; [ simpl; intuition (congruence || (repeat (maps_equal' || f_equal))) | ]))
194 |   end.
195 | 
196 | Ltac simpl_maps :=
197 |   repeat match goal with
198 |          | [ |- context[add ?m ?k1 ?v $? ?k2] ] =>
199 |            (rewrite (@lookup_add_ne _ _ m k1 k2 v) by (congruence || lia))
200 |            || (rewrite (@lookup_add_eq _ _ m k1 k2 v) by (congruence || lia))
201 |          end.
202 | 
203 | Ltac simplify := repeat (unifyTails; pose proof I);
204 |                 repeat match goal with
205 |                        | [ H : True |- _ ] => clear H
206 |                        end;
207 |                 repeat progress (simpl in *; intros; try autorewrite with core in *; simpl_maps);
208 |                                  repeat (normalize_set || doSubtract).
209 | Ltac propositional := intuition idtac.
210 | 
211 | Ltac linear_arithmetic := intros;
212 |     repeat match goal with
213 |            | [ |- context[max ?a ?b] ] =>
214 |              let Heq := fresh "Heq" in destruct (Nat.max_spec a b) as [[? Heq] | [? Heq]];
215 |                rewrite Heq in *; clear Heq
216 |            | [ _ : context[max ?a ?b] |- _ ] =>
217 |              let Heq := fresh "Heq" in destruct (Nat.max_spec a b) as [[? Heq] | [? Heq]];
218 |                rewrite Heq in *; clear Heq
219 |            | [ |- context[min ?a ?b] ] =>
220 |              let Heq := fresh "Heq" in destruct (Nat.min_spec a b) as [[? Heq] | [? Heq]];
221 |                rewrite Heq in *; clear Heq
222 |            | [ _ : context[min ?a ?b] |- _ ] =>
223 |              let Heq := fresh "Heq" in destruct (Nat.min_spec a b) as [[? Heq] | [? Heq]];
224 |                rewrite Heq in *; clear Heq
225 |            end; lia.
226 | 
227 | Ltac equality := intuition congruence.
228 | 
229 | Ltac cases E :=
230 |   ((repeat match type of E with
231 |            | _ \/ _ => destruct E as [E | E]
232 |            end)
233 |    || (match type of E with
234 |        | N => destruct E using indN
235 |        end)
236 |    || (is_var E; destruct E)
237 |    || match type of E with
238 |       | {_} + {_} => destruct E
239 |       | _ => let Heq := fresh "Heq" in destruct E eqn:Heq
240 |       end);
241 |   repeat match goal with
242 |          | [ H : _ = left _ |- _ ] => clear H
243 |          | [ H : _ = right _ |- _ ] => clear H
244 |          end.
245 | 
246 | Global Opaque max min.
247 | 
248 | Infix "==n" := eq_nat_dec (no associativity, at level 50).
249 | Infix "<=?" := le_lt_dec.
250 | 
251 | Export Frap.Map.
252 | 
253 | Ltac maps_equal := Frap.Map.M.maps_equal; simplify.
254 | 
255 | Ltac first_order := firstorder idtac.
256 | 
257 | 
258 | (** * Model checking *)
259 | 
260 | Lemma eq_iff : forall P Q,
261 |     P = Q
262 |     -> (P <-> Q).
263 | Proof.
264 |   equality.
265 | Qed.
266 | 
267 | Ltac sets0 := Sets.sets ltac:(simpl in *; intuition (subst; auto; try equality; try linear_arithmetic)).
268 | 
269 | Ltac sets := propositional;
270 |   try match goal with
271 |       | [ |- @eq (?T -> Prop) _ _ ] =>
272 |         change (T -> Prop) with (set T)
273 |       end;
274 |   try match goal with
275 |       | [ |- @eq (set _) _ _ ] =>
276 |         let x := fresh "x" in
277 |         apply sets_equal; intro x;
278 |         repeat match goal with
279 |                | [ H : @eq (set _) _ _ |- _ ] => apply (f_equal (fun f => f x)) in H;
280 |                                                 apply eq_iff in H
281 |                end
282 |       end; sets0;
283 |   try match goal with
284 |       | [ H : @eq (set ?T) _ _, x : ?T |- _ ] =>
285 |         repeat match goal with
286 |                | [ H : @eq (set T) _ _ |- _ ] => apply (f_equal (fun f => f x)) in H;
287 |                                                  apply eq_iff in H
288 |                end;
289 |           solve [ sets0 ]
290 |       end.
291 | 
292 | Ltac model_check_invert1 :=
293 |   match goal with
294 |   | [ H : ?P |- _ ] =>
295 |     match type of P with
296 |     | Prop => invert H;
297 |               repeat match goal with
298 |                      | [ H : existT _ ?x _ = existT _ ?x _ |- _ ] =>
299 |                        apply inj_pair2 in H; subst
300 |                      end; simplify
301 |     end
302 |   end.
303 | 
304 | Ltac model_check_invert := simplify; subst; repeat model_check_invert1.
305 | 
306 | Lemma oneStepClosure_solve : forall A (sys : trsys A) I I',
307 |   oneStepClosure sys I I'
308 |   -> I = I'
309 |   -> oneStepClosure sys I I.
310 | Proof.
311 |   equality.
312 | Qed.
313 | 
314 | Ltac singletoner := try (exfalso; solve [ sets ]);
315 |   repeat match goal with
316 |          (* | _ => apply singleton_in *)
317 |          | [ |- _ ?S ] => idtac S; apply singleton_in
318 |          | [ |- (_ \cup _) _ ] => apply singleton_in_other
319 |          end.
320 | 
321 | Ltac closure :=
322 |   repeat (apply oneStepClosure_empty
323 |           || (apply oneStepClosure_split; [ model_check_invert; try equality; solve [ singletoner ] | ])).
324 | 
325 | Ltac model_check_done := apply MscDone.
326 | Ltac model_check_step := eapply MscStep; [ closure | simplify ].
327 | 
328 | Ltac model_check_steps1 := model_check_step || model_check_done.
329 | Ltac model_check_steps := repeat model_check_steps1.
330 | 
331 | Ltac model_check_finish := simplify; propositional; subst; simplify; try equality; try linear_arithmetic.
332 | 
333 | Ltac model_check_infer :=
334 |   apply multiStepClosure_ok; simplify; model_check_steps.
335 | 
336 | Ltac model_check_find_invariant :=
337 |   simplify; eapply invariant_weaken; [ model_check_infer | ]; cbv beta in *.
338 | 
339 | Ltac model_check := model_check_find_invariant; model_check_finish.
340 | 
341 | Inductive ordering (n m : nat) :=
342 | | Lt (_ : n < m)
343 | | Eq (_ : n = m)
344 | | Gt (_ : n > m).
345 | 
346 | Local Hint Constructors ordering : core.
347 | Local Hint Extern 1 (_ < _) => lia : core.
348 | Local Hint Extern 1 (_ > _) => lia : core.
349 | 
350 | Theorem totally_ordered : forall n m, ordering n m.
351 | Proof.
352 |   induction n; destruct m; simpl; eauto.
353 |   destruct (IHn m); eauto.
354 | Qed.
355 | 
356 | Ltac total_ordering N M := destruct (totally_ordered N M).
357 | 
358 | Ltac inList x xs :=
359 |   match xs with
360 |   | (x, _) => true
361 |   | (_, ?xs') => inList x xs'
362 |   | _ => false
363 |   end.
364 | 
365 | Ltac maybe_simplify_map m found kont :=
366 |   match m with
367 |   | @empty ?A ?B => kont (@empty A B)
368 |   | ?m' $+ (?k, ?v) =>
369 |     let iL := inList k found in
370 |     match iL with
371 |     | true => maybe_simplify_map m' found kont
372 |     | false =>
373 |       maybe_simplify_map m' (k, found) ltac:(fun m' => kont (m' $+ (k, v)))
374 |     end
375 |   end.
376 | 
377 | Ltac simplify_map' m found kont :=
378 |   match m with
379 |   | ?m' $+ (?k, ?v) =>
380 |     let iL := inList k found in
381 |       match iL with
382 |       | true => maybe_simplify_map m' found kont
383 |       | false =>
384 |         simplify_map' m' (k, found) ltac:(fun m' => kont (m' $+ (k, v)))
385 |       end
386 |   end.
387 | 
388 | Ltac simplify_map :=
389 |   match goal with
390 |   | [ |- context[@add ?A ?B ?m ?k ?v] ] =>
391 |     simplify_map' (m $+ (k, v)) tt ltac:(fun m' =>
392 |                                            replace (@add A B m k v) with m' by maps_equal)
393 |   end.
394 | 
395 | From Stdlib Require Import Classical.
396 | Ltac excluded_middle P := destruct (classic P).
397 | 
398 | Lemma join_idempotent: forall (A B : Type) (m : fmap A B), (m $++ m) = m.
399 | Proof.
400 |   simplify; apply fmap_ext; simplify.
401 |   cases (m $? k).
402 |   - rewrite lookup_join1; auto.
403 |     eauto using lookup_Some_dom.
404 |   - rewrite lookup_join2; auto.
405 |     eauto using lookup_None_dom.
406 | Qed.
407 |   
408 | Lemma includes_refl: forall  (A B : Type) (m : fmap A B), m $<= m.
409 | Proof.
410 |   simplify.
411 |   apply includes_intro; auto.
412 | Qed.
413 | 
414 | Ltac dep_cases E :=
415 |   let x := fresh "x" in
416 |     remember E as x; simpl in x; dependent destruction x;
417 |       try match goal with
418 |             | [ H : _ = E |- _ ] => try rewrite <- H in *; clear H
419 |           end.
420 | 
421 | (** * More with [N] *)
422 | 
423 | Lemma recursion_step: forall {A: Type} (a: A) (f: N -> A -> A) (n: N),
424 |     N.recursion a f (n + 1)%N = f n (N.recursion a f n).
425 | Proof.
426 |   intros until f. setoid_rewrite N.add_1_r.
427 |   eapply N.recursion_succ; cbv; intuition congruence.
428 | Qed.
429 | 
430 | Ltac head f :=
431 |   match f with
432 |   | ?g _ => head g
433 |   | _ => constr:(f)
434 |   end.
435 | 
436 | (* If a function f is defined as
437 | 
438 |   recurse by cases
439 |   | 0 => base
440 |   | k + 1 => step recurse k
441 |   end.
442 | 
443 |   and we have an occurrence of (f (k + 1)) in our goal, we can use
444 |   "unfold_recurse f k" to replace (f (k + 1)) by (step (f k) k),
445 |   ie it allows us to unfold one recursive step. *)
446 | Ltac unfold_recurse f k :=
447 |   let h := head f in
448 |   let rhs := eval unfold h in f in
449 |   lazymatch rhs with
450 |   | N.recursion ?base ?step =>
451 |     let g := eval cbv beta in (step k (f k)) in
452 |     rewrite (recursion_step base step k : f (k + 1)%N = g) in *
453 |   | _ => let expected := open_constr:(N.recursion _ _) in
454 |          fail "The provided term" f "expands to" rhs "which is not of the expected form" expected
455 |   end.
456 | 
457 | (* This will make "simplify" a bit less nice in some cases (but these are easily worked around using
458 |    linear_arithmetic). *)
459 | Arguments N.mul: simpl never.
460 | Arguments N.add: simpl never.
461 | 
462 | Definition IF_then_else (p q1 q2 : Prop) :=
463 |   (p /\ q1) \/ (~p /\ q2).
464 |   
465 | Notation "'IFF' p 'then' q1 'else' q2" := (IF_then_else p q1 q2) (at level 95).
466 | 


--------------------------------------------------------------------------------
/IntroToProofScripting_template.v:
--------------------------------------------------------------------------------
  1 | Require Import Frap.
  2 | 
  3 | Set Implicit Arguments.
  4 | 
  5 | 
  6 | (** * Ltac Programming Basics *)
  7 | 
  8 | Theorem hmm : forall (a b c : bool),
  9 |   if a
 10 |     then if b
 11 |       then True
 12 |       else True
 13 |     else if c
 14 |       then True
 15 |       else True.
 16 | Proof.
 17 | Admitted.
 18 | 
 19 | Theorem hmm2 : forall (a b : bool),
 20 |   (if a then 42 else 42) = (if b then 42 else 42).
 21 | Proof.
 22 | Admitted.
 23 | 
 24 | 
 25 | (** * Automating the two-thread locked-increment example from TransitionSystems *)
 26 | 
 27 | (* Let's experience the process of gradually automating the proof we finished
 28 |  * the last lecture with.  Here's the system-definition code, stripped of
 29 |  * comments. *)
 30 | 
 31 | Inductive increment_program :=
 32 | | Lock
 33 | | Read
 34 | | Write (local : nat)
 35 | | Unlock
 36 | | Done.
 37 | 
 38 | Record inc_state := {
 39 |   Locked : bool;
 40 |   Global : nat
 41 | }.
 42 | 
 43 | Record threaded_state shared private := {
 44 |   Shared : shared;
 45 |   Private : private
 46 | }.
 47 | 
 48 | Definition increment_state := threaded_state inc_state increment_program.
 49 | 
 50 | Inductive increment_init : increment_state -> Prop :=
 51 | | IncInit :
 52 |   increment_init {| Shared := {| Locked := false; Global := O |};
 53 |                     Private := Lock |}.
 54 | 
 55 | Inductive increment_step : increment_state -> increment_state -> Prop :=
 56 | | IncLock : forall g,
 57 |   increment_step {| Shared := {| Locked := false; Global := g |};
 58 |                     Private := Lock |}
 59 |                  {| Shared := {| Locked := true; Global := g |};
 60 |                     Private := Read |}
 61 | | IncRead : forall l g,
 62 |   increment_step {| Shared := {| Locked := l; Global := g |};
 63 |                     Private := Read |}
 64 |                  {| Shared := {| Locked := l; Global := g |};
 65 |                     Private := Write g |}
 66 | | IncWrite : forall l g v,
 67 |   increment_step {| Shared := {| Locked := l; Global := g |};
 68 |                     Private := Write v |}
 69 |                  {| Shared := {| Locked := l; Global := S v |};
 70 |                     Private := Unlock |}
 71 | | IncUnlock : forall l g,
 72 |   increment_step {| Shared := {| Locked := l; Global := g |};
 73 |                     Private := Unlock |}
 74 |                  {| Shared := {| Locked := false; Global := g |};
 75 |                     Private := Done |}.
 76 | 
 77 | Definition increment_sys := {|
 78 |   Initial := increment_init;
 79 |   Step := increment_step
 80 | |}.
 81 | 
 82 | Inductive parallel1 shared private1 private2
 83 |   (init1 : threaded_state shared private1 -> Prop)
 84 |   (init2 : threaded_state shared private2 -> Prop)
 85 |   : threaded_state shared (private1 * private2) -> Prop :=
 86 | | Pinit : forall sh pr1 pr2,
 87 |   init1 {| Shared := sh; Private := pr1 |}
 88 |   -> init2 {| Shared := sh; Private := pr2 |}
 89 |   -> parallel1 init1 init2 {| Shared := sh; Private := (pr1, pr2) |}.
 90 | 
 91 | Inductive parallel2 shared private1 private2
 92 |           (step1 : threaded_state shared private1 -> threaded_state shared private1 -> Prop)
 93 |           (step2 : threaded_state shared private2 -> threaded_state shared private2 -> Prop)
 94 |           : threaded_state shared (private1 * private2)
 95 |             -> threaded_state shared (private1 * private2) -> Prop :=
 96 | | Pstep1 : forall sh pr1 pr2 sh' pr1',
 97 |   step1 {| Shared := sh; Private := pr1 |} {| Shared := sh'; Private := pr1' |}
 98 |   -> parallel2 step1 step2 {| Shared := sh; Private := (pr1, pr2) |}
 99 |                {| Shared := sh'; Private := (pr1', pr2) |}
100 | | Pstep2 : forall sh pr1 pr2 sh' pr2',
101 |   step2 {| Shared := sh; Private := pr2 |} {| Shared := sh'; Private := pr2' |}
102 |   -> parallel2 step1 step2 {| Shared := sh; Private := (pr1, pr2) |}
103 |                {| Shared := sh'; Private := (pr1, pr2') |}.
104 | 
105 | Definition parallel shared private1 private2
106 |            (sys1 : trsys (threaded_state shared private1))
107 |            (sys2 : trsys (threaded_state shared private2)) := {|
108 |   Initial := parallel1 sys1.(Initial) sys2.(Initial);
109 |   Step := parallel2 sys1.(Step) sys2.(Step)
110 | |}.
111 | 
112 | Definition increment2_sys := parallel increment_sys increment_sys.
113 | 
114 | Definition contribution_from (pr : increment_program) : nat :=
115 |   match pr with
116 |   | Unlock => 1
117 |   | Done => 1
118 |   | _ => 0
119 |   end.
120 | 
121 | Definition has_lock (pr : increment_program) : bool :=
122 |   match pr with
123 |   | Read => true
124 |   | Write _ => true
125 |   | Unlock => true
126 |   | _ => false
127 |   end.
128 | 
129 | Definition shared_from_private (pr1 pr2 : increment_program) :=
130 |   {| Locked := has_lock pr1 || has_lock pr2;
131 |      Global := contribution_from pr1 + contribution_from pr2 |}.
132 | 
133 | Definition instruction_ok (self other : increment_program) :=
134 |   match self with
135 |   | Lock => True
136 |   | Read => has_lock other = false
137 |   | Write n => has_lock other = false /\ n = contribution_from other
138 |   | Unlock => has_lock other = false
139 |   | Done => True
140 |   end.
141 | 
142 | Inductive increment2_invariant :
143 |   threaded_state inc_state (increment_program * increment_program) -> Prop :=
144 | | Inc2Inv : forall pr1 pr2,
145 |   instruction_ok pr1 pr2
146 |   -> instruction_ok pr2 pr1
147 |   -> increment2_invariant {| Shared := shared_from_private pr1 pr2; Private := (pr1, pr2) |}.
148 | 
149 | Lemma Inc2Inv' : forall sh pr1 pr2,
150 |   sh = shared_from_private pr1 pr2
151 |   -> instruction_ok pr1 pr2
152 |   -> instruction_ok pr2 pr1
153 |   -> increment2_invariant {| Shared := sh; Private := (pr1, pr2) |}.
154 | Proof.
155 |   simplify.
156 |   rewrite H.
157 |   apply Inc2Inv; assumption.
158 | Qed.
159 | 
160 | (* OK, HERE is where we prove the main theorem. *)
161 | 
162 | Theorem increment2_invariant_ok : invariantFor increment2_sys increment2_invariant.
163 | Proof.
164 | Admitted.
165 | 
166 | 
167 | (** * Implementing some of [propositional] ourselves *)
168 | 
169 | Print True.
170 | Print False.
171 | Locate "/\".
172 | Print and.
173 | Locate "\/".
174 | Print or.
175 | (* Implication ([->]) is built into Rocq, so nothing to look up there. *)
176 | 
177 | Section propositional.
178 |   Variables P Q R : Prop.
179 | 
180 |   Theorem propositional : (P \/ Q \/ False) /\ (P -> Q) -> True /\ Q.
181 |   Proof.
182 |   Admitted.
183 | End propositional.
184 | 
185 | (* Backtracking example #1 *)
186 | 
187 | Theorem m1 : True.
188 | Proof.
189 |   match goal with
190 |     | [ |- _ ] => intro
191 |     | [ |- True ] => constructor
192 |   end.
193 | Qed.
194 | 
195 | (* Backtracking example #2 *)
196 | 
197 | Theorem m2 : forall P Q R : Prop, P -> Q -> R -> Q.
198 | Proof.
199 |   intros; match goal with
200 |             | [ H : _ |- _ ] => idtac H
201 |           end.
202 | Admitted.
203 | 
204 | (* Let's try some more ambitious reasoning, with quantifiers.  We'll be
205 |  * instantiating quantified facts heuristically.  If we're not careful, we get
206 |  * in a loop repeating the same instantiation forever. *)
207 | 
208 | (* Spec: ensure that [P] doesn't follow trivially from hypotheses. *)
209 | Ltac notHyp P := idtac.
210 | 
211 | (* Spec: add [pf] as hypothesis only if it doesn't already follow trivially. *)
212 | Ltac extend pf := idtac.
213 | 
214 | (* Spec: add all simple consequences of known facts, including
215 |  * [forall]-quantified. *)
216 | Ltac completer := idtac.
217 | 
218 | Section firstorder.
219 |   Variable A : Set.
220 |   Variables P Q R S : A -> Prop.
221 | 
222 |   Hypothesis H1 : forall x, P x -> Q x /\ R x.
223 |   Hypothesis H2 : forall x, R x -> S x.
224 | 
225 |   Theorem fo : forall (y x : A), P x -> S x.
226 |   Proof.
227 |   Admitted.
228 | End firstorder.
229 | 
230 | 
231 | (** * Functional Programming in Ltac *)
232 | 
233 | (* Spec: return length of list. *)
234 | Ltac length ls := constr:(0).
235 | 
236 | Goal False.
237 |   let n := length (1 :: 2 :: 3 :: nil) in
238 |     pose n.
239 | Abort.
240 | 
241 | (* Spec: map Ltac function over list. *)
242 | Ltac map f ls := constr:(0).
243 | 
244 | Goal False.
245 |   (*let ls := map (nat * nat)%type ltac:(fun x => constr:((x, x))) (1 :: 2 :: 3 :: nil) in
246 |     pose ls.*)
247 | Abort.
248 | 
249 | (* Now let's revisit [length] and see how we might implement "printf debugging"
250 |  * for it. *)
251 | 
252 | 
253 | (** * Recursive Proof Search *)
254 | 
255 | (* Let's work on a tactic to try all possible instantiations of quantified
256 |  * hypotheses, attempting to find out where the goal becomes obvious. *)
257 | 
258 | Ltac inster n := idtac.
259 | 
260 | Section test_inster.
261 |   Variable A : Set.
262 |   Variables P Q : A -> Prop.
263 |   Variable f : A -> A.
264 |   Variable g : A -> A -> A.
265 | 
266 |   Hypothesis H1 : forall x y, P (g x y) -> Q (f x).
267 | 
268 |   Theorem test_inster : forall x, P (g x x) -> Q (f x).
269 |   Proof.
270 |     inster 2.
271 |   Admitted.
272 | 
273 |   Hypothesis H3 : forall u v, P u /\ P v /\ u <> v -> P (g u v).
274 |   Hypothesis H4 : forall u, Q (f u) -> P u /\ P (f u).
275 | 
276 |   Theorem test_inster2 : forall x y, x <> y -> P x -> Q (f y) -> Q (f x).
277 |   Proof.
278 |     inster 3.
279 |   Admitted.
280 | End test_inster.
281 | 
282 | (** ** A fancier example of proof search (probably skipped on first
283 |        reading/run-through) *)
284 | 
285 | Definition imp (P1 P2 : Prop) := P1 -> P2.
286 | Infix "-->" := imp (no associativity, at level 95).
287 | Ltac imp := unfold imp; firstorder.
288 | 
289 | (** These lemmas about [imp] will be useful in the tactic that we will write. *)
290 | 
291 | Theorem and_True_prem : forall P Q,
292 |   (P /\ True --> Q)
293 |   -> (P --> Q).
294 | Proof.
295 |   imp.
296 | Qed.
297 | 
298 | Theorem and_True_conc : forall P Q,
299 |   (P --> Q /\ True)
300 |   -> (P --> Q).
301 | Proof.
302 |   imp.
303 | Qed.
304 | 
305 | Theorem pick_prem1 : forall P Q R S,
306 |   (P /\ (Q /\ R) --> S)
307 |   -> ((P /\ Q) /\ R --> S).
308 | Proof.
309 |   imp.
310 | Qed.
311 | 
312 | Theorem pick_prem2 : forall P Q R S,
313 |   (Q /\ (P /\ R) --> S)
314 |   -> ((P /\ Q) /\ R --> S).
315 | Proof.
316 |   imp.
317 | Qed.
318 | 
319 | Theorem comm_prem : forall P Q R,
320 |   (P /\ Q --> R)
321 |   -> (Q /\ P --> R).
322 | Proof.
323 |   imp.
324 | Qed.
325 | 
326 | Theorem pick_conc1 : forall P Q R S,
327 |   (S --> P /\ (Q /\ R))
328 |   -> (S --> (P /\ Q) /\ R).
329 | Proof.
330 |   imp.
331 | Qed.
332 | 
333 | Theorem pick_conc2 : forall P Q R S,
334 |   (S --> Q /\ (P /\ R))
335 |   -> (S --> (P /\ Q) /\ R).
336 | Proof.
337 |   imp.
338 | Qed.
339 | 
340 | Theorem comm_conc : forall P Q R,
341 |   (R --> P /\ Q)
342 |   -> (R --> Q /\ P).
343 | Proof.
344 |   imp.
345 | Qed.
346 | 
347 | Ltac search_prem tac :=
348 |   let rec search P :=
349 |     tac
350 |     || (apply and_True_prem; tac)
351 |     || match P with
352 |          | ?P1 /\ ?P2 =>
353 |            (apply pick_prem1; search P1)
354 |            || (apply pick_prem2; search P2)
355 |        end
356 |   in match goal with
357 |        | [ |- ?P /\ _ --> _ ] => search P
358 |        | [ |- _ /\ ?P --> _ ] => apply comm_prem; search P
359 |        | [ |- _ --> _ ] => progress (tac || (apply and_True_prem; tac))
360 |      end.
361 | 
362 | Ltac search_conc tac :=
363 |   let rec search P :=
364 |     tac
365 |     || (apply and_True_conc; tac)
366 |     || match P with
367 |          | ?P1 /\ ?P2 =>
368 |            (apply pick_conc1; search P1)
369 |            || (apply pick_conc2; search P2)
370 |        end
371 |   in match goal with
372 |        | [ |- _ --> ?P /\ _ ] => search P
373 |        | [ |- _ --> _ /\ ?P ] => apply comm_conc; search P
374 |        | [ |- _ --> _ ] => progress (tac || (apply and_True_conc; tac))
375 |      end.
376 | 
377 | Theorem False_prem : forall P Q,
378 |   False /\ P --> Q.
379 | Proof.
380 |   imp.
381 | Qed.
382 | 
383 | Theorem True_conc : forall P Q : Prop,
384 |   (P --> Q)
385 |   -> (P --> True /\ Q).
386 | Proof.
387 |   imp.
388 | Qed.
389 | 
390 | Theorem Match : forall P Q R : Prop,
391 |   (Q --> R)
392 |   -> (P /\ Q --> P /\ R).
393 | Proof.
394 |   imp.
395 | Qed.
396 | 
397 | Theorem ex_prem : forall (T : Type) (P : T -> Prop) (Q R : Prop),
398 |   (forall x, P x /\ Q --> R)
399 |   -> (ex P /\ Q --> R).
400 | Proof.
401 |   imp.
402 | Qed.
403 | 
404 | Theorem ex_conc : forall (T : Type) (P : T -> Prop) (Q R : Prop) x,
405 |   (Q --> P x /\ R)
406 |   -> (Q --> ex P /\ R).
407 | Proof.
408 |   imp.
409 | Qed.
410 | 
411 | Theorem imp_True : forall P,
412 |   P --> True.
413 | Proof.
414 |   imp.
415 | Qed.
416 | 
417 | Ltac matcher :=
418 |   intros;
419 |     repeat search_prem ltac:(simple apply False_prem || (simple apply ex_prem; intro));
420 |       repeat search_conc ltac:(simple apply True_conc || simple eapply ex_conc
421 |         || search_prem ltac:(simple apply Match));
422 |       try simple apply imp_True.
423 | 
424 | (* Our tactic succeeds at proving a simple example. *)
425 | 
426 | Theorem t2 : forall P Q : Prop,
427 |   Q /\ (P /\ False) /\ P --> P /\ Q.
428 | Proof.
429 |   matcher.
430 | Qed.
431 | 
432 | (* In the generated proof, we find a trace of the workings of the search tactics. *)
433 | 
434 | Print t2.
435 | 
436 | (* We can also see that [matcher] is well-suited for cases where some human
437 |  * intervention is needed after the automation finishes. *)
438 | 
439 | Theorem t3 : forall P Q R : Prop,
440 |   P /\ Q --> Q /\ R /\ P.
441 | Proof.
442 |   matcher.
443 | Abort.
444 | 
445 | (* The [matcher] tactic even succeeds at guessing quantifier instantiations.  It
446 |  * is the unification that occurs in uses of the [Match] lemma that does the
447 |  * real work here. *)
448 | 
449 | Theorem t4 : forall (P : nat -> Prop) Q, (exists x, P x /\ Q) --> Q /\ (exists x, P x).
450 | Proof.
451 |   matcher.
452 | Qed.
453 | 
454 | Print t4.
455 | 
456 | 
457 | (** * Creating Unification Variables *)
458 | 
459 | (* A final useful ingredient in tactic crafting is the ability to allocate new
460 |  * unification variables explicitly.  Before we are ready to write a tactic, we
461 |  * can try out its ingredients one at a time. *)
462 | 
463 | Theorem t5 : (forall x : nat, S x > x) -> 2 > 1.
464 | Proof.
465 |   intros.
466 | 
467 |   evar (y : nat).
468 | 
469 |   let y' := eval unfold y in y in
470 |     clear y; specialize (H y').
471 | 
472 |   apply H.
473 | Qed.
474 | 
475 | (* Spec: create new evar of type [T] and pass to [k]. *)
476 | Ltac newEvar T k := idtac.
477 | 
478 | (* Spec: instantiate initial [forall]s of [H] with new evars. *)
479 | Ltac insterU H := idtac.
480 | 
481 | Theorem t5' : (forall x : nat, S x > x) -> 2 > 1.
482 | Proof.
483 | Admitted.
484 | 
485 | (* This particular example is somewhat silly, since [apply] by itself would have
486 |  * solved the goal originally.  Separate forward reasoning is more useful on
487 |  * hypotheses that end in existential quantifications.  Before we go through an
488 |  * example, it is useful to define a variant of [insterU] that does not clear
489 |  * the base hypothesis we pass to it. *)
490 | 
491 | Ltac insterKeep H := idtac.
492 | 
493 | Section t6.
494 |   Variables A B : Type.
495 |   Variable P : A -> B -> Prop.
496 |   Variable f : A -> A -> A.
497 |   Variable g : B -> B -> B.
498 | 
499 |   Hypothesis H1 : forall v, exists u, P v u.
500 |   Hypothesis H2 : forall v1 u1 v2 u2,
501 |     P v1 u1
502 |     -> P v2 u2
503 |     -> P (f v1 v2) (g u1 u2).
504 | 
505 |   Theorem t6 : forall v1 v2, exists u1, exists u2, P (f v1 v2) (g u1 u2).
506 |   Proof.
507 |   Admitted.
508 | End t6.
509 | 
510 | (* Here's an example where something bad happens. *)
511 | 
512 | Section t7.
513 |   Variables A B : Type.
514 |   Variable Q : A -> Prop.
515 |   Variable P : A -> B -> Prop.
516 |   Variable f : A -> A -> A.
517 |   Variable g : B -> B -> B.
518 | 
519 |   Hypothesis H1 : forall v, Q v -> exists u, P v u.
520 |   Hypothesis H2 : forall v1 u1 v2 u2,
521 |     P v1 u1
522 |     -> P v2 u2
523 |     -> P (f v1 v2) (g u1 u2).
524 | 
525 |   Theorem t7 : forall v1 v2, Q v1 -> Q v2 -> exists u1, exists u2, P (f v1 v2) (g u1 u2).
526 |   Proof.
527 |     (*intros; do 2 insterKeep H1;
528 |       repeat match goal with
529 |                | [ H : ex _ |- _ ] => destruct H
530 |              end; eauto.
531 | 
532 |     (* Oh, two trivial goals remain. *)
533 |     Unshelve.
534 |     assumption.
535 |     assumption.*)
536 |   Admitted.
537 | End t7.
538 | 
539 | Theorem t8 : exists p : nat * nat, fst p = 3.
540 | Proof.
541 |   econstructor.
542 |   instantiate (1 := (3, 2)).
543 |   equality.
544 | Qed.
545 | 
546 | (* A way that plays better with automation: *)
547 | 
548 | Theorem t9 : exists p : nat * nat, fst p = 3.
549 | Proof.
550 |   econstructor; match goal with
551 |                   | [ |- fst ?x = 3 ] => unify x (3, 2)
552 |                 end; equality.
553 | Qed.
554 | 


--------------------------------------------------------------------------------
/Interpreters.v:
--------------------------------------------------------------------------------
  1 | (** Formal Reasoning About Programs <http://adam.chlipala.net/frap/>
  2 |   * Chapter 4: Semantics via Interpreters
  3 |   * Author: Adam Chlipala
  4 |   * License: https://creativecommons.org/licenses/by-nc-nd/4.0/ *)
  5 | 
  6 | Require Import Frap.
  7 | 
  8 | 
  9 | (* We begin with a return to our arithmetic language from BasicSyntax,
 10 |  * adding subtraction*, which will come in handy later.
 11 |  * *: good pun, right? *)
 12 | Inductive arith : Set :=
 13 | | Const (n : nat)
 14 | | Var (x : var)
 15 | | Plus (e1 e2 : arith)
 16 | | Minus (e1 e2 : arith)
 17 | | Times (e1 e2 : arith).
 18 | 
 19 | Example ex1 := Const 42.
 20 | Example ex2 := Plus (Var "y") (Times (Var "x") (Const 3)).
 21 | 
 22 | (* The above definition only explains what programs *look like*.
 23 |  * We also care about what they *mean*.
 24 |  * The natural meaning of an expression is the number it evaluates to.
 25 |  * Actually, it's not quite that simple.
 26 |  * We need to consider the meaning to be a function over a valuation
 27 |  * to the variables, which in turn is itself a finite map from variable
 28 |  * names to numbers.  We use the book library's [fmap] type family. *)
 29 | Definition valuation := fmap var nat.
 30 | (* That is, the domain is [var] (a synonym for [string]) and the codomain/range
 31 |  * is [nat]. *)
 32 | 
 33 | (* The interpreter is a fairly innocuous-looking recursive function. *)
 34 | Fixpoint interp (e : arith) (v : valuation) : nat :=
 35 |   match e with
 36 |   | Const n => n
 37 |   | Var x =>
 38 |     (* Note use of infix operator to look up a key in a finite map. *)
 39 |     match v $? x with
 40 |     | None => 0 (* goofy default value! *)
 41 |     | Some n => n
 42 |     end
 43 |   | Plus e1 e2 => interp e1 v + interp e2 v
 44 |   | Minus e1 e2 => interp e1 v - interp e2 v
 45 |                    (* For anyone who's wondering: this [-] sticks at 0,
 46 |                     * if we would otherwise underflow. *)
 47 |   | Times e1 e2 => interp e1 v * interp e2 v
 48 |   end.
 49 | 
 50 | (* Here's an example valuation, using an infix operator for map extension. *)
 51 | Definition valuation0 : valuation :=
 52 |   $0 $+ ("x", 17) $+ ("y", 3).
 53 | 
 54 | (* Unfortunately, we can't execute code based on finite maps, since, for
 55 |  * convenience, they use uncomputable features.  The reason is that we need a
 56 |  * comparison function, a hash function, etc., to do computable finite-map
 57 |  * implementation, and such things are impossible to compute automatically for
 58 |  * all types in Rocq.  However, we can still prove theorems about execution of
 59 |  * finite-map programs, and the [simplify] tactic knows how to reduce the
 60 |  * key constructions. *)
 61 | Theorem interp_ex1 : interp ex1 valuation0 = 42.
 62 | Proof.
 63 |   simplify.
 64 |   equality.
 65 | Qed.
 66 | 
 67 | Theorem interp_ex2 : interp ex2 valuation0 = 54.
 68 | Proof.
 69 |   unfold valuation0.
 70 |   simplify.
 71 |   equality.
 72 | Qed.
 73 | 
 74 | (* Here's the silly transformation we defined last time. *)
 75 | Fixpoint commuter (e : arith) : arith :=
 76 |   match e with
 77 |   | Const _ => e
 78 |   | Var _ => e
 79 |   | Plus e1 e2 => Plus (commuter e2) (commuter e1)
 80 |   | Minus e1 e2 => Minus (commuter e1) (commuter e2)
 81 |                    (* ^-- NB: didn't change the operand order here! *)
 82 |   | Times e1 e2 => Times (commuter e2) (commuter e1)
 83 |   end.
 84 | 
 85 | (* Instead of proving various odds-and-ends properties about it,
 86 |  * let's show what we *really* care about: it preserves the
 87 |  * *meanings* of expressions! *)
 88 | Theorem commuter_ok : forall v e, interp (commuter e) v = interp e v.
 89 | Proof.
 90 |   induct e; simplify.
 91 | 
 92 |   equality.
 93 | 
 94 |   equality.
 95 | 
 96 |   linear_arithmetic.
 97 | 
 98 |   equality.
 99 | 
100 |   rewrite IHe1, IHe2.
101 |   ring.
102 | Qed.
103 | (* Well, that's a relief! ;-) *)
104 | 
105 | (* Let's also revisit substitution. *)
106 | Fixpoint substitute (inThis : arith) (replaceThis : var) (withThis : arith) : arith :=
107 |   match inThis with
108 |   | Const _ => inThis
109 |   | Var x => if x ==v replaceThis then withThis else inThis
110 |   | Plus e1 e2 => Plus (substitute e1 replaceThis withThis) (substitute e2 replaceThis withThis)
111 |   | Minus e1 e2 => Minus (substitute e1 replaceThis withThis) (substitute e2 replaceThis withThis)
112 |   | Times e1 e2 => Times (substitute e1 replaceThis withThis) (substitute e2 replaceThis withThis)
113 |   end.
114 | 
115 | Theorem substitute_ok : forall v replaceThis withThis inThis,
116 |   interp (substitute inThis replaceThis withThis) v
117 |   = interp inThis (v $+ (replaceThis, interp withThis v)).
118 | Proof.
119 |   induct inThis; simplify; try equality.
120 | 
121 |   (* One case left after our basic heuristic:
122 |    * the variable case, naturally! *)
123 |   cases (x ==v replaceThis); simplify; equality.
124 | Qed.
125 | (* Great; we seem to have gotten that one right, too. *)
126 | 
127 | (* Let's also define a pared-down version of the expression-simplification
128 |  * functions from last chapter. *)
129 | Fixpoint doSomeArithmetic (e : arith) : arith :=
130 |   match e with
131 |   | Const _ => e
132 |   | Var _ => e
133 |   | Plus (Const n1) (Const n2) => Const (n1 + n2)
134 |   | Plus e1 e2 => Plus (doSomeArithmetic e1) (doSomeArithmetic e2)
135 |   | Minus e1 e2 => Minus (doSomeArithmetic e1) (doSomeArithmetic e2)
136 |   | Times (Const n1) (Const n2) => Const (n1 * n2)
137 |   | Times e1 e2 => Times (doSomeArithmetic e1) (doSomeArithmetic e2)
138 |   end.
139 | 
140 | Theorem doSomeArithmetic_ok : forall e v, interp (doSomeArithmetic e) v = interp e v.
141 | Proof.
142 |   induct e; simplify; try equality.
143 | 
144 |   cases e1; simplify; try equality.
145 |   cases e2; simplify; equality.
146 | 
147 |   cases e1; simplify; try equality.
148 |   cases e2; simplify; equality.
149 | Qed.
150 | 
151 | (* Of course, we're going to get bored if we confine ourselves to arithmetic
152 |  * expressions for the rest of our journey.  Let's get a bit fancier and define
153 |  * a *stack machine*, related to postfix calculators that some of you may have
154 |  * experienced. *)
155 | Inductive instruction :=
156 | | PushConst (n : nat)
157 | | PushVar (x : var)
158 | | Add
159 | | Subtract
160 | | Multiply.
161 | 
162 | (* What does it all mean?  An interpreter tells us unambiguously! *)
163 | Definition run1 (i : instruction) (v : valuation) (stack : list nat) : list nat :=
164 |   match i with
165 |   | PushConst n => n :: stack
166 |   | PushVar x => (match v $? x with
167 |                   | None => 0
168 |                   | Some n => n
169 |                   end) :: stack
170 |   | Add =>
171 |     match stack with
172 |     | arg2 :: arg1 :: stack' => arg1 + arg2 :: stack'
173 |     | _ => stack (* arbitrary behavior in erroneous case (stack underflow) *)
174 |     end
175 |   | Subtract =>
176 |     match stack with
177 |     | arg2 :: arg1 :: stack' => arg1 - arg2 :: stack'
178 |     | _ => stack (* arbitrary behavior in erroneous case *)
179 |     end
180 |   | Multiply =>
181 |     match stack with
182 |     | arg2 :: arg1 :: stack' => arg1 * arg2 :: stack'
183 |     | _ => stack (* arbitrary behavior in erroneous case *)
184 |     end
185 |   end.
186 | 
187 | (* That function explained how to run one instruction.
188 |  * Here's how to run several of them. *)
189 | Fixpoint run (is : list instruction) (v : valuation) (stack : list nat) : list nat :=
190 |   match is with
191 |   | nil => stack
192 |   | i :: is' => run is' v (run1 i v stack)
193 |   end.
194 | 
195 | (* Instead of writing fiddly stack programs ourselves, let's *compile*
196 |  * arithmetic expressions into equivalent stack programs. *)
197 | Fixpoint compile (e : arith) : list instruction :=
198 |   match e with
199 |   | Const n => PushConst n :: nil
200 |   | Var x => PushVar x :: nil
201 |   | Plus e1 e2 => compile e1 ++ compile e2 ++ Add :: nil
202 |   | Minus e1 e2 => compile e1 ++ compile e2 ++ Subtract :: nil
203 |   | Times e1 e2 => compile e1 ++ compile e2 ++ Multiply :: nil
204 |   end.
205 | 
206 | (* Now, of course, we should prove our compiler correct.
207 |  * Skip down to the next theorem to see the overall correctness statement.
208 |  * It turns out that we need to strengthen the induction hypothesis with a
209 |  * lemma, to push the proof through. *)
210 | Lemma compile_ok' : forall e v is stack,
211 |     run (compile e ++ is) v stack = run is v (interp e v :: stack).
212 | Proof.
213 |   induct e; simplify.
214 | 
215 |   equality.
216 | 
217 |   equality.
218 | 
219 |   (* Here we want to use associativity of [++], to get the conclusion to match
220 |    * an induction hypothesis.  Let's ask Rocq to search its library for lemmas
221 |    * that would justify such a rewrite, giving a pattern with wildcards, to
222 |    * specify the essential structure that the rewrite should match. *)
223 |   Search ((_ ++ _) ++ _).
224 |   (* Ah, we see just the one! *)
225 |   rewrite <- app_assoc.
226 |   rewrite IHe1.
227 |   rewrite <- app_assoc.
228 |   rewrite IHe2.
229 |   simplify.
230 |   equality.
231 | 
232 |   rewrite <- app_assoc.
233 |   rewrite IHe1.
234 |   rewrite <- app_assoc.
235 |   rewrite IHe2.
236 |   simplify.
237 |   equality.
238 | 
239 |   rewrite <- app_assoc.
240 |   rewrite IHe1.
241 |   rewrite <- app_assoc.
242 |   rewrite IHe2.
243 |   simplify.
244 |   equality.
245 | Qed.
246 | 
247 | (* The overall theorem follows as a simple corollary. *)
248 | Theorem compile_ok : forall e v, run (compile e) v nil = interp e v :: nil.
249 | Proof.
250 |   simplify.
251 | 
252 |   (* To match the form of our lemma, we need to replace [compile e] with
253 |    * [compile e ++ nil], adding a "pointless" concatenation of the empty list.
254 |    * [Search] again helps us find a library lemma. *)
255 |   Search (_ ++ nil).
256 |   rewrite <- (app_nil_r (compile e)).
257 |   (* Note that we can use [rewrite] with explicit values of the first few
258 |    * quantified variables of a lemma.  Otherwise, [rewrite] picks an
259 |    * unhelpful place to rewrite.  (Try it and see!) *)
260 | 
261 |   apply compile_ok'.
262 |   (* Direct appeal to a previously proved lemma *)
263 | Qed.
264 | 
265 | 
266 | (* Let's get a bit fancier, moving toward the level of general-purpose
267 |  * imperative languages.  Here's a language of commands, building on the
268 |  * language of expressions we have defined. *)
269 | Inductive cmd :=
270 | | Skip
271 | | Assign (x : var) (e : arith)
272 | | Sequence (c1 c2 : cmd)
273 | | Repeat (e : arith) (body : cmd).
274 | 
275 | (* That last constructor is for repeating a body command some number of
276 |  * times.  Note that we sneakily avoid constructs that could introduce
277 |  * nontermination, since Rocq only accepts terminating programs, and we want to
278 |  * write an interpreter for commands.
279 |  * In contrast to our last one, this interpreter *transforms valuations*.
280 |  * We use a helper function for self-composing a function some number of
281 |  * times. *)
282 | 
283 | Fixpoint selfCompose {A} (f : A -> A) (n : nat) : A -> A :=
284 |   match n with
285 |   | O => fun x => x
286 |   | S n' => fun x => selfCompose f n' (f x)
287 |   end.
288 | 
289 | Fixpoint exec (c : cmd) (v : valuation) : valuation :=
290 |   match c with
291 |   | Skip => v
292 |   | Assign x e => v $+ (x, interp e v)
293 |   | Sequence c1 c2 => exec c2 (exec c1 v)
294 |   | Repeat e body => selfCompose (exec body) (interp e v) v
295 |   end.
296 | 
297 | (* Let's define some programs and prove that they operate in certain ways. *)
298 | 
299 | Example factorial_ugly :=
300 |   Sequence
301 |     (Assign "output" (Const 1))
302 |     (Repeat (Var "input")
303 |             (Sequence
304 |                (Assign "output" (Times (Var "output") (Var "input")))
305 |                (Assign "input" (Minus (Var "input") (Const 1))))).
306 | 
307 | (* Ouch; that code is hard to read.  Let's introduce some notations to make the
308 |  * concrete syntax more palatable.  We won't explain the general mechanisms on
309 |  * display here, but see the Rocq manual for details, or try to reverse-engineer
310 |  * them from our examples. *)
311 | Coercion Const : nat >-> arith.
312 | Coercion Var : var >-> arith.
313 | (*Declare Scope arith_scope.*)
314 | Infix "+" := Plus : arith_scope.
315 | Infix "-" := Minus : arith_scope.
316 | Infix "*" := Times : arith_scope.
317 | Delimit Scope arith_scope with arith.
318 | Notation "x <- e" := (Assign x e%arith) (at level 75).
319 | Infix ";" := Sequence (at level 76).
320 | Notation "'repeat' e 'doing' body 'done'" := (Repeat e%arith body) (at level 75).
321 | 
322 | (* OK, let's try that program again. *)
323 | Example factorial :=
324 |   "output" <- 1;
325 |   repeat "input" doing
326 |     "output" <- "output" * "input";
327 |     "input" <- "input" - 1
328 |   done.
329 | 
330 | (* Now we prove that it really computes factorial.
331 |  * First, a reference implementation as a functional program. *)
332 | Fixpoint fact (n : nat) : nat :=
333 |   match n with
334 |   | O => 1
335 |   | S n' => n * fact n'
336 |   end.
337 | 
338 | (* To prove that [factorial] is correct, the real action is in a lemma, to be
339 |  * proved by induction, showing that the loop works correctly.  So, let's first
340 |  * assign a name to the loop body alone. *)
341 | Definition factorial_body :=
342 |   "output" <- "output" * "input";
343 |   "input" <- "input" - 1.
344 | 
345 | (* Now for that lemma: self-composition of the body's semantics produces the
346 |  * expected changes in the valuation.
347 |  * Note that here we're careful to put the quantified variable [input] *first*,
348 |  * because the variables coming after it will need to *change* in the course of
349 |  * the induction.  Try switching the order to see what goes wrong if we put
350 |  * [input] later. *)
351 | Lemma factorial_ok' : forall input output v,
352 |   v $? "input" = Some input
353 |   -> v $? "output" = Some output
354 |   -> selfCompose (exec factorial_body) input v
355 |      = v $+ ("input", 0) $+ ("output", output * fact input).
356 | Proof.
357 |   induct input; simplify.
358 | 
359 |   maps_equal.
360 |   (* [maps_equal]: prove that two finite maps are equal by considering all
361 |    *   the relevant cases for mappings of different keys. *)
362 | 
363 |   rewrite H0.
364 |   f_equal.
365 |   linear_arithmetic.
366 | 
367 |   trivial.
368 |   (* [trivial]: Rocq maintains a database of simple proof steps, such as proving
369 |    *   a fact by direct appeal to a matching hypothesis.  [trivial] asks to try
370 |    *   all such simple steps. *)
371 | 
372 |   rewrite H, H0.
373 |   (* Note the two arguments to one [rewrite]! *)
374 |   rewrite (IHinput (output * S input)).
375 |   (* Note the careful choice of a quantifier instantiation for the IH! *)
376 |   maps_equal.
377 |   f_equal; ring.
378 |   simplify; f_equal; linear_arithmetic.
379 |   simplify; equality.
380 | Qed.
381 | 
382 | (* Finally, we have the natural correctness condition for factorial as a whole
383 |  * program. *)
384 | Theorem factorial_ok : forall v input,
385 |   v $? "input" = Some input
386 |   -> exec factorial v $? "output" = Some (fact input).
387 | Proof.
388 |   simplify.
389 |   rewrite H.
390 |   rewrite (factorial_ok' input 1); simplify.
391 |   f_equal; linear_arithmetic.
392 |   trivial.
393 |   trivial.
394 | Qed.
395 | 
396 | 
397 | (* One last example: let's try to do loop unrolling, for constant iteration
398 |  * counts.  That is, we can duplicate the loop body instead of using an explicit
399 |  * loop. *)
400 | 
401 | Fixpoint seqself (c : cmd) (n : nat) : cmd :=
402 |   match n with
403 |   | O => Skip
404 |   | S n' => Sequence c (seqself c n')
405 |   end.
406 | 
407 | Fixpoint unroll (c : cmd) : cmd :=
408 |   match c with
409 |   | Skip => c
410 |   | Assign _ _ => c
411 |   | Sequence c1 c2 => Sequence (unroll c1) (unroll c2)
412 |   | Repeat (Const n) c1 => seqself (unroll c1) n
413 |   (* ^-- the crucial case! *)
414 |   | Repeat e c1 => Repeat e (unroll c1)
415 |   end.
416 | 
417 | (* This obvious-sounding fact will come in handy: self-composition gives the
418 |  * same result, when passed two functions that map equal inputs to equal
419 |  * outputs. *)
420 | Lemma selfCompose_extensional : forall {A} (f g : A -> A) n x,
421 |   (forall y, f y = g y)
422 |   -> selfCompose f n x = selfCompose g n x.
423 | Proof.
424 |   induct n; simplify; try equality.
425 | 
426 |   rewrite H.
427 |   apply IHn.
428 |   trivial.
429 | Qed.
430 | 
431 | (* Crucial lemma: [seqself] is acting just like [selfCompose], in a suitable
432 |  * sense. *)
433 | Lemma seqself_ok : forall c n v,
434 |   exec (seqself c n) v = selfCompose (exec c) n v.
435 | Proof.
436 |   induct n; simplify; equality.
437 | Qed.
438 | 
439 | (* The two lemmas we just proved are the main ingredients to prove the natural
440 |  * correctness condition for [unroll]. *)
441 | Theorem unroll_ok : forall c v, exec (unroll c) v = exec c v.
442 | Proof.
443 |   induct c; simplify; try equality.
444 | 
445 |   cases e; simplify; try equality.
446 | 
447 |   rewrite seqself_ok.
448 |   apply selfCompose_extensional.
449 |   trivial.
450 | 
451 |   apply selfCompose_extensional.
452 |   trivial.
453 | 
454 |   apply selfCompose_extensional.
455 |   trivial.
456 | 
457 |   apply selfCompose_extensional.
458 |   trivial.
459 | 
460 |   apply selfCompose_extensional.
461 |   trivial.
462 | Qed.
463 | 


--------------------------------------------------------------------------------
/SepCancel.v:
--------------------------------------------------------------------------------
  1 | (** Formal Reasoning About Programs <http://adam.chlipala.net/frap/>
  2 |   * An entailment procedure for separation logic's assertion language
  3 |   * Author: Adam Chlipala
  4 |   * License: https://creativecommons.org/licenses/by-nc-nd/4.0/ *)
  5 | 
  6 | Require Import Frap Setoid Classes.Morphisms.
  7 | 
  8 | Set Implicit Arguments.
  9 | 
 10 | Module Type SEP.
 11 |   Parameter hprop : Type.
 12 |   Parameter lift : Prop -> hprop.
 13 |   Parameter star : hprop -> hprop -> hprop.
 14 |   Parameter exis : forall A, (A -> hprop) -> hprop.
 15 | 
 16 |   Notation "[| P |]" := (lift P).
 17 |   Infix "*" := star.
 18 |   Notation "'exists' x .. y , p" := (exis (fun x => .. (exis (fun y => p)) ..)).
 19 | 
 20 |   Parameters himp heq : hprop -> hprop -> Prop.
 21 | 
 22 |   Infix "===" := heq (no associativity, at level 70).
 23 |   Infix "===>" := himp (no associativity, at level 70).
 24 | 
 25 |   Axiom himp_heq : forall p q, p === q
 26 |                                <-> (p ===> q /\ q ===> p).
 27 |   Axiom himp_refl : forall p, p ===> p.
 28 |   Axiom himp_trans : forall p q r, p ===> q -> q ===> r -> p ===> r.
 29 | 
 30 |   Axiom lift_left : forall p (Q : Prop) r,
 31 |     (Q -> p ===> r)
 32 |     -> p * [| Q |] ===> r.
 33 |   Axiom lift_right : forall p q (R : Prop),
 34 |     p ===> q
 35 |     -> R
 36 |     -> p ===> q * [| R |].
 37 |   Axiom extra_lift : forall (P : Prop) p,
 38 |     P
 39 |     -> p === [| P |] * p.
 40 | 
 41 |   Axiom star_comm : forall p q, p * q === q * p.
 42 |   Axiom star_assoc : forall p q r, p * (q * r) === (p * q) * r.
 43 |   Axiom star_cancel : forall p1 p2 q1 q2, p1 ===> p2
 44 |     -> q1 ===> q2
 45 |     -> p1 * q1 ===> p2 * q2.
 46 | 
 47 |   Axiom exis_gulp : forall A p (q : A -> _),
 48 |     p * exis q === exis (fun x => p * q x).
 49 |   Axiom exis_left : forall A (p : A -> _) q,
 50 |     (forall x, p x ===> q)
 51 |     -> exis p ===> q.
 52 |   Axiom exis_right : forall A p (q : A -> _) x,
 53 |     p ===> q x
 54 |     -> p ===> exis q.
 55 | End SEP.
 56 | 
 57 | Module Make(Import S : SEP).
 58 |   Add Parametric Relation : hprop himp
 59 |     reflexivity proved by himp_refl
 60 |     transitivity proved by himp_trans
 61 |     as himp_rel.
 62 | 
 63 |   Lemma heq_refl : forall p, p === p.
 64 |   Proof.
 65 |     intros; apply himp_heq; intuition (apply himp_refl).
 66 |   Qed.
 67 | 
 68 |   Lemma heq_sym : forall p q, p === q -> q === p.
 69 |   Proof.
 70 |     intros; apply himp_heq; apply himp_heq in H; intuition auto.
 71 |   Qed.
 72 | 
 73 |   Lemma heq_trans : forall p q r, p === q -> q === r -> p === r.
 74 |   Proof.
 75 |     intros; apply himp_heq; apply himp_heq in H; apply himp_heq in H0;
 76 |     intuition (eauto using himp_trans).
 77 |   Qed.
 78 | 
 79 |   Add Parametric Relation : hprop heq
 80 |     reflexivity proved by heq_refl
 81 |     symmetry proved by heq_sym
 82 |     transitivity proved by heq_trans
 83 |     as heq_rel.
 84 | 
 85 |   Global Instance himp_heq_mor : Proper (heq ==> heq ==> iff) himp.
 86 |   Proof.
 87 |     hnf; intros; hnf; intros.
 88 |     apply himp_heq in H; apply himp_heq in H0.
 89 |     intuition eauto using himp_trans.
 90 |   Qed.
 91 | 
 92 |   Add Parametric Morphism : star
 93 |   with signature heq ==> heq ==> heq
 94 |   as star_mor.
 95 |   Proof.
 96 |     intros; apply himp_heq; apply himp_heq in H; apply himp_heq in H0;
 97 |     intuition (auto using star_cancel).
 98 |   Qed.
 99 | 
100 |   Add Parametric Morphism : star
101 |   with signature himp ==> himp ==> himp
102 |   as star_mor'.
103 |   Proof.
104 |     auto using star_cancel.
105 |   Qed.
106 | 
107 |   Global Instance exis_iff_morphism (A : Type) :
108 |     Proper (pointwise_relation A heq ==> heq) (@exis A).
109 |   Proof.
110 |     hnf; intros; apply himp_heq; intuition auto.
111 |     hnf in H.
112 |     apply exis_left; intro.
113 |     eapply exis_right.
114 |     assert (x x0 === y x0) by eauto.
115 |     apply himp_heq in H0; intuition eauto.
116 |     hnf in H.
117 |     apply exis_left; intro.
118 |     eapply exis_right.
119 |     assert (x x0 === y x0) by eauto.
120 |     apply himp_heq in H0; intuition eauto.
121 |   Qed.
122 | 
123 |   Global Instance exis_imp_morphism (A : Type) :
124 |     Proper (pointwise_relation A himp ==> himp) (@exis A).
125 |   Proof.
126 |     hnf; intros.
127 |     apply exis_left; intro.
128 |     eapply exis_right.
129 |     unfold pointwise_relation in H.
130 |     eauto.
131 |   Qed.
132 | 
133 |   Lemma star_combine_lift1 : forall P Q, [| P |] * [| Q |] ===> [| P /\ Q |].
134 |   Proof.
135 |     intros.
136 |     apply lift_left; intro.
137 |     rewrite extra_lift with (P := True); auto.
138 |     apply lift_left; intro.
139 |     rewrite extra_lift with (P := True) (p := [| P /\ Q |]); auto.
140 |     apply lift_right.
141 |     reflexivity.
142 |     tauto.
143 |   Qed.
144 | 
145 |   Lemma star_combine_lift2 : forall P Q, [| P /\ Q |] ===> [| P |] * [| Q |].
146 |   Proof.
147 |     intros.
148 |     rewrite extra_lift with (P := True); auto.
149 |     apply lift_left; intro.
150 |     apply lift_right; try tauto.
151 |     rewrite extra_lift with (P := True) (p := [| P |]); auto.
152 |     apply lift_right; try tauto.
153 |     reflexivity.
154 |   Qed.
155 | 
156 |   Lemma star_combine_lift : forall P Q, [| P |] * [| Q |] === [| P /\ Q |].
157 |   Proof.
158 |     intros.
159 |     apply himp_heq; auto using star_combine_lift1, star_combine_lift2.
160 |   Qed.
161 | 
162 |   Lemma star_comm_lift : forall P q, [| P |] * q === q * [| P |].
163 |   Proof.
164 |     intros; apply star_comm.
165 |   Qed.
166 | 
167 |   Lemma star_assoc_lift : forall p Q r,
168 |     (p * [| Q |]) * r === p * r * [| Q |].
169 |   Proof.
170 |     intros.
171 |     rewrite <- star_assoc.
172 |     rewrite (star_comm [| Q |]).
173 |     apply star_assoc.
174 |   Qed.
175 | 
176 |   Lemma star_comm_exis : forall A (p : A -> _) q, exis p * q === q * exis p.
177 |   Proof.
178 |     intros; apply star_comm.
179 |   Qed.
180 | 
181 |   Ltac lift :=
182 |     intros; apply himp_heq; split;
183 |     repeat (apply lift_left; intro);
184 |     repeat (apply lift_right; intuition auto).
185 | 
186 |   Hint Resolve himp_refl : core.
187 |   
188 |   Lemma lift_combine : forall p Q R,
189 |     p * [| Q |] * [| R |] === p * [| Q /\ R |].
190 |   Proof.
191 |     intros; apply himp_heq; split;
192 |     repeat (apply lift_left; intro);
193 |     repeat (apply lift_right; intuition auto).
194 |   Qed.
195 | 
196 |   Lemma lift1_left : forall (P : Prop) q,
197 |     (P -> [| True |] ===> q)
198 |     -> [| P |] ===> q.
199 |   Proof.
200 |     intros.
201 |     rewrite (@extra_lift True [| P |]); auto.
202 |     apply lift_left; auto.
203 |   Qed.
204 | 
205 |   Lemma lift1_right : forall p (Q : Prop),
206 |     Q
207 |     -> p ===> [| True |]
208 |     -> p ===> [| Q |].
209 |   Proof.
210 |     intros.
211 |     rewrite (@extra_lift True [| Q |]); auto.
212 |     apply lift_right; auto.
213 |   Qed.
214 | 
215 |   Ltac normalize0 :=
216 |     match goal with
217 |     | [ |- context[star ?p (exis ?q)] ] => rewrite (exis_gulp p q)
218 |     | [ |- context[star (star ?p (lift ?q)) (lift ?r)] ] => rewrite (lift_combine p q r)
219 |     | [ |- context[star ?p (star ?q ?r)] ] => rewrite (star_assoc p q r)
220 |     | [ |- context[star (lift ?p) (lift ?q)] ] => rewrite (star_combine_lift p q)
221 |     | [ |- context[star (lift ?p) ?q ] ] => rewrite (star_comm_lift p q)
222 |     | [ |- context[star (star ?p (lift ?q)) ?r] ] => rewrite (star_assoc_lift p q r)
223 |     | [ |- context[star (exis ?p) ?q] ] => rewrite (star_comm_exis p q)
224 |     end.
225 | 
226 |   Ltac normalizeL :=
227 |     (apply exis_left || apply lift_left; intro; try congruence)
228 |     || match goal with
229 |          | [ |- lift ?P ===> _ ] =>
230 |            match P with
231 |              | True => fail 1
232 |              | _ => apply lift1_left; intro; try congruence
233 |            end
234 |        end.
235 | 
236 |   Ltac normalizeR :=
237 |     match goal with
238 |     | [ |- _ ===> exis _ ] => eapply exis_right
239 |     | [ |- _ ===> _ * lift _ ] => apply lift_right
240 |     | [ |- _ ===> lift ?Q ] =>
241 |       match Q with
242 |       | True => fail 1
243 |       | _ => apply lift1_right
244 |       end
245 |     end.
246 | 
247 |   Ltac normalize1 := normalize0 || normalizeL || normalizeR.
248 | 
249 |   Lemma lift_uncombine : forall p P Q,
250 |     p * [| P /\ Q |] === p * [| P |] * [| Q |].
251 |   Proof.
252 |     lift.
253 |   Qed.
254 |   
255 |   Ltac normalize2 :=
256 |     match goal with
257 |     | [ |- context[star ?p (lift (?P /\ ?Q))] ] => rewrite (lift_uncombine p P Q)
258 |     | [ |- context[star ?p (star ?q ?r)] ] => rewrite (star_assoc p q r)
259 |     end.
260 | 
261 |   Ltac normalizeLeft :=
262 |     let s := fresh "s" in intro s;
263 |     let rhs := fresh "rhs" in
264 |     match goal with
265 |       | [ |- _ ===> ?Q ] => set (rhs := Q)
266 |     end;
267 |     simpl; intros; repeat (normalize0 || normalizeL);
268 |     repeat match goal with
269 |              | [ H : ex _ |- _ ===> _ ] => destruct H
270 |              | [ H : _ /\ _ |- _ ] => destruct H
271 |              | [ H : _ = _ |- _ ] => rewrite H
272 |            end; subst rhs.
273 |                                                       
274 |   Ltac normalize :=
275 |     simpl; intros; repeat normalize1; repeat normalize2;
276 |     repeat (match goal with
277 |               | [ H : ex _ |- _ ===> _ ] => destruct H
278 |             end; intuition idtac).
279 | 
280 |   Ltac forAllAtoms p k :=
281 |     match p with
282 |       | ?q * ?r => forAllAtoms q k || forAllAtoms r k
283 |       | _ => k p
284 |     end.
285 | 
286 |   Lemma stb1 : forall p q r,
287 |     (q * p) * r === q * r * p.
288 |   Proof.
289 |     intros; rewrite <- star_assoc; rewrite (star_comm p r); apply star_assoc.
290 |   Qed.
291 | 
292 |   Ltac sendToBack part := repeat (rewrite (stb1 part) || rewrite (star_comm part)).
293 | 
294 |   Theorem star_cancel' : forall p1 p2 q, p1 ===> p2
295 |     -> p1 * q ===> p2 * q.
296 |   Proof.
297 |     intros; apply star_cancel; auto using himp_refl.
298 |   Qed.
299 | 
300 |   Theorem star_cancel'' : forall p q, lift True ===> q
301 |     -> p ===> p * q.
302 |   Proof.
303 |     intros.
304 |     eapply himp_trans.
305 |     rewrite extra_lift with (P := True); auto.
306 |     rewrite star_comm.
307 |     apply star_cancel; auto.
308 |   Qed.
309 | 
310 |   Module Type TRY_ME_FIRST.
311 |     Parameter try_me_first : hprop -> Prop.
312 | 
313 |     Axiom try_me_first_easy : forall p, try_me_first p.
314 |   End TRY_ME_FIRST.
315 | 
316 |   Module TMF : TRY_ME_FIRST.
317 |     Definition try_me_first (_ : hprop) := True.
318 | 
319 |     Theorem try_me_first_easy : forall p, try_me_first p.
320 |     Proof.
321 |       constructor.
322 |     Qed.
323 |   End TMF.
324 | 
325 |   Import TMF.
326 |   Export TMF.
327 | 
328 |   Ltac cancel1 :=
329 |     match goal with
330 |       | [ |- ?p ===> ?q ] =>
331 |         (is_var q; fail 2)
332 |         || forAllAtoms p ltac:(fun p0 =>
333 |           (let H := fresh in assert (H : try_me_first p0) by eauto; clear H);
334 |                                  sendToBack p0;
335 |           forAllAtoms q ltac:(fun q0 =>
336 |             (let H := fresh in assert (H : try_me_first q0) by eauto; clear H);
337 |             sendToBack q0;
338 |             apply star_cancel'))
339 |     end ||
340 |     match goal with
341 |       | [ |- _ ===> ?Q ] =>
342 |         match Q with
343 |         | _ => is_evar Q; fail 1
344 |         | ?Q _ => is_evar Q; fail 1
345 |         | _ => apply himp_refl
346 |         end
347 |       | [ |- ?p ===> ?q ] =>
348 |         (is_var q; fail 2)
349 |         || forAllAtoms p ltac:(fun p0 =>
350 |           sendToBack p0;
351 |           forAllAtoms q ltac:(fun q0 =>
352 |             sendToBack q0;
353 |             apply star_cancel'))
354 |       | _ => progress autorewrite with core
355 |     end.
356 | 
357 |   Ltac hide_evars :=
358 |     repeat match goal with
359 |            | [ |- ?P ===> _ ] => is_evar P; set P
360 |            | [ |- _ ===> ?Q ] => is_evar Q; set Q
361 |            | [ |- context[star ?P _] ] => is_evar P; set P
362 |            | [ |- context[star _ ?Q] ] => is_evar Q; set Q
363 |            | [ |- _ ===> exists v, _ * ?R v ] => is_evar R; set R
364 |            end.
365 | 
366 |   Ltac restore_evars :=
367 |     repeat match goal with
368 |            | [ x := _ |- _ ] => subst x
369 |            end.
370 | 
371 |   Fixpoint flattenAnds (Ps : list Prop) : Prop :=
372 |     match Ps with
373 |     | nil => True
374 |     | [P] => P
375 |     | P :: Ps => P /\ flattenAnds Ps
376 |     end.
377 | 
378 |   Ltac allPuresFrom k :=
379 |     match goal with
380 |     | [ H : ?P |- _ ] =>
381 |       match type of P with
382 |       | Prop => generalize dependent H; allPuresFrom ltac:(fun Ps => k (P :: Ps))
383 |       end
384 |     | _ => intros; k (@nil Prop)
385 |     end.
386 | 
387 |   Ltac whichToQuantify skip foundAlready k :=
388 |     match goal with
389 |     | [ x : ?T |- _ ] =>
390 |       match type of T with
391 |       | Prop => fail 1
392 |       | _ =>
393 |         match skip with
394 |         | context[x] => fail 1
395 |         | _ =>
396 |           match foundAlready with
397 |           | context[x] => fail 1
398 |           | _ => (instantiate (1 := lift (x = x)); fail 2)
399 |                  || (instantiate (1 := fun _ => lift (x = x)); fail 2)
400 |                  || (whichToQuantify skip (x, foundAlready) k)
401 |           end
402 |         end
403 |       end
404 |     | _ => k foundAlready
405 |     end.
406 | 
407 |   Ltac quantifyOverThem vars e k :=
408 |     match vars with
409 |     | tt => k e
410 |     | (?x, ?vars') =>
411 |       match e with
412 |       | context[x] =>
413 |         match eval pattern x in e with
414 |         | ?f _ => quantifyOverThem vars' (exis f) k
415 |         end
416 |       | _ => quantifyOverThem vars' e k
417 |       end
418 |     end.
419 | 
420 |   Ltac addQuantifiers P k :=
421 |     whichToQuantify tt tt ltac:(fun vars =>
422 |         quantifyOverThem vars P k).
423 | 
424 |   Ltac addQuantifiersSkipping x P k :=
425 |     whichToQuantify x tt ltac:(fun vars =>
426 |         quantifyOverThem vars P k).
427 | 
428 |   Ltac basic_cancel :=
429 |     normalize; repeat cancel1; repeat match goal with
430 |                                       | [ H : _ /\ _ |- _ ] => destruct H
431 |                                       | [ |- _ /\ _ ] => split
432 |                                       end; eassumption || apply I.
433 | 
434 |   Ltac beautify := repeat match goal with
435 |                           | [ H : True |- _ ] => clear H
436 |                           | [ H : ?P, H' : ?P |- _ ] =>
437 |                             match type of P with
438 |                             | Prop => clear H'
439 |                             end
440 |                           | [ H : _ /\ _ |- _ ] => destruct H
441 |                           end.
442 | 
443 |   Ltac cancel := hide_evars; normalize; repeat cancel1; restore_evars; beautify;
444 |                  try match goal with
445 |                      | [ |- _ ===> ?p * ?q ] =>
446 |                        ((is_evar p; fail 1) || apply star_cancel'')
447 |                        || ((is_evar q; fail 1) || (rewrite (star_comm p q); apply star_cancel''))
448 |                      end;
449 |                  try match goal with
450 |                      | [ |- ?P ===> _ ] => sendToBack P;
451 |                        match goal with
452 |                        | [ |- ?P ===> ?Q * ?P ] => is_evar Q;
453 |                          rewrite (star_comm Q P);
454 |                          allPuresFrom ltac:(fun Ps =>
455 |                                               match Ps with
456 |                                               | nil => instantiate (1 := lift True)
457 |                                               | _ =>
458 |                                                 let Ps' := eval simpl in (flattenAnds Ps) in
459 |                                                 addQuantifiers (lift Ps') ltac:(fun e => instantiate (1 := e))
460 |                                               end;
461 |                                               basic_cancel)
462 |                        end
463 |                      | [ |- ?P ===> ?Q ] => is_evar Q;
464 |                        allPuresFrom ltac:(fun Ps =>
465 |                                             match Ps with
466 |                                             | nil => reflexivity
467 |                                             | _ =>
468 |                                               let Ps' := eval simpl in (flattenAnds Ps) in
469 |                                               addQuantifiers (star P (lift Ps')) ltac:(fun e => instantiate (1 := e));
470 |                                               basic_cancel
471 |                                             end)
472 |                      | [ |- ?P ===> ?Q ?x ] => is_evar Q;
473 |                         allPuresFrom ltac:(fun Ps =>
474 |                                              match Ps with
475 |                                              | nil => reflexivity
476 |                                              | _ =>
477 |                                                let Ps' := eval simpl in (flattenAnds Ps) in
478 |                                                addQuantifiersSkipping x (star P (lift Ps'))
479 |                                                  ltac:(fun e => match eval pattern x in e with
480 |                                                                 | ?f _ => instantiate (1 := f)
481 |                                                                 end);
482 |                                                basic_cancel
483 |                                              end)
484 |                      | [ |- _ ===> _ ] => intuition (try congruence)
485 |                      end; intuition idtac; beautify.
486 | End Make.
487 | 


--------------------------------------------------------------------------------