(**********************************************************************************
 * PredomCore.v                                                                   *
 * Formalizing Domains, Ultrametric Spaces and Semantics of Programming Languages *
 * Nick Benton, Lars Birkedal, Andrew Kennedy and Carsten Varming                 *
 * July 2010                                                                      *
 * Build with Coq 8.2pl1 plus SSREFLECT                                           *
 **********************************************************************************)

Require Export ssreflect ssrnat ssrbool eqtype.
Set Automatic Coercions Import.
Require Export Categories.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Unset Automatic Introduction.

(** printing -c> %\cont% *)
(** printing -m> %\mon% *)

(** %\include{macros}% *)

(** printing O1 %\ensuremath{O_1}% *)
(** printing O2 %\ensuremath{O_2}% *)
(** printing O3 %\ensuremath{O_3}% *)
(** printing O4 %\ensuremath{O_4}% *)
(** printing D1 %\ensuremath{D_1}% *)
(** printing D2 %\ensuremath{D_2}% *)
(** printing D3 %\ensuremath{D_3}% *)
(** printing x1 %\ensuremath{x_1}% *)
(** printing x2 %\ensuremath{x_2}% *)
(** printing x3 %\ensuremath{x_3}% *)
(** printing y1 %\ensuremath{y_1}% *)
(** printing y2 %\ensuremath{y_2}% *)
(** printing y3 %\ensuremath{y_3}% *)
(** printing p1 %\ensuremath{p_1}% *)
(** printing p2 %\ensuremath{p_2}% *)
(** printing p3 %\ensuremath{p_3}% *)

(** printing natO %\natO% *)
(** printing nat %\nat% *)
(** printing lub %\lub% *)
(** printing cpo %\cpo% *)
(** printing ord %\ord% *)

(** ** Ordered type *)

(*=Ole *)
Module PreOrd.
  Definition axiom T (Ole : T -> T -> Prop) :=
    forall x , Ole x x /\ forall y z, (Ole x y -> Ole y z -> Ole x z).
  Record mixin_of T := Mixin {Ole : T -> T -> Prop; _ : axiom Ole}.
  Notation class_of := mixin_of (only parsing).
  Lemma setAxiom T (c:mixin_of T):Setoid.axiom (fun x y =>  Ole c x y /\ Ole c y x). (*CLEAR*)
Proof.
move => T.
case => le A. split ; last split.
- move => x. by split ; apply (proj1 (A x)).
- move => x y z. simpl. case => l0 l1. case => l2 l3.
  by split ; [apply (proj2 (A x) y z l0 l2) | apply (proj2 (A z) y x l3 l1)].
- move => x y. simpl. case => l0 l1. by split.
Qed.

(*CLEARED*)  Coercion base2 T (c:class_of T) : Setoid.class_of T := Setoid.Mixin (setAxiom c).
  Structure type := Pack {sort :> Type; _ : class_of sort; _ : Type}.
  Definition class cT := let: Pack _ c _ := cT return class_of cT in c. (*CLEAR*)
  Definition unpack K (k : forall T (c : class_of T), K T c) cT :=
    let: Pack T c _ := cT return K _ (class cT) in k _ c.
  Definition repack cT : _ -> Type -> type := let k T c p := p c in unpack k cT.
  Definition pack T c := @Pack T c T.
(* Definition pack T c := @Pack T (Class c) T. *)
 (*CLEARED*)
  Coercion setoidType (cT:type) := Setoid.Pack (class cT) cT.
End PreOrd.
Notation ordType := PreOrd.type.
Notation OrdMixin := PreOrd.Mixin.
Notation OrdType := PreOrd.pack.
Canonical Structure PreOrd.setoidType.
(*=End *)

Definition Ole := (fun (O:ordType) => PreOrd.Ole (PreOrd.class O)).
Implicit Arguments Ole [O].

Lemma Ole_refl (O:ordType) (x:O) : Ole x x.
unfold Ole. case. simpl. move => O. case.
move => le A _ x. by apply (proj1 (A x)).
Qed.

