(* chains and anti-chains *)

Require Import Relations_1.
Require Import Ensembles.

Section Chains.

  Context {U : Type} (R : Relation U) (Ord : Order U R).

  Definition chain (X : Ensemble U) :=
    (forall (x y : U), In U X x -> In U X y -> R x y \/ R y x).

  Definition anti_chain (X : Ensemble U) :=
    (forall (x : U) (y : U), In U X x -> In U X y -> R x y -> x = y).

  Lemma chain_mono: forall (C : Ensemble U) (C' : Ensemble U),
    chain C -> Included _ C' C -> chain C'.
  Proof.
    unfold chain; intuition.
  Qed.

  Lemma anti_chain_mono: forall (C : Ensemble U) (C' : Ensemble U),
    anti_chain C -> Included _ C' C -> anti_chain C'.
  Proof.
    unfold anti_chain; intuition.
  Qed.

  Lemma chain_Empty_set: chain (Empty_set U).
  Proof.
    unfold chain; intros; destruct H.
  Qed.

  Lemma anti_chain_Empty_set: anti_chain (Empty_set U).
  Proof.
    unfold anti_chain; intros; destruct H.
  Qed.

  Lemma chain_Singleton: forall (x : U), chain (Singleton _ x).
  Proof.
    unfold chain.
    intros x y z x_y x_z.
    destruct x_y; destruct x_z.
    destruct Ord as [r _ _]; unfold Reflexive in r.
    intuition.
  Qed.

  Lemma anti_chain_Singleton: forall (x : U), anti_chain (Singleton _ x).
  Proof.
    unfold anti_chain.
    intros x y z x_y x_z.
    destruct x_y; destruct x_z.
    auto.
  Qed.

End Chains.


From mathcomp.ssreflect
Require Import ssreflect ssrbool ssrfun ssrnat eqtype seq.
Require Import pred prelude.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(**********)
(* Posets *)
(**********)

Module Poset.

Section RawMixin.

Record mixin_of (T : Type) := Mixin {
  mx_leq : T -> T -> Prop;
  _ : forall x, mx_leq x x;
  _ : forall x y, mx_leq x y -> mx_leq y x -> x = y;
  _ : forall x y z, mx_leq x y -> mx_leq y z -> mx_leq x z}.

End RawMixin.

Section ClassDef.

Record class_of T := Class {mixin : mixin_of T}.

Structure type : Type := Pack {sort : Type; _ : class_of sort; _ : Type}.
Local Coercion sort : type >-> Sortclass.

Variables (T : Type) (cT : type).
Definition class := let: Pack _ c _ as cT' := cT return class_of cT' in c.
Definition clone c of phant_id class c := @Pack T c T.

(* produce a poset type out of the mixin *)
(* equalize m0 and m by means of a phantom *)
Definition pack (m0 : mixin_of T) :=
  fun m & phant_id m0 m => Pack (@Class T m) T.

Definition leq := mx_leq (mixin class).

End ClassDef.

Module Exports.
Coercion sort : type >-> Sortclass.
Notation poset := Poset.type.
Notation PosetMixin := Poset.Mixin.
Notation Poset T m := (@pack T _ m id).

Notation "[ 'poset' 'of' T 'for' cT ]" := (@clone T cT _ id)
  (at level 0, format "[ 'poset'  'of'  T  'for'  cT ]") : form_scope.
Notation "[ 'poset' 'of' T ]" := (@clone T _ _ id)
  (at level 0, format "[ 'poset'  'of'  T ]") : form_scope.

Notation "x <== y" := (Poset.leq x y) (at level 70).

(* re-state lattice properties using the exported notation *)
Section Laws.
Variable T : poset.

Lemma poset_refl (x : T) : x <== x.
Proof. by case: T x=>S [[leq B R]]. Qed.

Lemma poset_asym (x y : T) : x <== y -> y <== x -> x = y.
Proof. by case: T x y=>S [[l R A Tr]] *; apply: (A). Qed.

Lemma poset_trans (y x z : T) : x <== y -> y <== z -> x <== z.
Proof. by case: T y x z=>S [[l R A Tr]] ? x y z; apply: (Tr). Qed.

End Laws.

Hint Resolve poset_refl.

Add Parametric Relation (T : poset) : T (@Poset.leq T)
  reflexivity proved by (@poset_refl _)
  transitivity proved by (fun x y => @poset_trans _ y x) as poset_rel.

End Exports.

End Poset.

Export Poset.Exports.

(**************************)
(* some basic definitions *)
(**************************)

Definition monotone (T1 T2 : poset) (f : T1 -> T2) :=
  forall x y, x <== y -> f x <== f y.

Section IdealDef.
Variable T : poset.

Structure ideal (P : T) := Ideal {id_val : T; id_pf : id_val <== P}.

(* Changing the type of the ideal *)

Lemma relaxP (P1 P2 : T) : P1 <== P2 -> forall p, p <== P1 -> p <== P2.
Proof. by move=>H1 p H2; apply: poset_trans H1. Qed.

Definition relax (P1 P2 : T) (x : ideal P1) (pf : P1 <== P2) :=
  Ideal (relaxP pf (id_pf x)).

End IdealDef.

(***********************)
(* poset constructions *)
(***********************)

Section SubPoset.
Variables (T : poset) (s : Pred T).

Local Notation tp := {x : T | x \In s}.

Definition sub_leq (p1 p2 : tp) := sval p1 <== sval p2.

Lemma sub_refl x : sub_leq x x.
Proof. by rewrite /sub_leq. Qed.

Lemma sub_asym x y : sub_leq x y -> sub_leq y x -> x = y.
Proof.
move: x y=>[x Hx][y Hy]; rewrite /sub_leq /= => H1 H2.
move: (poset_asym H1 H2) Hy=> <- Hy; congr exist.
by apply: proof_irrelevance.
Qed.

Lemma sub_trans x y z : sub_leq x y -> sub_leq y z -> sub_leq x z.
Proof.
move: x y z=>[x Hx][y Hy][z Hz]; rewrite /sub_leq /=.
by apply: poset_trans.
Qed.

(* no need to put canonical here, because the system won't be *)
(* able to get the proof C from the {x : T | x \In s} syntax *)
Definition subPosetMixin := PosetMixin sub_refl sub_asym sub_trans.
Definition subPoset := Eval hnf in Poset tp subPosetMixin.

End SubPoset.

(* pairing of posets *)

Section PairPoset.
Variable (A B : poset).
Local Notation tp := (A * B)%type.

Definition pair_leq (p1 p2 : tp) := p1.1 <== p2.1 /\ p1.2 <== p2.2.

Lemma pair_refl x : pair_leq x x.
Proof. by []. Qed.

Lemma pair_asym x y : pair_leq x y -> pair_leq y x -> x = y.
Proof.
move: x y=>[x1 x2][y1 y2][/= H1 H2][/= H3 H4].
by congr (_, _); apply: poset_asym.
Qed.

Lemma pair_trans x y z : pair_leq x y -> pair_leq y z -> pair_leq x z.
Proof.
move: x y z=>[x1 x2][y1 y2][z1 z2][/= H1 H2][/= H3 H4]; split=>/=.
- by apply: poset_trans H3.
by apply: poset_trans H4.
Qed.

Definition pairPosetMixin :=
  PosetMixin pair_refl pair_asym pair_trans.
Canonical pairPoset := Eval hnf in Poset tp pairPosetMixin.

End PairPoset.

(* functions into a poset form a poset *)

Section FunPoset.
Variable (A : Type) (B : poset).
Local Notation tp := (A -> B).

Definition fun_leq (p1 p2 : tp) := forall x, p1 x <== p2 x.

Lemma fun_refl x : fun_leq x x.
Proof. by []. Qed.

Lemma fun_asym x y : fun_leq x y -> fun_leq y x -> x = y.
Proof.
move=>H1 H2; apply: fext=>z;
by apply: poset_asym; [apply: H1 | apply: H2].
Qed.

Lemma fun_trans x y z : fun_leq x y -> fun_leq y z -> fun_leq x z.
Proof. by move=>H1 H2 t; apply: poset_trans (H2 t). Qed.

Definition funPosetMixin := PosetMixin fun_refl fun_asym fun_trans.
Canonical funPoset := Eval hnf in Poset tp funPosetMixin.

End FunPoset.

(* dependent functions into a poset form a poset *)

Section DFunPoset.
Variables (A : Type) (B : A -> poset).
Local Notation tp := (forall x, B x).

Definition dfun_leq (p1 p2 : tp) := forall x, p1 x <== p2 x.

Lemma dfun_refl x : dfun_leq x x.
Proof. by []. Qed.

Lemma dfun_asym x y : dfun_leq x y -> dfun_leq y x -> x = y.
Proof.
move=>H1 H2; apply: fext=>z;
by apply: poset_asym; [apply: H1 | apply: H2].
Qed.

Lemma dfun_trans x y z : dfun_leq x y -> dfun_leq y z -> dfun_leq x z.
Proof. by move=>H1 H2 t; apply: poset_trans (H2 t). Qed.

(* no point in declaring this canonical, since it's keyed on forall *)
(* and forall is not a symbol *)
Definition dfunPosetMixin :=
  PosetMixin dfun_refl dfun_asym dfun_trans.
Definition dfunPoset := Eval hnf in Poset tp dfunPosetMixin.

End DFunPoset.

(* ideal of a poset is a poset *)

Section IdealPoset.
Variable (T : poset) (P : T).

Definition ideal_leq (p1 p2 : ideal P) := id_val p1 <== id_val p2.

Lemma ideal_refl x : ideal_leq x x.
Proof. by case: x=>x H; rewrite /ideal_leq. Qed.

Lemma ideal_asym x y : ideal_leq x y -> ideal_leq y x -> x = y.
Proof.
move: x y=>[x1 H1][x2 H2]; rewrite /ideal_leq /= => H3 H4; move: H1 H2.
rewrite (poset_asym H3 H4)=>H1 H2.
congr Ideal; apply: proof_irrelevance.
Qed.

Lemma ideal_trans x y z : ideal_leq x y -> ideal_leq y z -> ideal_leq x z.
Proof. by apply: poset_trans. Qed.

Definition idealPosetMixin :=
  PosetMixin ideal_refl ideal_asym ideal_trans.
Canonical idealPoset := Eval hnf in Poset (ideal P) idealPosetMixin.

End IdealPoset.

(* Prop is a poset *)

Section PropPoset.

Definition prop_leq (p1 p2 : Prop) := p1 -> p2.

Lemma prop_refl x : prop_leq x x.
Proof. by []. Qed.

Lemma prop_asym x y : prop_leq x y -> prop_leq y x -> x = y.
Proof. by move=>H1 H2; apply: pext. Qed.

Lemma prop_trans x y z : prop_leq x y -> prop_leq y z -> prop_leq x z.
Proof. by move=>H1 H2; move/H1. Qed.

Definition propPosetMixin :=
  PosetMixin prop_refl prop_asym prop_trans.
Canonical propPoset := Eval hnf in Poset Prop propPosetMixin.

End PropPoset.

(* Pred is a poset *)

(* Can be inherited from posets of -> and Prop, but we declare a *)
(* dedicated structure to keep the infix notation of Pred. Otherwise, *)
(* poset inference turns Pred A into A -> Prop. *)

(*
Section PredPoset.
Variable A : Type.

Definition predPosetMixin : Poset.mixin_of (Pred A) :=
  funPosetMixin A propPoset.
Canonical predPoset := Eval hnf in Poset (Pred A) predPosetMixin.

End PredPoset.
*)

(*********************)
(* Complete lattices *)
(*********************)

Module Lattice.

Section RawMixin.

Variable T : poset.

Record mixin_of := Mixin {
  mx_sup : Pred T -> T;
  _ : forall (s : Pred T) x, x \In s -> x <== mx_sup s;
  _ : forall (s : Pred T) x,
        (forall y, y \In s -> y <== x) -> mx_sup s <== x}.

End RawMixin.

Section ClassDef.

Record class_of (T : Type) := Class {
  base : Poset.class_of T;
  mixin : mixin_of (Poset.Pack base T)}.

Local Coercion base : class_of >-> Poset.class_of.

Structure type : Type := Pack {sort : Type; _ : class_of sort; _ : Type}.
Local Coercion sort : type >-> Sortclass.

Variables (T : Type) (cT : type).
Definition class := let: Pack _ c _ as cT' := cT return class_of cT' in c.
Definition clone c of phant_id class c := @Pack T c T.

(* produce a lattice type out of the mixin *)
(* equalize m0 and m by means of a phantom *)
Definition pack b0 (m0 : mixin_of (Poset.Pack b0 T)) :=
  fun m & phant_id m0 m => Pack (@Class T b0 m) T.

Definition sup (s : Pred cT) : cT := mx_sup (mixin class) s.

Definition poset := Poset.Pack class cT.

End ClassDef.

Module Exports.
Coercion base : class_of >-> Poset.class_of.
Coercion sort : type >-> Sortclass.
Coercion poset : type >-> Poset.type.
Canonical Structure poset.

Notation lattice := Lattice.type.
Notation LatticeMixin := Lattice.Mixin.
Notation Lattice T m := (@pack T _ _ m id).

Notation "[ 'lattice' 'of' T 'for' cT ]" := (@clone T cT _ id)
  (at level 0, format "[ 'lattice'  'of'  T  'for' cT ]") : form_scope.
Notation "[ 'lattice' 'of' T ]" := (@clone T _ _ id)
  (at level 0, format "[ 'lattice'  'of'  T ]") : form_scope.

Implicit Arguments Lattice.sup [cT].
Prenex Implicits Lattice.sup.
Notation sup := Lattice.sup.

(* re-state lattice properties using the exported notation *)
Section Laws.
Variable T : lattice.

Lemma supP (s : Pred T) x : x \In s -> x <== sup s.
Proof. by case: T s x=>S [[p]][/= s H1 *]; apply: H1. Qed.

Lemma supM (s : Pred T) x : (forall y, y \In s -> y <== x) -> sup s <== x.
Proof. by case: T s x=>S [[p]][/= s H1 H2 *]; apply: (H2). Qed.

End Laws.

End Exports.

End Lattice.

Export Lattice.Exports.

(* we have greatest lower bounds too *)
Section Infimum.
Variable T : lattice.

Definition inf (s : Pred T) :=
  sup [Pred x : T | forall y, y \In s -> x <== y].

Lemma infP s : forall x, x \In s -> inf s <== x.
Proof. by move=>x H; apply: supM=>y; apply. Qed.

Lemma infM s : forall x, (forall y, y \In s -> x <== y) -> x <== inf s.
Proof. by apply: supP. Qed.

End Infimum.

(* we can compute least and greatest fixed points *)

Section Lat.
Variable T : lattice.

Definition lbot : T := sup Pred0.

Definition tarski_lfp (f : T -> T) := inf [Pred x : T | f x <== x].
Definition tarski_gfp (f : T -> T) := sup [Pred x : T | x <== f x].

Definition sup_closed (T : lattice) :=
  [Pred s : Pred T | forall d, d <=p s -> sup d \In s].

Definition sup_closure (T : lattice) (s : Pred T) :=
  [Pred p : T | forall t : Pred T, s <=p t -> t \In sup_closed T -> p \In t].

End Lat.

Implicit Arguments lbot [T].
Implicit Arguments sup_closed [T].
Implicit Arguments sup_closure [T].
Prenex Implicits sup_closed sup_closure.

Section BasicProperties.
Variable T : lattice.

Lemma sup_mono (s1 s2 : Pred T) : s1 <=p s2 -> sup s1 <== sup s2.
Proof. by move=>H; apply: supM=>y; move/H; apply: supP. Qed.

Lemma supE (s1 s2 : Pred T) : s1 =p s2 -> sup s1 = sup s2.
Proof. by move=>H; apply: poset_asym; apply: supM=>y; move/H; apply: supP. Qed.

(* Knaster-Tarski *)
Lemma tarski_lfp_fixed (f : T -> T) :
        monotone f -> f (tarski_lfp f) = tarski_lfp f.
Proof.
move=>M; suff L: f (tarski_lfp f) <== tarski_lfp f.
- by apply: poset_asym=>//; apply: infP; apply: M L.
by apply: infM=>x L; apply: poset_trans (L); apply: M; apply: infP.
Qed.

Lemma tarski_lfp_least f : forall x : T, f x = x -> tarski_lfp f <== x.
Proof. by move=>x H; apply: infP; rewrite InE /= H. Qed.

Lemma tarski_gfp_fixed (f : T -> T) :
        monotone f -> f (tarski_gfp f) = tarski_gfp f.
Proof.
move=>M; suff L: tarski_gfp f <== f (tarski_gfp f).
- by apply: poset_asym=>//; apply: supP; apply: M L.
by apply: supM=>x L; apply: poset_trans (L) _; apply: M; apply: supP.
Qed.

Lemma tarski_gfp_greatest f : forall x : T, f x = x -> x <== tarski_gfp f.
Proof. by move=>x H; apply: supP; rewrite InE /= H. Qed.

(* closure contains s *)
Lemma sup_clos_sub (s : Pred T) : s <=p sup_closure s.
Proof. by move=>p H1 t H2 H3; apply: H2 H1. Qed.

(* closure is smallest *)
Lemma sup_clos_min (s : Pred T) :
        forall t, s <=p t -> sup_closed t -> sup_closure s <=p t.
Proof. by move=>t H1 H2 p; move/(_ _ H1 H2). Qed.

(* closure is closed *)
Lemma sup_closP (s : Pred T) : sup_closed (sup_closure s).
Proof.
move=>d H1 t H3 H4; move: (sup_clos_min H3 H4)=>{H3} H3.
by apply: H4=>x; move/H1; move/H3.
Qed.

Lemma sup_clos_idemp (s : Pred T) : sup_closed s -> sup_closure s =p s.
Proof. by move=>p; split; [apply: sup_clos_min | apply: sup_clos_sub]. Qed.

Lemma sup_clos_mono (s1 s2 : Pred T) :
        s1 <=p s2 -> sup_closure s1 <=p sup_closure s2.
Proof.
move=>H1; apply: sup_clos_min (@sup_closP s2).
by move=>t /H1; apply: sup_clos_sub.
Qed.

End BasicProperties.

(* lattice constructions *)

Section SubLattice.
Variables (T : lattice) (s : Pred T) (C : sup_closed s).
Local Notation tp := (subPoset s).

Definition sub_sup' (u : Pred tp) : T :=
  sup [Pred x : T | exists y, y \In u /\ x = sval y].

Lemma sub_supX (u : Pred tp) : sub_sup' u \In s.
Proof. by apply: C=>x [][y H][_] ->. Qed.

Definition sub_sup (u : Pred tp) : tp :=
  exist _ (sub_sup' u) (sub_supX u).

Lemma sub_supP (u : Pred tp) (x : tp) : x \In u -> x <== sub_sup u.
Proof. by move=>H; apply: supP; exists x. Qed.

Lemma sub_supM (u : Pred tp) (x : tp) :
        (forall y, y \In u -> y <== x) -> sub_sup u <== x.
Proof. by move=>H; apply: supM=>y [z][H1] ->; apply: H H1. Qed.

Definition subLatticeMixin := LatticeMixin sub_supP sub_supM.
Definition subLattice := Eval hnf in Lattice {x : T | x \In s} subLatticeMixin.

End SubLattice.

(* pairing *)

Section PairLattice.
Variables (A B : lattice).
Local Notation tp := (A * B)%type.

Definition pair_sup (s : Pred tp) : tp :=
            (sup [Pred p | exists f, p = f.1 /\ f \In s],
             sup [Pred p | exists f, p = f.2 /\ f \In s]).

Lemma pair_supP (s : Pred tp) (p : tp) : p \In s -> p <== pair_sup s.
Proof. by move=>H; split; apply: supP; exists p. Qed.

Lemma pair_supM (s : Pred tp) (p : tp) :
        (forall q, q \In s -> q <== p) -> pair_sup s <== p.
Proof. by move=>H; split; apply: supM=>y [f][->]; case/H. Qed.

Definition pairLatticeMixin := LatticeMixin pair_supP pair_supM.
Canonical pairLattice := Eval hnf in Lattice tp pairLatticeMixin.

End PairLattice.

(* functions into a latice form a lattice *)

Section FunLattice.
Variables (A : Type) (B : lattice).
Local Notation tp := (A -> B).

Definition fun_sup (s : Pred tp) : tp :=
  fun x => sup [Pred p | exists f, f \In s /\ p = f x].

Lemma fun_supP (s : Pred tp) (p : tp) : p \In s -> p <== fun_sup s.
Proof. by move=>H x; apply: supP; exists p. Qed.

Lemma fun_supM (s : Pred tp) (p : tp) :
        (forall q, q \In s -> q <== p) -> fun_sup s <== p.
Proof. by move=>H t; apply: supM=>x [f][H1] ->; apply: H. Qed.

Definition funLatticeMixin := LatticeMixin fun_supP fun_supM.
Canonical funLattice := Eval hnf in Lattice tp funLatticeMixin.

End FunLattice.

(* dependent functions into a lattice form a lattice *)

Section DFunLattice.
Variables (A : Type) (B : A -> lattice).
Local Notation tp := (dfunPoset B).

Definition dfun_sup (s : Pred tp) : tp :=
  fun x => sup [Pred p | exists f, f \In s /\ p = f x].

Lemma dfun_supP (s : Pred tp) (p : tp) :
        p \In s -> p <== dfun_sup s.
Proof. by move=>H x; apply: supP; exists p. Qed.

Lemma dfun_supM (s : Pred tp) (p : tp) :
       (forall q, q \In s -> q <== p) -> dfun_sup s <== p.
Proof. by move=>H t; apply: supM=>x [f][H1] ->; apply: H. Qed.

Definition dfunLatticeMixin := LatticeMixin dfun_supP dfun_supM.
Definition dfunLattice := Eval hnf in Lattice (forall x, B x) dfunLatticeMixin.

End DFunLattice.

(* applied sup equals the sup of applications *)

Lemma sup_appE A (B : lattice) (s : Pred (A -> B)) (x : A) :
        sup s x = sup [Pred y : B | exists f, f \In s /\ y = f x].
Proof. by []. Qed.

Lemma sup_dappE A (B : A -> lattice) (s : Pred (dfunLattice B)) (x : A) :
        sup s x = sup [Pred y : B x | exists f, f \In s /\ y = f x].
Proof. by []. Qed.

(* ideal of a lattice forms a lattice *)

Section IdealLattice.
Variables (T : lattice) (P : T).

Definition ideal_sup' (s : Pred (ideal P)) :=
  sup [Pred x | exists p, p \In s /\ id_val p = x].

Lemma ideal_supP' (s : Pred (ideal P)) : ideal_sup' s <== P.
Proof. by apply: supM=>y [[x]] H /= [_] <-. Qed.

Definition ideal_sup (s : Pred (ideal P)) := Ideal (ideal_supP' s).

Lemma ideal_supP (s : Pred (ideal P)) p :
        p \In s -> p <== ideal_sup s.
Proof. by move=>H; apply: supP; exists p. Qed.

Lemma ideal_supM (s : Pred (ideal P)) p :
        (forall q, q \In s -> q <== p) -> ideal_sup s <== p.
Proof. by move=>H; apply: supM=>y [q][H1] <-; apply: H. Qed.

Definition idealLatticeMixin := LatticeMixin ideal_supP ideal_supM.
Canonical idealLattice := Eval hnf in Lattice (ideal P) idealLatticeMixin.

End IdealLattice.

(* Prop is a lattice *)

Section PropLattice.

Definition prop_sup (s : Pred Prop) : Prop := exists p, p \In s /\ p.

Lemma prop_supP (s : Pred Prop) p : p \In s -> p <== prop_sup s.
Proof. by exists p. Qed.

Lemma prop_supM (s : Pred Prop) p :
        (forall q, q \In s -> q <== p) -> prop_sup s <== p.
Proof. by move=>H [r][]; move/H. Qed.

Definition propLatticeMixin := LatticeMixin prop_supP prop_supM.
Canonical propLattice := Eval hnf in Lattice Prop propLatticeMixin.

End PropLattice.

(*
(* Pred is a lattice *)

Section PredLattice.
Variable A : Type.

Definition predLatticeMixin := funLatticeMixin A propLattice.
Canonical predLattice := Eval hnf in Lattice (Pred A) predLatticeMixin.

End PredLattice.
*)

(* monotonicity *)

Lemma id_mono (T : poset) : monotone (@id T).
Proof. by []. Qed.

Implicit Arguments id_mono [T].
Prenex Implicits id_mono.

Lemma const_mono (T1 T2 : poset) (y : T2) : monotone (fun x : T1 => y).
Proof. by []. Qed.

Implicit Arguments const_mono [T1 T2 y].
Prenex Implicits const_mono.

Lemma comp_mono (T1 T2 T3 : poset) (f1 : T2 -> T1) (f2 : T3 -> T2) :
        monotone f1 -> monotone f2 -> monotone (f1 \o f2).
Proof. by move=>M1 M2 x y H; apply: M1; apply: M2. Qed.

Implicit Arguments comp_mono [T1 T2 T3 f1 f2].
Prenex Implicits comp_mono.

Lemma proj1_mono (T1 T2 : poset) : monotone (@fst T1 T2).
Proof. by case=>x1 x2 [y1 y2][]. Qed.

Lemma proj2_mono (T1 T2 : poset) : monotone (@snd T1 T2).
Proof. by case=>x1 x2 [y1 y2][]. Qed.

Implicit Arguments proj1_mono [T1 T2].
Implicit Arguments proj2_mono [T1 T2].
Prenex Implicits proj1_mono proj2_mono.

Lemma diag_mono (T : poset) : monotone (fun x : T => (x, x)).
Proof. by []. Qed.

Implicit Arguments diag_mono [T].
Prenex Implicits diag_mono.

Lemma app_mono A (T : poset) (x : A) : monotone (fun f : A -> T => f x).
Proof. by move=>f1 f2; apply. Qed.

Implicit Arguments app_mono [A T].
Prenex Implicits app_mono.

Lemma dapp_mono A (T : A -> poset) (x : A) :
  monotone (fun f : dfunPoset T => f x).
Proof. by move=>f1 f2; apply. Qed.

Implicit Arguments dapp_mono [A T].
Prenex Implicits dapp_mono.

Lemma prod_mono (S1 S2 T1 T2 : poset) (f1 : S1 -> T1) (f2 : S2 -> T2) :
        monotone f1 -> monotone f2 -> monotone (f1 \* f2).
Proof.
by move=>M1 M2 [x1] x2 [y1 y2][/= H1 H2]; split; [apply: M1 | apply: M2].
Qed.

Implicit Arguments prod_mono [S1 S2 T1 T2 f1 f2].
Prenex Implicits prod_mono.

(**********)
(* Chains *)
(**********)

Section Chains.
Variable T : poset.

Definition chain_axiom (s : Pred T) :=
  (exists d, d \In s) /\
  (forall x y, x \In s -> y \In s -> x <== y \/ y <== x).

Structure chain := Chain {
  pred_of :> Pred T;
  _ : chain_axiom pred_of}.

Canonical chainPredType := @mkPredType T chain pred_of.

End Chains.

Lemma chainE (T : poset) (s1 s2 : chain T) :
        s1 = s2 <-> pred_of s1 =p pred_of s2.
Proof.
split=>[->//|]; move: s1 s2=>[s1 H1][s2 H2] /= E; move: H1 H2.
suff: s1 = s2 by move=>-> H1 H2; congr Chain; apply: proof_irrelevance.
by apply: fext=>x; apply: pext; split; move/E.
Qed.

(* mapping monotone function over a chain *)

Section ImageChain.
Variables (T1 T2 : poset) (s : chain T1) (f : T1 -> T2) (M : monotone f).

Lemma image_chainP :
        chain_axiom [Pred x2 : T2 | exists x1, x2 = f x1 /\ x1 \In s].
Proof.
case: s=>p [[d H1] H2]; split=>[|x y]; first by exists (f d); exists d.
case=>x1 [->] H3 [y1][->] H4; rewrite -!toPredE /= in H3 H4.
by case: (H2 x1 y1 H3 H4)=>L; [left | right]; apply: M L.
Qed.

Definition image_chain := Chain image_chainP.

End ImageChain.

Notation "[ f '^^' s 'by' M ]" := (@image_chain _ _ s f M)
  (at level 0, format "[ f  '^^'  s  'by'  M ]") : form_scope.

(* some chain constructions *)

Section ChainId.
Variables (T : poset) (s : chain T).

Lemma id_chainE (M : monotone id) : [id ^^ s by M] = s.
Proof. by apply/chainE=>x; split; [case=>y [<-]|exists x]. Qed.

End ChainId.

Section ChainConst.
Variables (T1 T2 : poset) (y : T2).

Lemma const_chainP : chain_axiom (Pred1 y).
Proof. by split; [exists y | move=>x1 x2 ->->; left]. Qed.

Definition const_chain := Chain const_chainP.

Lemma const_chainE s : [_ ^^ s by @const_mono T1 T2 y] = const_chain.
Proof.
apply/chainE=>z1; split; first by case=>z2 [->].
by case: s=>s [[d] H1] H2 <-; exists d.
Qed.

End ChainConst.

Section ChainCompose.
Variables (T1 T2 T3 : poset) (f1 : T2 -> T1) (f2 : T3 -> T2).
Variables (s : chain T3) (M1 : monotone f1) (M2 : monotone f2).

Lemma comp_chainE :
        [f1 ^^ [f2 ^^ s by M2] by M1] = [f1 \o f2 ^^ s by comp_mono M1 M2].
Proof.
apply/chainE=>x1; split; first by case=>x2 [->][x3][->]; exists x3.
by case=>x3 [->]; exists (f2 x3); split=>//; exists x3.
Qed.

End ChainCompose.

(* projections out of a chain *)

Section ProjChain.
Variables (T1 T2 : poset) (s : chain [poset of T1 * T2]).

Definition proj1_chain := [@fst _ _ ^^ s by proj1_mono].
Definition proj2_chain := [@snd _ _ ^^ s by proj2_mono].

End ProjChain.

(* diagonal chain *)

Section DiagChain.
Variable (T : poset) (s : chain T).

Definition diag_chain := [_ ^^ s by @diag_mono T].

Lemma proj1_diagE : proj1_chain diag_chain = s.
Proof. by rewrite /proj1_chain /diag_chain comp_chainE id_chainE. Qed.

Lemma proj2_diagE : proj2_chain diag_chain = s.
Proof. by rewrite /proj2_chain /diag_chain comp_chainE id_chainE. Qed.

End DiagChain.

(* applying functions from a chain of functions *)

Section AppChain.
Variables (A : Type) (T : poset) (s : chain [poset of A -> T]).

Definition app_chain x := [_ ^^ s by app_mono x].

End AppChain.

(* ditto for dependent functions *)

Section DAppChain.
Variables (A : Type) (T : A -> poset) (s : chain (dfunPoset T)).

Definition dapp_chain x := [_ ^^ s by dapp_mono x].

End DAppChain.

(* pairing chain applications *)

Section ProdChain.
Variables (S1 S2 T1 T2 : poset) (f1 : S1 -> T1) (f2 : S2 -> T2).
Variables (M1 : monotone f1) (M2 : monotone f2).
Variable (s : chain [poset of S1 * S2]).

Definition prod_chain := [f1 \* f2 ^^ s by prod_mono M1 M2].

Lemma proj1_prodE : proj1_chain prod_chain = [f1 ^^ proj1_chain s by M1].
Proof.
rewrite /proj1_chain /prod_chain !comp_chainE !/comp /=.
by apply/chainE.
Qed.

Lemma proj2_prodE : proj2_chain prod_chain = [f2 ^^ proj2_chain s by M2].
Proof.
rewrite /proj2_chain /prod_chain !comp_chainE !/comp /=.
by apply/chainE.
Qed.

End ProdChain.

(*********)
(* CPO's *)
(*********)

Module CPO.

Section RawMixin.

Record mixin_of (T : poset) := Mixin {
  mx_bot : T;
  mx_lim : chain T -> T;
  _ : forall x, mx_bot <== x;
  _ : forall (s : chain T) x, x \In s -> x <== mx_lim s;
  _ : forall (s : chain T) x,
        (forall y, y \In s -> y <== x) -> mx_lim s <== x}.

End RawMixin.

Section ClassDef.

Record class_of (T : Type) := Class {
  base : Poset.class_of T;
  mixin : mixin_of (Poset.Pack base T)}.

Local Coercion base : class_of >-> Poset.class_of.

Structure type : Type := Pack {sort; _ : class_of sort; _ : Type}.
Local Coercion sort : type >-> Sortclass.

Variables (T : Type) (cT : type).
Definition class := let: Pack _ c _ as cT' := cT return class_of cT' in c.
Definition clone c of phant_id class c := @Pack T c T.

Definition pack b0 (m0 : mixin_of (Poset.Pack b0 T)) :=
  fun m & phant_id m0 m => Pack (@Class T b0 m) T.

Definition poset := Poset.Pack class cT.
Definition lim (s : chain poset) : cT := mx_lim (mixin class) s.
Definition bot : cT := mx_bot (mixin class).

End ClassDef.

Module Import Exports.
Coercion base : class_of >-> Poset.class_of.
Coercion sort : type >-> Sortclass.
Coercion poset : type >-> Poset.type.
Canonical Structure poset.

Notation cpo := type.
Notation CPOMixin := Mixin.
Notation CPO T m := (@pack T _ _ m id).

Notation "[ 'cpo' 'of' T 'for' cT ]" := (@clone T cT _ idfun)
  (at level 0, format "[ 'cpo'  'of'  T  'for'  cT ]") : form_scope.
Notation "[ 'cpo' 'of' T ]" := (@clone T _ _ id)
  (at level 0, format "[ 'cpo'  'of'  T ]") : form_scope.

Implicit Arguments CPO.bot [cT].
Implicit Arguments CPO.lim [cT].
Prenex Implicits CPO.lim.
Prenex Implicits CPO.bot.
Notation lim := CPO.lim.
Notation bot := CPO.bot.

Section Laws.
Variable D : cpo.

Lemma botP (x : D) : bot <== x.
Proof. by case: D x=>S [[p]][/= b l H1 *]; apply: H1. Qed.

Lemma limP (s : chain D) x : x \In s -> x <== lim s.
Proof. by case: D s x=>S [[p]][/= b l H1 H2 *]; apply: (H2). Qed.

Lemma limM (s : chain D) x : (forall y, y \In s -> y <== x) -> lim s <== x.
Proof. by case: D s x=>S [[p]][/= b l H1 H2 H3 *]; apply: (H3). Qed.

End Laws.

End Exports.

End CPO.

Export CPO.Exports.

Hint Resolve botP.

(* common chain constructions *)

(* adding bot to a chain *)

Section LiftChain.
Variable (D : cpo) (s : chain D).

Hint Resolve botP.

Lemma lift_chainP : chain_axiom [Pred x : D | x = bot \/ x \In s].
Proof.
case: s=>p [[d H1] H2] /=; split=>[|x y]; first by exists d; right.
by case=>[->|H3][->|H4]; auto.
Qed.

Definition lift_chain := Chain lift_chainP.

End LiftChain.

(****************************)
(* common cpo constructions *)
(****************************)

(* pairs *)

Section PairCPO.
Variables (A B : cpo).
Local Notation tp := [poset of A * B].

Definition pair_bot : tp := (bot, bot).

Definition pair_lim (s : chain tp) : tp :=
  (lim (proj1_chain s), lim (proj2_chain s)).

Lemma pair_botP x : pair_leq pair_bot x.
Proof. by split; apply: botP. Qed.

Lemma pair_limP (s : chain tp) x : x \In s -> x <== pair_lim s.
Proof. by split; apply: limP; exists x. Qed.

Lemma pair_limM (s : chain tp) x :
        (forall y, y \In s -> y <== x) -> pair_lim s <== x.
Proof. by split; apply: limM=>y [z][->]; case/H. Qed.

Definition pairCPOMixin := CPOMixin pair_botP pair_limP pair_limM.
Canonical pairCPO := Eval hnf in CPO (A * B) pairCPOMixin.

End PairCPO.

(* functions *)

Section FunCPO.
Variable (A : Type) (B : cpo).
Local Notation tp := [poset of A -> B].

Definition fun_bot : tp := fun x => bot.

Definition fun_lim (s : chain tp) : tp :=
  fun x => lim (app_chain s x).

Lemma fun_botP x : fun_leq fun_bot x.
Proof. by move=>y; apply: botP. Qed.

Lemma fun_limP (s : chain tp) x : x \In s -> x <== fun_lim s.
Proof. by move=>H t; apply: limP; exists x. Qed.

Lemma fun_limM (s : chain tp) x :
        (forall y, y \In s -> y <== x) -> fun_lim s <== x.
Proof. by move=>H1 t; apply: limM=>y [f][->] H2; apply: H1. Qed.

Definition funCPOMixin := CPOMixin fun_botP fun_limP fun_limM.
Canonical funCPO := Eval hnf in CPO (A -> B) funCPOMixin.

End FunCPO.

(* dependent functions *)

Section DFunCPO.
Variable (A : Type) (B : A -> cpo).
Local Notation tp := (dfunPoset B).

Definition dfun_bot : tp := fun x => bot.

Definition dfun_lim (s : chain tp) : tp :=
  fun x => lim (dapp_chain s x).

Lemma dfun_botP x : dfun_bot <== x.
Proof. by move=>y; apply: botP. Qed.

Lemma dfun_limP (s : chain tp) x : x \In s -> x <== dfun_lim s.
Proof. by move=>H t; apply: limP; exists x. Qed.

Lemma dfun_limM (s : chain tp) x :
        (forall y, y \In s -> y <== x) -> dfun_lim s <== x.
Proof. by move=>H1 t; apply: limM=>y [f][->] H2; apply: H1. Qed.

Definition dfunCPOMixin := CPOMixin dfun_botP dfun_limP dfun_limM.
Definition dfunCPO := Eval hnf in CPO (forall x, B x) dfunCPOMixin.

End DFunCPO.

(* Prop *)

Section PropCPO.
Local Notation tp := [poset of Prop].

Definition prop_bot : tp := False.

Definition prop_lim (s : chain tp) : tp := exists p, p \In s /\ p.

Lemma prop_botP x : prop_bot <== x.
Proof. by []. Qed.

Lemma prop_limP (s : chain tp) p : p \In s -> p <== prop_lim s.
Proof. by exists p. Qed.

Lemma prop_limM (s : chain tp) p :
        (forall q, q \In s -> q <== p) -> prop_lim s <== p.
Proof. by move=>H [r][]; move/H. Qed.

Definition propCPOMixin := CPOMixin prop_botP prop_limP prop_limM.
Canonical propCPO := Eval hnf in CPO Prop propCPOMixin.

End PropCPO.

(* Pred *)

Section PredCPO.
Variable A : Type.

Definition predCPOMixin := funCPOMixin A propCPO.
Canonical predCPO := Eval hnf in CPO (Pred A) predCPOMixin.

End PredCPO.

(* every complete lattice is a cpo *)

Section LatticeCPO.
Variable A : lattice.
Local Notation tp := (Lattice.poset A).

Definition lat_bot : tp := lbot.

Definition lat_lim (s : chain tp) : tp := sup s.

Lemma lat_botP x : lat_bot <== x.
Proof. by apply: supM. Qed.

Lemma lat_limP (s : chain tp) x : x \In s -> x <== lat_lim s.
Proof. by apply: supP. Qed.

Lemma lat_limM (s : chain tp) x :
        (forall y, y \In s -> y <== x) -> lat_lim s <== x.
Proof. by apply: supM. Qed.

Definition latCPOMixin := CPOMixin lat_botP lat_limP lat_limM.
Definition latCPO := Eval hnf in CPO tp latCPOMixin.

End LatticeCPO.

(* sub-CPO's *)

(* every chain-closed subset of a cpo is a cpo *)

Section AdmissibleClosure.
Variable T : cpo.

Definition chain_closed :=
  [Pred s : Pred T |
     bot \In s /\ forall d : chain T, d <=p s -> lim d \In s].

(* admissible closure of s is the smallest closed set containing s *)
(* basically extends s to include the sups of chains *)
Definition chain_closure (s : Pred T) :=
  [Pred p : T | forall t : Pred T, s <=p t -> chain_closed t -> p \In t].

(* admissible closure contains s *)
Lemma chain_clos_sub (s : Pred T) : s <=p chain_closure s.
Proof. by move=>p H1 t H2 H3; apply: H2 H1. Qed.

(* admissible closure is smallest *)
Lemma chain_clos_min (s : Pred T) t :
        s <=p t -> chain_closed t -> chain_closure s <=p t.
Proof. by move=>H1 H2 p; move/(_ _ H1 H2). Qed.

(* admissible closure is closed *)
Lemma chain_closP (s : Pred T) : chain_closed (chain_closure s).
Proof.
split; first by move=>t _ [].
move=>d H1 t H3 H4; move: (chain_clos_min H3 H4)=>{H3} H3.
by case: H4=>_; apply=>// x; move/H1; move/H3.
Qed.

Lemma chain_clos_idemp (s : Pred T) :
        chain_closed s -> chain_closure s =p s.
Proof.
move=>p; split; last by apply: chain_clos_sub.
by apply: chain_clos_min=>//; apply: chain_closP.
Qed.

Lemma chain_clos_mono (s1 s2 : Pred T) :
        s1 <=p s2 -> chain_closure s1 <=p chain_closure s2.
Proof.
move=>H1; apply: chain_clos_min (chain_closP s2)=>p H2.
by apply: chain_clos_sub; apply: H1.
Qed.

(* intersection of admissible sets is admissible *)
Lemma chain_closI (s1 s2 : Pred T) :
       chain_closed s1 -> chain_closed s2 -> chain_closed (PredI s1 s2).
Proof.
move=>[H1 S1][H2 S2]; split=>// d H.
by split; [apply: S1 | apply: S2]=>// x; case/H.
Qed.

End AdmissibleClosure.

Implicit Arguments chain_closed [T].
Prenex Implicits chain_closed.

(* diagonal of an admissible set of pairs is admissible *)
Lemma chain_clos_diag (T : cpo) (s : Pred (T * T)) :
        chain_closed s -> chain_closed [Pred t : T | (t, t) \In s].
Proof.
move=>[B H1]; split=>// d H2.
rewrite InE /= -{1}(proj1_diagE d) -{2}(proj2_diagE d).
by apply: H1; case=>x1 x2 [x][[<- <-]]; apply: H2.
Qed.

Section SubCPO.
Variables (D : cpo) (s : Pred D) (C : chain_closed s).
Local Notation tp := (subPoset s).

Definition sub_bot := exist _ (@bot D) (proj1 C).

Lemma sub_botP (x : tp) : sval sub_bot <== sval x.
Proof. by apply: botP. Qed.

Lemma sval_mono : monotone (sval : tp -> D).
Proof. by move=>[x1 H1][x2 H2]; apply. Qed.

Lemma sub_limX (u : chain tp) : lim [sval ^^ u by sval_mono] \In s.
Proof. by case: C u=>P H u; apply: (H)=>t [[y]] H1 [->]. Qed.

Definition sub_lim (u : chain tp) : tp :=
  exist _ (lim [sval ^^ u by sval_mono]) (sub_limX u).

Lemma sub_limP (u : chain tp) x : x \In u -> x <== sub_lim u.
Proof. by move=>H; apply: limP; exists x. Qed.

Lemma sub_limM (u : chain tp) x :
        (forall y, y \In u -> y <== x) -> sub_lim u <== x.
Proof. by move=>H; apply: limM=>y [z][->]; apply: H. Qed.

Definition subCPOMixin := CPOMixin sub_botP sub_limP sub_limM.
Definition subCPO := Eval hnf in CPO {x : D | x \In s} subCPOMixin.

End SubCPO.

(***********************************************)
(* Continuity and Kleene's fixed point theorem *)
(***********************************************)

Lemma lim_mono (D : cpo) (s1 s2 : chain D) :
        s1 <=p s2 -> lim s1 <== lim s2.
Proof. by move=>H; apply: limM=>y; move/H; apply: limP. Qed.

Lemma limE (D : cpo) (s1 s2 : chain D) :
        s1 =p s2 -> lim s1 = lim s2.
Proof. by move=>H; apply: poset_asym; apply: lim_mono=>x; rewrite H. Qed.

Lemma lim_liftE (D : cpo) (s : chain D) :
        lim s = lim (lift_chain s).
Proof.
apply: poset_asym; apply: limM=>y H; first by apply: limP; right.
by case: H; [move=>-> | apply: limP].
Qed.

(* applied lim equals the lim of applications *)
(* ie., part of continuity of application *)
(* but is so often used, I give it a name *)

Lemma lim_appE A (D : cpo) (s : chain [cpo of A -> D]) (x : A) :
        lim s x = lim (app_chain s x).
Proof. by []. Qed.

Lemma lim_dappE A (D : A -> cpo) (s : chain (dfunCPO D)) (x : A) :
        lim s x = lim (dapp_chain s x).
Proof. by []. Qed.

Section Continuity.
Variables (D1 D2 : cpo) (f : D1 -> D2).

Definition continuous :=
  exists M : monotone f,
  forall s : chain D1, f (lim s) = lim [f ^^ s by M].

Lemma cont_mono : continuous -> monotone f.
Proof. by case. Qed.

Lemma contE (s : chain D1) (C : continuous) :
       f (lim s) = lim [f ^^ s by cont_mono C].
Proof.
case: C=>M E; rewrite E; congr (lim (image_chain _ _)).
apply: proof_irrelevance.
Qed.

End Continuity.

Module Kleene.

(* just for this proof, we want that nat is a poset under <= *)
(* in other scopes, we'll use the equality as ordering *)
Section NatPoset.

Lemma nat_refl x : x <= x. Proof. by []. Qed.

Lemma nat_asym x y : x <= y -> y <= x -> x = y.
Proof. by move=>H1 H2; apply: anti_leq; rewrite H1 H2. Qed.

Lemma nat_trans x y z : x <= y -> y <= z -> x <= z.
Proof. by apply: leq_trans. Qed.

Definition natPosetMixin := PosetMixin nat_refl nat_asym nat_trans.
Canonical natPoset := Eval hnf in Poset nat natPosetMixin.

End NatPoset.

Section NatChain.

Lemma nat_chain_axiom : chain_axiom (@PredT nat).
Proof.
split=>[|x y _ _]; first by exists 0.
rewrite /Poset.leq /= [y <= x]leq_eqVlt.
by case: leqP; [left | rewrite orbT; right].
Qed.

Definition nat_chain := Chain nat_chain_axiom.

End NatChain.

Section Kleene.
Variables (D : cpo) (f : D -> D) (C : continuous f).

Fixpoint pow m := if m is n.+1 then f (pow n) else bot.

Lemma pow_mono : monotone pow.
Proof.
move=>m n; elim: n m=>[|n IH] m /=; first by case: m.
rewrite {1}/Poset.leq /= leq_eqVlt ltnS.
case/orP; first by move/eqP=>->.
move/IH=>{IH} H; apply: poset_trans H _.
by elim: n=>[|n IH] //=; apply: cont_mono IH.
Qed.

Definition pow_chain := [pow ^^ nat_chain by pow_mono].

Lemma reindex : pow_chain =p lift_chain [f ^^ pow_chain by cont_mono C].
Proof.
move=>x; split.
- case; case=>[|n][->] /=; first by left.
  by right; exists (pow n); split=>//; exists n.
case=>/=; first by move=>->; exists 0.
by case=>y [->][n][->]; exists n.+1.
Qed.

Definition kleene_lfp := lim pow_chain.

Lemma kleene_lfp_fixed : f kleene_lfp = kleene_lfp.
Proof. by rewrite (@contE _ _ f) lim_liftE; apply: limE; rewrite reindex. Qed.

Lemma kleene_lfp_least : forall x, f x = x -> kleene_lfp <== x.
Proof.
move=>x H; apply: limM=>y [n][->] _.
by elim: n=>[|n IH] //=; rewrite -H; apply: cont_mono IH.
Qed.

End Kleene.

Module Exports.
Notation kleene_lfp := kleene_lfp.
Notation kleene_lfp_fixed := kleene_lfp_fixed.
Notation kleene_lfp_least := kleene_lfp_least.
End Exports.

End Kleene.

Export Kleene.Exports.

(**********************************)
(* Continuity of common functions *)
(**********************************)

Lemma id_cont (D : cpo) : continuous (@id D).
Proof. by exists id_mono; move=>d; rewrite id_chainE. Qed.

Implicit Arguments id_cont [D].
Prenex Implicits id_cont.

Lemma const_cont (D1 D2 : cpo) (y : D2) : continuous (fun x : D1 => y).
Proof.
exists const_mono; move=>s; apply: poset_asym.
- by apply: limP; case: s=>[p][[d H1] H2]; exists d.
by apply: limM=>_ [x][->].
Qed.

Implicit Arguments const_cont [D1 D2 y].
Prenex Implicits const_cont.

Lemma comp_cont (D1 D2 D3 : cpo) (f1 : D2 -> D1) (f2 : D3 -> D2) :
        continuous f1 -> continuous f2 -> continuous (f1 \o f2).
Proof.
case=>M1 H1 [M2 H2]; exists (comp_mono M1 M2); move=>d.
by rewrite /= H2 H1 comp_chainE.
Qed.

Implicit Arguments comp_cont [D1 D2 D3 f1 f2].
Prenex Implicits comp_cont.

Lemma proj1_cont (D1 D2 : cpo) : continuous (@fst D1 D2).
Proof. by exists proj1_mono. Qed.

Lemma proj2_cont (D1 D2 : cpo) : continuous (@snd D1 D2).
Proof. by exists proj2_mono. Qed.

Implicit Arguments proj1_cont [D1 D2].
Implicit Arguments proj2_cont [D1 D2].
Prenex Implicits proj1_cont proj2_cont.

Lemma diag_cont (D : cpo) : continuous (fun x : D => (x, x)).
Proof.
exists diag_mono=>d; apply: poset_asym;
by split=>/=; [rewrite proj1_diagE | rewrite proj2_diagE].
Qed.

Implicit Arguments diag_cont [D].
Prenex Implicits diag_cont.

Lemma app_cont A (D : cpo) x : continuous (fun f : A -> D => f x).
Proof. by exists (app_mono x). Qed.

Lemma dapp_cont A (D : A -> cpo) x : continuous (fun f : dfunCPO D => f x).
Proof. by exists (dapp_mono x). Qed.

Implicit Arguments app_cont [A D].
Implicit Arguments dapp_cont [A D].
Prenex Implicits app_cont dapp_cont.

Lemma prod_cont (S1 S2 T1 T2 : cpo) (f1 : S1 -> T1) (f2 : S2 -> T2) :
        continuous f1 -> continuous f2 -> continuous (f1 \* f2).
Proof.
case=>M1 H1 [M2 H2]; exists (prod_mono M1 M2)=>d; apply: poset_asym;
by (split=>/=; [rewrite proj1_prodE H1 | rewrite proj2_prodE H2]).
Qed.

Implicit Arguments prod_cont [S1 S2 T1 T2 f1 f2].
Prenex Implicits prod_cont.


Theorem Prod_Prop :  forall (P Q:Prop), P->(exists q:Q, P) -> forall q:Q, P.
Proof.
    intros. cut Q. destruct H0 as [q' Hq]. intros. apply Hq. apply q. Qed.

Theorem proveMyself : forall P:Prop, P->P.
Proof
    (fun (P:Prop) (p:P) => p).

Check (forall P:Prop, P->P).
Check (fun (P:Prop) (p:P) => p).

Theorem all_perm:
    forall (A:Type) (P:A->A->Prop),
    (forall x y : A, P x y) ->
    (forall x y : A, P y x).
Proof.
    Abort.

Theorem resolution:
    forall (A:Type) (P Q R S:A->Prop), (forall a:A, Q a -> R a -> S a) -> (forall b:A, P b -> Q b) -> (forall c:A, P c -> R c -> S c).
Proof.
    Abort.


From Fiat.Narcissus Require Import Examples.TutorialPrelude.

Record msg := { data : list (list (word 8)) }.
Definition format :=
  format_nat 8 ◦ length ◦ data ++
  format_list (format_nat 8 ◦ length ++ format_list format_word) ◦ data.
Definition invariant (m : msg) :=
  length (m.(data)) < pow2 8 /\ forall l, In l m.(data) -> length l < pow2 8.

Definition dec : CorrectAlignedDecoderFor invariant format.
Proof.
  synthesize_aligned_decoder.
Defined.


(* Project 2:  The Abstract Machince

    The purpose of this project is to formally define an abstract machince that translates a lanuage called
    While into a structured form of assembler code.  This is done in order to prove that the implementation
    of the programing lanuage is correct. This can not be acccomplished without first formally defining the meaing of
    each insturction, this mapping from symbols to meaing is done within the function AM using operational semantics.
    The rules are defined in Table 4.1 of the course text. The machince has a configuration of the following from <c,e,s>
    where c is a list of instructions defined below as code, e is a stack defined in the State.v file, and s is a state implemented
    as a function in State.v as well.

    Authors: Charles Chatwin and Chris Whitney*)

Require Import Arith ZArith List String State Bool Relation_Operators.
Import ListNotations.

(** ** Syntax *)
(* Translated from page 68 in text, where c is represented using lists*)
Inductive inst: Type :=
| PUSH   : Z -> inst
| ADD    | MULT | SUB
| TRUE   | FALSE
| EQ     | LE
| AND    | NEG
| FETCH  : Id.t -> inst
| STORE  : Id.t -> inst
| NOOP   : inst
| BRANCH : list inst -> list inst -> inst
| LOOP   : list inst -> list inst -> inst.

(*  Definition of c based of page 68, c is a list of inst which is called code here *)
Definition code: Type := list inst.

(* Configuration has the form <c,e,s> where c is a sequence of inst,
    e is the stack, and s is the storage*)
Definition config : Type := ( code * Stack.t * State.t) .

(** ** Structural Operational Semantics *)
Inductive am : config -> config -> Prop :=
(*NOOP (skip)*)
| am_noop:
    forall (c:code) (e:Stack.t)(s:State.t),
      am  (NOOP::c, e, s)  (c , e, s)
(*PUSH*)
| am_push:
  forall  (n:Z) (c:code) (e:Stack.t)(s:State.t),
      am ((PUSH n)::c, e, s) (c, (Stack.z n)::e, s)

(* Z operations *)
| am_add:
  forall  (z1 z2:Z) (c:code) (s:State.t)  (e:Stack.t),
     am (ADD::c, (Stack.z z1)::(Stack.z z2)::e, s) (c, (Stack.z (Z.add z1 z2))::e, s)

| am_sub:
  forall (z1 z2: Z) (c:code) (s:State.t)  (e:Stack.t),
     am (SUB::c, (Stack.z z1)::(Stack.z z2)::e, s) (c, (Stack.z (Z.sub z1 z2))::e, s)

| am_mult:
  forall (z1 z2: Z) (c:code) (s:State.t)  (e:Stack.t),
     am (MULT::c, (Stack.z z1)::(Stack.z z2)::e, s) (c, (Stack.z (Z.mul z1 z2))::e, s)

(* TRUE and FALSE *)
| am_true:
    forall (c:code) (s:State.t) (e:Stack.t) (tt:bool),
       am (TRUE::c, e, s) (c, (Stack.T tt)::e, s)

| am_false:
    forall (c:code) (s:State.t) (e:Stack.t) (ff:bool),
       am (FALSE::c, e, s) (c, (Stack.T ff)::e, s)

(* EQ and LE *)
| am_eq :
  forall (c:code) (s:State.t) (e:Stack.t) (z1 z2: Z),
    am (EQ::c,e,s) (c, (Stack.T (Z.eqb z1 z2))::e, s)

| am_le :
  forall (c:code) (s:State.t) (e:Stack.t) (z1 z2: Z),
    am (LE::c,e,s) (c, (Stack.T (Z.leb z1 z2))::e, s)

(* AND *)
| am_and:
  forall (c:code) (s:State.t) (e:Stack.t) (t1 t2:bool),
    am (AND::c, e, s) (c,(Stack.T (andb t1 t2))::e,s)

(*NEG *)
|am_neg:
  forall  (c:code) (s:State.t) (e:Stack.t) (t:bool),
    am (NEG::c,(Stack.T t)::e,s) (c,(Stack.T (negb t))::e,s)

(*FETCH*)
| am_fetch:
    forall (c:code) (s:State.t) (e:Stack.t) (x:Id.t),
      am ((FETCH x)::c,e,s) (c, (Stack.z (s x))::e,s)

(*STORE*)
|am_store:
    forall (c:code) (s:State.t) (e:Stack.t) (x:Id.t) (z:Z),
      am ((STORE x)::c,(Stack.z z)::e,s) (c,e, (State.update s x z))

(*BRANCH*)
|am_branch_tt:
    forall (c c1 c2:code) (s:State.t) (e:Stack.t),
      am ((BRANCH c1 c2)::c, (Stack.T true)::e, s) (c1++c, e, s)

|am_branch_ff:
    forall (c c1 c2:code) (s:State.t) (e:Stack.t),
      am ((BRANCH c1 c2)::c, (Stack.T false)::e, s) (c2++c, e, s)

(* LOOP *)
|am_loop:
    forall (c c1 c2:code) (s:State.t) (e:Stack.t),
      am ((LOOP c1 c2)::c, e, s) ( c1++(BRANCH(c2++[(LOOP c1 c2)]) [NOOP])::c,e,s).

Module Examples.

  Definition x : Id.t := Id.Id 0.

  Definition s (y: Id.t) : Z :=
    if Id.beq y x
      then 3%Z
    else 0%Z.

   Example ex_4_1 :
      exists s',
      (clos_refl_trans_1n _ am) ( (PUSH 1%Z)::(FETCH x)::(ADD)::(STORE x)::[],[ ], s )
                                             ([],[],s') /\ s' x = 4%Z.
   Proof.
       repeat eexists.
       do 10  econstructor.
       simpl. reflexivity.
  Qed.

   Example ex_4_2:
          (clos_trans  _ am) ( [ LOOP [TRUE] [NOOP] ], [ ], s) ([ LOOP [TRUE] [NOOP] ], [ ], s).
      Proof.
          do 5 (econstructor; simpl).
      Qed.

    Lemma ex_4_6:
      forall (c:code) (s:State.t) (e:Stack.t),
      exists c' s' e',
        (clos_refl_trans_1n _ am) (c,e,s) (c',e',s').
    Proof.
        repeat eexists.
        admit.
    Admitted.

(*Theorem 2.9 (page 41?)*) (*should do induction on derivation tree*)
(*show table 4.1 is determinisistc; use to prove there is only one
   computation sequence. (pg 73?)
Instead of taking am: prove for am; prove for reflex_trans am.*)

End Examples.


Theorem frobenius (A : Set) (p : A -> Prop) (q : Prop) :
(exists x : A, q /\ p x) <-> (q /\ exists x : A, p x).
Proof.
split.
intros [y[H1 H2]].
split.
assumption.
exists y.
assumption.
intros [H1 [y H2]].
exists y.
auto.
Qed.


Load LFindLoad.
From lfind Require Import LFind.
Require Import Arith.
From adtind Require Import goal49.

Set Printing Depth 1000.
Definition lfind_eval  l n0:=
Cons n0 l.

Compute lfind_eval  (Nil) (Zero).

Compute lfind_eval  (Cons Zero (Cons (Succ (Succ Zero)) Nil)) (Zero).

Compute lfind_eval  (Cons (Succ (Succ Zero)) (Cons (Succ Zero) Nil)) (Succ (Succ Zero)).

Compute lfind_eval  (Cons Zero (Cons (Succ (Succ Zero)) Nil)) (Succ (Succ Zero)).

Compute lfind_eval  (Cons Zero Nil) (Zero).

Compute lfind_eval  (Cons Zero (Cons (Succ (Succ Zero)) Nil)) (Zero).

Compute lfind_eval  (Cons (Succ (Succ (Succ Zero))) (Cons (Succ Zero) (Cons Zero Nil))) (Zero).

Compute lfind_eval  (Cons (Succ (Succ (Succ Zero))) (Cons (Succ (Succ (Succ Zero))) Nil)) (Succ Zero).

Compute lfind_eval  (Cons (Succ Zero) Nil) (Zero).

Compute lfind_eval  (Nil) (Succ Zero).

Compute lfind_eval  (Nil) (Succ (Succ Zero)).

Compute lfind_eval  (Cons Zero (Cons Zero Nil)) (Succ Zero).

Compute lfind_eval  (Nil) (Succ (Succ (Succ Zero))).

Compute lfind_eval  (Nil) (Zero).

Compute lfind_eval  (Nil) (Zero).

Compute lfind_eval  (Nil) (Zero).

Compute lfind_eval  (Nil) (Succ Zero).

Compute lfind_eval  (Cons (Succ Zero) (Cons (Succ Zero) Nil)) (Zero).

Compute lfind_eval  (Nil) (Succ Zero).

Compute lfind_eval  (Nil) (Succ (Succ Zero)).

Compute lfind_eval  (Nil) (Succ Zero).

Compute lfind_eval  (Cons Zero Nil) (Succ (Succ (Succ (Succ Zero)))).

Compute lfind_eval  (Cons Zero Nil) (Zero).

Compute lfind_eval  (Cons Zero (Cons Zero Nil)) (Zero).

Compute lfind_eval  (Cons Zero Nil) (Succ Zero).

Compute lfind_eval  (Nil) (Succ (Succ Zero)).

Compute lfind_eval  (Cons Zero (Cons Zero (Cons (Succ (Succ (Succ Zero))) Nil))) (Succ Zero).

Compute lfind_eval  (Nil) (Succ Zero).

Compute lfind_eval  (Cons (Succ Zero) (Cons Zero (Cons (Succ Zero) Nil))) (Succ Zero).

Compute lfind_eval  (Cons Zero Nil) (Zero).

Compute lfind_eval  (Cons (Succ Zero) Nil) (Zero).

Compute lfind_eval  (Cons Zero (Cons (Succ (Succ Zero)) Nil)) (Zero).

Compute lfind_eval  (Cons (Succ (Succ (Succ Zero))) (Cons Zero Nil)) (Zero).

Compute lfind_eval  (Cons Zero (Cons (Succ Zero) (Cons Zero Nil))) (Succ Zero).

Compute lfind_eval  (Cons (Succ Zero) Nil) (Zero).

Compute lfind_eval  (Nil) (Succ (Succ (Succ (Succ Zero)))).

Compute lfind_eval  (Nil) (Zero).


Require Import Iron.Data.List.Base.
Require Import Iron.Data.Nat.
Require Import Iron.Tactics.

(* Insert a new element at a place in the list.
   All the elements above that place are shifted up one.
   The resulting list is one element larger. *)
Fixpoint insert {A: Type} (ix: nat) (x: A) (xs: list A) : list A :=
 match ix, xs with
 | _,     nil      => x :: nil
 | S ix', y :: xs' => y :: (insert ix' x xs')
 | O    , xs'      => x :: xs'
 end.

(* When using the 'simpl' tactic we don't want to do a reduction
   that will leave the inner match expression in head position. *)
Arguments insert A ix x xs : simpl nomatch.

(********************************************************************)
(** Lemmas: insert *)

Lemma insert_rewind
 :  forall {A} ix t1 t2 (xx: list A)
 ,  insert ix t2 xx :> t1 = insert (S ix) t2 (xx :> t1).
Proof. auto. Qed.

Lemma insert_zero
 :  forall {A} x (xs : list A)
 ,  insert 0 x xs = xs :> x.
Proof.
 rip. destruct xs; auto.
Qed.
Hint Resolve insert_zero.

(* If we insert an element at a particular point in a list,
   then we can still get the elements above that point
   provided we increment their original indices. *)
Lemma get_insert_above
 :  forall {A: Type} n ix (xx: list A) x1 x2
 ,  n >= ix
 -> get n xx                    = Some x1
 -> get (S n) (insert ix x2 xx) = Some x1.
Proof.
 intros. gen n xx.
 induction ix; intros.
  destruct xx.
   false.
   destruct n; auto.
  destruct xx.
   false.
   destruct n.
    false. omega.
    simpl in H0. simpl. apply IHix.
     omega.
     auto.
Qed.
Hint Resolve get_insert_above.

(* If we insert an element at a particular point in a list,
   then we can still get the elements below that point
   using their original indices. *)
Lemma get_insert_below
 :  forall {A: Type} n ix (xx: list A) x1 x2
 ,  n < ix
 -> get n xx                = Some x1
 -> get n (insert ix x2 xx) = Some x1.
Proof.
 intros. gen n xx.
 induction ix; intros.
  destruct xx.
   false.
   destruct n.
    false. omega.
    false. omega.
  destruct xx.
   false.
   destruct n.
    simpl in H0. auto.
    simpl in H0. simpl. apply IHix. omega. auto.
Qed.
Hint Resolve get_insert_below.

(* Inserting a new element into a list then applying a function to
   all elements is the same as applying the function to all the
   original elements, then inserting the new one with the function
   already applied. *)
Lemma map_insert
 : forall {A B: Type} (f: A -> B) ix x (xs: list A)
 , map f (insert ix x xs)
 = insert ix (f x) (map f xs).
Proof.
 intros. gen ix x.
 induction xs; intros.
  simpl. destruct ix; auto.
  simpl. destruct ix; auto.
   rewrite <- insert_rewind. simpl.
   rewrite IHxs. auto.
Qed.

Lemma insert_app
 : forall {A : Type} ix (x: A) xs ys
 , insert ix x xs >< ys = insert (ix + length ys) x (xs >< ys).
Proof.
 intros.
 induction ys.
  simpl. norm_nat.  auto.
  simpl. rewrite IHys.
   rewrite insert_rewind.
   assert (S (ix + length ys) = ix + S (length ys)). auto.
   rewrite H. auto.
Qed.


(* -*- mode: coq; mode: visual-line -*- *)

Require Import HoTT.Basics HoTT.Types.

Local Open Scope nat_scope.
Local Open Scope path_scope.

Generalizable Variables A B f.

(** * Relational equivalences *)

(** This definition is due to Peter LeFanu Lumsdaine on the HoTT mailing list.  This definition gives more judgmental properties, though has the downside of jumping universe levels. *)

Record RelEquiv A B :=
  { equiv_rel : A -> B -> Type;
    relequiv_contr_f : forall a, Contr { b : B & equiv_rel a b };
    relequiv_contr_g : forall b, Contr { a : A & equiv_rel a b } }.

Arguments equiv_rel {A B} _ _ _.
Global Existing Instance relequiv_contr_f.
Global Existing Instance relequiv_contr_g.

Definition issig_relequiv {A B}
  : { equiv_rel : A -> B -> Type
    | { f : forall a, Contr { b : B & equiv_rel a b }
      | forall b, Contr { a : A & equiv_rel a b } } }
      <~> RelEquiv A B.
Proof.
  issig.
Defined.

Definition relequiv_of_equiv {A B} (e : A <~> B) : RelEquiv A B.
Proof.
  refine {| equiv_rel a b := e a = b |}.
  (** The rest is found by typeclass inference! *)
Defined.

Definition equiv_of_relequiv {A B} (e : RelEquiv A B) : A <~> B.
Proof.
  refine (equiv_adjointify
            (fun a => (center { b : B & equiv_rel e a b}).1)
            (fun b => (center { a : A & equiv_rel e a b}).1)
            _ _);
    intro x; cbn.
  { refine (ap pr1 (contr _) : _.1 = (x; _).1).
    exact (center {a : A & equiv_rel e a x}).2. }
  { refine (ap pr1 (contr _) : _.1 = (x; _).1).
    exact (center {b : B & equiv_rel e x b}).2. }
Defined.

Definition RelIsEquiv {A B} (f : A -> B)
  := { r : RelEquiv A B | forall x, (center { b : B & equiv_rel r x b }).1 = f x }.

(** TODO: Prove [ishprop_relisequiv `{Funext} {A B} f : IsHProp (@RelIsEquiv A B f)] *)

(** * Judgmental property *)
Definition inverse_relequiv {A B} (e : RelEquiv A B) : RelEquiv B A
  := {| equiv_rel a b := equiv_rel e b a |}.

Definition reinv_V {A B} (e : RelEquiv A B)
  : inverse_relequiv (inverse_relequiv e) = e
  := 1.

(** TODO: Is there a definition of this that makes [inverse_relequiv (relequiv_idmap A)] be [relequiv_idmap A], judgmentally? *)
Definition relequiv_idmap A : RelEquiv A A
  := {| equiv_rel a b := a = b |}.

(** TODO: Define composition; we probably need truncation to do this? *)


Require Export Shared.Base MoreList.

(** * Preliminaries *)

Instance le_preorder : PreOrder le.
Proof.
  constructor. all:cbv. all:intros;omega.
Qed.

Instance S_le_proper : Proper (le ==> le) S.
Proof.
  cbv. fold plus. intros. omega.
Qed.

Instance plus_le_proper : Proper (le ==> le ==> le) plus.
Proof.
  cbv. fold plus. intros. omega.
Qed.

Instance mult_le_proper : Proper (le ==> le ==> le) mult.
Proof.
  cbv. intros.
  apply mult_le_compat. all:eauto.
Qed.

Instance max_le_proper : Proper (le ==> le ==> le) max.
repeat intro. repeat eapply Nat.max_case_strong;omega.
Qed.

Instance min_le_proper : Proper (le ==> le ==> le) min.
repeat intro. repeat eapply Nat.min_case_strong;omega.
Qed.

Lemma nth_error_Some_lt A (H:list A) a x : nth_error H a = Some x -> a < |H|.
Proof.
  intros eq. revert H eq. induction a;intros;destruct H;cbn in *;inv eq. omega. apply IHa in H1. omega.
Qed.

Definition maxP (P:nat -> Prop) m := P m /\ (forall m', P m' -> m' <= m).


(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat div.
From mathcomp Require Import seq choice tuple bigop ssralg poly polydiv.
From mathcomp Require Import generic_quotient.

(* This file builds the field of fraction of any integral domain. *)
(* The main result of this file is the existence of the field *)
(* and of the tofrac function which is a injective ring morphism from R *)
(* to its fraction field {fraction R} *)

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Import GRing.Theory.
Local Open Scope ring_scope.
Local Open Scope quotient_scope.

Reserved Notation "{ 'ratio' T }" (at level 0, format "{ 'ratio'  T }").
Reserved Notation "{ 'fraction' T }" (at level 0, format "{ 'fraction'  T }").
Reserved Notation "x %:F" (at level 2, format "x %:F").

Section FracDomain.
Variable R : ringType.

(* ratios are pairs of R, such that the second member is nonzero *)
Inductive ratio := mkRatio { frac :> R * R; _ : frac.2 != 0 }.
Definition ratio_of of phant R := ratio.
Local Notation "{ 'ratio' T }" := (ratio_of (Phant T)).

Canonical ratio_subType := Eval hnf in [subType for frac].
Canonical ratio_of_subType := Eval hnf in [subType of {ratio R}].
Definition ratio_EqMixin := [eqMixin of ratio by <:].
Canonical ratio_eqType := EqType ratio ratio_EqMixin.
Canonical ratio_of_eqType := Eval hnf in [eqType of {ratio R}].
Definition ratio_ChoiceMixin := [choiceMixin of ratio by <:].
Canonical ratio_choiceType := ChoiceType ratio ratio_ChoiceMixin.
Canonical ratio_of_choiceType := Eval hnf in [choiceType of {ratio R}].

Lemma denom_ratioP : forall f : ratio, f.2 != 0. Proof. by case. Qed.

Definition ratio0 := (@mkRatio (0, 1) (oner_neq0 _)).
Definition Ratio x y : {ratio R} := insubd ratio0 (x, y).

Lemma numer_Ratio x y : y != 0 -> (Ratio x y).1 = x.
Proof. by move=> ny0; rewrite /Ratio /insubd insubT. Qed.

Lemma denom_Ratio x y : y != 0 -> (Ratio x y).2 = y.
Proof. by move=> ny0; rewrite /Ratio /insubd insubT. Qed.

Definition numden_Ratio := (numer_Ratio, denom_Ratio).

CoInductive Ratio_spec (n d : R) : {ratio R} -> R -> R -> Type :=
  | RatioNull of d = 0 : Ratio_spec n d ratio0 n 0
  | RatioNonNull (d_neq0 : d != 0) :
    Ratio_spec n d (@mkRatio (n, d) d_neq0) n d.

Lemma RatioP n d : Ratio_spec n d (Ratio n d) n d.
Proof.
rewrite /Ratio /insubd; case: insubP=> /= [x /= d_neq0 hx|].
  have ->: x = @mkRatio (n, d) d_neq0 by apply: val_inj.
  by constructor.
by rewrite negbK=> /eqP hx; rewrite {2}hx; constructor.
Qed.

Lemma Ratio0 x : Ratio x 0 = ratio0.
Proof. by rewrite /Ratio /insubd; case: insubP; rewrite //= eqxx. Qed.

End FracDomain.

Notation "{ 'ratio' T }" := (ratio_of (Phant T)).
Identity Coercion type_fracdomain_of : ratio_of >-> ratio.

Notation "'\n_' x"  := (frac x).1
  (at level 8, x at level 2, format "'\n_' x").
Notation "'\d_' x"  := (frac x).2
  (at level 8, x at level 2, format "'\d_' x").

Module FracField.
Section FracField.

Variable R : idomainType.

Local Notation frac := (R * R).
Local Notation dom := (ratio R).
Local Notation domP := denom_ratioP.

Implicit Types x y z : dom.

(* We define a relation in ratios *)
Local Notation equivf_notation x y := (\n_x * \d_y == \d_x * \n_y).
Definition equivf x y := equivf_notation x y.

Lemma equivfE x y : equivf x y = equivf_notation x y.
Proof. by []. Qed.

Lemma equivf_refl : reflexive equivf.
Proof. by move=> x; rewrite /equivf mulrC. Qed.

Lemma equivf_sym : symmetric equivf.
Proof. by move=> x y; rewrite /equivf eq_sym; congr (_==_); rewrite mulrC. Qed.

Lemma equivf_trans : transitive equivf.
Proof.
move=> [x Px] [y Py] [z Pz]; rewrite /equivf /= mulrC => /eqP xy /eqP yz.
by rewrite -(inj_eq (mulfI Px)) mulrA xy -mulrA yz mulrCA.
Qed.

(* we show that equivf is an equivalence *)
Canonical equivf_equiv := EquivRel equivf equivf_refl equivf_sym equivf_trans.

Definition type := {eq_quot equivf}.
Definition type_of of phant R := type.
Notation "{ 'fraction' T }" := (type_of (Phant T)).

(* we recover some structure for the quotient *)
Canonical frac_quotType := [quotType of type].
Canonical frac_eqType := [eqType of type].
Canonical frac_choiceType := [choiceType of type].
Canonical frac_eqQuotType := [eqQuotType equivf of type].

Canonical frac_of_quotType := [quotType of {fraction R}].
Canonical frac_of_eqType := [eqType of {fraction R}].
Canonical frac_of_choiceType := [choiceType of {fraction R}].
Canonical frac_of_eqQuotType := [eqQuotType equivf of {fraction R}].

(* we explain what was the equivalence on the quotient *)
Lemma equivf_def (x y : ratio R) : x == y %[mod type]
                                    = (\n_x * \d_y == \d_x * \n_y).
Proof. by rewrite eqmodE. Qed.

Lemma equivf_r x : \n_x * \d_(repr (\pi_type x)) = \d_x * \n_(repr (\pi_type x)).
Proof. by apply/eqP; rewrite -equivf_def reprK. Qed.

Lemma equivf_l x : \n_(repr (\pi_type x)) * \d_x = \d_(repr (\pi_type x)) * \n_x.
Proof. by apply/eqP; rewrite -equivf_def reprK. Qed.

Lemma numer0 x : (\n_x == 0) = (x == (ratio0 R) %[mod_eq equivf]).
Proof. by rewrite eqmodE /= !equivfE // mulr1 mulr0. Qed.

Lemma Ratio_numden : forall x, Ratio \n_x \d_x = x.
Proof.
case=> [[n d] /= nd]; rewrite /Ratio /insubd; apply: val_inj=> /=.
by case: insubP=> //=; rewrite nd.
Qed.

Definition tofrac := lift_embed {fraction R} (fun x : R => Ratio x 1).
Canonical tofrac_pi_morph := PiEmbed tofrac.

Notation "x %:F"  := (@tofrac x).

Implicit Types a b c : type.

Definition addf x y : dom := Ratio (\n_x * \d_y + \n_y * \d_x) (\d_x * \d_y).
Definition add := lift_op2 {fraction R} addf.

Lemma pi_add : {morph \pi : x y / addf x y >-> add x y}.
Proof.
move=> x y; unlock add; apply/eqmodP; rewrite /= equivfE.
rewrite /addf /= !numden_Ratio ?mulf_neq0 ?domP //.
rewrite mulrDr mulrDl eq_sym; apply/eqP.
rewrite !mulrA ![_ * \n__]mulrC !mulrA equivf_l.
congr (_ + _); first by rewrite -mulrA mulrCA !mulrA.
rewrite -!mulrA [X in _ * X]mulrCA !mulrA equivf_l.
by rewrite mulrC !mulrA -mulrA mulrC mulrA.
Qed.
Canonical pi_add_morph := PiMorph2 pi_add.

Definition oppf x : dom := Ratio (- \n_x) \d_x.
Definition opp := lift_op1 {fraction R} oppf.
Lemma pi_opp : {morph \pi : x / oppf x >-> opp x}.
Proof.
move=> x; unlock opp; apply/eqmodP; rewrite /= /equivf /oppf /=.
by rewrite !numden_Ratio ?(domP,mulf_neq0) // mulNr mulrN -equivf_r.
Qed.
Canonical pi_opp_morph := PiMorph1 pi_opp.

Definition mulf x y : dom := Ratio (\n_x * \n_y) (\d_x * \d_y).
Definition mul := lift_op2 {fraction R} mulf.

Lemma pi_mul : {morph \pi : x y / mulf x y >-> mul x y}.
Proof.
move=> x y; unlock mul; apply/eqmodP=> /=.
rewrite equivfE /= /addf /= !numden_Ratio ?mulf_neq0 ?domP //.
rewrite mulrAC !mulrA -mulrA equivf_r -equivf_l.
by rewrite mulrA ![_ * \d_y]mulrC !mulrA.
Qed.
Canonical pi_mul_morph := PiMorph2 pi_mul.

Definition invf x : dom := Ratio \d_x \n_x.
Definition inv := lift_op1 {fraction R} invf.

Lemma pi_inv : {morph \pi : x / invf x >-> inv x}.
Proof.
move=> x; unlock inv; apply/eqmodP=> /=; rewrite equivfE /invf eq_sym.
do 2?case: RatioP=> /= [/eqP|];
  rewrite ?mul0r ?mul1r -?equivf_def ?numer0 ?reprK //.
  by move=> hx /eqP hx'; rewrite hx' eqxx in hx.
by move=> /eqP ->; rewrite eqxx.
Qed.
Canonical pi_inv_morph := PiMorph1 pi_inv.

Lemma addA : associative add.
Proof.
elim/quotW=> x; elim/quotW=> y; elim/quotW=> z; rewrite !piE.
rewrite /addf /= !numden_Ratio ?mulf_neq0 ?domP // !mulrDl !mulrA !addrA.
by congr (\pi (Ratio (_ + _ + _) _)); rewrite mulrAC.
Qed.

Lemma addC : commutative add.
Proof.
by elim/quotW=> x; elim/quotW=> y; rewrite !piE /addf addrC [\d__ * _]mulrC.
Qed.

Lemma add0_l : left_id 0%:F add.
Proof.
elim/quotW=> x; rewrite !piE /addf !numden_Ratio ?oner_eq0 //.
by rewrite mul0r mul1r mulr1 add0r Ratio_numden.
Qed.

Lemma addN_l : left_inverse 0%:F opp add.
Proof.
elim/quotW=> x; apply/eqP; rewrite piE /equivf.
rewrite /addf /oppf !numden_Ratio ?(oner_eq0, mulf_neq0, domP) //.
by rewrite mulr1 mulr0 mulNr addNr.
Qed.

(* fracions form an abelian group *)
Definition frac_zmodMixin :=  ZmodMixin addA addC add0_l addN_l.
Canonical frac_zmodType := Eval hnf in ZmodType type frac_zmodMixin.

Lemma mulA : associative mul.
Proof.
elim/quotW=> x; elim/quotW=> y; elim/quotW=> z; rewrite !piE.
by rewrite /mulf !numden_Ratio ?mulf_neq0 ?domP // !mulrA.
Qed.

Lemma mulC : commutative mul.
Proof.
elim/quotW=> x; elim/quotW=> y; rewrite !piE /mulf.
by rewrite [_ * (\d_x)]mulrC [_ * (\n_x)]mulrC.
Qed.

Lemma mul1_l : left_id 1%:F mul.
Proof.
elim/quotW=> x; rewrite !piE /mulf.
by rewrite !numden_Ratio ?oner_eq0 // !mul1r Ratio_numden.
Qed.

Lemma mul_addl : left_distributive mul add.
Proof.
elim/quotW=> x; elim/quotW=> y; elim/quotW=> z; apply/eqP.
rewrite !piE /equivf /mulf /addf !numden_Ratio ?mulf_neq0 ?domP //; apply/eqP.
rewrite !(mulrDr, mulrDl) !mulrA; congr (_ * _ + _ * _).
  rewrite ![_ * \n_z]mulrC -!mulrA; congr (_ * _).
  rewrite ![\d_y * _]mulrC !mulrA; congr (_ * _ * _).
  by rewrite [X in _ = X]mulrC mulrA.
rewrite ![_ * \n_z]mulrC -!mulrA; congr (_ * _).
rewrite ![\d_x * _]mulrC !mulrA; congr (_ * _ * _).
by rewrite -mulrA mulrC [X in X * _] mulrC.
Qed.

Lemma nonzero1 : 1%:F != 0%:F :> type.
Proof. by rewrite piE equivfE !numden_Ratio ?mul1r ?oner_eq0. Qed.

(* fracions form a commutative ring *)
Definition frac_comRingMixin := ComRingMixin mulA mulC mul1_l mul_addl nonzero1.
Canonical frac_ringType := Eval hnf in RingType type frac_comRingMixin.
Canonical frac_comRingType := Eval hnf in ComRingType type mulC.

Lemma mulV_l : forall a, a != 0%:F -> mul (inv a) a = 1%:F.
Proof.
elim/quotW=> x /=; rewrite !piE.
rewrite /equivf !numden_Ratio ?oner_eq0 // mulr1 mulr0=> nx0.
apply/eqmodP; rewrite /= equivfE.
by rewrite !numden_Ratio ?(oner_eq0, mulf_neq0, domP) // !mulr1 mulrC.
Qed.

Lemma inv0 : inv 0%:F = 0%:F.
Proof.
rewrite !piE /invf !numden_Ratio ?oner_eq0 // /Ratio /insubd.
do 2?case: insubP; rewrite //= ?eqxx ?oner_eq0 // => u _ hu _.
by congr \pi; apply: val_inj; rewrite /= hu.
Qed.

(* fractions form a ring with explicit unit *)
Definition RatFieldUnitMixin := FieldUnitMixin mulV_l inv0.
Canonical frac_unitRingType := Eval hnf in UnitRingType type RatFieldUnitMixin.
Canonical frac_comUnitRingType := [comUnitRingType of type].

Lemma field_axiom : GRing.Field.mixin_of frac_unitRingType.
Proof. exact. Qed.

(* fractions form a field *)
Definition RatFieldIdomainMixin := (FieldIdomainMixin field_axiom).
Canonical frac_idomainType :=
  Eval hnf in IdomainType type (FieldIdomainMixin field_axiom).
Canonical frac_fieldType := FieldType type field_axiom.

End FracField.
End FracField.

Notation "{ 'fraction' T }" := (FracField.type_of (Phant T)).
Notation equivf := (@FracField.equivf _).
#[export] Hint Resolve denom_ratioP : core.

Section Canonicals.

Variable R : idomainType.

(* reexporting the structures *)
Canonical FracField.frac_quotType.
Canonical FracField.frac_eqType.
Canonical FracField.frac_choiceType.
Canonical FracField.frac_zmodType.
Canonical FracField.frac_ringType.
Canonical FracField.frac_comRingType.
Canonical FracField.frac_unitRingType.
Canonical FracField.frac_comUnitRingType.
Canonical FracField.frac_idomainType.
Canonical FracField.frac_fieldType.
Canonical FracField.tofrac_pi_morph.
Canonical frac_of_quotType := Eval hnf in [quotType of {fraction R}].
Canonical frac_of_eqType := Eval hnf  in [eqType of {fraction R}].
Canonical frac_of_choiceType := Eval hnf in [choiceType of {fraction R}].
Canonical frac_of_zmodType := Eval hnf in [zmodType of {fraction R}].
Canonical frac_of_ringType := Eval hnf in [ringType of {fraction R}].
Canonical frac_of_comRingType := Eval hnf in [comRingType of {fraction R}].
Canonical frac_of_unitRingType := Eval hnf in [unitRingType of {fraction R}].
Canonical frac_of_comUnitRingType := Eval hnf in [comUnitRingType of {fraction R}].
Canonical frac_of_idomainType := Eval hnf in [idomainType of {fraction R}].
Canonical frac_of_fieldType := Eval hnf in [fieldType of {fraction R}].

End Canonicals.

Section FracFieldTheory.

Import FracField.

Variable R : idomainType.

Lemma Ratio_numden (x : {ratio R}) : Ratio \n_x \d_x = x.
Proof. exact: FracField.Ratio_numden. Qed.

(* exporting the embeding from R to {fraction R} *)
Local Notation tofrac := (@FracField.tofrac R).
Local Notation "x %:F" := (tofrac x).

Lemma tofrac_is_additive: additive tofrac.
Proof.
move=> p q /=; unlock tofrac.
rewrite -[X in _ = _ + X]pi_opp -[X in _ = X]pi_add.
by rewrite /addf /oppf /= !numden_Ratio ?(oner_neq0, mul1r, mulr1).
Qed.

Canonical tofrac_additive := Additive tofrac_is_additive.

Lemma tofrac_is_multiplicative: multiplicative tofrac.
Proof.
split=> [p q|//]; unlock tofrac; rewrite -[X in _ = X]pi_mul.
by rewrite /mulf /= !numden_Ratio ?(oner_neq0, mul1r, mulr1).
Qed.

Canonical tofrac_rmorphism := AddRMorphism tofrac_is_multiplicative.

(* tests *)
Lemma tofrac0 : 0%:F = 0. Proof. exact: rmorph0. Qed.
Lemma tofracN : {morph tofrac: x / - x}. Proof. exact: rmorphN. Qed.
Lemma tofracD : {morph tofrac: x y / x + y}. Proof. exact: rmorphD. Qed.
Lemma tofracB : {morph tofrac: x y / x - y}. Proof. exact: rmorphB. Qed.
Lemma tofracMn n : {morph tofrac: x / x *+ n}. Proof. exact: rmorphMn. Qed.
Lemma tofracMNn n : {morph tofrac: x / x *- n}. Proof. exact: rmorphMNn. Qed.
Lemma tofrac1 : 1%:F = 1. Proof. exact: rmorph1. Qed.
Lemma tofracM : {morph tofrac: x y  / x * y}. Proof. exact: rmorphM. Qed.
Lemma tofracX n : {morph tofrac: x / x ^+ n}. Proof. exact: rmorphX. Qed.

Lemma tofrac_eq (p q : R): (p%:F == q%:F) = (p == q).
Proof.
apply/eqP/eqP=> [|->//]; unlock tofrac=> /eqmodP /eqP /=.
by rewrite !numden_Ratio ?(oner_eq0, mul1r, mulr1).
Qed.

Lemma tofrac_eq0 (p : R): (p%:F == 0) = (p == 0).
Proof. by rewrite tofrac_eq. Qed.
End FracFieldTheory.


(* This file is part of the Linear Logic formalization in Coq:
https://github.com/brunofx86/LL *)

(** ** Cut Elimination
Here we prove cut-elimination for linear logic and, as a corollary, we show the consistency of the logic
*)

Require Import Coq.Relations.Relations.
Require Import Coq.Arith.EqNat.
Require Import Coq.Classes.Morphisms.
Require Import Coq.Setoids.Setoid.
Require Export Coq.Sorting.PermutSetoid.
Require Export Coq.Sorting.PermutEq.
Require Import Coq.Program.Equality.
(* Require Export StructuralRules. *)
Require Export SequentCalculi.
Require Export Eqset.
Require Import myTactics.
Require Import CutCases.

Ltac simpl_duals H :=
  try rewrite one_bot in H;
  try rewrite bot_one in H;
  try rewrite top_zero in H;
  try rewrite zero_top in H;
  try rewrite atom_perp in H;
  try rewrite perp_atom in H;
  try rewrite tensor_par in H;
  try rewrite par_tensor in H;
  try rewrite with_plus in H;
  try rewrite plus_with in H;
  try rewrite bang_quest in H;
  try rewrite quest_bang in H.

Theorem cut_aux B L M1 M2 F :
      L =mul= M1 ++ M2 ->
        0 |~> 0 ; B ; F :: M1 ->
        0 |~> 0 ; B ; F° :: M2 ->
          exists m, m |~> 0 ; B ; L.
 Proof.
    intros P Hn1 Hn2.
    inversion Hn1; subst.
    *
     apply axPair in H.
     destruct H;
     firstorder; subst.
     +
       simpl_duals Hn2.
       inversion Hn2; subst.
       - (* init rule *)
        apply axPair in H.
        destruct H;
        firstorder; [lexp_contr H |].
        apply PerpEq in H; subst.
        eexists; eapply sig3_init.
        eauto.
       - (* contradiction *)
        eapply resolvers2 in H; firstorder; lexp_contr H.
       - (* top rule *)
        simpl_cases2.
        top_commutes.
     + (* symmetric case *)
       simpl_duals Hn2.
       inversion Hn2; subst.
       - (* init rule *)
        apply axPair in H.
        destruct H;
        firstorder; [|lexp_contr H].
        apply AtomEq in H; subst.
        eexists; eapply sig3_init.
        eauto.
       - (* contradiction *)
        eapply resolvers2 in H; firstorder; lexp_contr H.
       - (* top rule *)
        simpl_cases2.
        top_commutes.
    *
     eapply resolvers2 in H; firstorder.
     subst.
     simpl_duals Hn2.
     inversion Hn2; subst.
     + (* contradiction *)
       apply resolvers in H; firstorder; lexp_contr H.
     + (* contradiction *)
       eapply resolvers2 in H; firstorder; lexp_contr H.
     + (* top rule *)
       simpl_cases2.
       top_commutes.
    *
     destruct (FEqDec F Top).
     +
       subst. simpl_cases4.
       simpl_duals Hn2.
       inversion Hn2; subst.
       - (* contradiction *)
        apply resolvers in H0; firstorder; lexp_contr H0.
       - (* contradiction *)
        eapply resolvers2 in H0; firstorder; lexp_contr H0.
       - (* top rule *)
        simpl_cases2.
        top_commutes.
     + (* top rule *)
       simpl_cases2.
       top_commutes.
Qed.
Arguments cut_aux[B L M1 M2 F].

Theorem ccut_aux  B L M1 M2 F w :
      S w = Lexp_weight (! F) -> L =mul= M1 ++ M2 ->
        0 |~> 0 ; B ; ! F :: M1 -> 0 |~> 0 ; F° :: B ; M2 ->
        exists m, m |~> 0 ; B ; L.
  Proof.
    intros Hw P Hn1 Hn2.
    inversion Hn1; subst;
    [ apply resolvers in H; firstorder; lexp_contr H |
      apply resolvers2 in H; firstorder; lexp_contr H |
      simpl_cases2; top_commutes].
Qed.
Arguments ccut_aux [B L M1 M2 F w].

 Lemma cut_elimination_base: forall n B L,
  n |~> 1 ; B ; L -> exists m, m |~> 0 ; B ; L.
Proof.
  intros.
  revert dependent B.
  revert dependent L.
  induction n using strongind; intros.
  - inversion H.
  - inversion H0; subst.
    + assert (exists m, m |~> 0; B; M) as Hyp by solve [eapply H; auto].
      destruct Hyp as [t Ht]; eexists;
      refine (sig3_bot _ Ht); eauto.
    + assert (exists m, m |~> 0; B; F :: G :: M) as Hyp by solve [eapply H; auto].
      destruct Hyp as [t Ht]; eexists;
      refine (sig3_par _ Ht); resolve_rewrite.
    + apply Nat.eq_add_1 in H2.
      destruct H2; destruct H1; subst.
      assert (exists m, m |~> 0; B; F :: M) as Hyp.
      refine (H _ _ _ _ H4); resolve_max.
      destruct Hyp as [t Ht]; eexists;
      refine (sig3_tensor _ Ht H5); resolve_rewrite; auto.
      assert (exists m, m |~> 0; B; G :: N) as Hyp.
      refine (H _ _ _ _ H5); resolve_max.
      destruct Hyp as [t Ht]; eexists;
      refine (sig3_tensor _ H4 Ht); resolve_rewrite.
    + assert (exists m, m |~> 0; B; F :: M) as Hyp by solve [eapply H; auto].
      destruct Hyp as [t Ht]; eexists;
      refine (sig3_plus1 _ Ht); resolve_rewrite.
    + assert (exists m, m |~> 0; B; G :: M) as Hyp by solve [eapply H; auto].
      destruct Hyp as [t Ht]; eexists;
      refine (sig3_plus2 _ Ht); resolve_rewrite.
    + apply Nat.eq_add_1 in H2.
      destruct H2; destruct H1; subst.
      assert (exists m, m |~> 0; B; F :: M) as Hyp.
      refine (H _ _ _ _ H4); resolve_max.
      destruct Hyp as [t Ht]; eexists;
      refine (sig3_with _ Ht H5); resolve_rewrite. auto.
      assert (exists m, m |~> 0; B; G :: M) as Hyp.
      refine (H _ _ _ _ H5); resolve_max.
      destruct Hyp as [t Ht]; eexists;
      refine (sig3_with _ H4 Ht); resolve_rewrite.
    + rewrite H3 in H4.
      assert (exists m, m |~> 0; B; F:: L) as Hyp by solve [eapply H; auto].
      destruct Hyp as [t Ht]; eexists;
      refine (sig3_copy _ _ Ht); auto.
    + assert (exists m, m |~> 0; F:: B; M) as Hyp by solve [eapply H; auto].
      destruct Hyp as [t Ht]; eexists;
      refine (sig3_quest _ Ht); auto.
    + assert (exists m, m |~> 0; B; [F]) as Hyp by solve [eapply H; auto].
      destruct Hyp as [t Ht]; eexists;
      refine (sig3_bang _ Ht); auto.
    + assert (exists m, m |~> 0; B; Subst FX t :: M) as Hyp by solve [eapply H; auto].
      destruct Hyp as [p Hp]; eexists; eapply sig3_ex; eauto.
    +
      assert (forall y : Term, exists m, m |~> 0; B; Subst FX y :: M) as Hyp.
      intro.
      assert (n |~> 1; B; Subst FX y :: M) by auto.
      eapply H; auto.
      apply fx_swap_sig3h in Hyp.
      destruct Hyp as [p Hp];
      eexists; eapply sig3_fx; eauto.
    + (* caso CUT *)
    clear H0. clear H.
    revert dependent B.
    revert dependent L.
    revert dependent n.

    dependent induction w using strongind;

    dependent induction h using strongind; intros.

  * (* w=h=0 *)
    inversion H3; subst.
       **
         cut_free.
         simpl in H0, H1.
         cut_free.
         eapply cut_aux; eauto.
       **
         cut_free.
         simpl in H1, H0.
         inversion H0.
   *
     inversion H3; subst.
         **

        cut_free.
         simpl in H1.
         rename H1 into Hw, H2 into Hh.
         rename H4 into P, H5 into Hn1, H9 into Hn2.
         rename m into n1, n0 into n2.
         rename M into M1, N into M2.
         caseLexp F; subst; simpl; try inversion Hw;
         simpl_duals Hn1; simpl_duals Hn2.
         refine (aux_CUT_ap _ Hh _ P Hn1 Hn2); eauto.
         rewrite union_comm in P.
         rewrite Nat.add_comm in Hh.
         refine (aux_CUT_ap _ Hh _ _ Hn2 Hn1); eauto.
         rewrite union_comm in P.
         rewrite Nat.add_comm in Hh.
         refine (aux_CUT_bo _ Hh _ _ Hn2 Hn1); eauto.
         refine (aux_CUT_bo _ Hh _ _ Hn1 Hn2); eauto.
         rewrite union_comm in P.
         rewrite Nat.add_comm in Hh.
         refine (aux_CUT_tz _ Hh _ _ Hn2 Hn1); eauto.
         refine (aux_CUT_tz _ Hh _ _ Hn1 Hn2); eauto.
         **
         cut_free.
         simpl in H1.
         inversion H1.
  * (* h=0 e S w *)
    inversion H3; subst.
         **
         cut_free.
         simpl in H2.
         cut_free.
         eapply cut_aux; eauto.
         **
         cut_free.
         simpl in H2.
         cut_free.
         eapply ccut_aux; eauto.
  * inversion H3; subst; try cut_free.
     -- (** cut *)
     rename H2 into Hw, H4 into Hh.
     rename H5 into P, H6 into Hn1, H10 into Hn2.
     rename m into n1, n0 into n2.
     rename M into M1, N into M2.
     clear H3.
     caseLexp F; subst; simpl; try inversion Hw;
     simpl_duals Hn1; simpl_duals Hn2.
     refine (aux_CUT_tp _ _ _ _ P Hn1 Hn2); eauto.
     rewrite union_comm in P.
     rewrite Nat.add_comm in Hh.
     refine (aux_CUT_tp _ _ _ _ P Hn2 _); eauto.
     rewrite <- !lweight_dual; auto.
     rewrite <- !Ng_involutive; auto.
     rewrite union_comm in P.
     rewrite Nat.add_comm in Hh.
     refine (aux_CUT_pw _ _ _ _ P Hn2 _); eauto.
     rewrite <- !lweight_dual; auto.
     rewrite <- !Ng_involutive; auto.
     refine (aux_CUT_pw _ _ _ _ P Hn1 Hn2); eauto.
     refine (aux_CUT_bq _ _ _ _ P Hn1 Hn2); eauto.
     rewrite union_comm in P.
     rewrite Nat.add_comm in Hh.
     refine (aux_CUT_bq _ _ _ _ P Hn2 _); eauto.
     rewrite <- !lweight_dual; auto.
     rewrite <- !Ng_involutive; auto.
     refine (aux_CUT_ef _ _ Hw _ P Hn1 Hn2 ); eauto.
     refine (aux_CUT_fe _ _ Hw _ P Hn1 Hn2 ); eauto.

     -- (** ccut *)
         rename H2 into Hw, H4 into Hh.
         rename H5 into P, H6 into Hn1, H10 into Hn2.
         rename m into n1, n0 into n2.
         rename M into M1, N into M2.

         inversion Hn1;subst.
         eapply resolvers in H1; intuition;
         lexp_contr H2.
         eapply resolvers2 in H1; intuition;
         lexp_contr H2.

         (* Top Commutes *)
         simpl_cases2.
         eexists.
         rewrite P.
         rewrite H2.
         eapply sig3_top. eauto.

         (* Bot Commutes *)
         simpl_cases2.
         assert (exists m, m |~> 0 ; B; x ++ M2) as Hyp.
         rewrite H1 in H2.
         refine (H0 _ _ _ _ _ _);
         [ | change (0%nat) with (0+0);
             refine (sig3_ccut _ _ _ H2 Hn2);
             auto; try resolve_rewrite]; resolve_max.

        destruct Hyp as [t Ht];
        eexists;
        refine (sig3_bot _ Ht); auto; resolve_rewrite.

         (* Par Commutes *)
         simpl_cases2.
         assert (exists m, m |~> 0 ; B; F0 :: G :: (x ++ M2)) as Hyp.
         rewrite H1 in H2;
         rewrite union_rotate_cons in H2.
         refine (H0 _ _ _ _ _ _);
         [ | change (0%nat) with (0+0);
             refine (sig3_ccut _ _ _ H2 Hn2);
             auto; try resolve_rewrite]; resolve_max.

        destruct Hyp as [t Ht];
        eexists;
        refine (sig3_par _ Ht); auto; resolve_rewrite.

    (* Tensor Commutes *)
         simpl_cases2.
         cut_free.
         simpl_cases_tns.

      assert (exists m, m |~> 0 ; B; F0 :: (L1 ++ M2)) as Hyp.
      rewrite HL1 in H4;
        rewrite meq_swap_cons in H4.
     refine (H0 _ _ _ _ _ _);
     [ | change (0%nat) with (0+0);
         refine (sig3_ccut _ _ _ H4 Hn2);
         auto; try resolve_rewrite].
         inversion Hh.  resolve_max.
      destruct Hyp as [t Ht];
      eexists;
      refine (sig3_tensor _ Ht H6); auto; resolve_rewrite.

      assert (exists m, m |~> 0 ; B; G :: (L2 ++ M2)) as Hyp.

      rewrite HL2 in H6;
      rewrite meq_swap_cons in H6.
     refine (H0 _ _ _ _ _ _);
     [ | change (0%nat) with (0+0);
         refine (sig3_ccut _ _ _ H6 Hn2);
         auto; try resolve_rewrite].
         inversion Hh.  resolve_max.
      destruct Hyp as [t Ht];
      eexists;
      refine (sig3_tensor _ H4 Ht); auto; resolve_rewrite.

     (* Plus1 Commutes *)
         simpl_cases2.
         assert (exists m : nat, m |~> 0 ; B; F0 :: x ++ M2) as Hyp.
         rewrite H1 in H2;
         rewrite meq_swap_cons in H2.
     refine (H0 _ _ _ _ _ _);
     [ | change (0%nat) with (0+0);
         refine (sig3_ccut _ _ _ H2 Hn2);
        auto; try resolve_rewrite]; resolve_max.

        destruct Hyp as [t Ht];
        try rewrite union_assoc in Ht;
        eexists;
        refine (sig3_plus1 _ Ht); auto; resolve_rewrite.

     (* Plus2 Commutes *)
         simpl_cases2.
         assert (exists m : nat, m |~> 0 ; B; G :: x ++ M2) as Hyp.
         rewrite H1 in H2;
         rewrite meq_swap_cons in H2.
     refine (H0 _ _ _ _ _ _);
     [ | change (0%nat) with (0+0);
         refine (sig3_ccut _ _ _ H2 Hn2);
        auto; try resolve_rewrite]; resolve_max.

        destruct Hyp as [t Ht];
        try rewrite union_assoc in Ht;
        eexists;
        refine (sig3_plus2 _ Ht); auto; resolve_rewrite.

    (* With Commutes *)
         simpl_cases2.
         cut_free.
      assert (exists m, m |~> 0 ; B; F0 :: (x ++ M2)) as Hyp1.
      rewrite H2 in H4;
      rewrite meq_swap_cons in H4;
      refine (H0 _ _ _ _ _ _);
      [ | change (0%nat) with (0+0);
          refine (sig3_ccut _ _ _ H4 Hn2);
          auto; try resolve_rewrite];resolve_max.
          inversion Hh;  resolve_max.

      assert (exists m, m |~> 0 ; B; G :: (x ++ M2)) as Hyp2.
      rewrite H2 in H6; rewrite meq_swap_cons in H6;
      refine (H0 _ _ _ _ _ _);
      [ | change (0%nat) with (0+0);
          refine (sig3_ccut _ _ _ H6 Hn2);
          auto; try resolve_rewrite];resolve_max.
          inversion Hh;  resolve_max.
      destruct Hyp1 as [t1 Ht1];
      destruct Hyp2 as [t2 Ht2];

      eexists;
      refine (sig3_with _ Ht1 Ht2); resolve_rewrite.

      (* Copy Commutes *)
      assert (exists m, m |~> 0 ; B ; F0 :: L) as Hyp.
      rewrite meq_swap_cons in H2.
      rewrite H2 in H4.
       refine (H0 _ _ _ _ _ _);
      [ | change (0%nat) with (0+0);
          refine (sig3_ccut _ _ _ H4 Hn2);
          auto; try resolve_rewrite];resolve_max.

      destruct Hyp as [t Ht];
      eexists;
      refine (sig3_copy _ _ Ht); auto; resolve_rewrite.

      (* Quest Commutes *)
       simpl_cases2.

       assert (exists m, m |~> 0 ; F0 :: B; x ++ M2) as Hyp.
       rewrite H1 in H2.
       eapply height_preserving_weakning_sig3 with (D:=[F0]) in Hn2.
       rewrite <- app_comm_cons in Hn2.
       rewrite union_comm in Hn2.
       refine (H0 _ _ _ _ _ _);
     [ | change (0%nat) with (0+0);
         refine (sig3_ccut _ _ _ H2 Hn2);
         auto; try resolve_rewrite]; resolve_max.
       destruct Hyp as [t Ht];
       eexists;
       refine (sig3_quest _ Ht); auto; resolve_rewrite.

     (* Bang Principal *)
      eapply resolvers2 in H1; intuition.
      rewrite H5 in P, Hn1; clear H5.
      rewrite <- P in *. clear P.
      LexpSubst.
      clear H4.

      inversion Hn2; subst; inversion Hh; try cut_free.
      eexists; eapply sig3_init; eassumption.
      eexists; eapply sig3_one; eassumption.
      eexists; eapply sig3_top; eassumption.
      assert (exists m : nat, m |~> 0; B; M) as Hyp.
      refine (H0 _ _ _ _ _ _);
     [ |
        change (0%nat) with (0+0);
        refine (sig3_ccut _ _ _ Hn1 H4);
        auto]; resolve_max.
     destruct Hyp as [t Ht];
     eexists;
     refine (sig3_bot _ Ht); auto; resolve_rewrite.
      assert (exists m, m |~> 0; B; F0 :: G :: M) as Hyp.
      refine (H0 _ _ _ _ _ _);
     [ |
        change (0%nat) with (0+0);
        refine (sig3_ccut _ _ _ Hn1 H4);
        auto]; resolve_max.
     destruct Hyp as [t Ht];
     eexists;
     refine (sig3_par _ Ht); auto; resolve_rewrite.
      assert (exists m, m |~> 0; B; F0 :: M) as Hyp1.
      refine (H0 _ _ _ _ _ _);
     [ |
        change (0%nat) with (0+0);
        refine (sig3_ccut _ _ _ Hn1 H5);
        auto]; resolve_max.
      assert (exists m, m |~> 0; B; G :: N) as Hyp2.
      refine (H0 _ _ _ _ _ _);
     [ |
        change (0%nat) with (0+0);
        refine (sig3_ccut _ _ _ Hn1 H7);
        auto]; resolve_max.
     destruct Hyp1 as [t1 Ht1];
     destruct Hyp2 as [t2 Ht2];
     eexists;
     refine (sig3_tensor _ Ht1 Ht2); auto; resolve_rewrite.
     assert (exists m, m |~> 0; B; F0 :: M) as Hyp.
      refine (H0 _ _ _ _ _ _);
     [ |
        change (0%nat) with (0+0);
        refine (sig3_ccut _ _ _ Hn1 H4);
        auto]; resolve_max.
     destruct Hyp as [t Ht];
     eexists;
     refine (sig3_plus1 _ Ht); auto; resolve_rewrite.
     assert (exists m, m |~> 0; B; G :: M) as Hyp.
      refine (H0 _ _ _ _ _ _);
     [ |
        change (0%nat) with (0+0);
        refine (sig3_ccut _ _ _ Hn1 H4);
        auto]; resolve_max.
     destruct Hyp as [t Ht];
     eexists;
     refine (sig3_plus2 _ Ht); auto; resolve_rewrite.
      assert (exists m, m |~> 0; B; F0 :: M) as Hyp1.
      refine (H0 _ _ _ _ _ _);
     [ |
        change (0%nat) with (0+0);
        refine (sig3_ccut _ _ _ Hn1 H5);
        auto]; resolve_max.
      assert (exists m, m |~> 0; B; G :: M) as Hyp2.
      refine (H0 _ _ _ _ _ _);
     [ |
        change (0%nat) with (0+0);
        refine (sig3_ccut _ _ _ Hn1 H7);
        auto]; resolve_max.
     destruct Hyp1 as [t1 Ht1];
     destruct Hyp2 as [t2 Ht2];
     eexists;
     refine (sig3_with _ Ht1 Ht2); auto; resolve_rewrite.

     Focus 2.
     assert (exists m, m |~> 0; F0 :: B; M) as Hyp.
     rewrite meq_swap_cons in H4.
     eapply height_preserving_weakning_sig3 with (D:=[F0]) in Hn1.
     rewrite union_comm in Hn1.

      refine (H0 _ _ _ _ _ _);
     [ |
        change (0%nat) with (0+0);
        refine (sig3_ccut _ _ _ Hn1 H4);
        auto]; resolve_max.
     destruct Hyp as [t Ht];
     eexists;
     refine (sig3_quest _ Ht); auto; resolve_rewrite.
     Focus 2.
     assert (exists m, m |~> 0; B; [F0]) as Hyp.
     refine (H0 _ _ _ _ _ _);
     [ |
        change (0%nat) with (0+0);
        refine (sig3_ccut _ _ _ Hn1 H4);
        auto]; resolve_max.
     destruct Hyp as [t Ht];
     eexists;
     refine (sig3_bang _ Ht); auto; resolve_rewrite.

     destruct (FEqDec F0 F°); subst.
    assert (exists m, m |~> 0; B; F° :: L) as Hyp.
     rewrite H4 in H5.
          refine (H0 _ _ _ _ _ _);
     [ | change (0%nat) with (0+0);
         refine (sig3_ccut _ _ _ Hn1 H5);
         auto; resolve_rewrite]; resolve_max.

      destruct Hyp as [t Ht].

     refine (H _ _ _ _ _ _ _);
     [ | change (0%nat) with (0+0)].
     Focus 2.
     refine (sig3_cut _ _ _ H2 Ht); auto.
     inversion Hw.  unfold Lexp_weight; auto.
     apply not_eqLExp_sym in n1.
     simpl_cases2.
     assert (exists m, m |~> 0; B; F0 :: L) as Hyp.
     rewrite H4 in H5.
     refine (H0 _ _ _ _ _ _);
     [ |
        change (0%nat) with (0+0);
        refine (sig3_ccut _ _ _ Hn1 H5);
        auto]; resolve_max.
     destruct Hyp as [t Ht];
     eexists;
     refine (sig3_copy _ _ Ht); auto.

   assert (exists m, m |~> 0; B; Subst FX t :: M) as Hyp.
      refine (H0 _ _ _ _ _ _);
     [ |
        change (0%nat) with (0+0);
        refine (sig3_ccut _ _ _ Hn1 H4);
        auto]; resolve_max.
     destruct Hyp as [p Hp];
     eexists;
     refine (sig3_ex _ Hp); auto; resolve_rewrite.

   assert (forall y : Term, exists m, m |~> 0; B; Subst FX y :: M) as Hyp.
   intro.
   assert (n0 |~> 0; F° :: B; Subst FX y :: M) by auto.
      refine (H0 _ _ _ _ _ _);
     [ |
        change (0%nat) with (0+0);
        refine (sig3_ccut _ _ _ Hn1 H5);
        auto]; resolve_max.
     apply fx_swap_sig3h in Hyp.
     destruct Hyp as [p Hp];
     eexists;
     refine (sig3_fx _ Hp); auto; resolve_rewrite.

     simpl_cases2.
 assert (exists m, m |~> 0; B; Subst FX t :: (x++M2)) as Hyp.
 rewrite H1 in H2.
 rewrite meq_swap_cons in H2.
      refine (H0 _ _ _ _ _ _);
     [ |
        change (0%nat) with (0+0);
        refine (sig3_ccut _ _ _ H2 Hn2) ;
        auto]; resolve_max.
     destruct Hyp as [p Hp];
     eexists;
     refine (sig3_ex _ Hp); auto; resolve_rewrite.

     simpl_cases2.
    assert (forall y : Term, exists m, m |~> 0; B; Subst FX y :: (x++M2)) as Hyp.
   intro.
   assert (n |~> 0; B; Subst FX y :: M) by auto.
 rewrite H1 in H5.
 rewrite meq_swap_cons in H5.
      refine (H0 _ _ _ _ _ _);
     [ |
        change (0%nat) with (0+0);
        refine (sig3_ccut _ _ _ H5 Hn2) ;
        auto]; resolve_max.
     apply fx_swap_sig3h in Hyp.
     destruct Hyp as [p Hp];
     eexists;
     refine (sig3_fx _ Hp); auto; resolve_rewrite.
Qed.

Theorem cut_elimination : forall B L n c, n |~> c ; B ; L ->
          exists m, m |~> 0 ; B ; L.
Proof.
  intros.
  dependent induction n generalizing B L using strongind; induction c using strongind.
  + (* Case <0,0> *)
    eexists; eauto.
  + (* Case <0, S c> *)
    inversion H.
  + (* case <Sn, 0> *)
    inversion H0;subst;try (rewrite H2).
    ++ (* BOTTOM*) eexists. eapply sig3_bot;eauto.
    ++ (* PAR *)  eexists. eapply sig3_par;eauto.
    ++ (* TENSOR *)
       cut_free.
       eexists.
       change (0%nat) with (0+0).
       eapply sig3_tensor;eauto.
    ++ (* OPLUS F *)  eexists. eapply sig3_plus1; eauto.
    ++ (* OPLUS G *)  eexists. eapply sig3_plus2; eauto.
    ++ (* WITH *)
       cut_free.
       eexists.
       change (0%nat) with (0+0).
       eapply sig3_with;eauto.
    ++ (* COPY *) eexists. eapply sig3_copy; eauto.
    ++ (* QUEST *) eexists. eapply sig3_quest; eauto.
    ++ (* BANG *) eexists. eapply sig3_bang; eauto.
    ++ (* EX *) eexists. eapply sig3_ex; eauto.
    ++ (* FX *) eexists. eapply sig3_fx; eauto.
  + (* Case <Sn, Sc> *)
    rename H1 into IHn.

    inversion H0;subst.
    ++   (* bottom *)
      apply H in H3; auto. destruct H3.
      eexists.
      eapply sig3_bot; eauto.

    ++   (* PAR *)
      apply H in H3;auto.  destruct H3.
      eexists.
      eapply sig3_par; eauto.

      ++
        (* TENSOR *)
        apply H in H4;auto. destruct H4.
        apply H in H5;auto. destruct H5.
        change (0%nat) with (0+0).
        eexists.
        eapply sig3_tensor;eauto.
      ++ (* PLUS1 *)
        apply H in H3;auto.  destruct H3.
        eexists.
        eapply sig3_plus1; eauto.

      ++ (* PLUS2 *)
        apply H in H3;auto.  destruct H3.
        eexists.
        eapply sig3_plus2; eauto.

      ++ (* WITH *)
        apply H in H4;auto.  destruct H4.
        apply H in H5;auto.  destruct H5.

        change (0%nat) with (0+0).
        eexists.
        eapply sig3_with;eauto.
      ++ (* copy *)
        apply H in H4;auto.  destruct H4.
        eexists.
        eapply sig3_copy; eauto.
      ++  (* quest *)
        apply H in H3;auto.  destruct H3.
        eexists.
        eapply sig3_quest;eauto.
      ++ (* bang *)
        apply H in H3;auto.  destruct H3.
        eexists.
        eapply sig3_bang; eauto.
      ++ (* ex *)
        apply H in H3;auto.  destruct H3.
        eexists.
        eapply sig3_ex; eauto.
      ++ (* fx *)
        assert (forall y : Term, exists m, m |~> 0; B; Subst FX y :: M) as Hyp.
       intro.
       assert (n |~> S c; B; Subst FX y :: M) by auto.
       eapply H; auto.
         apply fx_swap_sig3h in Hyp.
         destruct Hyp as [p Hp].
         eexists.
      eapply sig3_fx;eauto.
      ++ (* CUT *)
      destruct H3.
      --
      apply H in H4;auto. destruct H4.
      apply H in H5;auto. destruct H5.

      assert(Hc: S(Init.Nat.max x0 x) |~> S(0 + 0) ; B ; L).
      eapply sig3_CUT.
      eapply  sig3_cut;eauto.

      apply cut_elimination_base in Hc.
      destruct Hc.
      eexists. eauto.
      --
     (* CCUT *)
      apply H in H4;auto. destruct H4.
      apply H in H5;auto. destruct H5.

      assert(Hc: S(Init.Nat.max x0 x) |~> S(0 + 0) ; B ; L).
      eapply sig3_CUT.
      eapply  sig3_ccut;eauto.

      apply cut_elimination_base in Hc.
      destruct Hc.
      eexists; eauto.
Qed.

Theorem weak_consistency : forall n c, ~ sig3 n c [] [0].
Proof.
  intros.
  intro.
  apply cut_elimination in H.
  destruct H.
  inversion H; subst;
  try simpl_cases0.
  eapply DestructMulFalse; eauto.
Qed.

Lemma strong_cons : forall n c, ~ sig3 n c [] [].
Proof.
  intros.
  intro.
  apply cut_elimination in H.
  destruct H.
  inversion H; subst;
  try solve [eapply DestructMulFalse; eauto].
Qed.

Theorem strong_consistency : forall n c, ~ sig3 n c [] [Bot].
Proof.
  intros.
  intro.
  apply cut_elimination in H.
  destruct H.
  inversion H; subst;
  try simpl_cases0.
  rewrite Hm in H1.
  eapply strong_cons; eauto.
  eapply DestructMulFalse; eauto.
Qed.


(** * FixPoint.v *)

From Babel Require Import TerminalDogma
                          ExtraDogma.Extensionality
                          SetFacility.

From Babel Require Export POrder.

From Babel Require Import Ranko.POrderCharacter.

From Coq Require Import Relations Arith.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(* the definition of a fixpoint *)
Definition fp (T : poset) (f : T -> T) (x : T) : Prop := f x = x.

(* set of fixpoints *)
Definition fp_s (T : poset) (f : T -> T) : 𝒫(T) := { x | fp f x }.

(* pre-fixpoint *)
Definition pre_fp (T : poset) (f : T -> T) (x : T) : Prop := x ⊑ f x.

(* pre-fixpoint set *)
Definition pre_fp_s (T : poset) (f : T -> T) : 𝒫(T) := { x | pre_fp f x }.

(* post-fixpoint *)
Definition post_fp (T : poset) (f : T -> T) (x : T) : Prop := f x ⊑ x.

(* post-fixpoint set *)
Definition post_fp_s (T : poset) (f : T -> T) : 𝒫(T) := { x | post_fp f x }.

(* fp_in_pre_fp : fp_s f ⊆ pre_fp_s f *)
Lemma fp_in_pre_fp (T : poset) : forall f : T -> T, fp_s f ⊆ pre_fp_s f.
Proof.
    rewrite /subset /fp_s /fp /pre_fp_s /pre_fp => //= f x ->.
    by reflexivity.
Qed.

(* fp_in_post_fp : fp_s f ⊆ post_fp_s f *)
Lemma fp_in_post_fp (T : poset) : forall f : T -> T, fp_s f ⊆ post_fp_s f.
Proof.
    have Hdual := @fp_in_pre_fp (T †po).
    by apply Hdual.
Qed.

(* a is the least fixpoint of f greater than x *)
Definition lfp_x (T : poset) (f : T -> T) (x a : T) :=
    least ({ y | y ∈ fp_s f /\ x ⊑ y }) a.

(* a is the least fixpoint of f *)
Definition lfp (T : poset) (f : T -> T) (a : T) :=
    least (fp_s f) a.

(* a is the greatest fixpoint of f smaller than x *)
Definition gfp_x (T : poset) (f : T -> T) (x a : T) :=
    largest ({ y | y ∈ fp_s f /\ y ⊑ x }) a.

(* a is the greatest fixpoint of f *)
Definition gfp (T : poset) (f : T -> T) (a : T) :=
    largest (fp_s f) a.

Lemma monofun_power_chain_mixin (T : cpo) (f : [T ↦ᵐ T]) (s : 𝒫(nat)):
        Chain.mixin_of ((fun_power f) [<] s [>] (⊔ᶜᵖᵒ (set_em T))).
Proof.
    rewrite /Chain.mixin_of. porder_level.
    clear - f.
    case E: (x1 <= x3).
    - left.
Admitted.

Canonical monofun_power_chain (T : cpo) (f : [T ↦ᵐ T]) (s : 𝒫(nat)) : chain T
    := Chain ((fun_power f) [<] s [>] (⊔ᶜᵖᵒ (set_em T)))
            (@monofun_power_chain_mixin T f s).

Definition KleeneFp (T : cpo) (f : [T ↦ T]) : T :=
    ⊔ᶜᵖᵒ ((fun_power f) [<] 𝕌 [>] (⊔ᶜᵖᵒ (set_em T))).

Axiom KleeneTheorem :
    forall (T : cpo) (f : [T ↦ T]), lfp f (KleeneFp f).


Require Import List.

Print length.

Inductive begaie {A: Type} : list A -> Prop :=
| Bnil : begaie nil
| Bcc : forall x l, begaie l -> begaie (x :: x :: l).

Fixpoint echanges {A: Type} (l : list A) : list A :=
    match l with
    | x :: y :: r => y :: x :: echanges r
    | _ => l
    end.

Search (length (_ ++ _)).

Theorem beg_ech_invar : forall A (l: list A), begaie l -> echanges l = l.
Proof.
intros A l bl.
induction bl.
-simpl. trivial.
-simpl.
 rewrite IHbl.
 trivial.
Qed.

Inductive pair : nat -> Prop :=
| P0 : pair 0
| P2 : forall n, pair n -> pair (S (S n)).

Theorem nbp : forall A (l: list A), begaie l -> pair (length l).
Proof.
intros A l hbl.
induction hbl.
simpl. apply P0.
simpl. apply P2.
simpl. apply IHhbl.
Qed.

Inductive begloin  {A: Type} : list A -> Prop :=
| Blnil : begloin nil
| Blca : forall x u v, begloin (u ++ v) -> begloin (x :: u ++ x :: v).

Theorem nblp : forall A (l: list A), begloin l -> pair (length l).
Proof.
  intros.
  induction H.
  simpl. apply P0.
  simpl. rewrite app_length.
  simpl. rewrite PeanoNat.Nat.add_succ_r.
  simpl. apply P2.
  simpl. rewrite <- app_length.
  simpl. apply IHbegloin.
Qed.

Inductive begloin'  {A: Type} : list A -> Prop :=
| Blnil' : begloin' nil
| Blca' : forall x u v w, begloin' (u ++ v ++ w) -> begloin' (u ++ x :: v ++ x :: w).

Theorem nblp' : forall A (l: list A), begloin' l -> pair (length l).
  intros.
  induction H.
  simpl. apply P0.
  simpl. rewrite app_length.
  simpl. rewrite app_length.
  simpl. rewrite PeanoNat.Nat.add_succ_r.
  rewrite PeanoNat.Nat.add_succ_r.
  rewrite PeanoNat.Nat.add_succ_r.
  apply P2.
  rewrite <- app_length.
  rewrite <- app_length.
  apply IHbegloin'.
  Qed.


Require Import Coq.ZArith.BinInt.
Require Import riscv.Utility.Encode.
Require Import coqutil.Z.BitOps.
Require Import coqutil.Z.prove_Zeq_bitwise.

Lemma invert_encode_SB: forall {opcode rs1 rs2 funct3 sbimm12},
  verify_SB opcode rs1 rs2 funct3 sbimm12 ->
  forall inst,
  encode_SB opcode rs1 rs2 funct3 sbimm12 = inst ->
  opcode = bitSlice inst 0 7 /\
  funct3 = bitSlice inst 12 15 /\
  rs1 = bitSlice inst 15 20 /\
  rs2 = bitSlice inst 20 25 /\
  sbimm12 = signExtend 13 (Z.shiftl (bitSlice inst 31 32) 12 <|>
                           Z.shiftl (bitSlice inst 25 31) 5 <|>
                           Z.shiftl (bitSlice inst 8 12) 1  <|>
                           Z.shiftl (bitSlice inst 7 8) 11).
Proof. intros. unfold encode_SB, verify_SB in *. prove_Zeq_bitwise. Qed.


Require Import Metalib.Metatheory.
Require Import LibTactics.
Require Import syntax_ott
               rules_inf.
Require Import Omega.

Lemma sub_inversion_arrow : forall A1 A2 B1 B2,
    sub (t_arrow A1 A2) (t_arrow B1 B2) -> sub B1 A1 /\ sub A2 B2.
Proof.
  intros.
  inversion H.
  subst.
  auto.
Qed.

Lemma sub_reflexivity : forall A,
    sub A A.
Proof.
  intros A.
  induction* A.
Qed.

Lemma sub_transtivity_aux : forall i,
    forall A B C,
      size_typ A + size_typ B + size_typ C = i ->
      sub A B -> sub B C -> sub A C.
Proof.
  intros i. pattern i. apply lt_wf_rec.
  clear i; intros i H.
  intros A B C He S1.
  lets S1':S1.
  gen H C.
  induction* S1;
    intros H C Hs S2.
  - (* B:=t_top *)
    remember t_top.
    gen i.
    induction* S2;
      try solve [inverts Heqt].
    intros i H Hs.
    constructor;
      eapply_first_lt_hyp;
      eauto;
      default_simp;
      omega.
  - (* arr *)
    remember (t_arrow B1 B2).
    lets S2': S2.
    gen i.
    induction S2;
      intros;
      inverts* Heqt.
    + apply S_arr;
      eapply_first_lt_hyp;
        eauto;
        default_simp;
        omega.
    + constructor;
        eapply_first_lt_hyp;
        eauto;
        default_simp;
        omega.
  - (* andl1 *)
    apply S_andl1.
      eapply_first_lt_hyp;
        eauto;
        default_simp;
        omega.
  - (* andl2 *)
    apply S_andl2.
      eapply_first_lt_hyp;
        eauto;
        default_simp;
        omega.
  - (* andr *)
    remember (t_and A2 A3).
    lets S2': S2.
    gen i.
    induction S2;
      intros;
      inverts* Heqt.
    + forwards: H S1_1 S2;
        eauto;
        default_simp;
        omega.
    + forwards: H S1_2 S2;
        eauto;
        default_simp;
        omega.
    + constructor;
      eapply_first_lt_hyp;
        eauto;
        default_simp;
        omega.
Qed.

Lemma sub_transtivity : forall A B C,
    sub A B -> sub B C -> sub A C.
Proof.
  intros A B C.
  pose proof (sub_transtivity_aux).
  intuition eauto.
Qed.

Ltac auto_sub :=
  try match goal with
      | [ |- sub ?A ?A ] => apply sub_reflexivity
      | [ |- sub (t_and ?A ?B) ?A ] => (apply~ S_andl1; auto_sub)
      | [ |- sub (t_and ?A ?B) ?B ] => (apply~ S_andl2; auto_sub)
      | [ H: sub ?A ?C |- sub (t_and ?A ?B) ?C ] => apply~ S_andl1
      | [ H: sub ?B ?C |- sub (t_and ?A ?B) ?C ] => apply~ S_andl2
      | [ H: sub ?A (t_and ?B ?C) |- sub ?A ?B ] => (
        eapply sub_transtivity;
        try apply H;
        try apply S_andl1;
        try apply sub_reflexivity)
      | [ H: sub ?A (t_and ?B ?C) |- sub ?A ?C ] => (
        try eapply sub_transtivity;
        try apply H;
        try apply S_andl2;
        try apply sub_reflexivity)
      | [ H: sub (t_arrow _ _) (t_arrow _ _) |- sub _ _ ] => (inverts H; auto_sub)
      | [ H1: sub ?A ?B, H2: sub ?B ?C |- sub ?A ?C ] => forwards*: sub_transtivity H1 H2
      | [ H1: sub ?A ?B, H2: sub ?B ?C |- sub ?A ?C ] => forwards*: sub_transtivity H1 H2
    | |- _ => try constructor*
      end.