Require Export Structure.
Require Export Categories.Typ.

Module Proset.

Module obj.

Structure mixin_of T := Mixin {
  le: T -> T -> Prop;
  le_preorder: PreOrder le;
}.

Lemma mixin_eq {T} (c d: mixin_of T): c = d <-> forall x y, le T c x y <-> le T d x y.
Proof.
  split.
  now intros [].
  destruct c as [R1 H1], d as [R2 H2]; simpl.
  intros H.
  enough (R1 = R2); [subst R2|].
  f_equal; apply proof_irrelevance.
  extensionality x.
  extensionality y.
  apply propositional_extensionality.
  apply H.
Qed.

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

Notation class_of := mixin_of (only parsing).

Section ClassDef.
Local Coercion sort: type >-> Sortclass.

Variable (T: type).
Definition class := match T return mixin_of T with Pack _ c => c end.

Let xT := match T with Pack T _ => T end.
Notation xclass := (class: mixin_of xT).

End ClassDef.

Module Exports.
Coercion sort: type >-> Sortclass.

Definition le {T: type}: T -> T -> Prop := le T (class T).
Instance le_preorder {T: type}: PreOrder le := le_preorder T (class T).
Infix "<=" := le.

End Exports.
End obj.
Export obj.Exports.
Notation obj := obj.type.

Structure hom (S T: obj) := Hom {
  map: S -> T;
  monotone: forall x y, x <= y -> map x <= map y;
}.

Arguments map {S T} h s.
Arguments monotone {S T} h x y H.
Coercion map: hom >-> Funclass.

Lemma hom_eq {S T: obj} (f g: hom S T): f = g <-> forall x, f x = g x.
Proof.
  split.
  now intros [].
  destruct f as [f Hf], g as [g Hg]; simpl.
  intros H.
  enough (f = g); [subst g|].
  f_equal; apply proof_irrelevance.
  now extensionality x.
Qed.

Program Definition cat_mixin := Category.Mixin obj hom
  (fun P => {|
    map x := x;
    monotone x y H := H;
  |})
  (fun X Y Z f g => {|
    map x := f (g x);
    monotone x y H := monotone f _ _ (monotone g x y H);
  |}) _ _ _.
Next Obligation.
  now apply hom_eq.
Qed.
Next Obligation.
  now apply hom_eq.
Qed.
Canonical cat := Category.Pack obj cat_mixin.

Instance map_monotone S T f: Proper (le ==> le) (@map S T f) := monotone f.

Program Definition dual_mixin (P: obj) := obj.Mixin P (fun x y => y <= x) _.
Next Obligation.
  split.
  easy.
  intros x y z H1 H2.
  now transitivity y.
Qed.
Definition dual (P: obj) := obj.Pack P (dual_mixin P).

Program Definition dual_map {S T: obj} (f: S ~> T): dual S ~> dual T := {|
  map x := f x;
  monotone x y H := monotone f y x H;
|}.

Program Canonical Dual: Functor cat cat := {|
  fobj := dual;
  fmap := @dual_map;
|}.

Lemma dual_invol (P: obj): dual (dual P) = P.
Proof.
  destruct P as [T c].
  unfold dual; simpl.
  f_equal.
  now apply obj.mixin_eq.
Qed.

Lemma Dual_invol: Dual ∘ Dual = id cat.
Proof.
  fun_eq X Y f.
  apply dual_invol.
  apply hom_eq; simpl.
  revert H H0.
  destruct X as [X [R1 H1]], Y as [Y [R2 H2]], f as [f Hf]; simpl in *.
  unfold dual, dual_mixin, le; simpl.
  replace (dual_mixin_obligation_1
  (obj.Pack X
     {|
     obj.le := fun x y : X => R1 y x;
     obj.le_preorder := dual_mixin_obligation_1
                     (obj.Pack X
                     {|
                     obj.le := R1;
                     obj.le_preorder := H1 |}) |})) with H1
    by apply proof_irrelevance.
  replace (dual_mixin_obligation_1
  (obj.Pack Y
     {|
     obj.le := fun x y : Y => R2 y x;
     obj.le_preorder := dual_mixin_obligation_1
                     (obj.Pack Y
                     {|
                     obj.le := R2;
                     obj.le_preorder := H2 |}) |})) with H2
    by apply proof_irrelevance.
  intros H H0 x.
  now rewrite !eq_iso_refl.
Qed.

Program Definition empty_mixin := obj.Mixin Empty_set (fun _ _ => True) _.
Next Obligation. easy. Qed.
Canonical empty := obj.Pack Empty_set empty_mixin.

Program Definition botCat_mixin := BotCategory.Mixin cat empty
  (fun P => {|
    map := Empty_set_rect (fun _ => P);
  |}) _.
Next Obligation.
  contradiction.
Qed.
Next Obligation.
  now apply hom_eq.
Qed.
Canonical botCat := BotCategory.Pack cat botCat_mixin.

Program Definition unit_mixin := obj.Mixin unit (fun _ _ => True) _.
Next Obligation. easy. Qed.
Canonical unit := obj.Pack unit unit_mixin.

Program Definition topCat_mixin := TopCategory.Mixin cat unit
  (fun P => {|
    map _ := tt;
  |}) _.
Next Obligation.
  reflexivity.
Qed.
Next Obligation.
  apply hom_eq; simpl.
  intros x.
  now destruct (f x).
Qed.
Canonical topCat := TopCategory.Pack cat topCat_mixin.

Program Definition sum_mixin (A B: obj) := obj.Mixin (A + B) (fun p q =>
  match p, q with
  | inl x, inl y => x <= y
  | inr x, inr y => x <= y
  | inl _, inr _ | inr _, inl _ => False
  end) _.
Next Obligation.
  split.
  now intros [x | x].
  intros [x|x] [y|y] [z|z]; try easy.
  all: apply transitivity.
Qed.
Canonical sum (A B: obj) := obj.Pack (A + B) (sum_mixin A B).

Program Canonical inl {A B: obj} := {|
  map := @inl A B;
|}.

Program Canonical inr {A B: obj} := {|
  map := @inr A B;
|}.

Program Canonical merge {X Y Z: obj} (f: hom X Z) (g: hom Y Z) := {|
  map := sum_rect (fun _ => Z) f g;
|}.
Next Obligation.
  destruct x as [x|x], y as [y|y]; simpl.
  2, 3: contradiction.
  all: now apply monotone.
Qed.

Program Definition coprodCat_mixin := CoprodCategory.Mixin cat sum
  (@merge) (@inl) (@inr) _.
Next Obligation.
  split.
  + intros H.
    subst h.
    split.
    all: now apply hom_eq.
  + intros [].
    subst f g.
    apply hom_eq; simpl.
    now intros [].
Qed.
Canonical coprodCat := CoprodCategory.Pack cat coprodCat_mixin.

Program Definition prod_mixin (A B: obj) := obj.Mixin (A * B) (fun p q => fst p <= fst q /\ snd p <= snd q) _.
Next Obligation.
  split.
  + intros p.
    now split.
  + intros p q r H1 H2.
    split.
    now transitivity (fst q).
    now transitivity (snd q).
Qed.
Canonical prod (A B: obj) := obj.Pack (A * B) (prod_mixin A B).

Program Canonical fst {A B: obj} := {|
  map := @fst A B;
|}.
Next Obligation.
  apply H.
Qed.

Program Canonical snd {A B: obj} := {|
  map := @snd A B;
|}.
Next Obligation.
  apply H.
Qed.

Program Definition prodCat_mixin := ProdCategory.Mixin cat prod
  (fun X Y Z f g => {|
    map x := (f x, g x);
  |}) (@fst) (@snd) _.
Next Obligation.
  now split; simpl; apply monotone.
Qed.
Next Obligation.
  split.
  + intros H.
    subst h.
    split.
    all: now apply hom_eq.
  + intros [].
    subst f g.
    apply hom_eq; simpl.
    intros x.
    now destruct (h x).
Qed.
Canonical prodCat := ProdCategory.Pack cat prodCat_mixin.

Program Definition sigT_mixin {I} (F: I -> obj) := obj.Mixin (sigT F) (fun x y => exists (e: projT1 x = projT1 y), match e in _ = z return F z with eq_refl => projT2 x end <= projT2 y) _.
Next Obligation.
  split.
  + intros [i x].
    now exists eq_refl.
  + intros [i x] [j y] [k z] [e1 H1] [e2 H2]; simpl in *.
    subst j k.
    exists eq_refl.
    now transitivity y.
Qed.
Canonical sigT {I} (F: I -> obj) := obj.Pack (sigT F) (sigT_mixin F).

Program Canonical existT {I} (F: I -> obj) (i: I) := {|
  map := existT F i;
|}.
Next Obligation.
  now exists eq_refl.
Qed.

Program Canonical sigT_map {I} {P: obj} {F: I -> obj} (f: forall i, hom (F i) P) := {|
  map := sigT_rect (fun _ => P) f;
|}.
Next Obligation.
  destruct H as [e H]; simpl in *.
  subst y.
  now apply monotone.
Qed.

Program Definition scoprodCat_mixin := SCoprodCategory.Mixin cat (@sigT) (@sigT_map) (@existT) _.
Next Obligation.
  split.
  + intros H.
    subst g.
    intros i.
    now apply hom_eq.
  + intros H.
    apply functional_extensionality_dep in H.
    subst f.
    apply hom_eq; simpl.
    now intros [i x].
Qed.
Canonical scoprodCat := SCoprodCategory.Pack cat scoprodCat_mixin.

Program Definition Prod_mixin {I} (F: I -> obj) := obj.Mixin (forall i, F i) (fun f g => forall i, f i <= g i) _.
Next Obligation.
  split.
  easy.
  intros f g h H1 H2 i.
  now transitivity (g i).
Qed.
Definition Prod {I} (F: I -> obj) := obj.Pack (forall i, F i) (Prod_mixin F).

Program Definition sprodCat_mixin := SProdCategory.Mixin cat
  (@Prod)
  (fun I T F f => {|
    map x i := f i x;
  |})
  (fun I F i => {|
    map x := x i;
  |}) _.
Next Obligation.
  intros i.
  now apply monotone.
Qed.
Next Obligation.
  split.
  + intros H.
    subst g.
    intros i.
    now apply hom_eq.
  + intros H.
    apply functional_extensionality_dep in H.
    subst f.
    now apply hom_eq.
Qed.
Canonical sprodCat := SProdCategory.Pack cat sprodCat_mixin.

Definition cartCat_class := CartCategory.Class cat topCat_mixin prodCat_mixin.
Canonical cartCat := CartCategory.Pack cat cartCat_class.

Program Definition exp_mixin (T S: obj) := obj.Mixin (hom S T) (fun f g => forall x, f x <= g x) _.
Next Obligation.
  split.
  easy.
  intros f g h H1 H2 x.
  now transitivity (g x).
Qed.
Canonical exp (T S: obj) := obj.Pack (hom S T) (exp_mixin T S).

Program Definition expCat_mixin := ExpCategory.Mixin prodCat
  exp
  (fun T S => {|
    map p := fst p (snd p);
  |})
  (fun T S P => {|
    map (f: (P × S) ~> T) := {|
      map x := {|
        map y := f (x, y);
      |};
    |};
  |}) _.
Next Obligation.
  destruct H as [Hh Hs]; simpl in *.
  now rewrite Hs.
Qed.
Next Obligation.
  now apply monotone.
Qed.
Next Obligation.
  intros z; simpl.
  now apply monotone.