Lemma Ole_trans (O:ordType) (x y z:O) : Ole x y -> Ole y z -> Ole x z.
case. simpl. move => O. case.
move => le A T x y z L L'.
by apply (proj2 (A x) y z L L').
Qed.

Hint Resolve Ole_refl Ole_trans.

(*Hint Extern 2  (Ole (o:=?X1) ?X2 ?X3 ) => simpl Ole.*)

Bind Scope O_scope with PreOrd.sort.
Delimit Scope O_scope with PreOrd.

(** printing <= %\ensuremath{\sqsubseteq}% *)
Infix "<=" := Ole : O_scope.
Open Scope O_scope.

Arguments Scope Ole [O_scope _ _].

(*=Pointed *)
Module Pointed.
  Definition axiom (T:ordType) (l:T) := forall x, l <= x.
  Record mixin_of (T:ordType) := Mixin {least_elem : T; _ : axiom least_elem}. (*CLEAR*)

  Lemma leastP (T:ordType) (X:mixin_of T) : forall x, (least_elem X) <= x.
  move => T; case. simpl. move => l A x. by apply A.
  Qed.
  (*CLEARED*)
  Record class_of T := Class
   { base :> PreOrd.class_of T; ext :> mixin_of (PreOrd.Pack base T)}. (*CLEAR*)

  Structure type := Pack {sort :> Type; _ : class_of sort; _ : Type}.
  Definition class cT := let: Pack _ c _ := cT return class_of cT in c.
  Definition unpack K (k : forall T (c : class_of T), K T c) cT :=
    let: Pack T c _ := cT return K _ (class cT) in k _ c.
  Definition repack cT : _ -> Type -> type := let k T c p := p c in unpack k cT.
  Definition pack := let k T c m := Pack (@Class T c m) T in PreOrd.unpack k.
  (*CLEARED*)
  Coercion ordType cT := PreOrd.Pack (class cT) cT.
  Definition setoidType cT := Setoid.Pack (class cT) cT.
  Definition least cT := least_elem (class cT). (*CLEAR*)
  Implicit Arguments least [cT].
(*CLEARED*)
End Pointed. (*CLEAR*)

Notation pointedType := Pointed.type.
Notation PointedMixin := Pointed.Mixin.
Notation PointedType := Pointed.pack.
(*CLEARED*)
Notation PBot := Pointed.least.
Canonical Structure Pointed.ordType.
Canonical Structure Pointed.setoidType.
Lemma leastP (O:pointedType) (x:O) : PBot <= x. (*CLEAR*)
move => O x. by apply Pointed.leastP.
Qed.
(*CLEARED*)
(*=End *)

Lemma discrete_ordAxiom T : PreOrd.axiom (fun (x y : T) => x = y).
move => T a. split ; first by [].
by move => y z ; apply trans_eq.
Qed.

Canonical Structure discrete_ordMixin T := OrdMixin (@discrete_ordAxiom T).
Definition discrete_ordType T := Eval hnf in OrdType (discrete_ordMixin T).

Lemma Ole_refl_eq : forall  (O:ordType) (x y:O), x = y -> x <= y.
intros O x y H; rewrite H; auto.
Save.

Hint Resolve Ole_refl_eq.

Lemma Ole_antisym : forall (O:ordType) (x y:O), x <= y -> y <= x -> x =-= y.
unfold Ole. unfold tset_eq. simpl.
case. move => T. case. simpl. move => X Y x y l0 l1. by split.
Save.
Hint Immediate Ole_antisym.

Definition Oeq_refl (O:ordType) := @tset_refl O.

Hint Resolve Oeq_refl.

Lemma Oeq_refl_eq : forall (O:ordType) (x y:O), x=y -> x =-= y.
intros O x y H; rewrite H; auto.
Save.
Hint Resolve Oeq_refl_eq.

Lemma Oeq_sym : forall (O:ordType) (x y:O), x =-= y -> y =-= x.
move => O x y X. by apply: tset_sym.
Save.

Lemma Oeq_le : forall (O:ordType) (x y:O), x =-= y -> x <= y.
move => O. move => x y. case. move => A B. by apply A.
Save.

Lemma Oeq_le_sym : forall (O:ordType) (x y:O), x =-= y -> y <= x.
move => O. move => x y. case. move => A B. by apply B.
Save.

Hint Resolve Oeq_le.
Hint Immediate Oeq_sym Oeq_le_sym.

Lemma Oeq_trans : forall (O:ordType) (x y z:O), x =-= y -> y =-= z -> x =-= z.
move => O. apply (@tset_trans O).
Save.
Hint Resolve Oeq_trans.

(** *** Setoid relations *)

Add Parametric Relation (O:ordType) : O (@tset_eq O : O -> O -> Prop)
       reflexivity proved by (@Oeq_refl O) symmetry proved by (@Oeq_sym O)
       transitivity proved by (@Oeq_trans O) as Oeq_Relation.

Add Parametric Relation (O:ordType) : O (@Ole O)
       reflexivity proved by (@Ole_refl O)
       transitivity proved by (@Ole_trans O) as Ole_Relation.

Instance Oeq_sub_ord_morpoh_eq (D:ordType) : subrelation (@tset_eq D : D -> D -> Prop) (@Ole D).
move => D d d' x. by apply (proj1 x).
Qed.

Add Parametric Morphism (O:ordType) : (@Ole O)
 with signature (@tset_eq O : O -> O -> Prop) ==> (@tset_eq O : O -> O -> Prop) ==> iff as Ole_eq_compat_iff.
split; intuition.
apply Ole_trans with x; firstorder using Ole_trans.
apply Ole_trans with y.
firstorder.
apply Ole_trans with y0.
assumption.
intuition.
Save.

Lemma Ole_eq_compat :
     forall (O : ordType) (x1 x2 : O),
       x1 =-= x2 -> forall x3 x4 : O, x3 =-= x4 -> x1 <= x3 -> x2 <= x4.
move => O x1 x2 e x3 x4 e'. rewrite -> e. by rewrite -> e'.
Save.

Lemma Ole_eq_right : forall (O : ordType) (x y z: O),
             x <= y -> y =-= z -> x <= z.
move => O x y z l e. rewrite l. by rewrite e.
Save.

Lemma Ole_eq_left : forall (O : ordType) (x y z: O),
             x =-= y -> y <= z -> x <= z.
move => O x y z e l. rewrite e. by rewrite l.
Save.

(** ** Monotonicity *)

(** *** Definition and properties *)

(*=monotonic *)
Definition monotonic (O1 O2 : ordType) (f : O1->O2) := forall x y, x <= y -> f x <= f y.
Module FMon. Section fmon.
 Variable O1 O2 : ordType.
 Record mixin_of (f:O1 -> O2) := Mixin { ext :> monotonic f}. (*CLEAR*)
 Notation class_of := mixin_of (only parsing).
(*CLEARED*)
 Structure type : Type := Pack {sort :> O1 -> O2; _ : class_of sort; _ : O1 -> O2}. (*CLEAR*)
 Definition class cT := let: Pack _ c _ := cT return class_of cT in c.
 Definition unpack K (k : forall T (c : class_of T), K T c) cT :=
   let: Pack T c _ := cT return K _ (class cT) in k _ c.
 Definition repack cT : _ -> Type -> type := let k T c p := p c in unpack k cT.
 Definition pack f (c:class_of f) := @Pack f c f.
(*CLEARED*)End fmon. End FMon.
Notation fmono := FMon.type. (*CLEAR*)
Notation fmonoMixin := FMon.Mixin.
Notation fmonoType := FMon.pack. (*CLEARED*)
(*=End *)

Lemma fmonotonic O1 O2 (f:fmono O1 O2) : monotonic f.
move => O1 O2. case. simpl. move => f. by case.
Qed.

Hint Resolve fmonotonic.
Hint Unfold monotonic.

Definition stable (O1 O2:ordType) (f : O1 -> O2) := forall x y, x =-= y -> f x =-= f y.
Hint Unfold stable.

Lemma monotonic_stable : forall (O1 O2 : ordType) (f:O1 -> O2),
             monotonic f -> stable f.
unfold monotonic, stable. move => O0 O1 f X x y e. split ; apply X ; by case e.
Save.
Hint Resolve monotonic_stable.

(*=fmonoOrd *)
Lemma fmono_axiom (O1 O2:ordType) :
    PreOrd.axiom (fun f g:fmono O1 O2 => forall x, f x <= g x). (*CLEAR*)
Proof.
move => O1 O2 x. split ; first by [].
move => y z L L' e ; by apply (Ole_trans (L e) (L' e)).
Qed.
(*CLEARED*)
Canonical Structure fmono_ordMixin (T T':ordType) := OrdMixin (@fmono_axiom T T').
Canonical Structure fmono_ordType T T' :=
                              Eval hnf in OrdType (fmono_ordMixin T T').
(*=End *)

(* fmon <= *)
Definition fmon_less (A B: ordType): relation (fmono A B) := (@Ole (@fmono_ordType A B)).

Lemma fmon_less_preorder (A B: ordType): PreOrder (@fmon_less A B).
intros. split. red; intros. by apply Ole_refl.
red; intros x y z. by apply Ole_trans.
Qed.

Existing Instance fmon_less_preorder.

Add Parametric Morphism (A B : ordType) :
  (@FMon.sort A B) with signature (@fmon_less A B ==> @Ole A ==> @Ole B)
 as fmon_le_compat.
intros. apply Ole_trans with (y x0) ; first by auto.
by apply (fmonotonic y).
Qed.

(* fmon == *)
Definition fmon_equal (A B: ordType): relation (fmono A B) := (@tset_eq (@fmono_ordType A B)).

Lemma fmon_equal_equivalence (A B: ordType): Equivalence (@fmon_equal A B).
intros. split. intros x. by apply Oeq_refl.
intros x y E. split ; first by apply (Oeq_sym E). by apply E.
intros x y z E0 E1. by apply (Oeq_trans E0 E1).
Qed.

Existing Instance fmon_equal_equivalence.

Add Parametric Morphism (A B : ordType) :
  (@FMon.sort A B) with signature (@fmon_equal A B ==> @tset_eq A ==> @tset_eq B)
 as fmon_eq_compat.
move => f g fg x y xy. apply Oeq_trans with (g x) ; first by split ; [apply (proj1 fg) | apply (proj2 fg)].
by apply (monotonic_stable (fmonotonic g)).
Qed.

Lemma id_mon (O:ordType) : @monotonic O O id.
by move => O x y.
Qed.

Definition oidM (O:ordType) := fmonoMixin (@id_mon O).
Definition oid (O:ordType) := Eval hnf in  FMon.pack (oidM O).

Lemma ordMorphSetoidAxiom (O0 O1:ordType) : @Setoid.axiom (fmono O0 O1) (@tset_eq (fmono_ordType O0 O1)).
move => O1 O2. split ; first by []. split.
- by apply: Oeq_trans.
- by apply: Oeq_sym.
Qed.

Canonical Structure ordMorphSetoidMixin O0 O1 := SetoidMixin (ordMorphSetoidAxiom O0 O1).
Canonical Structure ordMorphSetoidType O0 O1 := Eval hnf in SetoidType (ordMorphSetoidMixin O0 O1).

Lemma comp_mon (O1 O2 O3:ordType) (f:fmono O2 O3) (g:fmono O1 O2) : monotonic (fun x => f (g x)).
move => O1 O2 O3 f g x y l.
by do 2 apply fmonotonic.
Qed.

Definition ocompM (O1 O2 O3:ordType) (f:fmono O2 O3) (g:fmono O1 O2) := fmonoMixin (comp_mon f g).
Definition ocomp (O1 O2 O3:ordType) (f:fmono O2 O3) (g:fmono O1 O2) := Eval hnf in fmonoType (ocompM f g).

Lemma ordCatAxiom : Category.axiom ocomp oid.
split ; first by move => O0 O1 f ; split.
split ; first by move => O0 O1 f ; split.
split ; first by move => O0 O1 O2 O3 f g h ; split.
move => O0 O1 O2 f f' g g' e e' ; split => x ; apply Ole_trans with (y:=f (g' x)).
- simpl. apply fmonotonic. by apply (proj1 e').
- simpl. by apply (proj1 e).
- simpl. by apply (proj2 e).
- simpl. apply fmonotonic. by apply (proj2 e').
Qed.

Canonical Structure ordCatMixin := CatMixin ordCatAxiom.
Canonical Structure ordCatType := Eval hnf in CatType ordCatMixin.

Open Scope C_scope.

Lemma fmon_stable : forall (O1 O2 : ordType) (f:O1 =-> O2), stable f.
intros; apply monotonic_stable; auto.
Save.
Hint Resolve fmon_stable.

Definition mk_fmonoM (O1 O2:ordType) (f:O1 -> O2) (m:monotonic f) := fmonoMixin m.
Definition mk_fmono (O1 O2:ordType) (f:O1 -> O2) (m:monotonic f) : fmono O1 O2 := Eval hnf in fmonoType (mk_fmonoM m).

Section ordCatProd.

Variable O1 O2 : ordType.

Lemma prod_ord_axiom : PreOrd.axiom (fun x y :O1 * O2 => fst x <= fst y /\ snd x <= snd y).
move => x ; split ; clear ; first by case: x.
move => y z. case: x => x0 x1. case: y => y0 y1. case: z => z0 z1. simpl. move => [A B] [C D].
split ; by [apply Ole_trans with y0 | apply Ole_trans with y1].
Qed.

Canonical Structure prod_ordMixin := OrdMixin prod_ord_axiom.
Canonical Structure prod_ordType := Eval hnf in OrdType prod_ordMixin.

Lemma fst_mon : monotonic (@fst O1 O2).
case => x1 x2. case => y1 y2. by case => X Y.
Qed.

Definition Fst := Eval hnf in mk_fmono fst_mon.

Lemma snd_mon : monotonic (@snd O1 O2).
case => x1 x2. case => y1 y2. by case => X Y.
Qed.

Definition Snd := Eval hnf in mk_fmono snd_mon.

Lemma Prod_fun_mono Z (f:Z =-> O1) (g:Z =-> O2) : monotonic (fun p => (f p, g p)).
move => Z f g x y l. by split ; apply fmonotonic.
Qed.

Definition Prod_fun Z (f:Z =-> O1) (g:Z =-> O2) := Eval hnf in mk_fmono (Prod_fun_mono f g).

End ordCatProd.

Lemma fmon_eq_intro : forall (O1 O2:ordType) (f g:O1 =-> O2), (forall n, f n =-= g n) -> f =-= g.
move => O0 O1 f g X. split => x. by apply (proj1 (X x)).  by apply (proj2 (X x)).
Save.
Hint Resolve fmon_eq_intro.

Lemma fmon_eq_elim : forall (O1 O2:ordType) (f g:O1 =-> O2), f =-= g ->forall n, f n =-= g n.
move => O1 O2 f g e n. split ; by [apply (proj1 e) | apply (proj2 e)].
Save.
Hint Immediate fmon_eq_elim.

Lemma ordProdCatAxiom : @CatProduct.axiom _ prod_ordType (@Fst) (@Snd) Prod_fun.
move => O0 O1 O2 f g. split. split ; by apply: fmon_eq_intro.
move => h [X Y]. apply: fmon_eq_intro => x. have X':=fmon_eq_elim X x. have Y':=fmon_eq_elim Y x.
simpl in X', Y'. by split ; destruct X'; destruct Y'.
Qed.

Canonical Structure ordProdCatMixin := prodCatMixin ordProdCatAxiom.
Canonical Structure ordProdCatType := Eval hnf in prodCatType ordProdCatMixin.

Add Parametric Morphism (O0 O1:ordType) : (@pair O0 O1)
 with signature (@Ole O0) ++> (@Ole O1) ++> (@Ole (O0 * O1))
 as pair_le_compat.
move => x y e x' y' e'. by split.
Qed.

Add Parametric Morphism (O0 O1:ordType) : (@pair O0 O1)
 with signature (@tset_eq O0 : O0 -> O0 -> Prop) ==> (@tset_eq O1 : O1 -> O1 -> Prop) ==> (@tset_eq (O0 * O1))
 as pair_eq_compat.
move => x y e x' y' e'. split. by rewrite -> e ; rewrite -> e'.
by rewrite <- e ; rewrite <- e'.
Qed.

Lemma pair1_mon (O0 O1 : ordType) (x:O0) : monotonic (fun (y:O1) => (x,y)).
move => O0 O1 x y y' l. by rewrite -> l.
Qed.

Definition Pair (O0 O1 : ordType) (x:O0) : O1 =-> (O0 * O1) := Eval hnf in mk_fmono (pair1_mon x).

Lemma Curry_mono (O0 O1 O2 : ordType) (f:O0 * O1 =-> O2) : monotonic (fun x => f << Pair _ x).
move => O1 O2 O3 f x x' L y. simpl. by apply fmonotonic.
Qed.

Definition Curry (O0 O1 O2 : ordType) (f:O0 * O1 =-> O2) : O0 =-> fmono_ordType O1 O2 :=
            Eval hnf in mk_fmono (Curry_mono f).

Lemma Ev_mon O0 O1 : monotonic (fun (p:fmono_ordType O0 O1 * O0) => fst p (snd p)).
move => O0 O1. case => f x. case => f' x'. simpl. case ; simpl => L L'.
rewrite -> L. by rewrite -> L'.
Qed.

Definition Ev O0 O1 : (fmono_ordType O0 O1) * O0 =-> O1 := Eval hnf in mk_fmono (@Ev_mon O0 O1).

Lemma ordExpAxiom : @CatExp.axiom _ fmono_ordType (@Ev) (@Curry).
move => O0 O1 O2 h. split ; first by apply: fmon_eq_intro ; case.
move => h' X. apply: fmon_eq_intro => x. apply: fmon_eq_intro => y.
simpl. by apply (fmon_eq_elim X (x,y)).
Qed.

Canonical Structure ordExpMixin := expCatMixin ordExpAxiom.
Canonical Structure ordExpType := Eval hnf in expCatType ordExpMixin.

(*=natO *)
Lemma natO_axiom : PreOrd.axiom (fun n m : nat => leq n m).
(*CLEAR*)
Proof.
move => x ; split ; clear ; first by [].
move => y z ; by apply leq_trans.
Qed.
(*CLEARED*)Canonical Structure natO_ordMixin := OrdMixin natO_axiom.
Canonical Structure natO_ordType := Eval hnf in OrdType (natO_ordMixin).
Notation natO := natO_ordType.
(*=End *)

Lemma natO_le (x y : natO) : (x <= y) = (x <= y)%N.
by [].
Qed.

(*=CPO *)
Module CPO.
Definition axiom (T:ordType) (lub : (natO =-> T) -> T) :=
        forall  (c:natO =-> T) x n, (c n <= lub c) /\ ((forall n, c n <= x) -> lub c <= x).
Record mixin_of (T:ordType) : Type := Mixin {lub: (natO =-> T) -> T; _ : axiom lub }.
Record class_of (T:Type) : Type :=
  Class {base :> PreOrd.class_of T; ext :> mixin_of (PreOrd.Pack base T) }. (*CLEAR*)

Structure type : Type := Pack { sort :> Type; _ : class_of sort ; _ : Type}.

Definition class cT := let: Pack _ c _ := cT return class_of cT in c.
Definition unpack K (k : forall T (c : class_of T), K T c) cT :=
  let: Pack T c _ := cT return K _ (class cT) in k _ c.
Definition repack cT : _ -> Type -> type := let k T c p := p c in unpack k cT.

Definition pack := let k T c m := Pack (@Class T c m) T in PreOrd.unpack k.
(*CLEARED*)
Coercion ordType cT := PreOrd.Pack (class cT) cT.
Definition setoidType cT := Setoid.Pack (class cT) cT.
End CPO.
Notation cpoType := CPO.type.
Notation CpoMixin := CPO.Mixin.
Notation CpoType := CPO.pack.
Canonical Structure CPO.ordType.
Canonical Structure CPO.setoidType.
(*=End *)

Bind Scope D_scope with CPO.sort.
Delimit Scope D_scope with CPO.

Open Scope D_scope.

Definition lub (T:cpoType) : (natO =-> T) -> T := Eval hnf in CPO.lub (CPO.class T).

Lemma le_lub (T:cpoType) (c : natO =-> T) (n : nat) : c n <= lub c.
case. simpl. move => T. case. simpl. move => B. case. simpl. move => l A T' c n.
by apply (proj1 (A c (c 0) n)).
Qed.

Lemma lub_le (T:cpoType) (c : natO =-> T) (x : T) : (forall n, c n <= x) -> lub c <= x.
case. simpl. move => T. case. move => B. case. simpl. move => l A T' c x C.
by apply (proj2 (A c x O)).
Qed.

Hint Resolve le_lub lub_le.

Add Parametric Relation (O:cpoType) : O (@tset_eq O : O -> O -> Prop)
       reflexivity proved by (@Oeq_refl O) symmetry proved by (@Oeq_sym O)
       transitivity proved by (@Oeq_trans O) as Oeq_CpoRelation.

Add Parametric Relation (O:cpoType) : O (@Ole O)
       reflexivity proved by (@Ole_refl O)
       transitivity proved by (@Ole_trans O) as Ole_CpoRelation.

Add Parametric Morphism (c:cpoType) : (@lub c)
with signature (@Ole (fmono_ordType natO c) : (natO =-> c) -> (natO =-> c) -> Prop) ++> (@Ole c)
as lub_le_compat.
intros f g H; apply lub_le; intros.
apply Ole_trans with (g n); auto.
Save.
Hint Resolve lub_le_compat.

Add Parametric Morphism (c:cpoType) : (@lub c)
with signature (@tset_eq (natO =-> c) : (natO =-> c) -> (natO =-> c) -> Prop) ++> (@tset_eq c)
as lub_eq_compat.
move => f g H. split. simpl. rewrite -> (proj1 H). by apply: Ole_refl.
rewrite -> (proj2 H). by apply Ole_refl.
Save.
Hint Resolve lub_eq_compat.

Lemma lub_mon (D:cpoType) : monotonic (@lub D).
move => D f g l. by rewrite -> l.
Qed.

Definition Lub (D:cpoType) : (natO -=> D) =-> D := mk_fmono (@lub_mon D).

(*=Cont *)
Definition continuous (D1 D2 : cpoType) (f : ordCatType D1 D2) :=
                forall c : natO =-> D1,  f (lub c) <= lub (f << c).
Module FCont. Section fcont.
 Variable O1 O2 : cpoType.
 Record mixin_of (f:fmono O1 O2) := Mixin {cont :> continuous f }.
 Record class_of (f : O1 -> O2) :=
            Class {base :> FMon.mixin_of f; ext :> mixin_of (FMon.Pack base f) }. (*CLEAR*)

Structure type : Type := Pack {sort :> O1 -> O2; _ : class_of sort; _ : O1 -> O2}.
Definition class cT := let: Pack _ c _ := cT return class_of cT in c.
Definition unpack K (k : forall T (c : class_of T), K T c) cT :=
  let: Pack T c _ := cT return K _ (class cT) in k _ c.
Definition repack cT : _ -> Type -> type := let k T c p := p c in unpack k cT.
Definition pack := let k T c m := Pack (@Class T c m) T in FMon.unpack k.
(*CLEARED*) Coercion fmono f : fmono O1 O2 := FMon.Pack (class f) f.
End fcont. End FCont.
Notation fcont := FCont.type. (*CLEAR*)
Notation fcontMixin := FCont.Mixin.
Notation fcontType := FCont.pack.
(*CLEARED*)
Canonical Structure FCont.fmono.
(*=End *)

Lemma fcontinuous O1 O2 (f:fcont O1 O2) : continuous f.
move => O1 O2. case. simpl. move => f. case => fm. by case.
Qed.

Hint Resolve fcontinuous.
Hint Unfold continuous.

Canonical Structure mk_fcontM (D0 D1:cpoType) (f:fmono D0 D1) (c:continuous (FMon.Pack (FMon.class f) f)) := fcontMixin c.
Definition mk_fcont (D0 D1:cpoType) (f:fmono D0 D1) (c:continuous (FMon.Pack (FMon.class f) f)) := Eval hnf in @fcontType D0 D1 f (mk_fcontM c).

Lemma oid_cont (D:cpoType) : continuous (oid D).
move => D c. by rewrite -> comp_idL.
Qed.

Definition cid (D:cpoType) := Eval hnf in mk_fcont (@oid_cont D).

Lemma ocomp_cont (D0 D1 D2 : cpoType) (f:fcont D1 D2) (g:fcont D0 D1) : continuous (ocomp f g).
move => D0 D1 D2 f g c. simpl. apply Ole_trans with (f (lub ((g:fmono D0 D1) << c))).
by apply: fmonotonic ; apply: fcontinuous.
rewrite -> (fcontinuous f ((g:fmono D0 D1) << c)). by rewrite comp_assoc.
Qed.

Definition ccomp (D0 D1 D2 : cpoType) (f:fcont D1 D2) (g:fcont D0 D1) := Eval hnf in mk_fcont (ocomp_cont f g).

Lemma fcont_ord_axiom (D1 D2 :cpoType) : PreOrd.axiom (fun (f g:fcont D1 D2) => (f:fmono D1 D2) <= g).
move => D1 D2 f. split ; first by [].
move => g h ; by apply Ole_trans.
Qed.

Canonical Structure fcont_ordMixin (D1 D2 :cpoType) := OrdMixin (@fcont_ord_axiom D1 D2).
Canonical Structure fcont_ordType (D1 D2 :cpoType) := Eval hnf in OrdType (fcont_ordMixin D1 D2).

Lemma cpoMorphSetoidAxiom (D0 D1 : cpoType) : @Setoid.axiom (fcont D0 D1) (@tset_eq (fcont_ordType D0 D1)).
move => D0 D1. split ; first by [].
split ; first by apply: Oeq_trans.
by apply: Oeq_sym.
Qed.

Canonical Structure cpoMorphSetoidMixin O0 O1 := SetoidMixin (cpoMorphSetoidAxiom O0 O1).
Canonical Structure cpoMorphSetoidType O0 O1 := Eval hnf in SetoidType (cpoMorphSetoidMixin O0 O1).

(* fcont <= *)
Definition fcont_less (A B: cpoType): relation (fcont A B) := (@Ole _).

Definition fcont_less_preorder (A B: cpoType): PreOrder (@fcont_less A B).
move => A B. split ;first by move => x.
move => x y z. by apply Ole_trans.
Defined.

Existing Instance fcont_less_preorder.

Add Parametric Morphism (A B : cpoType) :
  (@FCont.sort A B) with signature (@fcont_less A B ++> @Ole A ++> @Ole B)
 as fcont_le_compat.
move => x y l x' y' l'. apply Ole_trans with (y:=x y') ; first by apply: fmonotonic.
by apply l.
Qed.

(* fcont == *)

Definition fcont_equal (A B: cpoType): relation (fcont A B) := (@tset_eq _).

Definition fcont_equal_equivalence (A B: cpoType): Equivalence (@fcont_equal A B).
intros A B. split.
- move => x. by apply: Oeq_refl.
- move => x y. by apply: Oeq_sym.
- move => x y z. by apply: Oeq_trans.
Defined.

Existing Instance fcont_equal_equivalence.

Add Parametric Morphism (A B : cpoType) :
  (@FCont.sort A B) with signature (@fcont_equal A B ==> @tset_eq A ==> @tset_eq B)
 as fcont_eq_compat.
move => x y l x' y' l'. apply Oeq_trans with (y:=x y') ; first by apply: fmon_stable.
by apply (fmon_eq_elim l y').
Qed.

(*=cpoCat *)
Lemma cpoCatAxiom : Category.axiom ccomp cid.
(*CLEAR*)
split ; first by move => D0 D1 f ; apply: fmon_eq_intro.
split ; first by move => D0 D1 f ; apply: fmon_eq_intro.
split ; first by move => D0 D1 D2 D3 f g h ; apply: fmon_eq_intro.
move => D0 D1 D2 f f' g g' e e'. apply: fmon_eq_intro => x. simpl. rewrite -> e. by rewrite -> e'.
Qed.
(*CLEARED*)Canonical Structure cpoCatMixin := CatMixin cpoCatAxiom.
Canonical Structure cpoCatType := Eval hnf in CatType cpoCatMixin.
(*=End *)

Definition prod_lub (D1 D2:cpoType) (f : natO =-> prod_ordType D1 D2) := (lub (pi1 << f), lub (pi2 << f)).

Lemma prod_cpo_axiom D1 D2 : CPO.axiom (prod_lub (D1:=D1) (D2:=D2)).
move => D1 D2 c x n ; split ; clear.
apply Ole_trans with (fst (c n), snd (c n)) ; first by case (c n).
by split ; simpl ; rewrite <- (le_lub _ n).
move => C. by split ; simpl ; apply lub_le => m ; [apply: (fmonotonic (@Fst D1 D2)) | apply: (fmonotonic (@Snd D1 D2))].
Qed.

Canonical Structure prod_cpoMixin D1 D2 := CpoMixin (@prod_cpo_axiom D1 D2).
Canonical Structure prod_cpoType D1 D2 := Eval hnf in CpoType (prod_cpoMixin D1 D2).

Lemma Prod_fun_cont (D1 D2 D3:cpoType) (f:D1=->D2) (g:D1=->D3) : continuous (<|f : ordCatType _ _, g|>).
intros D1 D2 D3 f g c.
simpl. split ; simpl ; rewrite comp_assoc.
- rewrite (fcontinuous f). by rewrite -> prod_fun_fst.
- rewrite fcontinuous. by rewrite prod_fun_snd.
Qed.

Definition PROD_fun (D2 D3 D1:cpoCatType)(f:D1=->D2)(g:D1=->D3) : D1 =-> prod_cpoType D2 D3 :=
  Eval hnf in mk_fcont (Prod_fun_cont f g).

Lemma Fst_cont (D1 D2 : cpoType) : continuous (@Fst D1 D2).
by move => D1 D2 c.
Qed.

Definition FST (D1 D2 : cpoType) : prod_cpoType D1 D2 =-> D1 := mk_fcont (@Fst_cont D1 D2).

Lemma Snd_cont (D1 D2 : cpoType) : continuous (@Snd D1 D2).
by move => D1 D2 c.
Qed.

Definition SND (D1 D2 : cpoType) : prod_cpoType D1 D2 =-> D2 := mk_fcont (@Snd_cont D1 D2).

Lemma cpoProdCatAxiom : @CatProduct.axiom _ prod_cpoType FST SND PROD_fun.
move => X Y Z f g.
split ; first by split ; [apply: (@prod_fun_fst ordProdCatType) | apply: (@prod_fun_snd ordProdCatType)].
move => h [A B].
by apply: (@prod_fun_unique ordProdCatType).
Qed.

Canonical Structure cpoProdCatMixin := prodCatMixin cpoProdCatAxiom.
Canonical Structure cpoProdCatType := Eval hnf in prodCatType cpoProdCatMixin.

Add Parametric Morphism (O0 O1:cpoType) : (@pair O0 O1)
 with signature (@Ole O0 : O0 -> O0 -> Prop) ++> (@Ole O1 : O1 -> O1 -> Prop) ++> (@Ole (O0 * O1))
 as pair_cpo_le_compat.
move => x y e x' y' e'. by split.
Qed.

Add Parametric Morphism (O0 O1:cpoType) : (@pair O0 O1)
 with signature (@tset_eq O0 : O0 -> O0 -> Prop) ==> (@tset_eq O1 : O1 -> O1 -> Prop) ==> (@tset_eq (O0 * O1))
 as pair_cpo_eq_compat.
move => x y e x' y' e'. case: e => e0 e1 ; case: e' => e2 e3. by split.
Qed.

(* my lemma *)
Lemma fcont_eq_intro : forall (A B : cpoType) (f g : A =-> B), (forall n, f n =-= g n) -> f =-= g.
move => O0 O1 f g X. split => x. by apply (proj1 (X x)).  by apply (proj2 (X x)).
Save.
Hint Resolve fcont_eq_intro.

Lemma const_mon (O1 O2 : ordType) (y:O2) : monotonic (fun _ : O1 => y).
by move => O1 O2 y x x'.
Qed.

Definition fmon_cte (O1 O2 : ordType) (y:O2) : O1 =-> O2 := Eval hnf in mk_fmono (@const_mon O1 O2 y).

Lemma lub_const (D:cpoType) (x:D) : lub (fmon_cte natO x) =-= x.
move => D x. split. by apply: lub_le. by apply (le_lub (fmon_cte natO x) O).
Qed.

Definition Fcontit_mono (D1 D2:cpoType) : monotonic (fun f:fcont_ordType D1 D2 => (f:(D1:ordType) -=> D2)) :=
 fun x y => id.

Definition Fcontit (D1 D2:cpoType) := Eval hnf in mk_fmono (@Fcontit_mono D1 D2).

Lemma eq_mono (D0 D1:ordType) (f:D0 -> D1) (g:D0 =-> D1) : (forall x, f x =-= g x) -> monotonic f.
move=> D0 D1 f g X x x' L. do 2 rewrite -> X. by rewrite L.
Qed.

Definition gen_mono (D0 D1:ordType) (f:D0 -> D1) (g:D0 =-> D1) (X:forall x, f x =-= g x) : D0 =-> D1 :=
   Eval hnf in mk_fmono (eq_mono X).

Lemma fcont_app_def_eq (O:ordType) (D1 D2:cpoType) (f: O =-> (fcont_ordType D1 D2)) (x:D1) :
  forall y, (fun y => f y x) y =-= (exp_fun(uncurry (Fcontit _ _ << f) << <|pi2,pi1|>) x) y.
by [].
Qed.

Lemma fmon_app_def_eq (O D1 D2:ordType) (f: O =-> D1 -=> D2) (x:D1) :
  forall y, (fun y => f y x) y =-= (exp_fun(uncurry (f:ordCatType _ _) << <|pi2,pi1|>) x) y.
by [].
Qed.

Definition fmon_app (O D1 D2:ordType) (f: O =-> D1 -=> D2) (x:D1) : O =-> D2 :=
  Eval hnf in gen_mono (fmon_app_def_eq f x).

Lemma fmon_app_eq (O D1 D2:ordType) (f: O =-> D1 -=> D2) (x:D1) :
  fmon_app f x =-= (exp_fun((uncurry f:ordCatType _ _) << <|pi2,pi1|>) x).
move => O D1 D2 f x. by apply fmon_eq_intro => y.
Qed.

Definition fcont_app (O:ordType) (D1 D2:cpoType) (f: O =-> (fcont_ordType D1 D2)) (x:D1) : O =-> D2 :=
  Eval hnf in gen_mono (fcont_app_def_eq f x).

Lemma fcont_app_eq (O:ordType) (D1 D2:cpoType) (f: O =-> (fcont_ordType D1 D2)) (x:D1) :
  fcont_app f x =-= (exp_fun((uncurry (Fcontit _ _ << f):ordCatType _ _) << <|pi2,pi1|>) x).
move => O D1 D2 f x. by apply fmon_eq_intro => y.
Qed.

Lemma fcont_lub_mono (D1 D2:cpoType) (c:natO =-> (fcont_ordType D1 D2)) : monotonic (fcont_app c).
move => D1 D2 c x y l n. simpl. by rewrite -> l.
Qed.

Lemma fcont_lub_cont (D1 D2:cpoType) (c:natO =-> (fcont_ordType D1 D2)) : continuous (Lub _ << mk_fmono (fcont_lub_mono c)).
move => D1 D2 c c'. simpl. apply lub_le => i. simpl.
rewrite (fcontinuous (c i)). apply lub_le_compat => j. simpl. by apply: (Ole_trans _ (le_lub _ i)).
Qed.

Definition fcont_lub (D1 D2:cpoType) (c:natO =-> (fcont_ordType D1 D2)) : D1 =-> D2 :=
  Eval hnf in mk_fcont (fcont_lub_cont c).

Lemma fcont_lub_simpl (D1 D2:cpoType) (c:natO =-> (fcont_ordType D1 D2)) (x:D1) :
  fcont_lub c x = lub (fcont_app c x).
by [].
Qed.

Lemma fcont_cpo_axiom (D0 D1:cpoType) : CPO.axiom (@fcont_lub D0 D1).
move => D0 D1 c x n. split.
- move => a. simpl. by rewrite <- (le_lub _ n).
- move => C. move => y. simpl. apply: lub_le => m. specialize (C m). simpl. by rewrite -> C.
Qed.

Canonical Structure fcont_cpoMixin (D0 D1:cpoType) := CpoMixin (@fcont_cpo_axiom D0 D1).
Canonical Structure fcont_cpoType (D0 D1:cpoType) := Eval hnf in CpoType (fcont_cpoMixin D0 D1).

Lemma fcont_app2_cont (D0 D1 D2:cpoType) (f: D0 =-> (fcont_cpoType D1 D2)) (x:D1) : continuous (fcont_app f x).
move => D0 D1 D2 f x c. simpl. rewrite (fcontinuous f). simpl. by apply lub_le_compat => n.
Qed.

Definition Fcont_app (D0 D1 D2:cpoType) (f: D0 =-> (fcont_cpoType D1 D2)) (x:D1) : D0 =-> D2 :=
   Eval hnf in mk_fcont (fcont_app2_cont f x).

Lemma Pair_cont (D0 D1 : cpoType) (x:D0) : continuous (Pair D1 x).
move => D0 D1 x c. simpl. split.
- simpl. by apply: (Ole_trans _ (le_lub (pi1 << (Pair D1 x << c)) O)).
- simpl. by apply lub_le_compat => i.
Qed.

Definition PAIR (D0 D1 : cpoType) (x:D0) : D1 =-> D0 * D1 := Eval hnf in mk_fcont (Pair_cont x).

Lemma Curry2_mon (D0 D1 D2 : cpoType) (f:D0 * D1 =-> D2) : monotonic (fun x => f << PAIR _ x).
move => D0 D1 D2 f x x' l y. simpl. by rewrite -> l.
Qed.

Definition CURRY_mon (D0 D1 D2 : cpoType) (f:D0 * D1 =-> D2) := Eval hnf in mk_fmono (Curry2_mon f).

Lemma Curry2_cont (D0 D1 D2 : cpoType) (f:D0 * D1 =-> D2) : continuous (CURRY_mon f).
move => D1 D2 D3 f c x. simpl. rewrite {1} (Oeq_sym (lub_const x)).
rewrite - {1} (prod_fun_snd c (fmon_cte natO x)).
rewrite - {1} (prod_fun_fst c (fmon_cte natO x)).
apply: (Ole_trans (fcontinuous f _)).
by apply lub_le_compat => i.
Qed.

Definition CURRY (D0 D1 D2 : cpoType) (f:D0 * D1 =-> D2) := Eval hnf in mk_fcont (Curry2_cont f).

Lemma Ev1_mon (D0 D1 : cpoType) : monotonic (fun x : ((fcont_cpoType D0 D1) * D0) => (fst x) (snd x)).
move => D0 D1. simpl. case => f x. case => f' x'. case ; simpl => L L'.
rewrite -> L. by rewrite -> L'.
Qed.

Definition EV1 (D0 D1 : cpoType) := Eval hnf in mk_fmono (@Ev1_mon D0 D1).

Lemma Ev_cont (D0 D1 : cpoType) : continuous (@EV1 D0 D1).
move => D0 D1 c. simpl.
apply Ole_trans with ((lub (pi1 << c)) (lub (pi2 << c))) ; first by apply: lub_le_compat => n.
rewrite -> (fcontinuous (lub (pi1 << c)) (pi2 << c)).
apply lub_le => i. simpl. apply lub_le => j. simpl. apply: (Ole_trans _ (le_lub _ (j+i))).
simpl. apply Ole_trans with (Fst _ _ (c j) (Snd _ _ (c i))) ; first by [].
rewrite -> (fmonotonic c (leq_addl j i)). by rewrite -> (fmonotonic c (leq_addr i j)).
Qed.

Definition EV (D0 D1 : cpoType) : (fcont_cpoType D0 D1 * D0) =-> D1 := Eval hnf in mk_fcont (@Ev_cont D0 D1).

Lemma cpoExpAxiom : @CatExp.axiom _ fcont_cpoType (@EV) (@CURRY).
move => D0 D1 D2 h. split ; first by apply: fmon_eq_intro ; case.
move => h' X. apply: fmon_eq_intro => x. apply: fmon_eq_intro => y.
simpl. by apply (fmon_eq_elim X (x,y)).
Qed.

Canonical Structure cpoExpMixin := expCatMixin cpoExpAxiom.
Canonical Structure cpoExpType := Eval hnf in expCatType cpoExpMixin.

Module CPPO.

Record class_of (T:Type) : Type := Class
  { base1 :> CPO.class_of T;
    ext :> Pointed.mixin_of (PreOrd.Pack base1 T)}.

Coercion base2 (T:Type) (c:class_of T) := Pointed.Class c.

Structure type : Type := Pack {sort :> Type; _ : class_of sort; _ : Type}.
Definition class cT := let: Pack _ c _ := cT return class_of cT in c.
Definition unpack K (k : forall T (c : class_of T), K T c) cT :=
  let: Pack T c _ := cT return K _ (class cT) in k _ c.
Definition repack cT : _ -> Type -> type := let k T c p := p c in unpack k cT.

Definition pack := let k T c m := Pack (@Class T c m) T in CPO.unpack k.

Coercion cpoType (cT:type) := CPO.Pack (class cT) cT.
Definition ordType (cT:type) := PreOrd.Pack (class cT) cT.
Definition pointedType (cT:type) := Pointed.Pack (class cT) cT.
Definition setoidType (cT:type) := Setoid.Pack (class cT) cT.

End CPPO.

Notation cppoType := CPPO.type.
Notation CppoType := CPPO.pack.

Canonical Structure CPPO.cpoType.
Canonical Structure CPPO.ordType.
Canonical Structure CPPO.pointedType.
Canonical Structure CPPO.setoidType.

Definition strict (D E:cppoType) (f:D -> E) := f PBot =-= PBot.

Lemma cppoCatAxiom : @Category.axiom cppoType cpoMorphSetoidType (fun D0 D1 D2 => @ccomp D0 D1 D2) (fun D0 => @cid D0).
split ; first by move => D0 D1 D2 ; apply: (proj1 (cpoCatAxiom)).
split ; first by move => D0 D1 D2 ; apply: (proj1 (proj2 (cpoCatAxiom))).
split ; first by move => D0 D1 D2 D3 ; apply: (proj1 (proj2 (proj2 (cpoCatAxiom)))).
move => D0 D1 D2 ; apply: (proj2 (proj2 (proj2 (cpoCatAxiom)))).
Qed.

Canonical Structure cppoCatMixin := CatMixin cppoCatAxiom.
Canonical Structure cppoCatType := Eval hnf in CatType cppoCatMixin.

Lemma cppoProdPointedAxiom (D0 D1:cppoType) : Pointed.axiom (PBot:D0,PBot : D1).
move => D0 D1. split ; simpl ; apply: leastP.
Qed.

Canonical Structure prod_cppoMixin (D0 D1:cppoType) := PointedMixin (@cppoProdPointedAxiom D0 D1).
Canonical Structure prod_cppoType (D0 D1:cppoType) := Eval hnf in CppoType (prod_cppoMixin D0 D1).

Lemma cppoProdCatAxiom : @CatProduct.axiom _ prod_cppoType (fun A B => @FST A B) (fun A B => @SND A B) (fun A B C => @PROD_fun A B C).
move => X Y Z f g.
split ; first by apply (proj1 (@cpoProdCatAxiom X Y Z f g)).
move => m. by apply (proj2 (@cpoProdCatAxiom X Y Z f g) m).
Qed.

Canonical Structure cppoProdCatMixin := prodCatMixin cppoProdCatAxiom.
Canonical Structure cppoProdCatType := Eval hnf in prodCatType cppoProdCatMixin.

Lemma const_cont (D E : cpoType) (x:E) : continuous (fmon_cte D x).
move => D E x c. simpl. by apply: (Ole_trans _ (le_lub _ O)).
Qed.

Definition const (D E:cpoType) x : D =-> E := Eval hnf in mk_fcont (const_cont x).

Lemma const_com D E F x h : @const D E x =-= @const F E x << h.
move => D E F x h. by apply: fmon_eq_intro.
Qed.

Lemma fcont_cppo_axiom D0 (D1 : cppoType) : Pointed.axiom (const D0 (PBot:D1)).
move => D0 D1 f x. simpl. apply: leastP.
Qed.

Canonical Structure exp_cppoMixin D0 (D1:cppoType) := PointedMixin (@fcont_cppo_axiom D0 D1).
Canonical Structure exp_cppoType D0 (D1:cppoType) := Eval hnf in CppoType (exp_cppoMixin D0 D1).

Lemma cppoExpAxiom : @CatExp.axiom cppoProdCatType exp_cppoType (fun D0 D1 => @EV D0 D1) (fun D0 D1 D2 => @CURRY D0 D1 D2).
move => D0 D1 D2 h.
split. by apply (proj1 (@cpoExpAxiom D0 D1 D2 h)).
move => h'. by apply (proj2 (@cpoExpAxiom D0 D1 D2 h) h').
Qed.

