├── _CoqProject ├── .gitignore ├── shell.nix ├── coq-lattice.opam ├── Makefile ├── .github └── workflows │ └── coq-ci.yml ├── README.md ├── default.nix └── Lattice.v /_CoqProject: -------------------------------------------------------------------------------- 1 | Lattice.v 2 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | /Lattice.v.d 2 | /Makefile.coq* 3 | /.Makefile.coq.* 4 | -------------------------------------------------------------------------------- /shell.nix: -------------------------------------------------------------------------------- 1 | args@{ version ? "lattice_8_15" }: 2 | (import ./default.nix args).${version} 3 | -------------------------------------------------------------------------------- /coq-lattice.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "johnw@newartisans.com" 3 | version: "dev" 4 | 5 | homepage: "https://github.com/jwiegley/category-theory" 6 | dev-repo: "git+https://github.com/jwiegley/category-theory.git" 7 | bug-reports: "https://github.com/jwiegley/category-theory/issues" 8 | license: "BSD-3-Clause" 9 | 10 | synopsis: "An axiom-free formalization of category theory in Coq" 11 | description: """ 12 | An axiom-free formalization of category theory in Coq for personal study and 13 | practical work. 14 | """ 15 | 16 | build: [make "JOBS=%{jobs}%" ] 17 | install: [make "install"] 18 | depends: [ 19 | "coq" {(>= "8.10" & < "8.16~") | (= "dev")} 20 | ] 21 | 22 | tags: [ 23 | ] 24 | authors: [ 25 | "John Wiegley" 26 | ] 27 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | JOBS = 1 2 | 3 | MISSING = \ 4 | find . \( \( -name foo \) -prune \) \ 5 | -o \( -name '*.v' \ 6 | -print \) | \ 7 | xargs egrep -i -Hn '(Fail|abort|admit|undefined|jww)' | \ 8 | egrep -v 'Definition undefined' | \ 9 | egrep -v '(old|new|research)/' 10 | 11 | all: category-theory 12 | -@$(MISSING) || exit 0 13 | 14 | category-theory: Makefile.coq $(wildcard *.v) 15 | make -f Makefile.coq JOBS=$(JOBS) 16 | 17 | Makefile.coq: _CoqProject 18 | coq_makefile -f $< -o $@ 19 | 20 | clean: _CoqProject Makefile.coq 21 | make -f Makefile.coq clean 22 | 23 | install: _CoqProject Makefile.coq 24 | make -f Makefile.coq install 25 | 26 | fullclean: clean 27 | rm -f Makefile.coq Makefile.coq.conf .Makefile.d 28 | -------------------------------------------------------------------------------- /.github/workflows/coq-ci.yml: -------------------------------------------------------------------------------- 1 | name: CI 2 | 3 | on: [push, pull_request] 4 | 5 | jobs: 6 | build: 7 | runs-on: ubuntu-latest 8 | strategy: 9 | matrix: 10 | image: 11 | - 'coqorg/coq:dev' 12 | - 'coqorg/coq:8.15' 13 | - 'coqorg/coq:8.14' 14 | - 'coqorg/coq:8.13' 15 | - 'coqorg/coq:8.12' 16 | - 'coqorg/coq:8.11' 17 | - 'coqorg/coq:8.10' 18 | fail-fast: false 19 | steps: 20 | - uses: actions/checkout@v2 21 | - uses: coq-community/docker-coq-action@v1 22 | with: 23 | opam_file: 'coq-lattice.opam' 24 | custom_image: ${{ matrix.image }} 25 | 26 | # See also: 27 | # https://github.com/coq-community/docker-coq-action#readme 28 | # https://github.com/erikmd/docker-coq-github-action-demo 29 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # A Reflection-based Proof Tactic for Lattices in Coq 2 | 3 | This code is largely based on work by Daniel W. H. James and Ralf Hinze from 4 | their 5 | paper 6 | [A Reflection-based Proof Tactic for Lattices in Coq](http://www.cs.ox.ac.uk/ralf.hinze/publications/TFP09.pdf). 7 | It also includes techniques presented by Arthur Azevedo de Amorim in his blog 8 | entry 9 | on 10 | [Writing reflective tactics](http://poleiro.info/posts/2015-04-13-writing-reflective-tactics.html). 11 | 12 | To use, provide type class instances for `LOSet` and its related type classes: 13 | `Order`, `Reflexive`, `Transitive` and `Lattice`. You will then be able to use 14 | the tactic `lattice` to solve goals expressed as inequalities that use the 15 | `ord` operator (also `≤`) from the `Order` type class. 16 | 17 | The code is straightforward enough that it can also serve as a template for 18 | other decision procedures you might want to write, which are too complex for 19 | Coq's own `Quote` library. 20 | -------------------------------------------------------------------------------- /default.nix: -------------------------------------------------------------------------------- 1 | args@{ 2 | rev ? "9222ae36b208d1c6b55d88e10aa68f969b5b5244" 3 | , sha256 ? "0dvl990alr4bb64w9b32dhzacvchpsspj8p3zqcgk7q5akvqh1mw" 4 | , pkgs ? import (builtins.fetchTarball { 5 | url = "https://github.com/NixOS/nixpkgs/archive/${rev}.tar.gz"; 6 | inherit sha256; }) { 7 | config.allowUnfree = true; 8 | config.allowBroken = false; 9 | } 10 | }: 11 | 12 | let lattice = coqPackages: 13 | with pkgs.${coqPackages}; pkgs.stdenv.mkDerivation rec { 14 | name = "coq${coq.coq-version}-lattice-${version}"; 15 | version = "1.0"; 16 | 17 | src = if pkgs ? coqFilterSource 18 | then pkgs.coqFilterSource [] ./. 19 | else ./.; 20 | 21 | buildInputs = [ 22 | coq coq.ocaml coq.camlp5 coq.findlib equations # coqhammer pkgs.z3-tptp 23 | ]; 24 | enableParallelBuilding = true; 25 | 26 | buildFlags = [ 27 | "JOBS=$(NIX_BUILD_CORES)" 28 | ]; 29 | 30 | installFlags = "COQLIB=$(out)/lib/coq/${coq.coq-version}/"; 31 | 32 | env = pkgs.buildEnv { inherit name; paths = buildInputs; }; 33 | passthru = { 34 | compatibleCoqVersions = v: builtins.elem v [ "8.10" "8.11" "8.12" "8.13" "8.14" "8.15" ]; 35 | }; 36 | }; 37 | 38 | in { 39 | lattice_8_10 = lattice "coqPackages_8_10"; 40 | lattice_8_11 = lattice "coqPackages_8_11"; 41 | lattice_8_12 = lattice "coqPackages_8_12"; 42 | lattice_8_13 = lattice "coqPackages_8_13"; 43 | lattice_8_14 = lattice "coqPackages_8_14"; 44 | lattice_8_15 = lattice "coqPackages_8_15"; 45 | } 46 | -------------------------------------------------------------------------------- /Lattice.v: -------------------------------------------------------------------------------- 1 | Require Import Coq.Program.Program. 2 | Require Import Coq.Bool.Bool. 3 | Require Import Coq.Arith.Bool_nat. 4 | Require Import Coq.Arith.PeanoNat. 5 | Require Import Coq.Lists.List. 6 | Require Import Coq.Relations.Relations. 7 | Require Import Coq.Classes.RelationClasses. 8 | Require Import Coq.Wellfounded.Lexicographic_Product. 9 | 10 | Generalizable All Variables. 11 | 12 | Reserved Infix "⊓" (at level 40, left associativity). 13 | Reserved Infix "⊔" (at level 36, left associativity). 14 | 15 | Class Lattice (A : Type) := { 16 | meet : A -> A -> A where "x ⊓ y" := (meet x y); 17 | join : A -> A -> A where "x ⊔ y" := (join x y); 18 | 19 | meet_commutative : forall a b, a ⊓ b = b ⊓ a; 20 | meet_associative : forall a b c, (a ⊓ b) ⊓ c = a ⊓ (b ⊓ c); 21 | meet_absorptive : forall a b, a ⊓ (a ⊔ b) = a; 22 | meet_idempotent : forall a, a ⊓ a = a; 23 | 24 | join_commutative : forall a b, a ⊔ b = b ⊔ a; 25 | join_associative : forall a b c, (a ⊔ b) ⊔ c = a ⊔ (b ⊔ c); 26 | join_absorptive : forall a b, a ⊔ (a ⊓ b) = a; 27 | join_idempotent : forall a, a ⊔ a = a 28 | }. 29 | 30 | Infix "⊓" := meet (at level 40, left associativity). 31 | Infix "⊔" := join (at level 36, left associativity). 32 | 33 | Class Order (A : Set) := { 34 | ord : relation A; 35 | 36 | reflexive :> Reflexive ord; 37 | antisymmetric : forall {x y}, ord x y -> ord y x -> x = y; 38 | transitive :> Transitive ord 39 | }. 40 | 41 | Infix "≤" := ord (at level 50). 42 | 43 | Class LOSet {A : Set} `(@Order A) `(@Lattice A) := { 44 | meet_consistent : forall a b, a ≤ b <-> a = a ⊓ b; 45 | join_consistent : forall a b, a ≤ b <-> b = a ⊔ b 46 | }. 47 | 48 | Section Lattice. 49 | 50 | Context `{O : Order A}. 51 | Context `{L : Lattice A}. 52 | Context `{@LOSet A O L}. 53 | 54 | Theorem meet_is_glb : forall a b : A, 55 | forall x, x ≤ a /\ x ≤ b <-> x ≤ a ⊓ b. 56 | Proof. 57 | split; intros. 58 | intuition. 59 | apply meet_consistent in H1. 60 | apply meet_consistent in H2. 61 | apply meet_consistent. 62 | rewrite <- meet_associative, <- H1. 63 | assumption. 64 | apply meet_consistent in H0. 65 | rewrite H0; clear H0. 66 | split; apply meet_consistent. 67 | rewrite meet_associative. 68 | rewrite (meet_commutative (a ⊓ b) a). 69 | rewrite <- (meet_associative a). 70 | rewrite meet_idempotent. 71 | reflexivity. 72 | rewrite meet_associative. 73 | rewrite meet_associative. 74 | rewrite meet_idempotent. 75 | reflexivity. 76 | Qed. 77 | 78 | Theorem meet_prime : forall a b : A, 79 | forall x, a ≤ x \/ b ≤ x -> a ⊓ b ≤ x. 80 | Proof. 81 | intros. 82 | destruct H0; 83 | apply meet_consistent in H0; 84 | apply meet_consistent; [rewrite meet_commutative|]; 85 | rewrite meet_associative; 86 | rewrite <- H0; reflexivity. 87 | Qed. 88 | 89 | Theorem join_is_lub : forall a b : A, 90 | forall x, a ≤ x /\ b ≤ x <-> a ⊔ b ≤ x. 91 | Proof. 92 | split; intros. 93 | intuition. 94 | apply join_consistent in H1. 95 | apply join_consistent in H2. 96 | apply join_consistent. 97 | rewrite join_associative, <- H2. 98 | assumption. 99 | apply join_consistent in H0. 100 | rewrite H0; clear H0. 101 | split; apply join_consistent. 102 | rewrite <- join_associative. 103 | rewrite <- join_associative. 104 | rewrite join_idempotent. 105 | reflexivity. 106 | rewrite (join_commutative a b). 107 | rewrite <- join_associative. 108 | rewrite <- join_associative. 109 | rewrite join_idempotent. 110 | reflexivity. 111 | Qed. 112 | 113 | Theorem join_prime : forall a b : A, 114 | forall x, x ≤ a \/ x ≤ b -> x ≤ a ⊔ b. 115 | Proof. 116 | intros. 117 | destruct H0; 118 | apply join_consistent in H0; 119 | apply join_consistent; [|rewrite join_commutative]; 120 | rewrite <- join_associative; 121 | rewrite <- H0; reflexivity. 122 | Qed. 123 | 124 | Set Decidable Equality Schemes. 125 | 126 | Inductive Term : Set := 127 | | Var : nat -> Term 128 | | Meet : Term -> Term -> Term 129 | | Join : Term -> Term -> Term. 130 | 131 | Lemma Meet_acc_l x y : Meet x y <> x. 132 | Proof. 133 | induction x; 134 | unfold not; intros; 135 | try discriminate. 136 | inversion H0; subst. 137 | contradiction. 138 | Qed. 139 | 140 | Lemma Meet_acc_r x y : Meet x y <> y. 141 | Proof. 142 | induction y; 143 | unfold not; intros; 144 | try discriminate. 145 | inversion H0; subst. 146 | contradiction. 147 | Qed. 148 | 149 | Lemma Join_acc_l x y : Join x y <> x. 150 | Proof. 151 | induction x; 152 | unfold not; intros; 153 | try discriminate. 154 | inversion H0; subst. 155 | contradiction. 156 | Qed. 157 | 158 | Lemma Join_acc_r x y : Join x y <> y. 159 | Proof. 160 | induction y; 161 | unfold not; intros; 162 | try discriminate. 163 | inversion H0; subst. 164 | contradiction. 165 | Qed. 166 | 167 | Fixpoint length (t : Term) : nat := 168 | match t with 169 | | Var n => 1 170 | | Meet t1 t2 => 1 + length t1 + length t2 171 | | Join t1 t2 => 1 + length t1 + length t2 172 | end. 173 | 174 | Fixpoint depth (t : Term) : nat := 175 | match t with 176 | | Var n => 0 177 | | Meet t1 t2 => 1 + max (depth t1) (depth t2) 178 | | Join t1 t2 => 1 + max (depth t1) (depth t2) 179 | end. 180 | 181 | Inductive Subterm : Term -> Term -> Prop := 182 | | Meet1 : forall t1 t2, Subterm t1 (Meet t1 t2) 183 | | Meet2 : forall t1 t2, Subterm t2 (Meet t1 t2) 184 | | Join1 : forall t1 t2, Subterm t1 (Join t1 t2) 185 | | Join2 : forall t1 t2, Subterm t2 (Join t1 t2). 186 | 187 | Definition Subterm_inv_t : forall x y, Subterm x y -> Prop. 188 | Proof. 189 | intros [] [] f; 190 | match goal with 191 | | [ H : Subterm ?X (Meet ?Y ?Z) |- Prop ] => 192 | destruct (Term_eq_dec X Y); subst; 193 | [ destruct (Term_eq_dec X Z); subst; 194 | [ exact (f = Meet1 _ _ \/ f = Meet2 _ _) 195 | | exact (f = Meet1 _ _) ] 196 | | destruct (Term_eq_dec X Z); subst; 197 | [ exact (f = Meet2 _ _) 198 | | exact False ] ] 199 | | [ H : Subterm ?X (Join ?Y ?Z) |- Prop ] => 200 | destruct (Term_eq_dec X Y); subst; 201 | [ destruct (Term_eq_dec X Z); subst; 202 | [ exact (f = Join1 _ _ \/ f = Join2 _ _) 203 | | exact (f = Join1 _ _) ] 204 | | destruct (Term_eq_dec X Z); subst; 205 | [ exact (f = Join2 _ _) 206 | | exact False ] ] 207 | | _ => exact False 208 | end. 209 | Defined. 210 | 211 | Corollary Subterm_inv x y f : Subterm_inv_t x y f. 212 | Proof. 213 | pose proof Term_eq_dec. 214 | destruct f, t1, t2; simpl; 215 | destruct (Term_eq_dec _ _); subst; 216 | try destruct (Term_eq_dec _ _); subst; 217 | try (rewrite e || rewrite <- e; clear e); 218 | try (rewrite e0 || rewrite <- e0; clear e0); 219 | try congruence; 220 | try rewrite <- Eqdep_dec.eq_rect_eq_dec; eauto; simpl; intuition; 221 | try rewrite <- Eqdep_dec.eq_rect_eq_dec; eauto; simpl; intuition; 222 | try (unfold eq_rect; destruct e0; intuition); 223 | try (unfold eq_rect; destruct e; intuition). 224 | Qed. 225 | 226 | Program Instance Subterm_Irreflexive : Irreflexive Subterm. 227 | Next Obligation. 228 | repeat intro. 229 | pose proof (Subterm_inv _ _ H0). 230 | inversion H0; subst; simpl in *. 231 | - now apply (Meet_acc_l x t2). 232 | - now apply (Meet_acc_r t1 x). 233 | - now apply (Join_acc_l x t2). 234 | - now apply (Join_acc_r t1 x). 235 | Qed. 236 | 237 | Lemma Subterm_wf : well_founded Subterm. 238 | Proof. 239 | constructor; intros. 240 | inversion H0; subst; simpl in *; 241 | induction y; 242 | induction t1 || induction t2; 243 | simpl in *; 244 | constructor; intros; 245 | inversion H1; subst; clear H1; 246 | try (apply IHy1; constructor); 247 | try (apply IHy2; constructor). 248 | Defined. 249 | 250 | Reserved Notation "〚 t 〛 env" (at level 9). 251 | 252 | Fixpoint eval (t : Term) (env : nat -> A) : A := 253 | match t with 254 | | Var n => env n 255 | | Meet t1 t2 => 〚t1〛env ⊓ 〚t2〛env 256 | | Join t1 t2 => 〚t1〛env ⊔ 〚t2〛env 257 | end where "〚 t 〛 env" := (eval t env). 258 | 259 | Definition Leq (s t : Term) : Prop := forall env, 〚s〛env ≤ 〚t〛env. 260 | Arguments Leq _ _ /. 261 | 262 | (* Note that Equiv can be computed from Leq. *) 263 | Definition Equiv (s t : Term) : Prop := forall env, 〚s〛env = 〚t〛env. 264 | Arguments Equiv _ _ /. 265 | 266 | Reserved Infix "≲" (at level 30). 267 | 268 | Definition R := symprod Term Term Subterm Subterm. 269 | Arguments R /. 270 | 271 | Open Scope lazy_bool_scope. 272 | 273 | Ltac meets_and_joins leq := 274 | repeat destruct (leq (_, _) _); 275 | simpl in *; 276 | subst; 277 | repeat match goal with 278 | | [ H : (_, _) = (_, _) |- _ ] => progress (inversion H; subst) 279 | | [ H : bool |- _ ] => destruct H 280 | end; 281 | try discriminate; 282 | simpl in *; 283 | repeat match goal with 284 | | [ |- _ ⊔ _ ≤ _ ] => apply join_is_lub; split; firstorder idtac 285 | | [ |- _ ≤ _ ⊔ _ ] => apply join_prime; firstorder idtac 286 | | [ |- _ ≤ _ ⊓ _ ] => apply meet_is_glb; split; firstorder idtac 287 | | [ |- _ ⊓ _ ≤ _ ] => apply meet_prime; firstorder idtac 288 | end. 289 | 290 | Local Obligation Tactic := 291 | program_simpl; try (constructor; constructor). 292 | 293 | Set Transparent Obligations. 294 | 295 | (* Whitman's decision procedure. *) 296 | Program Fixpoint leq (p : Term * Term) {wf R p} : 297 | { b : bool | b = true -> Leq (fst p) (snd p) } := 298 | match p with 299 | (* 1. If s = Var i and t = Var j, then s ≲ t holds iff i = j. *) 300 | | (Var i, Var j) => nat_eq_bool i j 301 | 302 | (* 2. If s = Join s1 s2, then s ≲ t holds iff s1 ≲ t and s2 ≲ t. *) 303 | | (Join s1 s2, t) => 304 | exist _ (proj1_sig (leq (s1, t)) &&& proj1_sig (leq (s2, t))) _ 305 | 306 | (* 3. If t = Meet t1 t2, then s ≲ t holds iff s ≲ t1 and s ≲ t2. *) 307 | | (s, Meet t1 t2) => 308 | exist _ (proj1_sig (leq (s, t1)) &&& proj1_sig (leq (s, t2))) _ 309 | 310 | (* 4. If s = Var i and t = Join t1 t2, then s ≲ t holds iff s ≲ t1 or s ≲ t2. *) 311 | | (Var i, Join t1 t2) => 312 | exist _ (proj1_sig (leq (Var i, t1)) ||| proj1_sig (leq (Var i, t2))) _ 313 | 314 | (* 5. If s = Meet s1 s2 and t = Var i, then s ≲ t holds iff s1 ≲ t or s2 ≲ t. *) 315 | | (Meet s1 s2, Var i) => 316 | exist _ (proj1_sig (leq (s1, Var i)) ||| proj1_sig (leq (s2, Var i))) _ 317 | 318 | (* 6. If s = Meet s1 s2 and t = Join t1 t2, then s ≲ t holds iff s1 ≲ t or 319 | s2 ≲ t or s ≲ t1 or s ≲ t2. *) 320 | | (Meet s1 s2, Join t1 t2) => 321 | exist _ (proj1_sig (leq (s1, Join t1 t2)) ||| 322 | proj1_sig (leq (s2, Join t1 t2)) ||| 323 | proj1_sig (leq (Meet s1 s2, t1)) ||| 324 | proj1_sig (leq (Meet s1 s2, t2))) _ 325 | end. 326 | Next Obligation. 327 | destruct (nat_eq_bool i j); simpl in *; subst. 328 | rewrite y; reflexivity. 329 | Defined. 330 | Next Obligation. meets_and_joins leq. Defined. 331 | Next Obligation. meets_and_joins leq. Defined. 332 | Next Obligation. meets_and_joins leq. Defined. 333 | Next Obligation. meets_and_joins leq. Defined. 334 | Next Obligation. 335 | repeat destruct (leq (_, _)); simpl in *. 336 | destruct x. apply meet_prime; left; apply o; reflexivity. 337 | destruct x0. apply meet_prime; right; apply o0; reflexivity. 338 | destruct x1. apply join_prime; left; apply o1; reflexivity. 339 | destruct x2. apply join_prime; right; apply o2; reflexivity. 340 | discriminate. 341 | Defined. 342 | Next Obligation. 343 | apply wf_symprod; 344 | apply Subterm_wf. 345 | Defined. 346 | 347 | Notation "s ≲ t" := (leq (s, t)) (at level 30). 348 | 349 | Definition leq_correct {t u : Term} (Heq : ` (t ≲ u) = true) : 350 | forall env, 〚t〛env ≤ 〚u〛env := proj2_sig (t ≲ u) Heq. 351 | 352 | Inductive Logic : Set := 353 | | LLe : Term -> Term -> Logic 354 | | LAnd : Logic -> Logic -> Logic 355 | | LOr : Logic -> Logic -> Logic 356 | | LImpl : Logic -> Logic -> Logic. 357 | 358 | Fixpoint logicDenote (t : Logic) (env : nat -> A) : Prop := 359 | match t with 360 | | LLe x y => 〚x〛env ≤ 〚y〛env 361 | | LAnd x y => logicDenote x env /\ logicDenote y env 362 | | LOr x y => logicDenote x env \/ logicDenote y env 363 | | LImpl x y => logicDenote x env -> logicDenote y env 364 | end. 365 | 366 | Inductive AndOr {A B : Type} : Type := 367 | | AO_Terms : A -> B -> AndOr 368 | | AO_And : AndOr -> AndOr -> AndOr 369 | | AO_Or : AndOr -> AndOr -> AndOr. 370 | 371 | Program Fixpoint normLe (p : Term * Term) {wf (R) p} : @AndOr Term Term := 372 | match p with 373 | | (Meet a b, c) => AO_Or (normLe (a, c)) (normLe (b, c)) 374 | | (Join a b, c) => AO_And (normLe (a, c)) (normLe (b, c)) 375 | | (c, Meet a b) => AO_And (normLe (c, a)) (normLe (c, b)) 376 | | (c, Join a b) => AO_Or (normLe (c, a)) (normLe (c, b)) 377 | | (a, b) => AO_Terms a b 378 | end. 379 | Next Obligation. 380 | intuition; match goal with [ H : _ = _ |- _ ] => inversion H end. 381 | Defined. 382 | Next Obligation. 383 | intuition; match goal with [ H : _ = _ |- _ ] => inversion H end. 384 | Defined. 385 | Next Obligation. 386 | intuition; match goal with [ H : _ = _ |- _ ] => inversion H end. 387 | Defined. 388 | Next Obligation. 389 | apply measure_wf. 390 | apply wf_symprod; 391 | apply Subterm_wf. 392 | Defined. 393 | 394 | Fixpoint denoteAndOr (t : @AndOr Term Term) : Logic := 395 | match t with 396 | | AO_Terms x y => LLe x y 397 | | AO_And x y => LAnd (denoteAndOr x) (denoteAndOr y) 398 | | AO_Or x y => LOr (denoteAndOr x) (denoteAndOr y) 399 | end. 400 | 401 | Program Fixpoint logicNorm (t : Logic) : Logic := 402 | match t with 403 | | LLe a b => denoteAndOr (normLe (a, b)) 404 | 405 | | LAnd x y => LAnd (logicNorm x) (logicNorm y) 406 | | LOr x y => LOr (logicNorm x) (logicNorm y) 407 | 408 | | LImpl x y => 409 | match logicNorm y with 410 | | LImpl y z => LImpl (LAnd (logicNorm x) y) z 411 | | y => LImpl (logicNorm x) y 412 | end 413 | end. 414 | 415 | Theorem logicNorm_sound : forall x env, 416 | logicDenote x env <-> 417 | logicDenote (logicNorm x) env. 418 | Proof. 419 | Admitted. 420 | 421 | (* 422 | Definition markVars (t : Term) (env : nat -> A) (f : nat -> bool) : 423 | nat -> bool := 424 | let fix go t f := 425 | match t with 426 | | Var x => fun n => (x =? n) ||| f n 427 | | Meet x y => go x (go y f) (* jww (2017-06-18): correct? *) 428 | | Join x y => go x (go y f) 429 | end in 430 | go t (fun _ => false). 431 | 432 | Fixpoint markLogic (t : Logic) (env : nat -> A) : Prop := 433 | match t with 434 | | LLe x y => 〚x〛env ≤ 〚y〛env 435 | | LAnd x y => logicDenote x env /\ logicDenote y env 436 | | LOr x y => logicDenote x env \/ logicDenote y env 437 | | LImpl x y => logicDenote x env -> logicDenote y env 438 | end. 439 | 440 | Fixpoint logicCheck (t : Logic) (env : nat -> A) : Prop := 441 | match t with 442 | | LLe x y => 〚x〛env ≤ 〚y〛env 443 | | LAnd x y => logicDenote x env /\ logicDenote y env 444 | | LOr x y => logicDenote x env \/ logicDenote y env 445 | | LImpl x y => logicDenote x env -> logicDenote y env 446 | end. 447 | 448 | Program Fixpoint determine_truth (t : Logic) {struct t} : 449 | { b : bool | b = true -> forall env, logicDenote t env } := 450 | match t with 451 | | LLe x y => leq (x, y) 452 | | LAnd x y => exist _ (` (determine_truth x) &&& ` (determine_truth y)) _ 453 | | LOr x y => exist _ (` (determine_truth x) ||| ` (determine_truth y)) _ 454 | | LImpl x y => exist _ (if ` (determine_truth x) 455 | then ` (determine_truth y) 456 | else false) _ 457 | end. 458 | Next Obligation. destruct x0; intuition. Defined. 459 | Next Obligation. destruct x0; intuition. Defined. 460 | Next Obligation. destruct x0; intuition. Defined. 461 | *) 462 | 463 | End Lattice. 464 | 465 | Notation "〚 t 〛 env" := (@eval _ _ t env) (at level 9). 466 | Notation "s ≲ t" := (@leq _ _ _ _ (s, t)) (at level 30). 467 | 468 | Import ListNotations. 469 | 470 | Ltac inList x xs := 471 | match xs with 472 | | tt => false 473 | | (x, _) => true 474 | | (_, ?xs') => inList x xs' 475 | end. 476 | 477 | Ltac addToList x xs := 478 | let b := inList x xs in 479 | match b with 480 | | true => xs 481 | | false => constr:((x, xs)) 482 | end. 483 | 484 | Ltac allVars xs e := 485 | match e with 486 | | ?e1 ⊓ ?e2 => 487 | let xs := allVars xs e1 in 488 | allVars xs e2 489 | | ?e1 ⊔ ?e2 => 490 | let xs := allVars xs e1 in 491 | allVars xs e2 492 | | _ => addToList e xs 493 | end. 494 | 495 | Ltac lookup x xs := 496 | match xs with 497 | | (x, _) => O 498 | | (_, ?xs') => 499 | let n := lookup x xs' in 500 | constr:(S n) 501 | end. 502 | 503 | Ltac reifyTerm env t := 504 | match t with 505 | | ?X1 ⊓ ?X2 => 506 | let r1 := reifyTerm env X1 in 507 | let r2 := reifyTerm env X2 in 508 | constr:(Meet r1 r2) 509 | | ?X1 ⊔ ?X2 => 510 | let r1 := reifyTerm env X1 in 511 | let r2 := reifyTerm env X2 in 512 | constr:(Join r1 r2) 513 | | ?X => 514 | let n := lookup X env in 515 | constr:(Var n) 516 | end. 517 | 518 | Ltac functionalize xs := 519 | let rec loop n xs' := 520 | match xs' with 521 | | (?x, tt) => constr:(fun _ : nat => x) 522 | | (?x, ?xs'') => 523 | let f := loop (S n) xs'' in 524 | constr:(fun m : nat => if m =? n then x else f m) 525 | end in 526 | loop 0 xs. 527 | 528 | Ltac reify := 529 | match goal with 530 | | [ |- ?S ≤ ?T ] => 531 | let xs := allVars tt S in 532 | let xs' := allVars xs T in 533 | let r1 := reifyTerm xs' S in 534 | let r2 := reifyTerm xs' T in 535 | let env := functionalize xs' in 536 | (* pose xs'; *) 537 | (* pose env; *) 538 | (* pose r1; *) 539 | (* pose r2; *) 540 | change (〚r1〛env ≤ 〚r2〛env) 541 | end. 542 | 543 | Ltac lattice := reify; apply leq_correct; vm_compute; auto. 544 | 545 | Example sample_1 `{LOSet A} : forall a b : A, 546 | a ≤ a ⊔ b. 547 | Proof. intros; lattice. Qed. 548 | 549 | Lemma running_example `{LOSet A} : forall a b : A, 550 | a ⊓ b ≤ a ⊔ b. 551 | Proof. 552 | intros a b. 553 | rewrite meet_consistent. 554 | rewrite meet_associative. 555 | rewrite join_commutative. 556 | rewrite meet_absorptive. 557 | reflexivity. 558 | Qed. 559 | 560 | Lemma running_example' `{LOSet A} : forall a b : A, 561 | a ⊓ b ≤ a ⊔ b. 562 | Proof. intros; lattice. Qed. 563 | 564 | Lemma median_inequality `{LOSet A} : forall x y z : A, 565 | (x ⊓ y) ⊔ (y ⊓ z) ⊔ (z ⊓ x) ≤ (x ⊔ y) ⊓ (y ⊔ z) ⊓ (z ⊔ x). 566 | Proof. intros; lattice. Qed. 567 | 568 | Ltac allVarsLogic xs e := 569 | match e with 570 | | ?X1 ≤ ?X2 => 571 | let xs := allVars xs X1 in 572 | allVars xs X2 573 | | ?X1 /\ ?X2 => 574 | let xs := allVarsLogic xs X1 in 575 | allVarsLogic xs X2 576 | | ?X1 \/ ?X2 => 577 | let xs := allVarsLogic xs X1 in 578 | allVarsLogic xs X2 579 | | ~ ?X1 => 580 | allVarsLogic xs X1 581 | | ?X1 -> ?X2 => 582 | let xs := allVarsLogic xs X1 in 583 | allVarsLogic xs X2 584 | end. 585 | 586 | Ltac reifyLogic env t := 587 | match t with 588 | | ?X1 ≤ ?X2 => 589 | let r1 := reifyTerm env X1 in 590 | let r2 := reifyTerm env X2 in 591 | constr:(LLe r1 r2) 592 | | ?X1 /\ ?X2 => 593 | let r1 := reifyLogic env X1 in 594 | let r2 := reifyLogic env X2 in 595 | constr:(LAnd r1 r2) 596 | | ?X1 \/ ?X2 => 597 | let r1 := reifyLogic env X1 in 598 | let r2 := reifyLogic env X2 in 599 | constr:(LOr r1 r2) 600 | | ?X1 -> ?X2 => 601 | let r1 := reifyLogic env X1 in 602 | let r2 := reifyLogic env X2 in 603 | constr:(LImpl r1 r2) 604 | end. 605 | 606 | Ltac lattice' := 607 | match goal with 608 | | [ |- ?P ] => 609 | let xs := allVarsLogic tt P in 610 | let r1 := reifyLogic xs P in 611 | let env := functionalize xs in 612 | (* pose xs; *) 613 | (* pose r1; *) 614 | (* pose env; *) 615 | change (logicDenote r1 env); 616 | apply logicNorm_sound; 617 | let p := fresh "p" in 618 | let Heqp := fresh "Heqp" in 619 | remember (logicNorm _) as p eqn:Heqp; 620 | vm_compute in Heqp; 621 | rewrite Heqp; clear Heqp p 622 | (* vm_compute; *) 623 | (* intuition idtac *) 624 | end. 625 | 626 | Lemma example_3 `{LOSet A} : forall a b c : A, 627 | b ≤ a ⊔ b -> 628 | a ⊓ c ≤ a -> 629 | a ⊓ b ≤ c -> 630 | a ⊓ c ≤ b. 631 | Proof. 632 | intros a b c. 633 | lattice'. 634 | simpl. 635 | intuition. 636 | Admitted. 637 | 638 | Lemma median_inequality' `{LOSet A} : forall x y z : A, 639 | (x ⊓ y) ⊔ (y ⊓ z) ⊔ (z ⊓ x) ≤ (x ⊔ y) ⊓ (y ⊔ z) ⊓ (z ⊔ x). 640 | Proof. 641 | intros. 642 | lattice. 643 | Qed. 644 | --------------------------------------------------------------------------------