mirror of https://github.com/nmvdw/HITs-Examples
183 lines
4.6 KiB
Coq
183 lines
4.6 KiB
Coq
|
Require Import HoTT.
|
||
|
|
From HoTTClasses Require Import interfaces.abstract_algebra tactics.ring_tac.
|
||
|
|
|
||
|
|
Section hProp_lattice.
|
||
|
|
Context `{Univalence}.
|
||
|
|
|
||
|
|
Definition lor (X Y : hProp) : hProp := BuildhProp (Trunc (-1) (sum X Y)).
|
||
|
|
Definition land (P Q : hProp) := BuildhProp (prod P Q).
|
||
|
|
Global Instance join_hprop : Join hProp := lor.
|
||
|
|
Global Instance meet_hprop : Meet hProp := land.
|
||
|
|
Global Instance land_associative : Associative land.
|
||
|
|
Proof.
|
||
|
|
intros P Q R.
|
||
|
|
apply path_hprop.
|
||
|
|
apply equiv_prod_assoc.
|
||
|
|
Defined.
|
||
|
|
Global Instance lor_associative : Associative lor.
|
||
|
|
Proof.
|
||
|
|
intros P Q R. symmetry.
|
||
|
|
apply path_iff_hprop ; cbn.
|
||
|
|
* simple refine (Trunc_ind _ _).
|
||
|
|
intros [xy | z] ; cbn.
|
||
|
|
+ simple refine (Trunc_ind _ _ xy).
|
||
|
|
intros [x | y].
|
||
|
|
++ apply (tr (inl x)).
|
||
|
|
++ apply (tr (inr (tr (inl y)))).
|
||
|
|
+ apply (tr (inr (tr (inr z)))).
|
||
|
|
* simple refine (Trunc_ind _ _).
|
||
|
|
intros [x | yz] ; cbn.
|
||
|
|
+ apply (tr (inl (tr (inl x)))).
|
||
|
|
+ simple refine (Trunc_ind _ _ yz).
|
||
|
|
intros [y | z].
|
||
|
|
++ apply (tr (inl (tr (inr y)))).
|
||
|
|
++ apply (tr (inr z)).
|
||
|
|
Defined.
|
||
|
|
|
||
|
|
Global Instance land_commutative : Commutative land.
|
||
|
|
Proof.
|
||
|
|
intros P Q.
|
||
|
|
apply path_hprop.
|
||
|
|
apply equiv_prod_symm.
|
||
|
|
Defined.
|
||
|
|
|
||
|
|
Global Instance lor_commutative : Commutative lor.
|
||
|
|
Proof.
|
||
|
|
intros P Q. symmetry.
|
||
|
|
apply path_iff_hprop ; cbn.
|
||
|
|
* simple refine (Trunc_ind _ _).
|
||
|
|
intros [x | y].
|
||
|
|
+ apply (tr (inr x)).
|
||
|
|
+ apply (tr (inl y)).
|
||
|
|
* simple refine (Trunc_ind _ _).
|
||
|
|
intros [y | x].
|
||
|
|
+ apply (tr (inr y)).
|
||
|
|
+ apply (tr (inl x)).
|
||
|
|
Defined.
|
||
|
|
|
||
|
|
Global Instance joinsemilattice_hprop : JoinSemiLattice hProp.
|
||
|
|
Proof.
|
||
|
|
split.
|
||
|
|
- split; [ split | ]; apply _.
|
||
|
|
- compute-[lor]. intros P.
|
||
|
|
apply path_iff_hprop ; cbn.
|
||
|
|
+ simple refine (Trunc_ind _ _).
|
||
|
|
intros [x | x] ; apply x.
|
||
|
|
+ apply (fun x => tr (inl x)).
|
||
|
|
Defined.
|
||
|
|
|
||
|
|
Global Instance meetsemilattice_hprop : MeetSemiLattice hProp.
|
||
|
|
Proof.
|
||
|
|
split.
|
||
|
|
- split; [ split | ]; apply _.
|
||
|
|
- compute-[land]. intros x.
|
||
|
|
apply path_iff_hprop ; cbn.
|
||
|
|
+ intros [a b] ; apply a.
|
||
|
|
+ intros a ; apply (pair a a).
|
||
|
|
Defined.
|
||
|
|
|
||
|
|
Global Instance lor_land_absorbtion : Absorption join meet.
|
||
|
|
Proof.
|
||
|
|
intros P Q.
|
||
|
|
apply path_iff_hprop ; cbn.
|
||
|
|
- intros X ; strip_truncations.
|
||
|
|
destruct X as [Xx | [Xy1 Xy2]] ; assumption.
|
||
|
|
- intros X.
|
||
|
|
apply (tr (inl X)).
|
||
|
|
Defined.
|
||
|
|
|
||
|
|
Global Instance land_lor_absorbtion : Absorption meet join.
|
||
|
|
Proof.
|
||
|
|
intros P Q.
|
||
|
|
apply path_iff_hprop ; cbn.
|
||
|
|
- intros [X Y] ; strip_truncations.
|
||
|
|
assumption.
|
||
|
|
- intros X.
|
||
|
|
split.
|
||
|
|
* assumption.
|
||
|
|
* apply (tr (inl X)).
|
||
|
|
Defined.
|
||
|
|
|
||
|
|
Global Instance hprop_lattice : Lattice hProp.
|
||
|
|
Proof. split; apply _. Defined.
|
||
|
|
|
||
|
|
End hProp_lattice.
|
||
|
|
|
||
|
|
(* Section lattice_semiring. *)
|
||
|
|
(* Context `{A : Type}. *)
|
||
|
|
(* Context `{Lattice A}. *)
|
||
|
|
(* Context `{Bottom A}. *)
|
||
|
|
(* Instance join_plus : Plus A := join. *)
|
||
|
|
(* Instance meet_plus : Mult A := meet. *)
|
||
|
|
(* Instance bot_zero : Zero A := bottom. *)
|
||
|
|
|
||
|
|
(* End lattice_semiring. *)
|
||
|
|
|
||
|
|
Create HintDb lattice_hints.
|
||
|
|
Hint Resolve associativity : lattice_hints.
|
||
|
|
Hint Resolve commutativity : lattice_hints.
|
||
|
|
Hint Resolve absorption : lattice_hints.
|
||
|
|
Hint Resolve idempotency : lattice_hints.
|
||
|
|
|
||
|
|
Section fun_lattice.
|
||
|
|
Context {A B : Type}.
|
||
|
|
Context `{Univalence}.
|
||
|
|
Context `{Lattice B}.
|
||
|
|
|
||
|
|
Definition max_fun (f g : (A -> B)) (a : A) : B
|
||
|
|
:= f a ⊔ g a.
|
||
|
|
|
||
|
|
Definition min_fun (f g : (A -> B)) (a : A) : B
|
||
|
|
:= f a ⊓ g a.
|
||
|
|
|
||
|
|
Global Instance fun_join : Join (A -> B) := max_fun.
|
||
|
|
Global Instance fun_meet : Meet (A -> B) := min_fun.
|
||
|
|
|
||
|
|
Ltac solve_fun :=
|
||
|
|
compute ; intros ; apply path_forall ; intro ;
|
||
|
|
eauto 10 with lattice_hints typeclass_instances.
|
||
|
|
|
||
|
|
Global Instance fun_lattice : Lattice (A -> B).
|
||
|
|
Proof.
|
||
|
|
repeat (split; try (apply _ || solve_fun)).
|
||
|
|
Defined.
|
||
|
|
End fun_lattice.
|
||
|
|
|
||
|
|
Section sub_lattice.
|
||
|
|
Context {A : Type} {P : A -> hProp}.
|
||
|
|
Context `{Lattice A}.
|
||
|
|
Context {Hmax : forall x y, P x -> P y -> P (join x y)}.
|
||
|
|
Context {Hmin : forall x y, P x -> P y -> P (meet x y)}.
|
||
|
|
|
||
|
|
Definition AP : Type := sig P.
|
||
|
|
|
||
|
|
Instance join_sub : Join AP := fun (x y : AP) =>
|
||
|
|
match x, y with
|
||
|
|
| (a ; pa), (b ; pb) =>
|
||
|
|
(join a b ; Hmax a b pa pb)
|
||
|
|
end.
|
||
|
|
|
||
|
|
Instance meet_sub : Meet AP := fun (x y : AP) =>
|
||
|
|
match x, y with
|
||
|
|
| (a ; pa), (b ; pb) =>
|
||
|
|
(meet a b ; Hmin a b pa pb)
|
||
|
|
end.
|
||
|
|
|
||
|
|
Local Instance hprop_sub : forall c, IsHProp (P c).
|
||
|
|
Proof.
|
||
|
|
apply _.
|
||
|
|
Defined.
|
||
|
|
|
||
|
|
Ltac solve_sub :=
|
||
|
|
repeat (intros [? ?])
|
||
|
|
; simple refine (path_sigma _ _ _ _ _); [ | apply hprop_sub ]
|
||
|
|
; compute
|
||
|
|
; eauto 10 with lattice_hints typeclass_instances.
|
||
|
|
|
||
|
|
Global Instance sub_lattice : Lattice AP.
|
||
|
|
Proof.
|
||
|
|
repeat (split; try (apply _ || solve_sub)).
|
||
|
|
Defined.
|
||
|
|
|
||
|
|
End sub_lattice.
|