Qed.
Next Obligation.
  intros f z; simpl.
  apply H.
Qed.
Next Obligation.
  split.
  + intros H.
    subst f.
    apply hom_eq; simpl.
    intros a.
    now apply hom_eq; simpl.
  + intros H.
    subst g.
    apply hom_eq; simpl.
    now intros [].
Qed.
Definition expCat_class := ExpCategory.Class cat prodCat_mixin expCat_mixin.
Canonical expCat := ExpCategory.Pack cat expCat_class.

Definition CCC_class := CCC.Class cat cartCat_class expCat_mixin.
Canonical CCC := CCC.Pack cat CCC_class.

Program Canonical Forget: Functor cat Typ := {|
  fobj := obj.sort;
  fmap := @map;
|}.

Definition discrete_mixin T := obj.Mixin T eq _.
Definition discrete T := obj.Pack T (discrete_mixin T).

Definition discrete_map {S T} (f: S -> T) :=
  Hom (discrete S) (discrete T) f (f_equal f).

Program Canonical Discrete := {|
  fobj := discrete;
  fmap := @discrete_map;
|}.
Next Obligation.
  now apply hom_eq.
Qed.
Next Obligation.
  now apply hom_eq.
Qed.

Program Definition discreteU: id Typ ~> Forget ∘ Discrete := {|
  transform T x := x;
|}.

Program Definition discrete_counit (P: obj): discrete P ~> P := {|
  map x := x;
|}.
Next Obligation.
  now destruct H.
Qed.

Program Canonical discreteCU: Discrete ∘ Forget ~> id cat := {|
  transform := discrete_counit;
|}.
Next Obligation.
  now apply hom_eq.
Qed.

Lemma discrete_adjoint: adjoint_by Discrete Forget discreteU discreteCU.
Proof.
  apply adjoint_by_alt; split.
  + intros T.
    now apply hom_eq.
  + intros P.
    now extensionality x.
Qed.

Program Definition indiscrete_mixin T := obj.Mixin T (fun _ _ => True) _.
Next Obligation. easy. Qed.
Definition indiscrete T := obj.Pack T (indiscrete_mixin T).

Definition indiscrete_map {S T} (f: S -> T) :=
  Hom (indiscrete S) (indiscrete T) f (fun _ _ _ => I).

Program Canonical Indiscrete := {|
  fobj := indiscrete;
  fmap := @indiscrete_map;
|}.
Next Obligation.
  now apply hom_eq.
Qed.

Definition indiscrete_unit (P: obj): P ~> indiscrete P :=
  Hom P (indiscrete P) (fun x => x) (fun _ _ _ => I).

Program Canonical indiscreteU: id cat ~> Indiscrete ∘ Forget := {|
  transform := indiscrete_unit;
|}.

Program Definition indiscreteCU: Forget ∘ Indiscrete ~> id Typ := {|
  transform T x := x;
|}.

Lemma indiscrete_adjoint: adjoint_by Forget Indiscrete indiscreteU indiscreteCU.
Proof.
  apply adjoint_by_alt.
  split.
  + intros P.
    now extensionality x.
  + intros T.
    now apply hom_eq.
Qed.

Program Definition category_mixin (P: obj) := Category.Mixin P le reflexivity (fun _ _ _ f g => transitivity g f) _ _ _.
Next Obligation.
  apply proof_irrelevance.
Qed.
Next Obligation.
  apply proof_irrelevance.
Qed.
Next Obligation.
  apply proof_irrelevance.
Qed.
Canonical category (P: obj) := Category.Pack P (category_mixin P).
Coercion category: obj >-> Category.

Lemma chom_eq {P: obj} {x y: P} (f g: x ~> y): f = g.
Proof. exact (proof_irrelevance (le x y) f g). Qed.

Program Canonical hom_func {P Q: obj} (f: hom P Q) := {|
  fobj := f;
  fmap := monotone f;
|}.
Next Obligation.
  apply chom_eq.
Qed.
Next Obligation.
  apply chom_eq.
Qed.
Coercion hom_func: hom >-> Functor.

Program Canonical Cat: Functor cat Cat := {|
  fobj := category;
  fmap := @hom_func;
|}.
Next Obligation.
  now fun_eq x y f.
Qed.
Next Obligation.
  now fun_eq x y h.
Qed.

Program Definition conn_mixin (C: Category) := obj.Mixin C (fun x y => inhabited (x ~> y)) _.
Next Obligation.
  split.
  + intros x.
    constructor.
    exact (id x).
  + intros x y z [f] [g].
    constructor.
    exact (g ∘ f).
Qed.
Definition conn (C: Category) := obj.Pack C (conn_mixin C).

Program Definition conn_map {S T: Category} (F: Functor S T): conn S ~> conn T := {|
  map := F;
|}.
Next Obligation.
  destruct H as [f].
  constructor.
  exact (fmap F f).
Qed.

Program Canonical Conn: Functor Functor.Cat cat := {|
  fobj := conn;
  fmap := @conn_map;
|}.
Next Obligation.
  now apply hom_eq.
Qed.
Next Obligation.
  now apply hom_eq.
Qed.

Program Definition Conn_unit (C: Category): Functor C (conn C) := {|
  fobj x := x;
  fmap x y := @inhabits _;
|}.
Next Obligation.
  apply chom_eq.
Qed.
Next Obligation.
  apply chom_eq.
Qed.

Program Canonical ConnU: id Functor.Cat ~> Cat ∘ Conn := {|
  transform := Conn_unit;
|}.
Next Obligation.
  rename x into S, y into T, f into F.
  fun_eq x y f.
  apply chom_eq.
Qed.

Program Definition Conn_counit (P: obj): conn P ~> P := {|
  map x := x;
|}.
Next Obligation.
  now destruct H.
Qed.

Program Canonical ConnCU: Conn ∘ Cat ~> id cat := {|
  transform := Conn_counit;
|}.
Next Obligation.
  now apply hom_eq.
Qed.

Lemma Conn_adjoint: adjoint_by Conn Cat ConnU ConnCU.
Proof.
  apply adjoint_by_alt.
  split.
  + intros C.
    now apply hom_eq.
  + intros P.
    fun_eq x y f.
    apply chom_eq.
Qed.

Lemma iso_alt {P: obj} (x y: P): x ≃ y <-> x <= y /\ y <= x.
Proof.
  split.
  + intros [i].
    split.
    exact (to i).
    exact (from i).
  + intros [f g].
    constructor.
    exists f, g.
    all: apply chom_eq.
Qed.

Instance le_respect_iso (P: obj): Proper (isomorphic P ==> isomorphic P ==> iff) le.
Proof.
  enough (Proper (isomorphic P ==> isomorphic P ==> impl) le).
  now split; apply H.
  intros x1 x2 Hx y1 y2 Hy H.
  rewrite iso_alt in Hx, Hy.
  now rewrite (proj2 Hx), <- (proj1 Hy).
Qed.

Instance map_iso S T: Proper (isomorphic (exp T S) ==> isomorphic S ==> isomorphic T) (@map S T).
Proof.
  intros f g Hf x y Hx.
  apply iso_alt in Hf.
  apply iso_alt in Hx.
  apply iso_alt.
  split.
  1: rewrite <- (proj1 Hf y).
  2: rewrite (proj2 Hf y).
  all: now apply monotone.
Qed.

End Proset.

Export Proset.obj.Exports.
Notation Proset := Proset.cat.
Coercion Proset.map: Proset.hom >-> Funclass.
Coercion Proset.category: Proset.obj >-> Category.
Coercion Proset.hom_func: Proset.hom >-> Functor.
Canonical Proset.empty.
Canonical Proset.unit.
Canonical Proset.sum.
Canonical Proset.prod.
Canonical Proset.sigT.
Canonical Proset.inl.
Canonical Proset.inr.
Canonical Proset.merge.
Canonical Proset.fst.
Canonical Proset.snd.
Canonical Proset.existT.
Canonical Proset.sigT_map.
Canonical Proset.exp.
Canonical Proset.cat.
Canonical Proset.botCat.
Canonical Proset.topCat.
Canonical Proset.coprodCat.
Canonical Proset.prodCat.
Canonical Proset.scoprodCat.
Canonical Proset.sprodCat.
Canonical Proset.expCat.
Canonical Proset.cartCat.
Canonical Proset.CCC.

Canonical Proset.Forget.
Canonical Proset.Discrete.
Canonical Proset.discreteCU.
Canonical Proset.Indiscrete.
Canonical Proset.indiscreteU.
Canonical Proset.category.
Canonical Proset.hom_func.
Canonical Proset.Cat.
Canonical Proset.Conn.
Canonical Proset.ConnU.
Canonical Proset.ConnCU.

Module Poset.

Module obj.

Structure mixin_of (P: Proset.obj) := Mixin {
  le_antisym (x y: P): x <= y -> y <= x -> x = y;
}.

Lemma mixin_eq {P} (c d: mixin_of P): c = d.
Proof. apply proof_irrelevance. Qed.

Structure class_of T := Class {
  base: Proset.obj.mixin_of T;
  mixin: mixin_of (Proset.obj.Pack T base);
}.

Lemma class_eq {T} (c d: class_of T): c = d <-> forall x y, Proset.obj.le T (base T c) x y <-> Proset.obj.le T (base T d) x y.
Proof.
  rewrite <- Proset.obj.mixin_eq.
  split.
  now intros [].
  destruct c as [c Hc], d as [d Hd]; simpl.
  intros H.
  subst d.
  f_equal; apply proof_irrelevance.
Qed.

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

Section ClassDef.
Local Coercion base: class_of >-> Proset.obj.mixin_of.
Local Coercion mixin: class_of >-> mixin_of.
Local Coercion sort: type >-> Sortclass.

Variable (T: type).
Definition class := match T return class_of T with Pack _ c => c end.

Let xT := match T with Pack T _ => T end.
Notation xclass := (class: class_of xT).

Definition Proset := Proset.obj.Pack T xclass.

End ClassDef.

Module Exports.
Coercion base: class_of >-> Proset.obj.mixin_of.
Coercion mixin: class_of >-> mixin_of.
Coercion sort: type >-> Sortclass.
Coercion Proset: type >-> Proset.obj.
Canonical Proset.

Definition le_antisym {T: type}: forall x y: T, x <= y -> y <= x -> x = y := le_antisym T (class T).
Instance le_partialorder {T: type}: PartialOrder eq (@le T).
Proof.
  intros x y.
  change (x = y <-> x <= y /\ y <= x).
  split.
  now intros [].
  intros [].
  now apply le_antisym.
Qed.

End Exports.
End obj.
Export obj.Exports.
Notation obj := obj.type.

Definition cat_mixin := Category.Mixin obj Proset.hom
  (@id Proset) (@comp Proset) (@comp_assoc Proset) (@comp_id_l Proset) (@comp_id_r Proset).
Canonical cat := Category.Pack obj cat_mixin.

Program Definition dual_mixin (P: obj) := obj.Mixin (Proset.dual P) _.
Next Obligation.
  now apply le_antisym.
Qed.
Definition dual_class (P: obj) := obj.Class P (Proset.dual_mixin P) (dual_mixin P).
Definition dual (P: obj) := obj.Pack P (dual_class P).

Program Definition Dual: Functor cat cat := {|
  fobj := dual;
  fmap := @Proset.dual_map;
|}.