Canonical Structure cppoExpMixin := expCatMixin cppoExpAxiom.
Canonical Structure cppoExpType := Eval hnf in expCatType cppoExpMixin.

Lemma discrete_cpoAxiom T : @CPO.axiom (discrete_ordType T) (fun c => c 0).
move => T c e n. split.
- have L:c 0 <= c n by apply fmonotonic.
  have E:c 0 = c n by apply L. by rewrite E.
- move => X. by specialize (X 0).
Qed.

Canonical Structure discrete_cpoMixin T := CpoMixin (@discrete_cpoAxiom T).
Definition discrete_cpoType T := Eval hnf in CpoType (@discrete_cpoMixin (discrete_ordType T)).

Canonical Structure nat_cpoType := Eval hnf in discrete_cpoType nat.
Canonical Structure bool_cpoType := Eval hnf in discrete_cpoType bool.

Definition monic (D E:ordType) (f:D =-> E) := forall x y, f x <= f y -> x <= y.

Lemma subordAxiom (D:ordType) (P:D -> Prop) : PreOrd.axiom
   (fun (x' y:{x : D | P x}) => match x' with exist x _ => match y with exist y _ => @Ole D x y end end).
move => D P. case => a Pa. split ; first by []. case => b Pb. case => c Pc.
by apply Ole_trans.
Qed.

Canonical Structure sub_ordMixin D P := OrdMixin (@subordAxiom (D:ordType) (P:D -> Prop)).
Canonical Structure sub_ordType D P := Eval hnf in OrdType (@sub_ordMixin D P).

Definition SubOrde (D:ordType) (P:D -> Prop) (d:D)  (X:P d) : sub_ordType P := exist (fun x => P x) d X.

Implicit Arguments SubOrde [D P].

Lemma InheritFun_mono D (E:ordType) (Q:E->Prop) (f:D =-> E) (p:forall d, Q (f d)) : monotonic (fun d => @SubOrde E Q (f d) (p d)).
move => D E Q f p x y lxy. by apply: fmonotonic.
Qed.

Definition InheritFunm D (E:ordType) (Q:E->Prop) (f:D =-> E) (p:forall d, Q (f d)) :
 D =-> sub_ordType Q := Eval hnf in mk_fmono (InheritFun_mono p).

Implicit Arguments InheritFunm [D E Q].

Lemma Forget_mono D P : monotonic (fun (O:@sub_ordType D P) => match O with exist x _ => x end).
move => D P. case => x px. by case.
Qed.

Definition Forgetm D P : (@sub_ordType D P) =-> D := Eval hnf in mk_fmono (@Forget_mono D P).

Lemma fmonD_mon D (E:ordType) (f:D -> E) : @monotonic (discrete_cpoType D) E f.
move => D E f x y l. by rewrite -> l.
Qed.

Definition fmonD D (E:ordType) (f:D -> E) : discrete_ordType D =-> E := Eval hnf in mk_fmono (fmonD_mon f).

Lemma ford_axiom (A:Type) (O:ordType) : PreOrd.axiom (fun f g:A->O => forall x, f x <= g x).
move => A O f.
split ; first by apply (proj1 (@fmono_axiom (discrete_ordType A) O (fmonD f))).
move => y z X Y. by apply (proj2 (@fmono_axiom (discrete_ordType A) O (fmonD f)) (fmonD y) (fmonD z) X Y).
Qed.

Canonical Structure ford_ordMixin (T:Type) (O:ordType) := OrdMixin (@ford_axiom T O).
Definition ford_ordType T O := Eval hnf in OrdType (ford_ordMixin T O).

Lemma lub_comp_le :
    forall (D1 D2 : cpoType) (f:ordCatType D1 D2) (h : natO =-> D1),  lub (f << h) <= f (lub h).
intros; apply lub_le; simpl; intros.
apply (fmonotonic f); auto.
Save.
Hint Resolve lub_comp_le.

Lemma lub_comp_eq :
    forall (D1 D2 : cpoType) (f:cpoCatType D1 D2) (h : natO =-> D1), f (lub h) =-= lub ((f:ordCatType _ _) << h).
move => D1 D2 f g. apply: Ole_antisym ; last by apply: lub_comp_le.
rewrite fcontinuous. apply lub_le => n. simpl. by apply: (Ole_trans _ (le_lub _ n)).
Save.
Hint Resolve lub_comp_eq.

Lemma mseq_lift_left_mon (O:ordType) (f:natO =-> O) (n:nat) : monotonic (fun i => f (n+i)%N).
move => O f n x y l. apply fmonotonic. unfold Ole. simpl. rewrite -> (leq_add2l n x y). by apply l.
Qed.

Definition mseq_lift_left (O:ordType) (f:natO =-> O) (n:nat) := Eval hnf in mk_fmono (mseq_lift_left_mon f n).

Lemma lub_lift_left : forall (D:cpoType) (f:natO =-> D) n, lub f =-= lub (mseq_lift_left f n).
move => D f n. apply: Ole_antisym.
- apply lub_le. move => m. rewrite <- (le_lub _ m). simpl. apply fmonotonic. rewrite natO_le. by rewrite leq_addl.
- apply lub_le. move => m. by rewrite <- (le_lub _ (n+m)).
Qed.
Hint Resolve lub_lift_left.

Lemma lub_fun_mon (O:ordType) (D:cpoType) (h : natO =-> O -=> D) : monotonic (fun m => lub (fmon_app h m)).
move => O D h x y l. apply lub_le_compat => n. simpl. by rewrite -> l.
Qed.

Definition lub_fun (O:ordType) (D:cpoType) (h : natO =-> O -=> D) : O =-> D :=
  Eval hnf in mk_fmono (lub_fun_mon h).

Lemma fmon_cpo_axiom (O:ordType) (D:cpoType) : @CPO.axiom (O -=> D) (lub_fun (O:=O) (D:=D)).
move => O D c x n ; split => e ; simpl ; first by rewrite <- (le_lub _ n).
move => a. simpl. apply lub_le. move => m. simpl. by rewrite (e m).
Qed.

Canonical Structure fmon_cpoMixin (O:ordType) (D:cpoType) := CpoMixin (@fmon_cpo_axiom O D).
Canonical Structure fmon_cpoType (O:ordType) (D:cpoType) := Eval hnf in CpoType (@fmon_cpoMixin O D).

Definition fmon_shift (O1 O2 O3:ordType) (f: O1 =-> O2 -=> O3) : O2 =-> O1 -=> O3 :=
  exp_fun (uncurry f << <|pi2,pi1|>).

Lemma fmon_fcont_shift_cont (O:ordType) (D1 D2:cpoType) (f: O =-> D1 -=> D2) : continuous (fmon_shift (Fcontit D1 D2<<f)).
move => O D1 D2 f c x. simpl. rewrite (fcontinuous (f x)). by apply lub_le_compat => i.
Qed.

Definition fmon_fcont_shift (O:ordType) (D1 D2:cpoType) (f: O =-> D1 -=> D2) : D1 =-> fmon_cpoType O D2 :=
  Eval hnf in mk_fcont (fmon_fcont_shift_cont f).

Lemma fcont_app_continuous :
       forall (O:ordType) (D1 D2:cpoType) (f: O =-> D1 -=> D2) (h:natO =-> D1),
            fcont_app f (lub h) <= lub ((fmon_fcont_shift f:ordCatType _ _) << h).
move => O D1 D2 f h x. simpl. rewrite (fcontinuous (f x)). by apply lub_le_compat.
Save.

Lemma fmon_diag_mon (O1 O2:ordType)(h:O1 =-> (O1 -=> O2)) : monotonic (fun n => h n n).
move => O1 O2 h x y l. by rewrite -> l.
Qed.

Definition fmon_diag (O1 O2:ordType)(h:O1 =-> (O1 -=> O2)) : O1 =-> O2 :=
  Eval hnf in mk_fmono (fmon_diag_mon h).

Lemma lub_diag D (c:ordCatType natO (fmon_cpoType natO D)) : lub (lub c) =-= lub (fmon_diag c).
move => D c. apply: Ole_antisym.
- apply: lub_le => i. apply: lub_le => j. apply: (Ole_trans _ (le_lub _ (i+j))).
  simpl. rewrite -> (fmonotonic c (leq_addl i j)).
  by rewrite -> (fmonotonic (c (i+j)%N) (leq_addr j i)).
- apply: lub_le => i. by do 2 apply: (Ole_trans _ (le_lub _ i)).
Qed.

Lemma zero_ord_axiom : PreOrd.axiom (fun x y : Empty => True).
by case.
Qed.

Canonical Structure zero_ordMixin := OrdMixin zero_ord_axiom.
Canonical Structure zero_ordType := Eval hnf in OrdType zero_ordMixin.

Lemma ordZeroAxiom : @CatInitial.axiom ordCatType zero_ordType.
move => C f g. apply: fmon_eq_intro. by case.
Qed.

Lemma Zero_fun_mono (X:ordType) : monotonic (fun (x:Empty) => match x with end:X).
move => X. by case.
Qed.

Definition Zero_fun X : zero_ordType =-> X := Eval hnf in mk_fmono (@Zero_fun_mono X).

Canonical Structure ordInitialMixin := initialCatMixin Zero_fun ordZeroAxiom.
Canonical Structure ordInitialType := Eval hnf in initialCatType ordInitialMixin.

Lemma zero_cpo_axiom : @CPO.axiom zero_ordType (fun (c:natO =-> Zero) => c 0).
move => c. by case.
Qed.

Canonical Structure zero_cpoMixin := CpoMixin zero_cpo_axiom.
Canonical Structure zero_cpoType := Eval hnf in CpoType zero_cpoMixin.

Lemma cpoZeroAxiom : @CatInitial.axiom cpoCatType zero_cpoType.
move => C f g. by apply: fmon_eq_intro.
Qed.

Lemma ZERO_fun_cont (X:cpoType) : continuous (@Zero_fun X).
move => X c. simpl. by case: (lub c).
Qed.

Definition ZERO_fun X : zero_cpoType =-> X := Eval hnf in mk_fcont (ZERO_fun_cont X).

Canonical Structure cpoInitialMixin := initialCatMixin ZERO_fun cpoZeroAxiom.
Canonical Structure cpoInitialType := Eval hnf in initialCatType cpoInitialMixin.

Lemma one_ord_axiom : PreOrd.axiom (fun x y : unit => True).
by case.
Qed.

Canonical Structure one_ordMixin := OrdMixin one_ord_axiom.
Canonical Structure one_ordType := Eval hnf in OrdType one_ordMixin.

Lemma ordOneAxiom : @CatTerminal.axiom ordCatType one_ordType.
move => C f g. apply: fmon_eq_intro => x. case: (f x). by case: (g x).
Qed.

Canonical Structure ordTerminalMixin := terminalCatMixin (fun O1 => fmon_cte O1 tt) ordOneAxiom.
Canonical Structure ordTerminalType := Eval hnf in terminalCatType ordTerminalMixin.

Lemma one_cpo_axiom : @CPO.axiom one_ordType (fun (c:natO =-> One) => tt).
move => c x n. split ; first by case: (c n).
by move => X ; case x.
Qed.

Canonical Structure one_cpoMixin := CpoMixin one_cpo_axiom.
Canonical Structure one_cpoType := Eval hnf in CpoType one_cpoMixin.

Lemma cpoOneAxiom : @CatTerminal.axiom cpoCatType one_cpoType.
move => C f g. apply: fmon_eq_intro => x. case: (f x). by case: (g x).
Qed.

Canonical Structure cpoTerminalMixin := terminalCatMixin (fun D => const D tt) cpoOneAxiom.
Canonical Structure cpoTerminalType := Eval hnf in terminalCatType cpoTerminalMixin.

Lemma one_pointedAxiom : Pointed.axiom tt.
by case.
Qed.

Canonical Structure one_pointedMixin := PointedMixin one_pointedAxiom.
Canonical Structure one_pointedType := Eval hnf in PointedType one_pointedMixin.

Canonical Structure one_cppoType := Eval hnf in CppoType one_pointedMixin.

Lemma cppoOneAxiom : CatTerminal.axiom one_cppoType.
move => C f g. by apply: (cpoOneAxiom).
Qed.

Canonical Structure cppoTerminalMixin := terminalCatMixin (fun D => const D tt : cppoCatType D one_cppoType) cppoOneAxiom.
Canonical Structure cppoTerminalType := Eval hnf in terminalCatType cppoTerminalMixin.

Lemma eq_cont (D0 D1:cpoType) (f:D0 -> D1) (g:D0 =-> D1) (X:forall x, f x =-= g x) : continuous (gen_mono X).
move => D0 D1 f g X c. simpl. rewrite -> (X (lub c)). rewrite -> (fcontinuous g c).
apply lub_le_compat => n. simpl. by rewrite -> (X (c n)).
Qed.

Definition gen_cont (D0 D1:cpoType) (f:D0 -> D1) (g:D0 =-> D1) (X:forall x, f x =-= g x) := Eval hnf in mk_fcont (eq_cont X).

Add Parametric Relation (O O':cpoType) : (O =-> O') (@Ole (fcont_ordType O O') : (O =-> O') -> (O =-> O') -> Prop)
       reflexivity proved by (@Ole_refl _)
       transitivity proved by (@Ole_trans _) as Ole_XRelation.

Add Parametric Relation (O O':ordType) : (O =-> O') (@Ole (O -=> O') : (O =-> O') -> (O =-> O') -> Prop)
       reflexivity proved by (@Ole_refl _)
       transitivity proved by (@Ole_trans _) as Ole_XXRelation.

Add Parametric Morphism (D1 D2 D3:cpoType) : (@Category.comp cpoCatType D1 D2 D3)
with signature (@Ole (fcont_ordType D2 D3) : (D2 =-> D3) -> (D2 =-> D3) -> Prop) ++>
               (@Ole (fcont_ordType D1 D2) : (D1 =-> D2) -> (D1 =-> D2) -> Prop) ++>
               (@Ole (fcont_ordType D1 D3) : (D1 =-> D3) -> (D1 =-> D3) -> Prop)
as comp_le_compat.
move => f g l f' g' l' x.
simpl. rewrite -> l. by rewrite -> l'.
Qed.

Add Parametric Morphism (D1 D2 D3:ordType) : (@Category.comp ordCatType D1 D2 D3)
with signature (@Ole (D2 -=> D3) : (D2 =-> D3) -> (D2 =-> D3) -> Prop) ++>
               (@Ole (D1 -=> D2) : (D1 =-> D2) -> (D1 =-> D2) -> Prop) ++>
               (@Ole (D1 -=> D3) : (D1 =-> D3) -> (D1 =-> D3) -> Prop)
as comp_le_ord_compat.
move => f g l f' g' l' x.
simpl. rewrite -> l. by rewrite -> l'.
Qed.

Lemma ccomp_mon (D1 D2 D3:cpoType) : monotonic (fun (p:(D2 -=> D3) * (D1 -=> D2)) => (fst p : cpoCatType _ _) << snd p).
move => D1 D2 D3. case => f g. case => f' g'. simpl.
case ; simpl => l l'. rewrite -> l. by rewrite -> l'.
Qed.

Definition Ccomp (D1 D2 D3:cpoType) := Eval hnf in mk_fmono (@ccomp_mon D1 D2 D3).

Lemma Ccomp_cont (D1 D2 D3:cpoType) : continuous (@Ccomp D1 D2 D3).
move => D1 D2 D3 c x. simpl.
rewrite -> fcont_app_continuous. rewrite lub_diag. by apply lub_le_compat => i.
Qed.

Definition CCOMP (D1 D2 D3:cpoType) := Eval hnf in mk_fcont (@Ccomp_cont D1 D2 D3).

Lemma comp_lub_eq (D0 D1 D2 :cpoType) (f:D1 =-> D2) (c:natO =-> fcont_ordType D0 D1) :
   f << lub c =-= lub ((@exp_fun _ (D1 -=> D2) _ _ (CCOMP D0 D1 D2) f : ordCatType _ _) << c).
move => D0 D1 D2 f c. apply: fmon_eq_intro => d. simpl. rewrite lub_comp_eq.
apply lub_eq_compat. by apply fmon_eq_intro => n.
Qed.

Lemma lub_comp (D0 D1 D2 :cpoType) (f:D0 =-> D1) (c:natO =-> fcont_ordType D1 D2) :
   (lub c : cpoCatType _ _) << f =-= lub ((@exp_fun _ (D0 -=> D1) _ _ (CCOMP D0 D1 D2 << <|pi2,pi1|>) f : ordCatType _ _) << c).
move => D0 D1 D2 f c. apply: fmon_eq_intro => d. simpl.
apply lub_eq_compat. by apply fmon_eq_intro => n.
Qed.

Lemma lub_comp_both (X Y Z:cpoType) (c:natO =-> fcont_ordType X Y) (c':natO =-> fcont_ordType Y Z) :
  (lub c' : cpoCatType _ _) << lub c =-= lub ( (CCOMP _ _ _ : ordCatType _ _) << <|c', c|>).
move => X Y Z c c'.
have a:=@lub_comp_eq _ _ ( ((CCOMP X Y Z))) (<|c',c|>). rewrite <- a.
apply: comp_eq_compat. simpl. by rewrite prod_fun_fst.
simpl. by rewrite prod_fun_snd.
Qed.

Section OrdProdI.
Variable (I:Type) (O:I -> ordType).

Lemma prodI_ord_axiom : PreOrd.axiom (fun p1 p2 :(forall i:I, O i) => forall i:I, p1 i <= p2 i).
move => x ; split ; clear ; first by [].
move => y z X Y i. rewrite (X i). by rewrite (Y i).
Qed.

Canonical Structure prodI_ordMixin := OrdMixin prodI_ord_axiom.
Canonical Structure prodI_ordType := Eval hnf in OrdType prodI_ordMixin.

Lemma Proj_monotonic (i:I) : monotonic (fun (x:prodI_ordType ) => x i).
move => i x y l. by apply l.
Qed.

Definition Proj (i:I) : prodI_ordType =-> O i := Eval hnf in mk_fmono (Proj_monotonic i).

Lemma prodi_fun_mon (D:ordType) (f:forall i:I, D =-> O i) : monotonic (fun d => (fun i => f i d):prodI_ordType).
move => D f d0 d1 deq i.
by rewrite -> deq.
Qed.

Definition Prodi_fun D (f:forall i:I, D =-> O i) : D =-> prodI_ordType := Eval hnf in mk_fmono (prodi_fun_mon f).

End OrdProdI.

Lemma ordProdIAxiom : forall I:Type, @CatIProduct.axiom _ I (@prodI_ordType I) (@Proj I) (@Prodi_fun I).
move => I A X f. split.
- move => i. by apply fmon_eq_intro => x.
- move => m Z. apply fmon_eq_intro => x. split ; simpl => i.
  + specialize (Z i). by apply (proj1 Z x).
  + specialize (Z i). by apply (proj2 Z x).
Qed.

Canonical Structure ordProdIMixin := prodICatMixin ordProdIAxiom.
Canonical Structure ordProdICat := Eval hnf in prodICatType ordProdIMixin.

Section ProdICPO.

Variable I:Type.
Variable D:I -> cpoType.

Lemma prodi_cpo_axiom : CPO.axiom (fun (f : natO =-> prodI_ordType D) (i:I) => lub (Proj D i << f)).
move => c x n ; split ; clear.
- move => i. simpl. by rewrite <- (le_lub _ n).
- move => C i. apply lub_le => n. simpl. by apply C.
Qed.

Canonical Structure prodi_cpoMixin := @CpoMixin (prodI_ordType D) _ prodi_cpo_axiom.
Canonical Structure prodi_cpoType := Eval hnf in @CpoType (prodI_ordType D) prodi_cpoMixin.

Lemma Proj_cont i : continuous (@Proj I D i:ordCatType prodi_cpoType _).
move => i c. simpl. by apply: lub_le_compat.
Qed.

Definition PROJ i := Eval hnf in mk_fcont (Proj_cont i).

Lemma prod_fun_cont (D1:cpoType) (f:forall i:I, D1 =-> D i) :
   continuous (@Prodi_fun I _ D1 (fun i => (f i)) : ordCatType D1 prodi_cpoType).
move => D1 f c i.
simpl. rewrite (fcontinuous (f i)). by apply: lub_le_compat => n.
Qed.

Definition PRODI_fun D1 (f:forall i:I, D1 =-> D i) : D1 =-> prodi_cpoType :=
  Eval hnf in mk_fcont (prod_fun_cont f).

End ProdICPO.

Lemma cpoProdIAxiom : forall I:Type, @CatIProduct.axiom _ I (@prodi_cpoType I) (@PROJ I) (@PRODI_fun I).
move => I A X f. split.
- move => i. apply (proj1 (ordProdIAxiom f) i).
- move => m Z. by apply (proj2 (ordProdIAxiom f) m Z).
Qed.

Canonical Structure cpoProdIMixin := prodICatMixin cpoProdIAxiom.
Canonical Structure cpoProdICat := prodICatType cpoProdIMixin.


(** This module should be [Require]d but not [Import]ed (except for the notations submodule). *)

Require Import
  Coq.Unicode.Utf8 Coq.Lists.List Coq.Setoids.Setoid Coq.Classes.Morphisms Coq.Sorting.Permutation.

#[global]
Instance: ∀ A, Proper (@Permutation A ==> eq) (@length A).
Proof Permutation_length.

Section contents.
  Context {T: Type}.

  Inductive L: Type := one: T → L | cons: T → L → L.

  Fixpoint app (a b: L) {struct a}: L :=
    match a with
    | one x => cons x b
    | cons x y => cons x (app y b)
    end.

  Fixpoint foldr {R} (o: T → R) (f: T → R → R) (a: L): R :=
    match a with
    | one x => o x
    | cons x y => f x (foldr o f y)
    end.

  Fixpoint foldr1 (f: T → T → T) (a: L): T :=
    match a with
    | one x => x
    | cons x y => f x (foldr1 f y)
    end.

  Definition head (l: L): T := match l with one x => x | cons x _ => x end.

  Fixpoint to_list (l: L): list T :=
    match l with
    | one x => x :: nil
    | cons x xs => x :: to_list xs
    end.

  Local Coercion to_list: L >-> list.

  Fixpoint from_list (x: T) (xs: list T): L :=
    match xs with
    | nil => one x
    | List.cons h t => cons x (from_list h t)
    end.

  Definition tail (l: L): list T := match l with one _ => nil | cons _ x => to_list x end.

  Lemma decomp_eq (l: L): l = from_list (head l) (tail l).
  Proof with auto.
    induction l...
    destruct l...
    simpl in *.
    rewrite IHl...
  Qed.

  Definition last: L → T := foldr1 (fun x y => y).

  Fixpoint replicate_Sn (x: T) (n: nat): L :=
    match n with
    | 0 => one x
    | S n' => cons x (replicate_Sn x n')
    end.

  Fixpoint take (n: nat) (l: L): L :=
    match l, n with
    | cons x xs, S n' => take n' xs
    | _, _ => one (head l)
    end.

  Lemma two_level_rect (P: L → Type)
    (Pone: ∀ x, P (one x))
    (Ptwo: ∀ x y, P (cons x (one y)))
    (Pmore: ∀ x y z, P z → (∀ y', P (cons y' z)) → P (cons x (cons y z))):
      ∀ l, P l.
  Proof with auto.
   cut (∀ l, P l * ∀ x, P (cons x l)).
    intros. apply X.
   destruct l...
   revert t.
   induction l...
   intros.
   split. apply IHl.
   intro.
   apply Pmore; intros; apply IHl.
  Qed.

  Lemma tl_length (l: L): S (length (tl l)) = length l.
  Proof. destruct l; reflexivity. Qed.

  Notation ListPermutation := (@Permutation.Permutation _).

  Definition Permutation (x y: L): Prop := ListPermutation x y.

  Global Instance: Equivalence Permutation.
  Proof with intuition.
   unfold Permutation.
   split; repeat intro...
   transitivity y...
  Qed.

  Global Instance: Proper (Permutation ==> ListPermutation) to_list.
  Proof. firstorder. Qed.

  Lemma Permutation_ne_tl_length (x y: L):
    Permutation x y → length (tl x) = length (tl y).
  Proof.
   intro H.
   apply eq_add_S.
   do 2 rewrite tl_length.
   rewrite H.
   reflexivity.
  Qed.
End contents.

Module Export coercions.
  Coercion to_list: L >-> list.
End coercions.

Arguments L : clear implicits.

Fixpoint tails {A} (l: L A): L (L A) :=
  match l with
  | one x => one (one x)
  | cons x y => cons l (tails y)
  end.

Lemma tails_are_shorter {A} (y x: L A):
  In x (tails y) →
  length x <= length y.
Proof with auto.
 induction y; simpl.
  intros [[] | ?]; intuition.
 intros [[] | C]...
Qed.

Fixpoint map {A B} (f: A → B) (l: L A): L B :=
  match l with
  | one x => one (f x)
  | cons h t => cons (f h) (map f t)
  end.

Lemma list_map {A B} (f: A → B) (l: L A): to_list (map f l) = List.map f (to_list l).
Proof. induction l. reflexivity. simpl. congruence. Qed.

Global Instance: forall {A B} (f: A → B), Proper (Permutation ==> Permutation) (map f).
Proof with auto.
 intros ????? E.
 unfold Permutation.
 do 2 rewrite list_map.
 rewrite E.
 reflexivity.
Qed.

Fixpoint inits {A} (l: L A): L (L A) :=
  match l with
  | one x => one (one x)
  | cons h t => cons (one h) (map (cons h) (inits t))
  end.

Module notations.
  Global Notation ne_list := L.
  Global Infix ":::" := cons (at level 60, right associativity).
    (* Todo: Try to get that "[ x ; .. ; y ]" notation working. *)

  Fixpoint ne_zip {A B: Type} (l: ne_list A) (m: ne_list B) {struct l} : ne_list (A * B) :=
    match l with
    | one a => one (a, head m)
    | a ::: l =>
        match m with
        | one b => one (a, b)
        | b ::: m => (a, b) ::: ne_zip l m
        end
    end.
End notations.


Require Import Logic.lib.Coqlib.
Require Import Logic.lib.Ensembles_ext.
Require Import Logic.GeneralLogic.Base.
Require Import Logic.GeneralLogic.ProofTheory.TheoryOfSequentCalculus.

Local Open Scope logic_base.

Class NormalSequentCalculus (L: Language) (Gamma: ProofTheory L): Type := {
  provable_derivable: forall x, provable x <-> derivable empty_context x
}.

Class BasicSequentCalculus (L: Language) (Gamma: ProofTheory L) := {
  deduction_weaken: forall Phi Psi x, Included _ Phi Psi -> Phi |-- x -> Psi |-- x;
  derivable_assum: forall Phi x, Ensembles.In _ Phi x -> Phi |-- x;
  deduction_subst: forall (Phi Psi: context) y, (forall x, Psi x -> Phi |-- x) -> Union _ Phi Psi |-- y -> Phi |-- y
}.

Class FiniteWitnessedSequentCalculus (L: Language) (Gamma: ProofTheory L) := {
  derivable_finite_witnessed: forall (Phi: context) (y: expr), Phi |-- y -> exists xs, Forall Phi xs /\ (fun x => In x xs) |-- y
}.

Section DerivableRulesFromSequentCalculus.

Context {L: Language}
        {Gamma: ProofTheory L}
        {bSC: BasicSequentCalculus L Gamma}.

Lemma deduction_subst1: forall Phi x y, Phi |-- x -> Phi;; x |-- y -> Phi |-- y.
Proof.
  intros.
  apply deduction_subst with (Singleton _ x); auto.
  intros.
  inversion H1; subst.
  auto.
Qed.

Lemma derivable_trans: forall (Phi Psi: context) y, (forall x, Psi x -> Phi |-- x) -> Psi |-- y -> Phi |-- y.
Proof.
  intros.
  eapply deduction_subst; eauto.
  eapply deduction_weaken; eauto.
  apply right_Included_Union.
Qed.

Lemma deduction_weaken1: forall Phi x y,
  Phi |-- y ->
  Phi;; x |-- y.
Proof.
  intros.
  eapply deduction_weaken; eauto.
  intros ? ?; left; auto.
Qed.

Lemma derivable_assum1: forall (Phi: context) (x: expr), Phi;; x |-- x.
Proof.
  intros.
  apply derivable_assum.
  right; constructor.
Qed.

Lemma contextual_derivable_finite_witnessed {fwSC: FiniteWitnessedSequentCalculus L Gamma}: forall (Phi Psi: context) (y: expr), Union _ Phi Psi |-- y -> exists xs, Forall Psi xs /\ Union _ Phi (fun x => In x xs) |-- y.
Proof.
  apply DeductionWeaken_DerivableFiniteWitnessed_2_ContextualDerivableFiniteWitnessed.
  + hnf; intros; eapply deduction_weaken; eauto.
  + hnf; intros; eapply derivable_finite_witnessed; eauto.
Qed.

Lemma deduction_weaken0 {SC: NormalSequentCalculus L Gamma}: forall Phi y,
  |-- y ->
  Phi |-- y.
Proof.
  intros.
  rewrite provable_derivable in H.
  eapply deduction_weaken; eauto.
  intros ? [].
Qed.

End DerivableRulesFromSequentCalculus.

Ltac solve_assum :=
  (first [apply derivable_assum1 | assumption | apply deduction_weaken1; solve_assum] || fail 1000 "Cannot find the conclusion in assumption").


Require Import List Lia.
Require Import TypeClasses Ltacs.
(* Requiring, but not yet importing *)
Require Coq.Program.Equality.
Import ListNotations.

Tactic Notation "exT" hyp(H) :=
  eapply (Eqdep_dec.inj_pair2_eq_dec) in H;
  try (apply nat_eq_dec').

(*
  [Vectors] are lists plus size built in. More unwieldy to construct,
  more powerful to use.
*)
Inductive Vector {A : Type} : nat -> Type :=
| vecnil  : @Vector A 0
| veccons : forall (x : A) (n : nat), Vector n -> Vector (S n).

Definition vector_length {A : Type} {len : nat} (v : @Vector A len) := len.

Fixpoint default_vector {A : Type} `{H : Defaultable A} (n : nat) : (@Vector A n) :=
  match n with
  | 0 => vecnil
  | S n' => (veccons defVal n' (default_vector n'))
  end.

#[global]
Instance defaultable_vector {A : Type} `{H : Defaultable A} (n : nat) : Defaultable (@Vector A n) :=
{
  defVal := default_vector n
}.

Fixpoint vector_get_value {A : Type} {len : nat}
  (vec : @Vector A len) (index : nat) : option A :=
  match index with
  | 0 =>
      match vec with
      | vecnil => None
      | (veccons curA remLen vec') =>
          Some curA
      end
  | S ind' =>
      match vec with
      | vecnil => None
      | (veccons curA remLen vec') =>
          vector_get_value vec' ind'
      end
  end.

Lemma vgv_gte_len_none : forall {A : Type} {len : nat} (n : nat)
  (v : @Vector A len),
  n >= len ->
  vector_get_value v n = None.
Proof.
  intros A len n v.
  generalize dependent n.
  induction v; intros; destruct n; simpl; eauto.
  - destruct n0; try (eapply IHv); lia.
  - destruct n0; try (eapply IHv); lia.
Qed.

Lemma vgv_lt_len_some : forall {A : Type} {len : nat} (n : nat)
  (v : @Vector A len),
  n < len ->
  exists aVal, vector_get_value v n = Some aVal.
Proof.
  intros A len n v.
  generalize dependent n.
  induction v; intros; destruct n; simpl; try lia.
  - destruct n0; try (eapply IHv); try lia.
    eexists. eauto.
  - destruct n0; try (eapply IHv); try lia.
    eexists. eauto.
Qed.

Fixpoint vector_set_value {A : Type} {len : nat}
    (vec : (@Vector A len)) (index : nat) (newV : A) : (@Vector A len) :=
  match index with
  | 0 =>
      match vec with
      | vecnil => vecnil
      | (veccons curA remLen vec') =>
          (veccons newV remLen vec')
      end
  | S ind' =>
      match vec with
      | vecnil => vecnil
      | (veccons curA remLen vec') =>
          (veccons curA remLen (vector_set_value vec' ind' newV))
      end
  end.

Lemma vsv_gte_len_same : forall {A : Type} {len : nat} (n : nat)
  (v : @Vector A len) (newV : A),
  n >= len ->
  vector_set_value v n newV = v.
Proof.
  intros A len n v.
  generalize dependent n.
  induction v; intros; destruct n; simpl; eauto.
  - destruct n0; try (erewrite IHv); eauto; lia.
  - destruct n0; try (erewrite IHv); eauto; lia.
Qed.

(** This sort of lemma is slightly convoluted and
    we wont prove until needed.
*)
Lemma vsv_lt_len_some : forall {A : Type} {len : nat} (n : nat)
  (v v' : @Vector A len) (curV newV : A),
  n < len ->
  vector_get_value v n = Some curV ->
  vector_set_value v n newV = v' ->
  curV <> newV ->
  v <> v'.
Proof.
  intros A len n v.
  generalize dependent n.
  induction v; intros; destruct n; simpl; try lia.
  - inv H0. inv H1. destruct n0; try lia.
    inv H4. subst. simpl. intros HC.
    inversion HC. cong.
  - inv H0. inv H1. destruct n0; try lia.
    * (* n0 = 0 *)
      inv H4. subst. simpl. intros HC.
      inversion HC. cong.
    * (* n0 = S n0 *)
      simpl in *. assert (n0 < S n). lia.
      destruct (vector_set_value v n0 newV) eqn:VSV.
      ** (* vsv = vecnil *)
         specialize IHv with n0 vecnil curV newV.
         eapply (IHv H5 H0 VSV) in H2.
         intros HC. inversion HC. exT H7; eauto.
      ** (* vsv = (veccons x0 n1 v0) *)
         specialize IHv with n0 (veccons x0 n1 v0) curV newV.
         eapply (IHv H5 H0 VSV) in H2.
         intros HC. inversion HC. exT H7; eauto.
Qed.

Module VectorNotations.
Declare Scope vector_scope.
Delimit Scope vector_scope with vector.
Notation "<[ ]" := vecnil (format "<[ ]") : vector_scope.
Notation "h <:: t" := (veccons h _ t) (at level 60, right associativity)
  : vector_scope.
Notation "<[ x ]" := (veccons x 0 vecnil) (at level 105) : vector_scope.
Notation "<[ x ; y ; .. ; z ]" := (veccons x _ (veccons y _ .. (veccons z _ (vecnil)) ..)) (at level 105) : vector_scope.
Notation "v <@[ i ]" := (vector_get_value v i) (at level 60, right associativity) : vector_scope.
Notation "v set<@[ i ] <- v'" := (vector_set_value v i v') (at level 65, left associativity) : vector_scope.
Open Scope vector_scope.
End VectorNotations.

Import VectorNotations.

Example vec1 : @Vector nat 0. econstructor. Defined.

Example vec2 : @Vector nat 2.
repeat econstructor. Defined.

Example vec3 : @Vector nat 3 := <[1 ; 2 ; 3].

Example vec3get : vec3 <@[2] = Some 3. reflexivity. Defined.

Example vec3set : (vec3 set<@[1] <- 42) = <[ 1 ; 42 ; 3].
reflexivity. Defined.

Example vec4 : @Vector nat 1 := 1 <:: vecnil.

Fixpoint list_to_vec {A : Type} (l : list A) : @Vector A (length l).
destruct l; simpl.
- apply vecnil.
- apply veccons; eauto.
Defined.

Lemma list_to_vec_preserve_len : forall {A : Type} (l : list A),
  length l = vector_length (list_to_vec l).
Proof.
  induction l; eauto.
Qed.

Example ltv1test : (list_to_vec [1;2;3]) = <[ 1 ;2;3].
reflexivity. Defined.

Fixpoint vec_to_list {A : Type} {n : nat} (ls : Vector n) : list A :=
  match ls with
  | vecnil => nil
  | veccons x n vec' =>
      x :: (vec_to_list vec')
  end.

Lemma vec_to_list_preserve_len : forall {A : Type} {len : nat} (v : @Vector A len),
  vector_length v = length (vec_to_list v).
Proof.
  induction v; eauto. simpl.
  unfold vector_length in *.
  eauto.
Qed.

Example vec11 :
  vec_to_list (<[ 1 ]) = [1].
unfold vec_to_list. reflexivity. Defined.

Example vec1test : (vec_to_list (<[ 12 ; 42 ])) = [12; 42].
reflexivity. Defined.

Lemma vector_forall_lists : forall A (l : list A),
  exists v : (@Vector A (length l)), True.
Proof with (repeat econstructor; eauto).
  intros.
  induction l; simpl in *.
  - eexists...
  - inversion IHl. eexists...
Qed.

Theorem vectors_equiv_lists : forall A (l : list A),
  exists v : (@Vector A (length l)),
    v = list_to_vec l.
Proof with (repeat econstructor; eauto).
  intros.
  induction l; simpl in *.
  - eexists...
  - inversion IHl. eexists...
Qed.

Theorem vec_to_list_involutive :
  forall A (l : list A),
  vec_to_list (list_to_vec l) = l.
Proof with eauto.
  induction l...
  simpl. rewrite IHl...
Qed.

(** Vector Testing
    - We need to ensure that the access of vectors is intuitive
*)
Definition tvec1 := <[ 1 ; 2 ; 3; 4].
Example testVec1_1 : tvec1 <@[1] = Some 2. reflexivity. Defined.
Example testVec1_2 : tvec1 <@[0] = Some 1. reflexivity. Defined.
Example testVec1_3 : tvec1 <@[4] = None. reflexivity. Defined.
Example testVec1_4 : tvec1 <@[3] = Some 4. reflexivity. Defined.

Fixpoint eqb_vector {A : Type} `{H : EqClass A} {n1 n2 : nat}
  (v1 : (@Vector A n1)) (v2 : (@Vector A n2)) : bool :=
  match v1, v2 with
  | vecnil, vecnil => true
  | (veccons curA1 n1' vec1'), (veccons curA2 n2' vec2') =>
      if (eqb curA1 curA2)
      then eqb_vector vec1' vec2'
      else false
  | _, _ => false
  end.

Theorem eqb_vector_refl: forall {A : Type} `{H : EqClass A} {len : nat}
  (v : (@Vector A len)),
    eqb_vector v v = true.
Proof.
  destruct H.
  induction v; simpl; eauto.
  assert (eqb x x = true). rewrite eqb_leibniz. auto.
  rewrite H. auto.
Qed.

Lemma eqb_vector_only_same_size : forall {A : Type} `{H : EqClass A} {n1 n2 : nat}
  (v1 : (@Vector A n1)) (v2 : (@Vector A n2)),
  eqb_vector v1 v2 = true -> n1 = n2.
Proof.
  intros. generalize dependent n2.
  induction v1; destruct v2; eauto; intros Hvec.
  - inversion Hvec.
  - inversion Hvec.
  - inversion Hvec.
    destruct (Nat.eqb n n0) eqn:Neq.
    * (* n = n0*)
      destruct H.
      destruct (eqb x x0) eqn:Xeq.
      ** (* x = x0 *)
        destruct (eqb_vector v1 v2) eqn:Veq.
        *** (* v1 = v2 *)
            eapply IHv1 in Veq. subst. eauto.
        *** (* v1 <> v2 *) inversion H1.
            destruct (eqb x x0); eauto.
      ** (* x <> x0 *) inversion H1.
          destruct (eqb x x0); eauto; cong.
    * (* n <> n0 *)
      destruct (eqb x x0); eauto. cong.
Qed.

Theorem eqb_vector_works : forall {A : Type} `{H : EqClass A} {len : nat}
  (v1 v2 : @Vector A len),
  eqb_vector v1 v2 = true ->
  (forall (i : nat),
    (v1 <@[i]) = (v2 <@[i])).
Proof.
  induction v1; destruct v2; eauto; intros; try inversion H0.
  destruct (eqb x x0) eqn:Eqx; try congruence.
  * (* x = x0 *)
    pose proof (eqb_vector_only_same_size _ _ H2). subst.
    pose proof (IHv1 _ H2).
    destruct i; eauto.
    simpl. erewrite eqb_leibniz in Eqx. subst. eauto.
Qed.

Module VectorTypeClass.
(** Note: Importing this also comes with the burden of JMeq
    it is necessary for proving things related to vector equality
    implying leibniz equality
    - Specifically it includes "dependent destruction" which is
      very powerful
*)
Import Coq.Program.Equality.

Lemma tail_neq_impl_neq : forall {A : Type} `{H : EqClass A} {n : nat}
  (v1 v2 : @Vector A n) (h1 h2 : A),
  v1 <> v2 ->
  h1 <:: v1 <> h2 <:: v2.
Proof.
  induction v1; dependent destruction v2; intros; simpl in *; eauto.
  intros HC.
  inversion HC.
  eapply (Eqdep_dec.inj_pair2_eq_dec) in H4.
  subst. congruence.
  apply nat_eq_dec'.
Qed.

#[global]
Instance deceq_vector {A : Type} `{H : EqClass A} {n : nat} : DecEq (@Vector A n).
constructor.
induction x1; dependent destruction x2; simpl in *; eauto; destruct H.
destruct (IHx1 x2).
- (* x1 = x2 *)
  subst.
  destruct (eqb x x3) eqn:Heq.
  * (* x = x3 *)
    apply eqb_leibniz in Heq. subst. eauto.
  * (* x <> x3 *)
    apply neqb_leibniz in Heq. right.
    qcon.
- (* x1 <> x2 *)
  right. apply tail_neq_impl_neq; eauto.
Defined.

#[global]
Instance eq_class_vector {A : Type} `{H : EqClass A} {n : nat} : EqClass (@Vector A n) :=
{
  eqb := gen_deceq_eqb ;
  eqb_leibniz := gen_eqb_impl_eqb_leibniz ;
  neqb_leibniz := gen_eqb_impl_neqb_leibniz ;
}.

End VectorTypeClass.


From Coq Require Import OrderedType FMaps FSets ZArith.
From mathcomp Require Import ssreflect ssrbool ssrnat ssrint eqtype tuple.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

(** Structure with a base type t. *)

Module NatType <: Equalities.Typ.
  Definition t : Set := nat.
End NatType.

Module IntType <: Equalities.Typ.
  Definition t : Set := int.
End IntType.

Module PosType <: Equalities.Typ.
  Definition t : Set := positive.
End PosType.

Module NType <: Equalities.Typ.
  Definition t : Set := N.
End NType.

Module ZType <: Equalities.Typ.
  Definition t : Set := Z.
End ZType.

Module Type HasDefault (Import T : Equalities.Typ).
  Parameter default : t.
End HasDefault.

Module Type HasDefaultTyp := Equalities.Typ <+ HasDefault.

(** Structure with a base eqType t. *)

Module Type EQTYPE.
  Parameter t : eqType.
End EQTYPE.

Module IntEqtype <: EQTYPE.
  Definition t := int_eqType.
End IntEqtype.

(** Structure with a base type t equipped with a reflectable Boolean equality. *)

Module Type HAS_REFLECTABLE_EQB (Import X : Equalities.Typ).
  Parameter Inline eqb : t -> t -> bool.
  Parameter Inline eqb_refl : forall x : t, eqb x x.
  Parameter Inline eqb_eq : forall x y : t, eqb x y -> x = y.
End HAS_REFLECTABLE_EQB.

Module Type REFLECTABLE := Equalities.Typ <+ HAS_REFLECTABLE_EQB.

Module MakeReflection (X : REFLECTABLE).

  Lemma eqbP : Equality.axiom X.eqb.
  Proof.
    move=> x y.
    case H: (X.eqb x y).
    - apply: ReflectT.
      apply: X.eqb_eq.
      assumption.
    - apply: ReflectF.
      move/idP/eqP/eqP: H => Hne Heq; apply: Hne.
      rewrite Heq.
      exact: X.eqb_refl.
  Qed.

  Canonical reflectable_Mixin := EqMixin eqbP.
  Canonical reflectable_eqType := Eval hnf in EqType X.t reflectable_Mixin.

End MakeReflection.

(** Make (option t) an eqType given that t is an eqType. *)

Module MakeOptionReflectable (X : EQTYPE).

  Definition option_eqb (x y : option X.t) : bool :=
    match x, y with
    | None, None => true
    | None, Some _ => false
    | Some _, None => false
    | Some a, Some b => a == b
    end.

  Lemma option_eqbP : Equality.axiom option_eqb.
  Proof.
    move=> x y; case: y; case: x => /=.
    - move=> x y.
      case H: (x == y).
      + apply: ReflectT.
        rewrite (eqP H).
        reflexivity.
      + apply: ReflectF.
        move=> Heq.
        move/idP/eqP/eqP: H; apply.
        case: Heq => Heq; rewrite Heq.
        exact: eqxx.
    - move=> y.
      apply: ReflectF.
      move=> H; discriminate.
    - move=> x.
      apply: ReflectF.
      move=> H; discriminate.
    - apply: ReflectT.
      reflexivity.
  Qed.

  Canonical option_Mixin := EqMixin option_eqbP.
  Canonical option_eqType := Eval hnf in EqType (option X.t) option_Mixin.

End MakeOptionReflectable.

Module OptionIntEqtype <: EQTYPE.
  Module OptionInt := MakeOptionReflectable(IntEqtype).
  Definition t := OptionInt.option_eqType.
End OptionIntEqtype.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e255m765_13limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition freeze :
  { freeze : feBW_tight -> feBW_limbwidths
  | forall a, phiBW_limbwidths (freeze a) = phiBW_tight a }.
Proof.
  Set Ltac Profiling.
  Time synthesize_freeze ().
  Show Ltac Profile.
Time Defined.

Print Assumptions freeze.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e206m5_8limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition freeze :
  { freeze : feBW_tight -> feBW_limbwidths
  | forall a, phiBW_limbwidths (freeze a) = phiBW_tight a }.
Proof.
  Set Ltac Profiling.
  Time synthesize_freeze ().
  Show Ltac Profile.
Time Defined.

Print Assumptions freeze.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e512m569_11limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition freeze :
  { freeze : feBW_tight -> feBW_limbwidths
  | forall a, phiBW_limbwidths (freeze a) = phiBW_tight a }.
Proof.
  Set Ltac Profiling.
  Time synthesize_freeze ().
  Show Ltac Profile.
Time Defined.

Print Assumptions freeze.


Require Import Coq.Classes.Morphisms.
Require Import Coq.ZArith.ZArith.
Require Import Coq.micromega.Lia.
Require Import Crypto.Util.ZUtil.Definitions.
Require Import Crypto.Util.ZUtil.LandLorBounds.
Require Import Crypto.Util.ZUtil.LandLorShiftBounds.
Require Import Crypto.Util.ZUtil.Morphisms.
Require Import Crypto.Util.ZUtil.Tactics.LtbToLt.
Require Import Crypto.Util.ZUtil.Tactics.SplitMinMax.
Require Import Crypto.Util.ZRange.
Require Import Crypto.Util.ZRange.Operations.
Require Import Crypto.Util.ZRange.BasicLemmas.
Require Import Crypto.Util.ZRange.CornersMonotoneBounds.
Require Import Crypto.Util.Tactics.UniquePose.
Require Import Crypto.Util.Tactics.SpecializeBy.
Require Import Crypto.Util.Tactics.SplitInContext.
Require Import Crypto.Util.Tactics.DestructHead.
Require Import Crypto.Util.Tactics.BreakMatch.

Local Open Scope bool_scope.
Local Open Scope Z_scope.

Module ZRange.
  Import Operations.ZRange.
  Import CornersMonotoneBounds.ZRange.

  Lemma is_bounded_by_bool_lor_land_bound_helper
        f (Hf : f = Z.lor \/ f = Z.land)
        x x_bs y y_bs
        (Hboundedx : is_bounded_by_bool x x_bs = true)
        (Hboundedy : is_bounded_by_bool y y_bs = true)
    : is_tighter_than_bool
        (constant (f (Z.round_lor_land_bound x) (Z.round_lor_land_bound y)))
        (four_corners_and_zero (fun x y => f (Z.round_lor_land_bound x) (Z.round_lor_land_bound y)) x_bs y_bs)
      = true.
  Proof.
    apply monotoneb_four_corners_and_zero_gen with (x:=x) (y:=y);
      destruct_head'_or; subst f; eauto with typeclass_instances zarith core.
  Qed.

  Local Existing Instances Z.land_round_Proper_pos_r
        Z.land_round_Proper_pos_l
        Z.lor_round_Proper_pos_r
        Z.lor_round_Proper_pos_l
        Z.land_round_Proper_neg_r
        Z.land_round_Proper_neg_l
        Z.lor_round_Proper_neg_r
        Z.lor_round_Proper_neg_l.

  Lemma is_bounded_by_bool_land_lor_bounds_helper
        f (Hf : f = Z.lor \/ f = Z.land)
        x x_bs y y_bs
        (Hboundedx : is_bounded_by_bool x x_bs = true)
        (Hboundedy : is_bounded_by_bool y y_bs = true)
    : is_bounded_by_bool (f x y) (land_lor_bounds f x_bs y_bs) = true.
  Proof.
    pose proof (is_bounded_by_bool_lor_land_bound_helper f Hf x (extend_land_lor_bounds x_bs) y (extend_land_lor_bounds y_bs)) as H.
    pose proof (fun pf1 pf2 => is_bounded_by_bool_lor_land_bound_helper f Hf 0 (extend_land_lor_bounds x_bs) y (extend_land_lor_bounds y_bs) pf2 pf1) as H0x.
    pose proof (fun pf1 pf2 => is_bounded_by_bool_lor_land_bound_helper f Hf (-1) (extend_land_lor_bounds x_bs) y (extend_land_lor_bounds y_bs) pf2 pf1) as Hm1x.
    pose proof (is_bounded_by_bool_lor_land_bound_helper f Hf x (extend_land_lor_bounds x_bs) 0 (extend_land_lor_bounds y_bs)) as H0y.
    pose proof (is_bounded_by_bool_lor_land_bound_helper f Hf x (extend_land_lor_bounds x_bs) (-1) (extend_land_lor_bounds y_bs)) as Hm1y.
    pose proof (is_bounded_by_bool_lor_land_bound_helper f Hf 0 (extend_land_lor_bounds x_bs) 0 (extend_land_lor_bounds y_bs)) as H00.
    pose proof (is_bounded_by_bool_lor_land_bound_helper f Hf (-1) (extend_land_lor_bounds x_bs) 0 (extend_land_lor_bounds y_bs)) as Hm10.
    pose proof (is_bounded_by_bool_lor_land_bound_helper f Hf 0 (extend_land_lor_bounds x_bs) (-1) (extend_land_lor_bounds y_bs)) as H0m1.
    pose proof (is_bounded_by_bool_lor_land_bound_helper f Hf (-1) (extend_land_lor_bounds x_bs) (-1) (extend_land_lor_bounds y_bs)) as Hm1m1.
    specialize_by (eapply ZRange.is_bounded_by_of_is_tighter_than; try eapply ZRange.is_tighter_than_bool_extend_land_lor_bounds; eassumption || reflexivity).
    revert H H0x Hm1x H0y Hm1y H00 Hm1m1 H0m1 Hm10.
    cbv [land_lor_bounds constant is_tighter_than_bool is_bounded_by_bool is_true] in *; cbn [lower upper] in *.
    rewrite !Bool.andb_true_iff, !Z.leb_le in *.
    cbv [extend_land_lor_bounds].
    cbn [lower upper] in *.
    destruct (Z.round_lor_land_bound_bounds x) as [Hx|Hx], (Z.round_lor_land_bound_bounds y) as [Hy|Hy].
    all: repeat apply Z.min_case_strong; repeat apply Z.max_case_strong.
    all: try (intros; exfalso; clear dependent f; lia).
    all: destruct x as [|x|x], y as [|y|y]; try (intros; exfalso; clear dependent f; lia).
    all: change (Z.round_lor_land_bound 0) with 0 in *.
    all: change (Z.round_lor_land_bound (-1)) with (-1) in *.
    all: intros.
    all: repeat match goal with
                | _ => assumption
                | [ H : ?T, H' : ?T |- _ ] => clear H'
                | [ H : 0 <= 0 <= 0 |- _ ] => clear H
                | [ H : 0 <= -1 <= _ -> _ |- _ ] => clear H
                | [ H : 0 <= -1 -> _ |- _ ] => clear H
                | [ H : ?x <= ?x <= _ -> _ |- _ ] => specialize (fun pf => H (conj (@Z.le_refl x) pf))
                | [ H : _ <= ?x <= ?x -> _ |- _ ] => specialize (fun pf => H (conj pf (@Z.le_refl x)))
                | [ H : ?T, H' : ?T /\ _ -> _ |- _ ] => specialize (fun pf => H' (conj H pf))
                | [ H : ?T, H' : _ /\ ?T -> _ |- _ ] => specialize (fun pf => H' (conj pf H))
                | _ => progress specialize_by_assumption
                | _ => progress specialize_by (destruct_head'_and; assumption)
                | [ H : _ <= Z.pos _ <= ?x |- _ ] => unique assert (0 <= x) by (clear -H; lia)
                | [ H : ?x <= Z.neg _ <= _ |- _ ] => unique assert (x <= -1) by (clear -H; lia)
                | [ H : ?a <= _ <= ?c, H' : ?c <= ?d, H'' : ?a <= ?d -> _ |- _ ]
                  => unique assert (a <= d) by (clear -H H'; lia)
                | [ H : ?a <= ?b -> ?c <= ?d <= ?e -> _ |- _ ] => specialize (fun pf1 pf2 => H pf2 pf1)
                end.
    all: destruct Hf; subst f.
    all: split.
    all: destruct_head'_and.
    all: split_and.
    all: repeat lazymatch goal with
                | [ |- Z.land _ (Z.pos ?x) <= _ ]
                  => is_var x; etransitivity; [ apply Z.land_round_bound_pos_r' | ]
                | [ |- Z.land (Z.pos ?x) _ <= _ ]
                  => is_var x; etransitivity; [ apply Z.land_round_bound_pos_l' | ]
                | [ |- _ <= Z.land _ (Z.pos ?x) ]
                  => is_var x; etransitivity; [ | apply Z.land_round_bound_pos_r ]
                | [ |- _ <= Z.land (Z.pos ?x) _ ]
                  => is_var x; etransitivity; [ | apply Z.land_round_bound_pos_l ]
                | [ |- Z.land _ (Z.neg ?x) <= _ ]
                  => is_var x; etransitivity; [ apply Z.land_round_bound_neg_r | ]
                | [ |- Z.land (Z.neg ?x) _ <= _ ]
                  => is_var x; etransitivity; [ apply Z.land_round_bound_neg_l | ]
                | [ |- _ <= Z.land _ (Z.neg ?x) ]
                  => is_var x; etransitivity; [ | apply Z.land_round_bound_neg_r' ]
                | [ |- _ <= Z.land (Z.neg ?x) _ ]
                  => is_var x; etransitivity; [ | apply Z.land_round_bound_neg_l' ]
                | [ |- Z.lor _ (Z.pos ?x) <= _ ]
                  => is_var x; etransitivity; [ apply Z.lor_round_bound_pos_r' | ]
                | [ |- Z.lor (Z.pos ?x) _ <= _ ]
                  => is_var x; etransitivity; [ apply Z.lor_round_bound_pos_l' | ]
                | [ |- _ <= Z.lor _ (Z.pos ?x) ]
                  => is_var x; etransitivity; [ | apply Z.lor_round_bound_pos_r ]
                | [ |- _ <= Z.lor (Z.pos ?x) _ ]
                  => is_var x; etransitivity; [ | apply Z.lor_round_bound_pos_l ]
                | [ |- Z.lor _ (Z.neg ?x) <= _ ]
                  => is_var x; etransitivity; [ apply Z.lor_round_bound_neg_r | ]
                | [ |- Z.lor (Z.neg ?x) _ <= _ ]
                  => is_var x; etransitivity; [ apply Z.lor_round_bound_neg_l | ]
                | [ |- _ <= Z.lor _ (Z.neg ?x) ]
                  => is_var x; etransitivity; [ | apply Z.lor_round_bound_neg_r' ]
                | [ |- _ <= Z.lor (Z.neg ?x) _ ]
                  => is_var x; etransitivity; [ | apply Z.lor_round_bound_neg_l' ]
                | [ |- Z.pos ?x <= _ ]
                  => is_var x; etransitivity; [ eassumption | ]
                | [ |- _ <= Z.neg ?x ]
                  => is_var x; etransitivity; [ | eassumption ]
                | [ |- _ <= Z.pos ?x ]
                  => is_var x; transitivity 0; [ assumption | lia ]
                | [ |- Z.neg ?x <= _ ]
                  => is_var x; transitivity (-1); [ lia | assumption ]
                | _ => idtac
                end.
    all: try assumption.
    all: try (rewrite ?Z.lor_0_l, ?Z.lor_0_r, ?Z.land_0_l, ?Z.land_0_r, ?Z.lor_m1_l, ?Z.lor_m1_r, ?Z.land_m1_l, ?Z.land_m1_r in *; reflexivity || assumption).
  Qed.

  Lemma is_bounded_by_bool_land_bounds
        x x_bs y y_bs
        (Hboundedx : is_bounded_by_bool x x_bs = true)
        (Hboundedy : is_bounded_by_bool y y_bs = true)
    : is_bounded_by_bool (Z.land x y) (ZRange.land_bounds x_bs y_bs) = true.
  Proof.
    cbv [ZRange.land_bounds].
    cbv [is_bounded_by_bool] in *.
    cbn [upper lower].
    repeat match goal with
           | H : (_ && _)%bool = true |- _ =>
             apply Bool.andb_true_iff in H; destruct H
           end.
    Z.ltb_to_lt.
    pose proof (Z.log2_up_le_mono (-x) (- lower x_bs) ltac:(lia)).
    pose proof (Z.log2_up_le_mono (-y) (- lower y_bs) ltac:(lia)).
    assert (0 <= 2 ^ (Z.max (Z.log2_up (- lower x_bs))
                            (Z.log2_up (- lower y_bs))))
      by (apply Z.pow_nonneg; lia).
    pose proof (Z.pow_le_mono
                  2 (Z.max (Z.log2_up (- x)) (Z.log2_up (- y)))
                  2 (Z.max (Z.log2_up (- lower x_bs)) (Z.log2_up (- lower y_bs)))
                  ltac:(lia) ltac:(lia)).
    destruct (Z_lt_le_dec x 0); destruct (Z_lt_le_dec y 0).
    all:lazymatch goal with
        | Hx : ?x < 0, Hy : ?y < 0 |- context [Z.land ?x ?y] =>
          pose proof (Z.land_neg_lower x y ltac:(lia) ltac:(lia));
            pose proof (proj2 (Z.land_neg x y) ltac:(lia));
            pose proof (Z.land_le x y ltac:(lia))
        | Hx : ?x < 0, Hy : 0 <= ?y |- context [Z.land ?x ?y] =>
          pose proof (Z.land_neg_l_range x y ltac:(lia) ltac:(lia));
            pose proof (proj2 (Z.land_nonneg x y) ltac:(lia))
        | Hx : 0 <= ?x, Hy : ?y < 0 |- context [Z.land ?x ?y] =>
          pose proof (Z.land_neg_r_range x y ltac:(lia) ltac:(lia));
            pose proof (proj2 (Z.land_nonneg x y) ltac:(lia))
        | Hx : 0 <= ?x, Hy : 0 <= ?y |- context [Z.land ?x ?y] =>
          pose proof (Z.land_le x y ltac:(lia));
            let H := fresh in
            pose proof (Z.land_le y x ltac:(lia)) as H;
              rewrite Z.land_comm in H;
              pose proof (proj2 (Z.land_nonneg x y) ltac:(lia))
        end.
    all:break_innermost_match;
      repeat match goal with
             | H : (_ && _)%bool = true |- _ =>
               apply Bool.andb_true_iff in H; destruct H
             | H : (_ && _)%bool = false |- _ =>
               apply Bool.andb_false_iff in H; destruct H
             end; Z.ltb_to_lt.
    all:try lia.
    all:apply Bool.andb_true_iff; split;
      Z.ltb_to_lt; try lia.
  Qed.

  Lemma is_bounded_by_bool_lor_bounds
        x x_bs y y_bs
        (Hboundedx : is_bounded_by_bool x x_bs = true)
        (Hboundedy : is_bounded_by_bool y y_bs = true)
    : is_bounded_by_bool (Z.lor x y) (ZRange.lor_bounds x_bs y_bs) = true.
  Proof. apply is_bounded_by_bool_land_lor_bounds_helper; auto. Qed.
End ZRange.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal4.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.
Derive Show for lst.

              Derive Arbitrary for lst.

              Instance Dec_Eq_lst : Dec_Eq lst.

              Proof. dec_eq. Qed.

Lemma conj15synthconj1 : forall  (lv0 : lst) (lv1 : natural), (@eq natural (len (append lv0 (Cons lv1 lv0))) (Succ (len (append lv0 (append Nil lv0))))).
Admitted.
QuickChick conj15synthconj1.


From isla Require Import opsem.

Definition a80000 : isla_trace :=
  WriteReg "R0" [] (RegVal_Base (Val_Bits (BV 64%N 0x100000%Z))) Mk_annot :t:
  Smt (DeclareConst 46%Z (Ty_BitVec 64%N)) Mk_annot :t:
  ReadReg "_PC" [] (RegVal_Base (Val_Symbolic 46%Z)) Mk_annot :t:
  Smt (DefineConst 47%Z (Manyop (Bvmanyarith Bvadd) [Val (Val_Symbolic 46%Z) Mk_annot; Val (Val_Bits (BV 64%N 0x4%Z)) Mk_annot] Mk_annot)) Mk_annot :t:
  WriteReg "_PC" [] (RegVal_Base (Val_Symbolic 47%Z)) Mk_annot :t:
  tnil
.


(**********************************************************************************

 The arrow category

 Contents
 1. Definition via two-sided displayed categories
 2. Discreteness and univalence
 3. It is a two-sided fibration

 **********************************************************************************)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.TwoSidedDispCat.
Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Isos.
Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Univalence.
Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Discrete.
Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.TwoSidedFibration.
Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.DisplayedFunctor.

Local Open Scope cat.

Section ArrowTwoSidedDispCat.
  Context (C : category).

  (**
   1. Definition via two-sided displayed categories
   *)
  Definition arrow_twosided_disp_cat_ob_mor
    : twosided_disp_cat_ob_mor C C.
  Proof.
    simple refine (_ ,, _).
    - exact (λ x y, x --> y).
    - exact (λ x₁ x₂ y₁ y₂ h₁ h₂ f g, f · h₂ = h₁ · g).
  Defined.

  Definition arrow_twosided_disp_cat_id_comp
    : twosided_disp_cat_id_comp arrow_twosided_disp_cat_ob_mor.
  Proof.
    split.
    - intros x y xy ; cbn.
      rewrite id_left, id_right.
      apply idpath.
    - intros x₁ x₂ x₃ y₁ y₂ y₃ xy₁ xy₂ xy₃ f₁ f₂ g₁ g₂ p q ; cbn in *.
      rewrite assoc'.
      rewrite q.
      rewrite !assoc.
      apply maponpaths_2.
      exact p.
  Qed.

  Definition arrow_twosided_disp_cat_data
    : twosided_disp_cat_data C C.
  Proof.
    simple refine (_ ,, _).
    - exact arrow_twosided_disp_cat_ob_mor.
    - exact arrow_twosided_disp_cat_id_comp.
  Defined.

  Definition isaprop_arrow_twosided_mor
             {x₁ x₂ : C}
             {y₁ y₂ : C}
             (xy₁ : arrow_twosided_disp_cat_data x₁ y₁)
             (xy₂ : arrow_twosided_disp_cat_data x₂ y₂)
             (f : x₁ --> x₂)
             (g : y₁ --> y₂)
    : isaprop (xy₁ -->[ f ][ g ] xy₂).
  Proof.
    apply homset_property.
  Qed.

  Definition arrow_twosided_disp_cat_axioms
    : twosided_disp_cat_axioms arrow_twosided_disp_cat_data.
  Proof.
    repeat split.
    - intro ; intros.
      apply isaprop_arrow_twosided_mor.
    - intro ; intros.
      apply isaprop_arrow_twosided_mor.
    - intro ; intros.
      apply isaprop_arrow_twosided_mor.
    - intro ; intros.
      apply isasetaprop.
      apply isaprop_arrow_twosided_mor.
  Qed.

  Definition arrow_twosided_disp_cat
    : twosided_disp_cat C C.
  Proof.
    simple refine (_ ,, _).
    - exact arrow_twosided_disp_cat_data.
    - exact arrow_twosided_disp_cat_axioms.
  Defined.

  (**
   2. Discreteness and univalence
   *)
  Definition arrow_twosided_disp_cat_is_iso
    : all_disp_mor_iso arrow_twosided_disp_cat.
  Proof.
    intro ; intros.
    simple refine (_ ,, _ ,, _) ; cbn in *.
    - use z_iso_inv_on_right.
      rewrite assoc.
      use z_iso_inv_on_left ; cbn.
      exact fg.
    - apply isaprop_arrow_twosided_mor.
    - apply isaprop_arrow_twosided_mor.
  Qed.

  Definition is_univalent_arrow_twosided_disp_cat
    : is_univalent_twosided_disp_cat arrow_twosided_disp_cat.
  Proof.
    intros x₁ x₂ y₁ y₂ p₁ p₂ xy₁ xy₂.
    induction p₁, p₂ ; cbn.
    use isweqimplimpl.
    - intros f.
      pose (p := pr1 f) ; cbn in p.
      rewrite id_left, id_right in p.
      exact (!p).
    - apply homset_property.
    - use isaproptotal2.
      + intro.
        apply isaprop_is_iso_twosided_disp.
      + intros.
        apply homset_property.
  Qed.

  Definition discrete_arrow_twosided_disp_cat
    : discrete_twosided_disp_cat arrow_twosided_disp_cat.
  Proof.
    repeat split.
    - intro ; intros.
      apply homset_property.
    - exact arrow_twosided_disp_cat_is_iso.
    - exact is_univalent_arrow_twosided_disp_cat.
  Qed.

  (**
   3. It is a two-sided fibration
   *)
  Definition arrow_twosided_opcleaving
    : twosided_opcleaving arrow_twosided_disp_cat.
  Proof.
    intros x₁ x₂ x₃ f g ; cbn in *.
    simple refine (f · g ,, _ ,, _) ; cbn.
    - apply id_left.
    - intros x₄ x₅ h k l p.
      use iscontraprop1.
      + use invproofirrelevance.
        intros φ₁ φ₂.
        use subtypePath.
        {
          intro.
          apply isaset_disp_mor.
        }
        apply isaprop_arrow_twosided_mor.
      + simple refine (_ ,, _).
        * cbn in *.
          rewrite id_left, assoc in p.
          exact p.
        * apply isaprop_arrow_twosided_mor.
  Qed.

  Definition arrow_twosided_cleaving
    : twosided_cleaving arrow_twosided_disp_cat.
  Proof.
    intros x₁ x₂ x₃ f g ; cbn in *.
    simple refine (g · f ,, _ ,, _) ; cbn.
    - rewrite id_right.
      apply idpath.
    - intros x₄ x₅ h k l p.
      use iscontraprop1.
      + use invproofirrelevance.
        intros φ₁ φ₂.
        use subtypePath.
        {
          intro.
          apply isaset_disp_mor.
        }
        apply isaprop_arrow_twosided_mor.
      + cbn in *.
        simple refine (_ ,, _).
        * rewrite id_right, assoc' in p.
          exact p.
        * apply isaprop_arrow_twosided_mor.
  Qed.

  Definition arrow_twosided_fibration
    : twosided_fibration arrow_twosided_disp_cat.
  Proof.
    simple refine (_ ,, _ ,, _).
    - exact arrow_twosided_opcleaving.
    - exact arrow_twosided_cleaving.
    - intro ; intros.
      apply arrow_twosided_disp_cat_is_iso.
  Defined.
End ArrowTwoSidedDispCat.

Section ArrowTwoSidedDispCatFunctor.
  Context {C : category}
          (D : discrete_twosided_fibration C C)
          (idD : ∏ (x : C), D x x)
          (f_idD : ∏ (x₁ x₂ : C) (f : x₁ --> x₂), idD x₁ -->[ f ][ f ] idD x₂).

  Definition arrow_to_discrete_twosided_fibration_data
    : twosided_disp_functor_data
        (functor_identity C) (functor_identity C)
        (arrow_twosided_disp_cat C) D.
  Proof.
    simple refine (_ ,, _).
    - exact (λ x y f, discrete_twosided_cleaving_ob _ (pr122 D) (idD y) f).
    - cbn ; intros x₁ x₂ y₁ y₂ g₁ g₂ f₁ f₂ p.
      use discrete_twosided_cleaving_cartesian.
      refine (transportb
                (λ z, _ -->[ z ][ _ ] _)
                p
                (transportb
                   (λ z, _ -->[ _ ][ z ] _)
                   (id_right _ @ !(id_left _))
                   (discrete_twosided_cleaving_mor (pr1 D) (pr122 D) (idD y₁) g₁ ;;2 _))).
      apply f_idD.
  Defined.

  Definition arrow_to_discrete_twosided_fibration_laws
    : twosided_disp_functor_laws
        _ _ _ _
        arrow_to_discrete_twosided_fibration_data.
  Proof.
    split ; intro ; intros ; apply D.
  Qed.

  Definition arrow_to_discrete_twosided_fibration
    : twosided_disp_functor
        (functor_identity C) (functor_identity C)
        (arrow_twosided_disp_cat C) D.
  Proof.
    simple refine (_ ,, _).
    - exact arrow_to_discrete_twosided_fibration_data.
    - exact arrow_to_discrete_twosided_fibration_laws.
  Defined.
End ArrowTwoSidedDispCatFunctor.


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*             Yannick Forster            [+]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(*                             [+] Affiliation Saarland Univ. *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

Require Import Definitions.
Require Import bsm_defs mm_defs eill ill.

Require Import PCP_BPCP BPCP_iBPCP iBPCP_BSM BSM_MM MM_EILL EILL_ILL.

(** * List of all results *)

(** Reduction results for the following problems:

    0) PCP: Post Correspondence Problem
    1) BPCP: Binary Post Correspondence Problem (see Definitions.v)
    2) BSM_HALTING: given a Binary Stack Machine P and an initial
       state st, starting at the first instruction of P with st
       as initial value for stacks, does the computation halt ?
       (see Bsm/bsm_defs.v)
    3) MM_HALTING: given a Minsky Machine P starting at instruction 1,
       and an initial state v (the initial values of registers),
       does the computation starting from (1,v) reach the state (0,vec_zero) ?
       (see Mm/mm_defs.v)
    4) EILL_PROVABILITY: given an EILL sequent (elementary fragment of ILL)
       is it provable in G_EILL ? (see Ll/eill.v)
    5) ILL_PROVABILITY: given a sequent of the (!,&,-o) fragment of ILL
       is it provable in G_ILL ? (see Ll/ill.v)
 *)

Check PCP_BPCP.                     Print Assumptions PCP_BPCP.
Check BPCP_iBPCP.                   Print Assumptions BPCP_iBPCP.
Check iBPCP_BSM_HALTING.            Print Assumptions iBPCP_BSM_HALTING.
Check BSM_MM_HALTING.               Print Assumptions BSM_MM_HALTING.
Check MM_HALTING_EILL_PROVABILITY.  Print Assumptions MM_HALTING_EILL_PROVABILITY.
Check EILL_ILL_PROVABILITY.         Print Assumptions EILL_ILL_PROVABILITY.

Theorem ILL_undec : PCP ⪯ ILL_PROVABILITY.
Proof.
  eapply reduces_transitive. exact PCP_BPCP.
  eapply reduces_transitive. exact BPCP_iBPCP.
  eapply reduces_transitive. exact iBPCP_BSM_HALTING.
  eapply reduces_transitive. exact BSM_MM_HALTING.
  eapply reduces_transitive. exact MM_HALTING_EILL_PROVABILITY.
  exact EILL_ILL_PROVABILITY.
Qed.

(** * Formal Undecidability *)

Module Def_of_undec.

  Inductive dec {X} (P : X -> Prop) : Prop := is_dec (H : forall x, { P x} + {~ P x}).

  Notation compl P := (fun x => ~ P x).

  Notation "Q ⪯T P" := (dec (P) -> dec (Q)) (at level 20).

  Lemma red_turing X Y (P : X -> Prop) (Q : Y -> Prop) : P ⪯ Q -> P ⪯T Q.
  Proof.
    intros (f & Hf) [ H ].
    exists.
    intros x; destruct (H (f x)) as [ H1 | H1 ];
      rewrite <- Hf in H1; tauto.
  Qed.

  (* Lemma red_turing_compl X Y (Q : Y -> Prop) (P : X -> Prop) : *)
  (*   Q ⪯ P -> compl Q ⪯T compl P. *)
  (* Proof. *)
  (*   intros [f] [d]. econstructor. intros x. *)
  (*   destruct (d (f x)). *)
  (*   + left. firstorder. *)
  (*   + right. firstorder. *)
  (* Qed. *)

  Inductive undec : forall X, (X -> Prop) -> Prop :=
    undec_seed : undec PCP
  | undec_red X (P : X -> Prop) Y (Q : Y -> Prop) : Q ⪯T P -> undec Q -> undec P.

  Lemma red_undec  X Y (Q : Y -> Prop) (P : X -> Prop) :
    Q ⪯ P -> undec Q -> undec P.
  Proof.
    intros. eapply undec_red. eapply red_turing; eauto. eauto.
  Qed.

  Lemma undec_compl X (P : X -> Prop) :
    undec (compl P) -> undec P.
  Proof.
    intros. eapply undec_red; try eassumption. firstorder.
  Qed.

  Lemma undec_PCP X (P : X -> Prop) :
    undec P <-> (PCP ⪯T P).
  Proof.
    split; intros.
    - induction H; eauto.
    - eauto using undec.
  Qed.

End Def_of_undec.


Require Import Iron.Language.SystemF2r.Step.
Require Import Iron.Language.SystemF2r.SubstExpExp.
Require Import Iron.Language.SystemF2r.SubstTypeExp.
Require Import Iron.Language.SystemF2r.SubstTypeType.
Require Import Iron.Language.SystemF2r.TyJudge.

(* When an expression takes a step the result has the same type. *)
Theorem preservation
 :  forall ke te x x' t
 ,  TYPE ke te x t
 -> STEP x x'
 -> TYPE ke te x' t.
Proof.
 intros ke te x x' t HT HS.
 gen ke te x' t.
 induction x; intros.

 Case "XVar".
  inverts HS.

 Case "XLAM".
  inverts HS.

 Case "XAPP".
  inverts HT.
  inverts keep HS.

  SCase "ESAPPLAM".
   inverts H3.
   eapply subst_type_exp in H4; eauto.
   rewrite substTE_liftTE in H4. auto.

  SCase "ESAPP1".
   apply TYAPP; eauto.

 Case "XLam".
  inverts HS.

 Case "XApp".
  inverts HT.
  inverts keep HS.

  SCase "ESAppLam".
   inverts H3.
   lets D: subst_exp_exp H9 H5. auto.

  SCase "EsApp1".
   eapply TYApp; eauto.

  SCase "EsApp2".
   eapply TYApp; eauto.
Qed.
Hint Resolve preservation.

(* When we multi-step evaluate some expression,
   then the result has the same type as the original. *)
Lemma preservation_steps
 :  forall x1 t1 x2
 ,  TYPE nil nil x1 t1
 -> STEPS x1 x2
 -> TYPE nil nil x2 t1.
Proof.
 intros. induction H0; burn.
Qed.
Hint Resolve preservation_steps.

(* When we multi-step evaluate some expression,
   then the result has the same type as the original.
   Using the left-linearised form for the evaluation. *)
Lemma preservation_stepsl
 :  forall x1 t1 x2
 ,  TYPE nil nil x1 t1
 -> STEPSL x1 x2
 -> TYPE nil nil x2 t1.
Proof.
 intros. induction H0; burn.
Qed.
Hint Resolve preservation_stepsl.


Require Export List.
Require Export Bool.
Require Export Arith.
Require Export Peano_dec.
Require Export Coq.Arith.PeanoNat.
Require Export Coq.Program.Wf.
Require Export Coq.Program.Tactics.
Require Export Coq.Logic.FunctionalExtensionality.
Require Export Recdef.

Require Import common.CpdtTactics.
Require Import common.wyv_common.
Require Import common.rhs_mat_tree.
Set Implicit Arguments.

Import WfExtensionality.

Lemma subtype_rfn_sel_sel_low_reduce :
  forall T1 x L Ts T, T1 = (t_rfn_sel x L Ts T) ->
                 forall T2 x L T', T2 = (t_sel_low x L T') ->
                              subtype T1 T2 = orb (subtype T1 T')
                                                  (subtype T T2).
Proof.
  intros.

  remember (subtype T1 T2) as sub_fn; subst T1 T2.

  unfold subtype, subtype_func in Heqsub_fn;
    simpl in Heqsub_fn;
    rewrite fix_sub_eq_ext in Heqsub_fn;
    simpl in Heqsub_fn;
    fold subtype_func in Heqsub_fn;
    auto.
Qed.