Lemma dual_invol (P: obj): dual (dual P) = P.
Proof.
  destruct P as [T c].
  unfold dual; simpl.
  f_equal.
  now apply obj.class_eq.
Qed.

Program Definition empty_mixin := obj.Mixin Proset.empty _.
Next Obligation. easy. Qed.
Definition empty_class := obj.Class Empty_set Proset.empty_mixin empty_mixin.
Canonical empty := obj.Pack Empty_set empty_class.

Program Definition botCat_mixin := BotCategory.Mixin cat empty
  (fun P => {|
    Proset.map := Empty_set_rect (fun _ => P);
  |}) _.
Next Obligation.
  contradiction.
Qed.
Next Obligation.
  now apply Proset.hom_eq.
Qed.
Canonical botCat := BotCategory.Pack cat botCat_mixin.

Program Definition unit_mixin := obj.Mixin Proset.unit _.
Next Obligation.
  now destruct x, y.
Qed.
Definition unit_class := obj.Class unit Proset.unit_mixin unit_mixin.
Canonical unit := obj.Pack unit unit_class.

Program Definition topCat_mixin := TopCategory.Mixin cat unit
  (fun P => {|
    Proset.map _ := tt;
  |}) _.
Next Obligation.
  reflexivity.
Qed.
Next Obligation.
  apply Proset.hom_eq; simpl.
  intros x.
  now destruct (f x).
Qed.
Canonical topCat := TopCategory.Pack cat topCat_mixin.

Program Definition sum_mixin (A B: obj) := obj.Mixin (Proset.sum A B) _.
Next Obligation.
  destruct x as [x|x], y as [y|y]; simpl in *.
  2, 3: contradiction.
  all: f_equal.
  all: now apply le_antisym.
Qed.
Definition sum_class (A B: obj) := obj.Class (A + B) (Proset.sum_mixin A B) (sum_mixin A B).
Canonical sum (A B: obj) := obj.Pack (A + B) (sum_class A B).

Program Definition coprodCat_mixin := CoprodCategory.Mixin cat sum
  (@Proset.merge) (@Proset.inl) (@Proset.inr) _.
Next Obligation.
  split.
  + intros H.
    subst h.
    split.
    all: now apply Proset.hom_eq.
  + intros [].
    subst f g.
    apply Proset.hom_eq; simpl.
    now intros [].
Qed.
Canonical coprodCat := CoprodCategory.Pack cat coprodCat_mixin.

Program Definition prod_mixin (A B: obj) := obj.Mixin (Proset.prod A B) _.
Next Obligation.
  f_equal.
  all: apply le_antisym.
  1, 3: apply H.
  all: apply H0.
Qed.
Definition prod_class (A B: obj) := obj.Class (A * B) (Proset.prod_mixin A B) (prod_mixin A B).
Canonical prod (A B: obj) := obj.Pack (A * B) (prod_class A B).

Program Definition prodCat_mixin := ProdCategory.Mixin cat prod
  (fun X Y Z f g => {|
    Proset.map x := (f x, g x);
  |}) (@Proset.fst) (@Proset.snd) _.
Next Obligation.
  now split; simpl; apply Proset.monotone.
Qed.
Next Obligation.
  split.
  + intros H.
    subst h.
    split.
    all: now apply Proset.hom_eq.
  + intros [].
    subst f g.
    apply Proset.hom_eq; simpl.
    intros x.
    now destruct (h x).
Qed.
Canonical prodCat := ProdCategory.Pack cat prodCat_mixin.

Program Definition sigT_mixin {I} (F: I -> obj) := obj.Mixin (Proset.sigT F) _.
Next Obligation.
  destruct H as [e H1], H0 as [e1 H2]; simpl in *.
  subst y.
  rewrite (proof_irrelevance _ e1 eq_refl) in H2; clear e1.
  f_equal.
  now apply le_antisym.
Qed.
Definition sigT_class {I} (F: I -> obj) := obj.Class (sigT F) (Proset.sigT_mixin F) (sigT_mixin F).
Canonical sigT {I} (F: I -> obj) := obj.Pack (sigT F) (sigT_class F).

Program Definition scoprodCat_mixin := SCoprodCategory.Mixin cat (@sigT) (@Proset.sigT_map) (@Proset.existT) _.
Next Obligation.
  split.
  + intros H.
    subst g.
    intros i.
    now apply Proset.hom_eq.
  + intros H.
    apply functional_extensionality_dep in H.
    subst f.
    apply Proset.hom_eq; simpl.
    now intros [i x].
Qed.
Canonical scoprodCat := SCoprodCategory.Pack cat scoprodCat_mixin.

Program Definition Prod_mixin {I} (F: I -> obj) := obj.Mixin (Proset.Prod F) _.
Next Obligation.
  extensionality i.
  now apply le_antisym.
Qed.
Definition Prod_class {I} (F: I -> obj) := obj.Class (forall i, F i) (Proset.Prod_mixin F) (Prod_mixin F).
Definition Prod {I} (F: I -> obj) := obj.Pack (forall i, F i) (Prod_class F).

Program Definition sprodCat_mixin := SProdCategory.Mixin cat
  (@Prod)
  (fun I T F f => {|
    Proset.map x i := f i x;
  |})
  (fun I F i => {|
    Proset.map x := x i;
  |}) _.
Next Obligation.
  intros i.
  now apply Proset.monotone.
Qed.
Next Obligation.
  split.
  + intros H.
    subst g.
    intros i.
    now apply Proset.hom_eq.
  + intros H.
    apply functional_extensionality_dep in H.
    subst f.
    now apply Proset.hom_eq.
Qed.
Canonical sprodCat := SProdCategory.Pack cat sprodCat_mixin.

Definition cartCat_class := CartCategory.Class cat topCat_mixin prodCat_mixin.
Canonical cartCat := CartCategory.Pack cat cartCat_class.

Program Definition exp_mixin (T S: obj) := obj.Mixin (Proset.exp T S) _.
Next Obligation.
  apply Proset.hom_eq.
  intros i.
  now apply le_antisym.
Qed.
Definition exp_class (T S: obj) := obj.Class (Proset.hom S T) (Proset.exp_mixin T S) (exp_mixin T S).
Canonical exp (T S: obj) := obj.Pack (Proset.hom S T) (exp_class T S).

Program Definition expCat_mixin := ExpCategory.Mixin prodCat
  exp
  (fun T S => {|
    Proset.map p := fst p (snd p);
  |})
  (fun T S P => {|
    Proset.map (f: (P × S) ~> T) := {|
      Proset.map x := {|
        Proset.map y := f (x, y);
      |};
    |};
  |}) _.
Next Obligation.
  destruct H as [Hh Hs]; simpl in *.
  now rewrite Hs.
Qed.
Next Obligation.
  now apply Proset.monotone.
Qed.
Next Obligation.
  intros z; simpl.
  now apply Proset.monotone.
Qed.
Next Obligation.
  intros f z; simpl.
  apply H.
Qed.
Next Obligation.
  split.
  + intros H.
    subst f.
    apply Proset.hom_eq; simpl.
    intros a.
    now apply Proset.hom_eq; simpl.
  + intros H.
    subst g.
    apply Proset.hom_eq; simpl.
    now intros [].
Qed.
Definition expCat_class := ExpCategory.Class cat prodCat_mixin expCat_mixin.
Canonical expCat := ExpCategory.Pack cat expCat_class.

Definition CCC_class := CCC.Class cat cartCat_class expCat_mixin.
Canonical CCC := CCC.Pack cat CCC_class.

Definition forget_map {S T: obj} (f: S ~> T): obj.Proset S ~> T := f.

Program Canonical Forget: Functor cat Proset := {|
  fobj := obj.Proset;
  fmap := @forget_map;
|}.

Structure strict (P: Proset) := {
  sclass: P -> Prop;
  sclass_correct: exists x, forall y, sclass y <-> x ≃ y;
}.

Arguments sclass {P} s p.
Arguments sclass_correct {P} s.
Coercion sclass: strict >-> Funclass.

Program Definition strictObj {P: Proset} (x: P) := {|
  sclass y := x ≃ y;
|}.
Next Obligation.
  now exists x.
Qed.

Lemma strict_eq {P: Proset} (X Y: strict P): X = Y <-> forall x, X x <-> Y x.
Proof.
  split.
  now intros [].
  destruct X as [X HX], Y as [Y HY]; simpl.
  intros H.
  enough (X = Y); [subst Y|].
  f_equal; apply proof_irrelevance.
  extensionality x.
  apply propositional_extensionality.
  apply H.
Qed.

Lemma strictObj_eq {P: Proset} (X: strict P) (x: P): X = strictObj x <-> X x.
Proof.
  split.
  + intros HX.
    now subst X; simpl.
  + intros Hx.
    apply strict_eq.
    intros z; simpl.
    destruct (sclass_correct X) as [y Hy].
    rewrite Hy.
    f_equiv.
    now apply Hy.
Qed.

Lemma strictObj_surj {P: Proset} (X: strict P): exists x, strictObj x = X.
Proof.
  destruct (sclass_correct X) as [x Hx].
  exists x.
  symmetry.
  now apply strictObj_eq, Hx.
Qed.

Program Definition strict_pro_mixin (P: Proset) := Proset.obj.Mixin (strict P) (fun X Y => forall x y, X x -> Y y -> x <= y) _.
Next Obligation.
  split.
  + intros X x y Hx Hy.
    destruct (sclass_correct X) as [z Hz].
    rewrite <- (proj1 (Hz x) Hx).
    rewrite <- (proj1 (Hz y) Hy).
    reflexivity.
  + intros X Y Z H1 H2 x z Hx Hz.
    destruct (sclass_correct Y) as [y Hy].
    specialize (Hy y).
    apply proj2 in Hy.
    specialize (Hy (reflexivity y)).
    transitivity y.
    now apply H1.
    now apply H2.
Qed.
Canonical strict_pro (P: Proset) := Proset.obj.Pack (strict P) (strict_pro_mixin P).

Program Definition strict_po_mixin (P: Proset) := obj.Mixin (strict_pro P) _.
Next Obligation.
  rename x into X, y into Y.
  destruct (strictObj_surj X) as [x HX].
  destruct (strictObj_surj Y) as [y HY].
  subst X Y.
  apply strictObj_eq, Proset.iso_alt.
  split.
  now apply H; simpl.
  now apply H0; simpl.
Qed.
Definition strict_po_class (P: Proset) := obj.Class (strict P) (strict_pro_mixin P) (strict_po_mixin P).
Canonical strict_po (P: Proset) := obj.Pack (strict P) (strict_po_class P).

Program Definition strict_map {S T: Proset} (f: S ~> T) (X: strict S): strict T := {|
  sclass y := forall x, X x -> f x ≃ y;
|}.
Next Obligation.
  destruct (strictObj_surj X) as [x HX].
  subst X.
  exists (f x).
  intros y.
  split.
  + intros Hy.
    now apply Hy; simpl.
  + intros Hy z Hz; simpl in Hz.
    rewrite <- Hy.
    now apply Proset.map_iso.
Qed.

Lemma strict_map_obj {S T: Proset} (f: S ~> T) (x: S): strict_map f (strictObj x) = strictObj (f x).
Proof.
  apply strictObj_eq; simpl.
  intros y H.
  now apply Proset.map_iso.
Qed.

Program Canonical Strict_map {S T: Proset} (f: S ~> T): strict_pro S ~> strict_pro T := {|
  Proset.map := strict_map f;
|}.
Next Obligation.
  rename x into X, y into Y.
  destruct (strictObj_surj X) as [x HX].
  destruct (strictObj_surj Y) as [y HY].
  subst X Y.
  rewrite !strict_map_obj.
  intros a b H1 H2; simpl in *.
  rewrite <- H1, <- H2.
  now apply Proset.monotone, H; simpl.
Qed.

Program Canonical Strict := {|
  fobj := strict_po;
  fmap := @Strict_map;
|}.
Next Obligation.
  apply Proset.hom_eq.
  intros X.
  destruct (strictObj_surj X) as [x HX].
  subst X.
  apply strict_map_obj.
Qed.
Next Obligation.
  apply Proset.hom_eq.
  intros X.
  destruct (strictObj_surj X) as [x HX].
  subst X; simpl.
  now rewrite !strict_map_obj.
Qed.

Program Canonical strict_unit (P: Proset): P ~> strict_pro P := {|
  Proset.map := strictObj;
|}.
Next Obligation.
  intros a b H1 H2; simpl in *.
  now rewrite <- H1, <- H2.
Qed.

Program Canonical strictU: id Proset ~> Forget ∘ Strict := {|
  transform := strict_unit;
|}.
Next Obligation.
  apply Proset.hom_eq; simpl.
  intros z.
  symmetry.
  apply strict_map_obj.
Qed.

Lemma strict_inhabited {P: Proset} (X: strict P): inhabited P.
Proof. now destruct (strictObj_surj X) as [x Hx]. Qed.

Definition strictStrong {P: obj} (X: strict P): P :=
  epsilon (strict_inhabited X) X.

Lemma strictStrong_spec {P: obj} (X: strict P): X (strictStrong X).
Proof.
  unfold strictStrong.
  apply epsilon_spec.
  destruct (strictObj_surj X) as [x Hx].
  subst X.
  now exists x; simpl.
Qed.

Lemma strictStrong_obj {P: obj} (x: P): strictStrong (strictObj x) = x.
Proof.
  apply le_antisym.
  all: apply Proset.iso_alt.
  2: symmetry.
  all: apply (strictStrong_spec (strictObj x)).
Qed.

Program Canonical strict_counit (P: obj): strict_pro P ~> P := {|
  Proset.map := strictStrong;
|}.
Next Obligation.
  rename x into X, y into Y.
  destruct (strictObj_surj X) as [x HX].
  destruct (strictObj_surj Y) as [y HY].
  subst X Y.
  rewrite !strictStrong_obj.
  now apply H; simpl.
Qed.

Program Canonical strictCU: Strict ∘ Forget ~> id cat := {|
  transform := strict_counit;
|}.
Next Obligation.
  apply Proset.hom_eq.
  intros X; simpl.
  destruct (strictObj_surj X) as [z HX].
  subst X.
  rewrite strict_map_obj, !strictStrong_obj.
  reflexivity.
Qed.

Lemma strict_adjoint: adjoint_by Strict Forget strictU strictCU.
Proof.
  apply adjoint_by_alt.
  split.
  + intros P.
    apply Proset.hom_eq.
    intros X; simpl in *.
    destruct (strictObj_surj X) as [x HX].
    subst X.
    now rewrite strict_map_obj, strictStrong_obj.
  + intros P.
    apply Proset.hom_eq; simpl.
    apply strictStrong_obj.
Qed.

End Poset.

Export Poset.obj.Exports.
Notation Poset := Poset.cat.
Canonical Poset.empty.
Canonical Poset.unit.
Canonical Poset.sum.
Canonical Poset.prod.
Canonical Poset.sigT.
Canonical Poset.exp.
Canonical Poset.cat.
Canonical Poset.botCat.
Canonical Poset.topCat.
Canonical Poset.coprodCat.
Canonical Poset.prodCat.
Canonical Poset.scoprodCat.
Canonical Poset.sprodCat.
Canonical Poset.expCat.
Canonical Poset.cartCat.
Canonical Poset.CCC.

Canonical Poset.Forget.

Definition is_proset (C: Category) :=
  forall (x y: C) (f g: x ~> y), f = g.

Definition is_directed (C: Category) :=
  forall x y: C, x ~> y -> y ~> x -> x = y.

Definition is_poset (C: Category) :=
  is_proset C /\ is_directed C.

Lemma Proset_correct (P: Proset): is_proset P.
Proof.
  intros x y f g.
  apply Proset.chom_eq.
Qed.

Lemma Poset_correct (P: Poset.obj): is_poset P.
Proof.
  split.
  apply Proset_correct.
  intros x y f g.
  now apply le_antisym.
Qed.

Lemma proset_ex (C: Category): is_proset C -> Proset.category (Proset.Conn C) ≃ C.
Proof.
  intros H.
  assert (inhabited (forall (x y: C) (f: @hom (Proset.Conn C) x y), x ~> y)).
    apply inhabit_forall.
    intros x.
    apply inhabit_forall.
    intros y.
    apply inhabit_forall.
    intros f.
    exact f.
  destruct H0 as [F].
  constructor.
  unshelve eexists.
  1: exists (fun x: Proset.Conn C => x: C) F.
  3: exists (Proset.ConnU C).
  3, 4: fun_eq x y f.
  all: intros.
  3: apply Proset.chom_eq.
  all: apply H.
Qed.

Lemma dual_proset (P: Proset): co P = Proset.dual P.
Proof.
  unfold co, Proset.dual, Proset.category; simpl.
  f_equal.
  apply cat_mixin_eq; simpl.
  repeat split.
  intros x e.
  apply proof_irrelevance.
  intros x y z f g e1 e2 e3.
  apply proof_irrelevance.
Qed.

Lemma dual_poset (P: Poset): co P = Poset.dual P.
Proof. apply dual_proset. Qed.


Set Implicit Arguments.

Require Import Platform.AutoSep.
Require Import Platform.Facade.examples.FiatADTs.
Import Adt.
Require Import Platform.Cito.RepInv.

Require Import Platform.Facade.examples.FiniteSetF Platform.Facade.examples.ListSetF Platform.Facade.examples.SeqF Platform.Facade.examples.ListSeqF.

Definition rep_inv p adtvalue : HProp :=
  match adtvalue with
    | List ls => lseq ls p
    | Junk _ => [| False |]
    | FEnsemble s => lset s p
  end%Sep.

Module Ri <: RepInv FiatADTs.Adt.

  Definition RepInv := W -> ADTValue -> HProp.

  Definition rep_inv := rep_inv.

  Lemma rep_inv_ptr : forall p a, rep_inv p a ===> p =?> 1 * any.
    destruct a; simpl.
    eapply Himp_trans; [ apply lseq_fwd | sepLemma ]; apply any_easy.
    sepLemma.
    eapply Himp_trans; [ apply lset_fwd | sepLemma ]; apply any_easy.
  Qed.

End Ri.


(* Copyright © 1998-2006
 * Henk Barendregt
 * Luís Cruz-Filipe
 * Herman Geuvers
 * Mariusz Giero
 * Rik van Ginneken
 * Dimitri Hendriks
 * Sébastien Hinderer
 * Bart Kirkels
 * Pierre Letouzey
 * Iris Loeb
 * Lionel Mamane
 * Milad Niqui
 * Russell O’Connor
 * Randy Pollack
 * Nickolay V. Shmyrev
 * Bas Spitters
 * Dan Synek
 * Freek Wiedijk
 * Jan Zwanenburg
 *
 * This work is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2 of the License, or
 * (at your option) any later version.
 *
 * This work is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License along
 * with this work; if not, write to the Free Software Foundation, Inc.,
 * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
 *)

(* begin hide *)
Require Export CoRN.algebra.CFields.
Require Export CoRN.tactics.AlgReflection.

Section Field_Interpretation_Function.

Variable F : CField.
Variable val : varindex -> F.
Variable unop : unopindex -> CSetoid_un_op F.
Variable binop : binopindex -> CSetoid_bin_op F.
Variable pfun : pfunindex -> PartFunct F.

Inductive interpF : expr -> F -> CProp :=
  | interpF_var :
      forall (i:varindex) (z:F), (val i[=]z) -> interpF (expr_var i) z
  | interpF_int : forall (k:Z) (z:F), (zring k[=]z) -> interpF (expr_int k) z
  | interpF_plus :
      forall (e f:expr) (x y z:F),
        (x[+]y[=]z) ->
        interpF e x -> interpF f y -> interpF (expr_plus e f) z
  | interpF_mult :
      forall (e f:expr) (x y z:F),
        (x[*]y[=]z) ->
        interpF e x -> interpF f y -> interpF (expr_mult e f) z
  | interpF_unop :
      forall (e:expr) (f:unopindex) (x z:F),
        (unop f x[=]z) -> interpF e x -> interpF (expr_unop f e) z
  | interpF_binop :
      forall (e e':expr) (f:binopindex) (x y z:F),
        (binop f x y[=]z) ->
        interpF e x -> interpF e' y -> interpF (expr_binop f e e') z
  | interpF_part :
      forall (e:expr) (f:pfunindex) (x z:F) (Hx:Dom (pfun f) x),
        (pfun f x Hx[=]z) -> interpF e x -> interpF (expr_part f e) z
  | interpF_div :
      forall (e f:expr) (x y z:F) (nzy:y[#][0]),
        ((x[/]y[//]nzy)[=]z) ->
        interpF e x -> interpF f y -> interpF (expr_div e f) z.

Definition wfF (e:expr) := sigT (interpF e).

Inductive xexprF : F -> Type :=
  | xexprF_var : forall i:varindex, xexprF (val i)
  | xexprF_int : forall k:Z, xexprF (zring k)
  | xexprF_plus : forall (x y:F) (e:xexprF x) (f:xexprF y), xexprF (x[+]y)
  | xexprF_mult : forall (x y:F) (e:xexprF x) (f:xexprF y), xexprF (x[*]y)
  | xexprF_unop : forall (x:F) (f:unopindex) (e:xexprF x), xexprF (unop f x)
  | xexprF_binop :
      forall (x y:F) (f:binopindex) (e:xexprF x) (e':xexprF y),
        xexprF (binop f x y)
  | xexprF_part :
      forall (x:F) (f:pfunindex) (e:xexprF x) (Hx:Dom (pfun f) x),
        xexprF (pfun f x Hx)
  | xexprF_div :
      forall (x y
              (* more things rrational translates: *)
              :F) (e:xexprF x) (f:xexprF y) (nzy:y[#][0]),
        xexprF (x[/]y[//]nzy)
  | xexprF_zero : xexprF [0]
  | xexprF_one : xexprF [1]
  | xexprF_nat : forall n:nat, xexprF (nring n)
  | xexprF_inv : forall (x:F) (e:xexprF x), xexprF [--]x
  | xexprF_minus : forall (x y:F) (e:xexprF x) (f:xexprF y), xexprF (x[-]y)
  | xexprF_power : forall (x:F) (e:xexprF x) (n:nat), xexprF (x[^]n).

Fixpoint xforgetF (x:F) (e:xexprF x) {struct e} : expr :=
  match e with
  | xexprF_var i => expr_var i
  | xexprF_int k => expr_int k
  | xexprF_plus _ _ e f => expr_plus (xforgetF _ e) (xforgetF _ f)
  | xexprF_mult _ _ e f => expr_mult (xforgetF _ e) (xforgetF _ f)
  | xexprF_unop _ f e => expr_unop f (xforgetF _ e)
  | xexprF_binop _ _ f e e' => expr_binop f (xforgetF _ e) (xforgetF _ e')
  | xexprF_part _ f e _ => expr_part f (xforgetF _ e)
  | xexprF_div _ _ e f _ => expr_div (xforgetF _ e) (xforgetF _ f)
  | xexprF_zero => expr_zero
  | xexprF_one => expr_one
  | xexprF_nat n => expr_nat n
  | xexprF_inv _ e => expr_inv (xforgetF _ e)
  | xexprF_minus _ _ e f => expr_minus (xforgetF _ e) (xforgetF _ f)
  | xexprF_power _ e n => expr_power n (xforgetF _ e)
  end.

Definition xinterpF (x:F) (e:xexprF x) := x.

Lemma xexprF2interpF : forall (x:F) (e:xexprF x), interpF (xforgetF _ e) x.
Proof.
 intros x e.
 induction e.
              apply (interpF_var i); algebra.
             apply (interpF_int k); algebra.
            apply (interpF_plus (xforgetF _ e1) (xforgetF _ e2) x y (x[+]y)); algebra.
           apply (interpF_mult (xforgetF _ e1) (xforgetF _ e2) x y (x[*]y)); algebra.
          apply (interpF_unop (xforgetF _ e) f x (unop f x)); algebra.
         apply (interpF_binop (xforgetF _ e1) (xforgetF _ e2) f x y (binop f x y)); algebra.
        eapply (interpF_part (xforgetF _ e) f x (pfun f x Hx)).
         apply eq_reflexive_unfolded.
        algebra.
       apply (interpF_div (xforgetF _ e1) (xforgetF _ e2) x y (x[/]y[//]nzy) nzy); algebra.
      apply (interpF_int 0); algebra.
     apply (interpF_int 1); Step_final ([1]:F).
    apply (interpF_int (Z_of_nat n)); algebra.
   apply (interpF_mult (xforgetF _ e) (expr_int (-1)) x (zring (-1)) [--]x); auto.
    Step_final (zring (-1)[*]x).
   apply (interpF_int (-1)); algebra.
  apply (interpF_plus (xforgetF _ e1) (xforgetF _ (xexprF_inv _ e2)) x [--]y (x[-]y)); algebra.
  apply (interpF_mult (xforgetF _ e2) (expr_int (-1)) y (zring (-1)) [--]y); auto.
   Step_final (zring (-1)[*]y).
  apply (interpF_int (-1)); algebra.
 induction n.
  apply (interpF_int 1); Step_final ([1]:F).
 apply (interpF_mult (xforgetF _ e) (expr_power n (xforgetF _ e)) x ( x[^]n) (x[^]S n)); algebra.
Qed.

Definition xexprF_diagram_commutes :
  forall (x:F) (e:xexprF x), interpF (xforgetF _ e) (xinterpF _ e) :=
  xexprF2interpF.

Lemma xexprF2wfF : forall (x:F) (e:xexprF x), wfF (xforgetF _ e).
Proof.
 intros x e.
 exists x.
 apply xexprF2interpF.
Qed.

Record fexprF : Type :=  {finterpF : F; fexprF2xexprF : xexprF finterpF}.

Definition fexprF_var (i:varindex) := Build_fexprF _ (xexprF_var i).
Definition fexprF_int (k:Z) := Build_fexprF _ (xexprF_int k).
Definition fexprF_plus (e e':fexprF) :=
  Build_fexprF _
    (xexprF_plus (finterpF e) (finterpF e') (fexprF2xexprF e)
       (fexprF2xexprF e')).
Definition fexprF_mult (e e':fexprF) :=
  Build_fexprF _
    (xexprF_mult (finterpF e) (finterpF e') (fexprF2xexprF e)
       (fexprF2xexprF e')).

Definition fforgetF (e:fexprF) := xforgetF (finterpF e) (fexprF2xexprF e).

Lemma fexprF2interpF : forall e:fexprF, interpF (fforgetF e) (finterpF e).
Proof.
 intros e.
 elim e. intros x e'.
 unfold fforgetF in |- *. simpl in |- *.
 apply xexprF2interpF.
Qed.

Lemma fexprF2wfF : forall e:fexprF, wfF (fforgetF e).
Proof.
 intro e.
 unfold fforgetF in |- *.
 apply xexprF2wfF.
Qed.

Load "Opaque_algebra".

Lemma refl_interpF :
 forall (e:expr) (x y:F), interpF e x -> interpF e y -> x[=]y.
Proof.
 intro e.
 induction e.
        intros x y Hx Hy.
        inversion Hx.
        inversion Hy.
        Step_final (val v).
       intros x y Hx Hy.
       inversion Hx.
       inversion Hy.
       Step_final (zring z:F).
      intros x y H1 H2.
      inversion H1.
      inversion H2.
      astepl (x0[+]y0).
      Step_final (x1[+]y1).
     intros x y H1 H2.
     inversion H1.
     inversion H2.
     astepl (x0[*]y0).
     Step_final (x1[*]y1).
    intros x y H0 H1.
    inversion H0.
    inversion H1.
    astepl (x0[/]y0[//]nzy). Step_final (x1[/]y1[//]nzy0).
    intros x y H0 H1.
   inversion H0.
   inversion H1.
   astepl (unop u x0); Step_final (unop u x1).
  intros x y H0 H1.
  inversion H0.
  inversion H1.
  astepl (binop b x0 y0); Step_final (binop b x1 y1).
 intros x y H0 H1.
 inversion H0.
 inversion H1.
 astepl (pfun p x0 Hx); Step_final (pfun p x1 Hx0).
Qed.

Lemma interpF_wd :
 forall (e:expr) (x y:F), interpF e x -> (x[=]y) -> interpF e y.
Proof.
 intros e x y H H0.
 inversion H; try (rewrite <- H2; rewrite H3 in H1). (* Compat 8.0 *)
        apply interpF_var. Step_final x.
        apply interpF_int. Step_final x.
       apply interpF_plus with x0 y0; auto. Step_final x.
      apply interpF_mult with x0 y0; auto. Step_final x.
     apply interpF_unop with x0; auto. Step_final x.
    apply interpF_binop with x0 y0; auto. Step_final x.
   apply interpF_part with x0 Hx; auto. Step_final x.
  apply interpF_div with x0 y0 nzy; auto. Step_final x.
Qed.

End Field_Interpretation_Function.

Section Field_NormCorrect.

Variable F : CField.
Variable val : varindex -> F.
Variable unop : unopindex -> CSetoid_un_op F.
Variable binop : binopindex -> CSetoid_bin_op F.
Variable pfun : pfunindex -> PartFunct F.

Notation II := (interpF F val unop binop pfun).

(*
four kinds of exprs:

  I	(expr_int _)
  V	(expr_var _)
  M	(expr_mult V M)
	I
  P	(expr_plus M P)
	I

M: sorted on V
P: sorted on M, all M's not an I
*)

Opaque Zmult.
Lemma MI_mult_corr_F :
 forall (e f:expr) (x y:F), II e x -> II f y -> II (MI_mult e f) (x[*]y).
Proof.
 cut (forall x y:F, II (expr_int 0) y -> II (expr_int 0) (x[*]y)).
  cut (forall (e1 e2 f:expr) (x y:F),
    (forall (f:expr) (x y:F), II e2 x -> II f y -> II (MI_mult e2 f) (x[*]y)) ->
      II (expr_mult e1 e2) x -> II f y -> II (expr_mult e1 (MI_mult e2 f)) (x[*]y)).
   cut (forall (i j:Z) (x y:F),
     II (expr_int i) x -> II (expr_int j) y -> II (expr_int (i * j)) (x[*]y)).
    cut (forall (e f:expr) (x y:F), II e x -> II f y -> II (expr_mult e f) (x[*]y)).
     simple induction e; simple induction f; simpl in |- *; auto.
            simple induction z; simpl in |- *; auto.
           simple induction z0; induction z; simpl in |- *; auto.
          simple induction z; simpl in |- *; auto.
         simple induction z; simpl in |- *; auto.
        induction f; simpl in |- *; auto.
         simple induction z; simpl in |- *; auto.
        simple induction z0; simpl in |- *; auto.
       simple induction z; simpl in |- *; auto.
      simple induction z; simpl in |- *; auto.
     simple induction z; simpl in |- *; auto.
    intros; apply interpF_mult with x y; algebra.
   intros; apply interpF_wd with (zring (i * j):F).
    apply interpF_int; algebra.
   inversion X. inversion X0.
   Step_final (zring i[*]zring j:F).
  intros. inversion X0.
  try (rewrite H in X2; rewrite H1 in X3; rewrite H0 in H2). (* compat 8.0 *)
  apply interpF_wd with (x0[*](y0[*]y)); algebra.
   apply interpF_mult with x0 (y0[*]y); algebra.
  Step_final (x0[*]y0[*]y).
 intros. inversion X. try (rewrite H in H0; rewrite H1 in H0). (* compat 8.0 *)
 apply interpF_wd with (zring 0:F).
  apply interpF_int; algebra.
 astepl ([0]:F).
 astepl (x[*][0]).
 Step_final (x[*]zring 0).
Qed.
Transparent Zmult.

Opaque MI_mult.
Lemma MV_mult_corr_F :
 forall (e f:expr) (x y:F), II e x -> II f y -> II (MV_mult e f) (x[*]y).
Proof.
 cut (forall (e1 e2 f:expr) (x y:F),
   (forall (f:expr) (x y:F), II e2 x -> II f y -> II (MV_mult e2 f) (x[*]y)) ->
     II (expr_mult e1 e2) x -> II f y -> II (expr_mult e1 (MV_mult e2 f)) (x[*]y)).
  cut (forall (e f:expr) (x y:F), II e x -> II f y -> II (MI_mult (expr_mult f expr_one) e) (x[*]y)).
   cut (forall (e f:expr) (x y:F), II e x -> II f y -> II (expr_mult f e) (x[*]y)).
    cut (forall (e f:expr) (x y:F), II e x -> II f y -> II (expr_mult e f) (x[*]y)).
     intros H H0 H1 H2 e. elim e.
     simpl in |- *; auto.
           simpl in |- *; auto.
          intros e1 H3 e2 H4.
          elim e1; simpl in |- *; auto.
         intros e1 H3 e2 H4.
         elim e1; simpl in |- *; auto.
            intros n f.
            elim f; simpl in |- *; auto.
            intro m.
            elim (lt_nat n m); simpl in |- *; auto.
           intros u e0 H5 f.
           elim f; simpl in |- *; auto.
           intros u0 e3 H6.
           elim lt_nat; simpl in |- *; auto.
           elim andb; simpl in |- *; auto.
          intros b e0 H6 e3 H7 f.
          elim f; simpl in |- *; auto.
          intros b0 e4 H8 e5 H9.
          elim lt_nat; simpl in |- *; auto.
          elim andb; simpl in |- *; auto.
          elim andb; simpl in |- *; auto.
         intros n f H5 f0.
         elim f0; simpl in |- *; auto.
         intros f1 e0 H6.
         elim lt_nat; simpl in |- *; auto.
         elim andb; simpl in |- *; auto.
        intros. simpl in |- *. auto.
        intros n e0 H3 f.
       elim f; simpl in |- *; auto.
      intros n e0 H3 e1 H4 f.
      elim f; simpl in |- *; auto.
     intros n e0 H3 f.
     elim f; simpl in |- *; auto.
    intros; apply interpF_mult with x y; algebra.
   intros; apply interpF_wd with (y[*]x); algebra.
   apply interpF_mult with y x; algebra.
  intros; apply interpF_wd with (y[*][1][*]x).
   apply MI_mult_corr_F; auto.
   apply interpF_mult with y ([1]:F); algebra.
   apply (interpF_int F val unop binop pfun 1); algebra.
  Step_final (x[*](y[*][1])).
 intros. inversion X0. try (rewrite H0 in H2; rewrite H in X2; rewrite H1 in X3). (* compat 8.0 *)
 apply interpF_wd with (x0[*](y0[*]y)).
  apply interpF_mult with x0 (y0[*]y); algebra.
 Step_final (x0[*]y0[*]y).
Qed.
Transparent MI_mult.

Opaque MV_mult MI_mult.
Lemma MM_mult_corr_F :
 forall (e f:expr) (x y:F), II e x -> II f y -> II (MM_mult e f) (x[*]y).
Proof.
 cut (forall (e1 e2 f:expr) (x y:F),
   (forall (f:expr) (x y:F), II e2 x -> II f y -> II (MM_mult e2 f) (x[*]y)) ->
     II (expr_mult e1 e2) x -> II f y -> II (MV_mult (MM_mult e2 f) e1) (x[*]y)).
  cut (forall (i:Z) (f:expr) (x y:F),
    II (expr_int i) x -> II f y -> II (MI_mult f (expr_int i)) (x[*]y)).
   cut (forall (e f:expr) (x y:F), II e x -> II f y -> II (expr_mult e f) (x[*]y)).
    intros H H0 H1 e.
    elim e; intros; simpl in |- *; auto.
   intros; apply interpF_mult with x y; algebra.
  intros; apply interpF_wd with (y[*]x); algebra.
  apply MI_mult_corr_F; auto.
 intros. inversion X0. try (rewrite H in X2; rewrite H1 in X3; rewrite H0 in H2). (* compat 8.0 *)
 apply interpF_wd with (y0[*]y[*]x0).
  apply MV_mult_corr_F; auto.
 astepl (x0[*](y0[*]y)).
 Step_final (x0[*]y0[*]y).
Qed.
Transparent MV_mult MI_mult.

Opaque MV_mult.
Lemma MM_plus_corr_F :
 forall (e f:expr) (x y:F), II e x -> II f y -> II (MM_plus e f) (x[+]y).
Proof.
 cut (forall (i j:Z) (x y:F),
   II (expr_int i) x -> II (expr_int j) y -> II (expr_int (i + j)) (x[+]y)).
  cut (forall (e f:expr) (x y:F), II e x -> II f y -> II (expr_plus e f) (x[+]y)).
   intros H H0 e; elim e.
          simpl in |- *; auto.
         intros z f; elim f; simpl in |- *; auto.
        simpl in |- *; auto.
       intros e1 H1 e2 H2.
       elim e1; simpl in |- *; auto.
          intros n f.
          elim f; simpl in |- *; auto.
          intros f1 H3 f2 H4.
          elim f1; simpl in |- *; auto.
          intro m.
          cut (eq_nat n m = true -> n = m).
           elim (eq_nat n m); simpl in |- *; auto.
           intros. inversion X. try (rewrite H6 in X1; rewrite H8 in X2; rewrite H7 in H9). (* compat 8.0 *)
           inversion X0. try (rewrite H10 in X3; rewrite H12 in X4; rewrite H11 in H13). (* compat 8.0 *)
           apply interpF_wd with ((y0[+]y1)[*]x0).
            apply MV_mult_corr_F; auto.
           astepl (x0[*](y0[+]y1)).
           astepl (x0[*]y0[+]x0[*]y1).
           cut (x0[=]x1). intro.
            Step_final (x0[*]y0[+]x1[*]y1).
           apply refl_interpF with val unop binop pfun (expr_var n).
            assumption.
           rewrite (H5 (refl_equal true)). assumption.
           intros; apply eq_nat_corr; auto.
         intros u e0 H3 f.
         elim f; simpl in |- *; auto.
         intros e3 H4 e4 H5.
         elim e3; simpl in |- *; auto.
         intros u0 e5 H6.
         cut (andb (eq_nat u u0) (eq_expr e0 e5) = true -> u = u0).
          cut (andb (eq_nat u u0) (eq_expr e0 e5) = true -> e0 = e5).
           elim andb; simpl in |- *; auto.
           intros H' H''. intros.
           inversion X. try (rewrite H7 in X1; rewrite H9 in X2; rewrite H8 in H10). (* compat 8.0 *)
           inversion X0. try (rewrite H11 in X3; rewrite H13 in X4; rewrite H12 in H14). (* compat 8.0 *)
           apply interpF_wd with ((y0[+]y1)[*]x0).
            apply MV_mult_corr_F; auto.
           astepr (x0[*]y0[+]x1[*]y1). astepl (y0[*]x0[+]y1[*]x0).
           apply bin_op_wd_unfolded. algebra. astepr (y1[*]x1). apply mult_wdr.
            apply refl_interpF with val unop binop pfun (expr_unop u e0).
            auto. rewrite H'. rewrite H''. auto. auto. auto.
           intro. elim (andb_prop _ _ H7); intros. apply eq_expr_corr; auto.
          intro. elim (andb_prop _ _ H7); intros. apply eq_nat_corr; auto.
         intros u e0 H3 e3 H4 f.
        elim f; simpl in |- *; auto.
        intros e4 H5 e5 H6.
        elim e4; simpl in |- *; auto.
        intros u0 e6 H7 e7 H8.
        cut (andb (eq_nat u u0) (andb (eq_expr e0 e6) (eq_expr e3 e7)) = true -> u = u0).
         cut (andb (eq_nat u u0) (andb (eq_expr e0 e6) (eq_expr e3 e7)) = true -> e0 = e6).
          cut (andb (eq_nat u u0) (andb (eq_expr e0 e6) (eq_expr e3 e7)) = true -> e3 = e7).
           elim andb; simpl in |- *; auto.
           intros H' H'' H'''. intros.
           inversion X. try (rewrite H9 in X1; rewrite H11 in X2; rewrite H10 in H12). (* compat 8.0 *)
           inversion X0. try (rewrite H13 in X3; rewrite H15 in X4; rewrite H14 in H16). (* compat 8.0 *)
           apply interpF_wd with ((y0[+]y1)[*]x0).
            apply MV_mult_corr_F; auto.
           astepr (x0[*]y0[+]x1[*]y1). astepl (y0[*]x0[+]y1[*]x0).
           apply bin_op_wd_unfolded. algebra. astepr (y1[*]x1). apply mult_wdr.
            apply refl_interpF with val unop binop pfun (expr_binop u e0 e3).
            auto. rewrite H'. rewrite H''. rewrite H'''. auto. auto. auto.
           auto.
          intro. elim (andb_prop _ _ H9); intros. elim (andb_prop _ _ H11); intros.
          apply eq_expr_corr; auto.
         intro. elim (andb_prop _ _ H9); intros. elim (andb_prop _ _ H11); intros.
         apply eq_expr_corr; auto.
        intro. elim (andb_prop _ _ H9); intros. apply eq_nat_corr; auto.
        intros f e0 H3.
       intro f0.
       elim f0; simpl in |- *; auto.
       intros e3 H4 e4 H5.
       elim e3; simpl in |- *; auto.
       intros f1 e5 H6.
       cut (andb (eq_nat f f1) (eq_expr e0 e5) = true -> f = f1).
        cut (andb (eq_nat f f1) (eq_expr e0 e5) = true -> e0 = e5).
         elim (andb (eq_nat f f1) (eq_expr e0 e5)); simpl in |- *; auto.
         intros.
         inversion X. try (rewrite H9 in X1; rewrite H11 in X2; rewrite H10 in H12). (* compat 8.0 *)
         inversion X0. try (rewrite H13 in X3; rewrite H15 in X4; rewrite H14 in H16). (* compat 8.0 *)
         apply interpF_wd with ((y0[+]y1)[*]x0).
          apply MV_mult_corr_F; auto.
         astepr (x0[*]y0[+]x1[*]y1). astepl (y0[*]x0[+]y1[*]x0).
         apply bin_op_wd_unfolded. algebra. astepr (y1[*]x1). apply mult_wdr.
          apply refl_interpF with val unop binop pfun (expr_part f e0).
          auto. rewrite H7. rewrite H8; auto. auto.
         intro. elim (andb_prop _ _ H7); intros. apply eq_expr_corr; auto.
        intro. elim (andb_prop _ _ H7); intros. apply eq_nat_corr; auto.
       simpl in |- *; auto.
     intros u e0 H1 f.
     elim f; simpl in |- *; auto.
    intros u e0 H1 e1 H2 f.
    elim f; simpl in |- *; auto.
   intros u e0 H1 f.
   elim f; simpl in |- *; auto.
  intros; apply interpF_plus with x y; algebra.
 intros. inversion X. try (rewrite H1 in H0; rewrite H in H0). (* compat 8.0 *)
 inversion X0. try (rewrite H2 in H3; rewrite H4 in H3). (* compat 8.0 *)
 apply interpF_wd with (zring (i + j):F).
  apply interpF_int; algebra.
 Step_final (zring i[+]zring j:F).
Qed.
Transparent MV_mult.

Opaque MM_plus.
Lemma PM_plus_corr_F :
 forall (e f:expr) (x y:F), II e x -> II f y -> II (PM_plus e f) (x[+]y).
Proof.
 cut (forall (e1 e2 f:expr) (x y:F),
   (forall (f:expr) (x y:F), II e2 x -> II f y -> II (PM_plus e2 f) (x[+]y)) ->
     II (expr_plus e1 e2) x -> II f y -> II (expr_plus e1 (PM_plus e2 f)) (x[+]y)).
  cut (forall (e1 e2 f:expr) (x y:F),
    (forall (f:expr) (x y:F), II e2 x -> II f y -> II (PM_plus e2 f) (x[+]y)) ->
      II (expr_plus e1 e2) x -> II f y -> II (PM_plus e2 (MM_plus e1 f)) (x[+]y)).
   cut (forall (e f:expr) (x y:F), II e x -> II f y -> II (MM_plus e f) (x[+]y)).
    cut (forall (e f:expr) (x y:F), II e x -> II f y -> II (expr_plus e f) (x[+]y)).
     cut (forall (e f:expr) (x y:F), II e x -> II f y -> II (expr_plus f e) (x[+]y)).
      intros H H0 H1 H2 H3 e. elim e.
      simpl in |- *; auto.
            intros z f; elim f; intros; simpl in |- *; auto.
           intros e1 H4 e2 H5 f. simpl in |- *.
           elim (lt_monom e1 f); elim (eq_monom e1 f); elim f; intros; simpl in |- *; auto.
          simpl in |- *; auto.
         simpl in |- *; auto.
        simpl in |- *; auto.
       simpl in |- *; auto.
      simpl in |- *; auto.
     intros; apply interpF_wd with (y[+]x); algebra.
     apply interpF_plus with y x; algebra.
    intros; apply interpF_plus with x y; algebra.
   intros; apply MM_plus_corr_F; auto.
  intros. inversion X0. try (rewrite H in X2; rewrite H1 in X3; rewrite H0 in H2). (* compat 8.0 *)
  apply interpF_wd with (y0[+](x0[+]y)).
   apply X; auto.
   apply MM_plus_corr_F; auto.
  astepl (y0[+]x0[+]y).
  Step_final (x0[+]y0[+]y).
 intros. inversion X0. try (rewrite H in X2; rewrite H1 in X3; rewrite H0 in H2). (* compat 8.0 *)
 apply interpF_wd with (x0[+](y0[+]y)).
  apply interpF_plus with x0 (y0[+]y); algebra.
 Step_final (x0[+]y0[+]y).
Qed.
Transparent MM_plus.

Opaque PM_plus.
Lemma PP_plus_corr_F :
 forall (e f:expr) (x y:F), II e x -> II f y -> II (PP_plus e f) (x[+]y).
Proof.
 cut (forall (e1 e2 f:expr) (x y:F),
   (forall (f:expr) (x y:F), II e2 x -> II f y -> II (PP_plus e2 f) (x[+]y)) ->
     II (expr_plus e1 e2) x -> II f y -> II (PM_plus (PP_plus e2 f) e1) (x[+]y)).
  cut (forall (i:Z) (f:expr) (x y:F),
    II (expr_int i) x -> II f y -> II (PM_plus f (expr_int i)) (x[+]y)).
   cut (forall (e f:expr) (x y:F), II e x -> II f y -> II (expr_plus e f) (x[+]y)).
    intros H H0 H1 e.
    elim e; intros; simpl in |- *; auto.
   intros. apply interpF_plus with x y; algebra.
   intros. apply interpF_wd with (y[+]x); algebra.
  apply PM_plus_corr_F; auto.
 intros. inversion X0. try (rewrite H in X2; rewrite H1 in X3; rewrite H0 in H2). (* compat 8.0 *)
 apply interpF_wd with (y0[+]y[+]x0).
  apply PM_plus_corr_F; auto.
 astepl (x0[+](y0[+]y)).
 Step_final (x0[+]y0[+]y).
Qed.
Transparent PM_plus.

Opaque PM_plus MM_mult MI_mult.
Lemma PM_mult_corr_F :
 forall (e f:expr) (x y:F), II e x -> II f y -> II (PM_mult e f) (x[*]y).
Proof.
 cut (forall (e1 e2 f:expr) (x y:F),
   (forall (f:expr) (x y:F), II e2 x -> II f y -> II (PM_mult e2 f) (x[*]y)) ->
     II (expr_plus e1 e2) x -> II f y -> II (PM_plus (PM_mult e2 f) (MM_mult e1 f)) (x[*]y)).
  cut (forall (i:Z) (f:expr) (x y:F), II (expr_int i) x ->
    II f y -> II (PM_plus (expr_int 0) (MI_mult f (expr_int i))) (x[*]y)).
   cut (forall (e f:expr) (x y:F), II e x -> II f y -> II (expr_mult e f) (x[*]y)).
    intros H H0 H1 e.
    elim e; intros; simpl in |- *; auto.
   intros. apply interpF_mult with x y; algebra.
   intros. apply interpF_wd with (zring 0[+]y[*]x).
  apply PM_plus_corr_F.
    apply interpF_int; algebra.
   apply MI_mult_corr_F; auto.
  astepl ([0][+]y[*]x).
  Step_final (y[*]x).
 intros. inversion X0. try (rewrite H in X2; rewrite H1 in X3; rewrite H0 in H2). (* compat 8.0 *)
 apply interpF_wd with (y0[*]y[+]x0[*]y).
  apply PM_plus_corr_F; auto.
  apply MM_mult_corr_F; auto.
 astepl ((y0[+]x0)[*]y).
 Step_final ((x0[+]y0)[*]y).
Qed.

Opaque PM_mult.
Lemma PP_mult_corr_F :
 forall (e f:expr) (x y:F), II e x -> II f y -> II (PP_mult e f) (x[*]y).
Proof.
 cut (forall (e1 e2 f:expr) (x y:F),
   (forall (f:expr) (x y:F), II e2 x -> II f y -> II (PP_mult e2 f) (x[*]y)) ->
     II (expr_plus e1 e2) x -> II f y -> II (PP_plus (PM_mult f e1) (PP_mult e2 f)) (x[*]y)).
  cut (forall (i:Z) (f:expr) (x y:F),
    II (expr_int i) x -> II f y -> II (PM_mult f (expr_int i)) (x[*]y)).
   cut (forall (e f:expr) (x y:F), II e x -> II f y -> II (expr_mult e f) (x[*]y)).
    intros H H0 H1 e.
    elim e; intros; simpl in |- *; auto.
   intros. apply interpF_mult with x y; algebra.
   intros. apply interpF_wd with (y[*]x); algebra.
  apply PM_mult_corr_F; auto.
 intros. inversion X0. try (rewrite H in X2; rewrite H1 in X3; rewrite H0 in H2). (* compat 8.0 *)
 apply interpF_wd with (y[*]x0[+]y0[*]y).
  apply PP_plus_corr_F; auto.
  apply PM_mult_corr_F; auto.
 astepl (x0[*]y[+]y0[*]y).
 Step_final ((x0[+]y0)[*]y).
Qed.

Transparent PP_plus PM_mult PP_mult PM_plus MI_mult.
Lemma FF_plus_corr_F :
 forall (e f:expr) (x y:F), II e x -> II f y -> II (FF_plus e f) (x[+]y).
Proof.
 cut (forall (e1 e2 f1 f2:expr) (x y:F), II (expr_div e1 e2) x -> II (expr_div f1 f2) y ->
   II (expr_div (PP_plus (PP_mult e1 f2) (PP_mult e2 f1)) (PP_mult e2 f2)) (x[+]y)).
  cut (forall (e f:expr) (x y:F), II e x -> II f y -> II (expr_plus e f) (x[+]y)).
   intros H H0 e f.
   elim e; elim f; intros; simpl in |- *; auto.
  intros. apply interpF_plus with x y; algebra.
  intros. inversion X.
 try (rewrite H in X1; rewrite H1 in X2; rewrite H0 in H2). (* compat 8.0 *)
 inversion X0.
 try (rewrite H3 in X3; rewrite H5 in X4; rewrite H4 in H6). (* compat 8.0 *)
 cut (y0[*]y1[#][0]). intro H13.
  apply interpF_div with (x0[*]y1[+]y0[*]x1) (y0[*]y1) H13; auto.
    astepl ((x0[*]y1[/] y0[*]y1[//]H13)[+](y0[*]x1[/] y0[*]y1[//]H13)).
    astepl ((x0[/] y0[//]nzy)[*](y1[/] y1[//]nzy0)[+] (y0[/] y0[//]nzy)[*](x1[/] y1[//]nzy0)).
    astepl ((x0[/] y0[//]nzy)[*][1][+][1][*](x1[/] y1[//]nzy0)).
    Step_final ((x0[/] y0[//]nzy)[+](x1[/] y1[//]nzy0)).
   apply PP_plus_corr_F; auto.
    apply PP_mult_corr_F; auto.
   apply PP_mult_corr_F; auto.
  apply PP_mult_corr_F; auto.
 apply mult_resp_ap_zero; auto.
Qed.

Lemma FF_mult_corr_F :
 forall (e f:expr) (x y:F), II e x -> II f y -> II (FF_mult e f) (x[*]y).
Proof.
 cut (forall (e1 e2 f1 f2:expr) (x y:F), II (expr_div e1 e2) x -> II (expr_div f1 f2) y ->
   II (expr_div (PP_mult e1 f1) (PP_mult e2 f2)) (x[*]y)).
  cut (forall (e f:expr) (x y:F), II e x -> II f y -> II (expr_mult e f) (x[*]y)).
   intros H H0 e f.
   elim e; elim f; intros; simpl in |- *; auto.
  intros. apply interpF_mult with x y; algebra.
  intros. inversion X.
 try (rewrite H in X1; rewrite H1 in X2; rewrite H0 in H2). (* compat 8.0 *)
 inversion X0.
 try (rewrite H3 in X3; rewrite H5 in X4; rewrite H4 in H6). (* compat 8.0 *)
 cut (y0[*]y1[#][0]). intro H13.
  apply interpF_div with (x0[*]x1) (y0[*]y1) H13.
    Step_final ((x0[/] y0[//]nzy)[*](x1[/] y1[//]nzy0)).
   apply PP_mult_corr_F; auto.
  apply PP_mult_corr_F; auto.
 apply mult_resp_ap_zero; auto.
Qed.

Transparent FF_div.
Lemma FF_div_corr_F :
 forall (e f:expr) (x y:F) (nzy:y[#][0]),
   II e x -> II f y -> II (FF_div e f) (x[/]y[//]nzy).
Proof.
 cut (forall (e1 e2 f1 f2:expr) (x y:F) (nzy:y[#][0]), II (expr_div e1 e2) x ->
   II (expr_div f1 f2) y -> II (expr_div (PP_mult e1 f2) (PP_mult e2 f1)) (x[/]y[//]nzy)).
  cut (forall (e f:expr) (x y:F) (nzy:y[#][0]), II e x -> II f y -> II (expr_div e f) (x[/]y[//]nzy)).
   intros H H0 e f.
   elim e; elim f; intros; simpl in |- *; auto.
  intros. apply interpF_div with x y nzy; algebra.
  intros. inversion X.
 try (rewrite H in X1; rewrite H1 in X2; rewrite H0 in H2). (* compat 8.0 *)
 inversion X0.
 try (rewrite H3 in X3; rewrite H5 in X4; rewrite H4 in H6). (* compat 8.0 *)
 cut (x1[#][0]). intro nzx1.
  cut (y0[*]x1[#][0]). intro H13.
   cut ((x1[/]y1[//]nzy1)[#][0]). intro H14.
    apply interpF_div with (x0[*]y1) (y0[*]x1) H13.
      astepl ((y1[*]x0)[/]y0[*]x1[//]H13).
      astepl (((y1[*]x0)[/]y0[//]nzy0)[/]x1[//]nzx1).
      astepl ((y1[*](x0[/]y0[//]nzy0))[/]x1[//]nzx1).
      astepl (((x0[/]y0[//]nzy0)[*]y1)[/]x1[//]nzx1).
      Step_final ((x0[/]y0[//]nzy0)[/]x1[/]y1[//]nzy1[//]H14).
     apply PP_mult_corr_F; auto.
    apply PP_mult_corr_F; auto.
   apply div_resp_ap_zero_rev; auto.
  apply mult_resp_ap_zero; auto.
 apply div_resp_ap_zero with y1 nzy1.
 astepl y. auto.
Qed.

Lemma NormF_corr : forall (e:expr) (x:F), II e x -> II (NormF e) x.
Proof.
 intro; elim e; intros; simpl in |- *.
        apply (interpF_div F val unop binop pfun
          (expr_plus (expr_mult (expr_var v) expr_one) expr_zero) expr_one x ([1]:F) x (ring_non_triv F)).
          algebra.
         apply (interpF_plus F val unop binop pfun (expr_mult (expr_var v) expr_one) expr_zero x ([0]:F) x).
           algebra.
          apply (interpF_mult F val unop binop pfun (expr_var v) expr_one x ([1]:F) x); algebra.
          apply (interpF_int F val unop binop pfun 1); algebra.
         apply (interpF_int F val unop binop pfun 0); algebra.
        apply (interpF_int F val unop binop pfun 1); algebra.
       apply (interpF_div F val unop binop pfun (expr_int z) expr_one x ( [1]:F) x (ring_non_triv F)).
         algebra. algebra. apply (interpF_int F val unop binop pfun 1); algebra.
        inversion X1. try (rewrite H in X2; rewrite H1 in X3; rewrite H0 in H2). (* compat 8.0 *)
      apply interpF_wd with (x0[+]y). apply FF_plus_corr_F; auto. auto.
       inversion X1. try (rewrite H in X2; rewrite H1 in X3; rewrite H0 in H2). (* compat 8.0 *)
     apply interpF_wd with (x0[*]y). apply FF_mult_corr_F; auto. auto.
      inversion X1. try (rewrite H in X2; rewrite H1 in X3; rewrite H0 in H2). (* compat 8.0 *)
    apply interpF_wd with (x0[/]y[//]nzy).
     apply FF_div_corr_F; auto. auto.
    inversion X0. try (rewrite H in H2; rewrite H1 in X1; rewrite H0 in H2). (* compat 8.0 *)
   apply (interpF_div F val unop binop pfun
     (expr_plus (expr_mult (expr_unop u (NormF e0)) expr_one) expr_zero)
       expr_one x ([1]:F) x (ring_non_triv F)).
     algebra.
    apply (interpF_plus F val unop binop pfun (expr_mult (expr_unop u (NormF e0)) expr_one) expr_zero x (
      [0]:F) x).
      algebra.
     apply (interpF_mult F val unop binop pfun (expr_unop u (NormF e0)) expr_one x ([1]:F) x); algebra.
      apply (interpF_unop F val unop binop pfun (NormF e0) u x0); algebra.
     apply (interpF_int F val unop binop pfun 1); algebra.
    apply (interpF_int F val unop binop pfun 0); algebra.
   apply (interpF_int F val unop binop pfun 1); algebra.
  inversion X1. try (rewrite H in H3; rewrite H1 in X2; rewrite H2 in X3; rewrite H0 in H3). (* compat 8.0 *)
  apply (interpF_div F val unop binop pfun
    (expr_plus (expr_mult (expr_binop b (NormF e0) (NormF e1)) expr_one)
      expr_zero) expr_one x ([1]:F) x (ring_non_triv F)).
    algebra.
   apply (interpF_plus F val unop binop pfun
     (expr_mult (expr_binop b (NormF e0) (NormF e1)) expr_one) expr_zero x ([0]:F) x).
     algebra.
    apply (interpF_mult F val unop binop pfun (expr_binop b (NormF e0) (NormF e1))
      expr_one x ([1]:F) x); algebra.
     apply (interpF_binop F val unop binop pfun (NormF e0) (NormF e1) b x0 y); algebra.
    apply (interpF_int F val unop binop pfun 1); algebra.
   apply (interpF_int F val unop binop pfun 0); algebra.
  apply (interpF_int F val unop binop pfun 1); algebra.
 inversion X0.
 try ((generalize Hx H2; clear Hx H2; rewrite H; intros Hx H2);
   rewrite H1 in X1; rewrite H0 in H2). (* compat 8.0 *)
 apply (interpF_div F val unop binop pfun
   (expr_plus (expr_mult (expr_part p (NormF e0)) expr_one) expr_zero)
     expr_one x ([1]:F) x (ring_non_triv F)).
   algebra.
  apply (interpF_plus F val unop binop pfun (expr_mult (expr_part p (NormF e0)) expr_one) expr_zero x (
    [0]:F) x).
    algebra.
   apply (interpF_mult F val unop binop pfun (expr_part p (NormF e0)) expr_one x ([1]:F) x); algebra.
    apply (interpF_part F val unop binop pfun (NormF e0) p x0) with (Hx := Hx); algebra.
   apply (interpF_int F val unop binop pfun 1); algebra.
  apply (interpF_int F val unop binop pfun 0); algebra.
 apply (interpF_int F val unop binop pfun 1); algebra.
Qed.

Lemma Norm_wfF :
 forall e:expr,
   wfF F val unop binop pfun e -> wfF F val unop binop pfun (NormF e).
Proof.
 unfold wfF in |- *.
 intros.
 elim X.
 intros.
 exists x.
 apply NormF_corr.
 assumption.
Qed.

Lemma expr_is_zero_corr_F :
 forall e:expr,
   wfF F val unop binop pfun e -> expr_is_zero e = true -> II e [0].
Proof.
 unfold wfF in |- *.
 intros e H.
 elim H. intro.
 elim e; simpl in |- *; try (intros; exfalso; inversion H0; fail).
 intros e0 H0 e1 H1.
 elim e0; simpl in |- *; try (intros; exfalso; inversion H2; fail).
 intro.
 elim z; simpl in |- *; try (intros; exfalso; inversion H2; fail); intros H2 H3.
 inversion H2. try (rewrite H4 in X; rewrite H6 in X0; rewrite H5 in H7). (* compat 8.0 *)
 apply interpF_div with ([0]:F) y nzy; auto.
  algebra.
 apply (interpF_int F val unop binop pfun 0); algebra.
Qed.

Lemma Tactic_lemma_zero_F :
 forall (x:F) (e:xexprF F val unop binop pfun x),
   expr_is_zero (NormF (xforgetF _ _ _ _ _ _ e)) = true -> x[=][0].
Proof.
 intros.
 apply refl_interpF with val unop binop pfun (NormF (xforgetF _ _ _ _ _ _ e)).
  apply NormF_corr.
  apply xexprF2interpF.
 apply expr_is_zero_corr_F.
  apply Norm_wfF.
  apply xexprF2wfF.
 assumption.
Qed.

Lemma Tactic_lemmaF :
 forall (x y:F) (e:xexprF F val unop binop pfun x)
   (f:xexprF F val unop binop pfun y),
   expr_is_zero
     (NormF (xforgetF _ _ _ _ _ _ (xexprF_minus _ _ _ _ _ _ _ e f))) = true ->
   x[=]y.
Proof.
 intros.
 apply cg_inv_unique_2.
 apply Tactic_lemma_zero_F with (xexprF_minus _ _ _ _ _ _ _ e f).
 assumption.
Qed.

End Field_NormCorrect.

Ltac QuoteF R l t :=
match l with
 (Quad ?vl ?ul ?bl ?pl) =>
(let a := constr:(fun n:varindex => (Mnth n vl (cm_unit R))) in
 let b := constr:(fun n:unopindex => (Mnth n ul (@cg_inv R))) in
 let c := constr:(fun n:binopindex => (Mnth n bl (@csg_op R))) in
 let d := constr:(fun n:pfunindex => (Mnth n pl (total_eq_part _ (@cg_inv R)))) in
 match t with
 | (zring ?k) =>
    match (ClosedZ k) with
    | true => constr:(xexprF_int R a b c d k)
    end
 | (csbf_fun _ _ _ csg_op ?x ?y) =>
    let x' := QuoteF R l x in
    let y' := QuoteF R l y in
    constr:(xexprF_plus R a b c d _ _ x' y')
 | (csbf_fun _ _ _ cr_mult ?x ?y) =>
    let x' := QuoteF R l x in
    let y' := QuoteF R l y in
    constr:(xexprF_mult R a b c d _ _ x' y')
 | (cf_div ?x ?y ?H) =>
    let x' := QuoteF R l x in
    let y' := QuoteF R l y in
    constr:(xexprF_div R a b c d _ _ x' y' H)
 | ([0]) => constr:(xexprF_zero R a b c d)
 | ([1]) => constr:(xexprF_one R a b c d)
 | (nring ?n) =>
    match (ClosedNat n) with
    | true => constr:(xexprF_nat R a b c d n)
    end
 | (csf_fun _ _ cg_inv ?x) =>
    let x' := QuoteF R l x in
    constr:(xexprF_inv R a b c d _ x')
 | (cg_minus ?x ?y) =>
    let x' := QuoteF R l x in
    let y' := QuoteF R l y in
    constr:(xexprF_minus R a b c d _ _ x' y')
 | (csf_fun _ _ (@nexp_op _ ?n) ?x) =>
    match (ClosedNat n) with
    | true => let x' := QuoteF R l x in
              constr:(xexprF_power R a b c d _ x' n)
    end
 | (pfpfun ?f ?x ?h) =>
    let x' := QuoteF R l x in
    let i := FindIndex f pl in
    constr:(xexprF_part R a b c d _ i x' h)
 | (csf_fun _ _ ?f ?x) =>
    let x' := QuoteF R l x in
    let i := FindIndex f ul in
    constr:(xexprF_unop R a b c d _ i x')
 | (csbf_fun _ _ _ ?f ?x ?y) =>
    let x' := QuoteF R l x in
    let y' := QuoteF R l y in
    let i := FindIndex f bl in
    constr:(xexprF_binop R a b c d _ _ i x' y')
 | ?t =>
    let i := FindIndex t vl in
    constr:(xexprF_var R a b c d i)
end)
end.

Ltac FindTermVariablesF t l :=
match t with
| (zring ?k) =>
    match (ClosedZ k) with
    | true => constr:(l)
    end
| (csbf_fun _ _ _ csg_op ?x ?y) =>
    let l1 := FindTermVariablesF x l in
    let l2 := FindTermVariablesF y l1 in
    constr:(l2)
| (csbf_fun _ _ _ cr_mult ?x ?y) =>
    let l1 := FindTermVariablesF x l in
    let l2 := FindTermVariablesF y l1 in
    constr:(l2)
| (cf_div ?x ?y ?H) =>
    let l1 := FindTermVariablesF x l in
    let l2 := FindTermVariablesF y l1 in
    constr:(l2)
| ([0]) => constr:(l)
| ([1]) => constr:(l)
| (nring ?n) =>
    match (ClosedNat n) with
    | true => constr:(l)
    end
| (csf_fun _ _ cg_inv ?x) =>
    let l1 := FindTermVariablesF x l in
    constr:(l1)
| (cg_minus ?x ?y) =>
    let l1 := FindTermVariablesF x l in
    let l2 := FindTermVariablesF y l1 in
    constr:(l2)
| (csf_fun _ _ (@nexp_op _ ?n) ?x) =>
    match (ClosedNat n) with
    | true => let l1 := FindTermVariablesF x l in
              constr:(l1)
    end
| (pfpfun ?f ?x ?h) =>
    let l1 := FindTermVariablesF x l in
    match l1 with
     (Quad ?vl ?ul ?bl ?pl) => constr:(Quad vl ul bl (Mcons f pl))
    end
| (csf_fun _ _ ?f ?x) =>
    let l1 := FindTermVariablesF x l in
    match l1 with
     (Quad ?vl ?ul ?bl ?pl) => constr:(Quad vl (Mcons f ul) bl pl)
    end
| (csbf_fun _ _ _ ?f ?x ?y) =>
    let l1 := FindTermVariablesF x l in
    let l2 := FindTermVariablesF y l1 in
    match l2 with
     (Quad ?vl ?ul ?bl ?pl) => constr:(Quad vl ul (Mcons f bl) pl)
    end
| ?t => match l with
         (Quad ?vl ?ul ?bl ?pl) => constr:(Quad (Mcons t vl) ul bl pl)
        end
end.

Ltac FindTermsVariablesF fn t1 t2 :=
    let l1 := FindTermVariablesF t1 (Quad (Mnil fn) (Mnil (CSetoid_un_op fn)) (Mnil (CSetoid_bin_op fn)) (Mnil (PartFunct fn))) in
    let l2 := FindTermVariablesF t2 l1 in
    constr:(l2).

Ltac rationalF F x y :=
                 let l:=FindTermsVariablesF F x y in
                 let t1:=(QuoteF F l x) in
                 let t2:=(QuoteF F l y) in
                 eapply Tactic_lemmaF with (e:=t1) (f:=t2)
                 ; reflexivity.

(* end hide *)