Require Export Iron.Language.SystemF2Effect.Store.Prop.
Require Export Iron.Language.SystemF2Effect.Type.Operator.LiftTT.
Require Export Iron.Language.SystemF2Effect.Type.Relation.WfT.
Require Export Iron.Language.SystemF2Effect.Type.Exp.

(********************************************************************)
(* Only types of effect and closure kinds can be used in sums. *)
Definition SumKind (k : ki) : Prop
 := k = KEffect.
Hint Unfold SumKind.

(* Region kinds cannot be the result of type applications. *)
Definition AppKind (k : ki) : Prop
 := ~ (k = KRegion).
Hint Unfold AppKind.

(* Kinds judgement assigns a kind to a type *)
Inductive KindT : kienv -> stprops -> ty -> ki -> Prop :=
  | KiVar
    :  forall ke sp i k
    ,  get i ke = Some k
    -> KindT ke sp (TVar i) k

  | KiForall
    :  forall ke sp k t
    ,  KindT (ke :> k) sp t KData
    -> KindT ke        sp (TForall k t) KData

  | KiApp
    :  forall ke sp t1 t2 k11 k12
    ,  AppKind k12
    -> KindT ke sp t1 (KFun k11 k12)
    -> KindT ke sp t2 k11
    -> KindT ke sp (TApp t1 t2) k12

  | KiSum
    :  forall ke sp k t1 t2
    ,  SumKind k
    -> KindT ke sp t1 k -> KindT ke sp t2 k
    -> KindT ke sp (TSum t1 t2) k

  | KiBot
    :  forall ke sp k
    ,  SumKind k
    -> KindT ke sp (TBot k) k

  | KiCon0
    :  forall ke sp tc k
    ,  k = kindOfTyCon0 tc
    -> KindT ke sp (TCon0 tc) k

  | KiCon1
    :  forall ke sp tc t1 k1 k
    ,  KFun k1 k = kindOfTyCon1 tc
    -> KindT ke sp t1 k1
    -> KindT ke sp (TCon1 tc t1) k

  | KiCon2
    :  forall ke sp tc t1 t2 k1 k2 k
    ,  KFun k1 (KFun k2 k) = kindOfTyCon2 tc
    -> KindT ke sp t1 k1
    -> KindT ke sp t2 k2
    -> KindT ke sp (TCon2 tc t1 t2) k

  | KiRgn
    :  forall ke sp p
    ,  In (SRegion p) sp
    -> KindT ke sp (TRgn p) KRegion.

Hint Constructors KindT.

(********************************************************************)
(* Invert all hypothesis that are compound kinding statements. *)
Ltac inverts_kind :=
 repeat
  (match goal with
   | [ H: KindT _ _ (TVar _)      _  |- _ ] => inverts H
   | [ H: KindT _ _ (TForall _ _) _  |- _ ] => inverts H
   | [ H: KindT _ _ (TApp _ _)    _  |- _ ] => inverts H
   | [ H: KindT _ _ (TSum _ _)    _  |- _ ] => inverts H
   | [ H: KindT _ _ (TBot _ )     _  |- _ ] => inverts H
   | [ H: KindT _ _ (TCon0 _)     _  |- _ ] => inverts H
   | [ H: KindT _ _ (TCon1 _ _)   _  |- _ ] => inverts H
   | [ H: KindT _ _ (TCon2 _ _ _) _  |- _ ] => inverts H
   | [ H: KindT _ _ (TCap _) _       |- _ ] => inverts H
   end).

(********************************************************************)
(* Forms of types *)
Lemma kind_region
 :  forall t sp
 ,  KindT   nil sp t KRegion
 -> (exists p, t = TRgn p).
Proof.
 intros.
 destruct t; burn.

  Case "TApp".
   inverts_kind.
   false. auto.

  Case "TCon0".
   destruct t; nope.

  Case "TCon1".
   destruct t; nope.

  Case "TCon2".
   destruct t1; nope.
   inverts_kind.
    destruct tc. simpl in *. nope.

  Case "TCap".
   destruct t.
   exists n. auto.
Qed.
Hint Resolve kind_region.

(* Well kinded sums have SumKind *)
Lemma kind_sumkind
 :  forall ke sp t1 t2 k
 ,  KindT ke sp (TSum t1 t2) k
 -> SumKind k.
Proof.
 intros.
 inverts H. auto.
Qed.
Hint Resolve kind_sumkind.


Require Import Coq.Classes.RelationClasses.
Require Import ChargeCore.Tactics.Tactics.
Require Import Logic.Syntax.
Require Import Logic.Semantics.

(** NOTE: Avoid using this **)
Ltac breakAbstraction :=
  simpl in *; unfold tlaEntails in *; simpl in *.

Ltac restoreCoercions :=
  change NatT with NatC in *;
  change RealT with ConstC in *;
  change VarNowT with VarC in *.

Ltac restoreAbstraction :=
  change And    with (@land Formula _) in *;
  change Imp    with (@limpl Formula _) in *;
  change Or     with (@lor Formula _) in *;
  change TRUE   with (@ltrue Formula _) in *;
  change FALSE  with (@lfalse Formula _) in *;
  change Syntax.Forall with (@lforall Formula _) in *;
  change Syntax.Exists with (@lexists Formula _) in *;
  change tlaEntails with (@lentails Formula _) in *;
  fold eval_formula; restoreCoercions.

Lemma tlaRefl
: forall G l o,
    match o with
    | Ge | Le | Eq => true
    | _ => false
    end = true ->
    G |-- Comp l l o.
Proof.
  breakAbstraction. intros. unfold eval_comp; simpl;
  destruct o; try congruence; simpl.
  apply RIneq.Req_ge. reflexivity.
  apply RIneq.Req_le. reflexivity.
Qed.

Ltac tlaRefl :=
  apply tlaRefl; reflexivity.

Ltac tlaSplit := apply landR.

Ltac tlaAssume :=
  match goal with
  | |- ?X |-- ?Y =>
    solve [ reflexivity
          | apply landL1 ; tlaAssume
          | apply landL2 ; tlaAssume ]
  end.

Ltac tlaIntro := charge_intro.

Ltac tlaIntuition :=
  breakAbstraction ; intuition ; restoreAbstraction.

Ltac tlaAssert H := charge_assert H.

Ltac tlaRevert := charge_revert.

Ltac tlaCutByHyp H :=
  match type of H with
  | _ |-- _ -->> ?C => tlaAssert C
  | _ |-- ?C => tlaAssert C
  end.

(** Rewriting **)
Section RW_Impl.
  Variable P : Formula.
  Definition RW_Impl (A B : Formula) : Prop :=
    P |-- A -->> B.

  Global Instance Reflexive_RW_Impl : Reflexive RW_Impl.
  Proof.
    red; red. intros. apply limplAdj. tlaAssume.
  Qed.

  Global Instance Transitive_RW_Impl : Transitive RW_Impl.
  Proof.
    red; red. intros. apply limplAdj.
    eapply Lemmas.lcut. instantiate (1 := y).
    apply landAdj. apply H.
    apply landL1. apply H0.
  Qed.

  Require Import Setoid.

  Global Add Parametric Relation : Formula RW_Impl
   reflexivity proved by Reflexive_RW_Impl
   transitivity proved by Transitive_RW_Impl
   as RW_Impl_rel.

  Global Add Parametric Morphism : (@land Formula _) with
    signature (RW_Impl ==> RW_Impl ==> RW_Impl)
    as RW_Impl_and_mor.
  Proof.
    unfold RW_Impl. simpl.
    breakAbstraction. simpl. intuition.
  Qed.

  Global Add Parametric Morphism : (@land Formula _) with
    signature (RW_Impl --> RW_Impl --> Basics.flip RW_Impl)
    as RW_Impl_and_flip_mor.
  Proof.
    unfold RW_Impl. simpl.
    breakAbstraction. simpl. intuition.
  Qed.

  Global Add Parametric Morphism : (@lor Formula _) with
    signature (RW_Impl ==> RW_Impl ==> RW_Impl)
    as RW_Impl_or_mor.
  Proof.
    unfold RW_Impl. simpl.
    breakAbstraction. simpl. intuition.
  Qed.

  Global Add Parametric Morphism : (@lor Formula _) with
    signature (RW_Impl --> RW_Impl --> Basics.flip RW_Impl)
    as RW_Impl_or_flip_mor.
  Proof.
    unfold RW_Impl. simpl.
    breakAbstraction. simpl. intuition.
  Qed.

  Global Add Parametric Morphism : (@limpl Formula _) with
    signature (RW_Impl --> RW_Impl ==> RW_Impl)
    as RW_Impl_impl_mor.
  Proof.
    unfold RW_Impl. simpl.
    breakAbstraction. simpl. intuition.
  Qed.

  Global Add Parametric Morphism : (@limpl Formula _) with
    signature (RW_Impl ==> RW_Impl --> Basics.flip RW_Impl)
    as RW_Impl_impl_flip_mor.
  Proof.
    unfold RW_Impl. simpl.
    breakAbstraction. simpl. intuition.
  Qed.

  Global Add Parametric Morphism : (@lentails Formula _ P) with
    signature (RW_Impl ==> Basics.impl)
    as RW_Impl_entails_mor.
  Proof.
    unfold RW_Impl, Basics.impl. simpl.
    breakAbstraction. simpl. intuition.
  Qed.

  Global Add Parametric Morphism : (@lentails Formula _ P) with
    signature (RW_Impl --> Basics.flip Basics.impl)
    as RW_Impl_flip_entails_mor.
  Proof.
    unfold RW_Impl, Basics.impl. simpl.
    breakAbstraction. simpl. intuition.
  Qed.

  Definition rw_impl {A B : Formula} (H : P |-- A -->> B) : RW_Impl A B := H.

End RW_Impl.

(* TODO: This automation is way too expensive!
Class SimpleEntail (A B : Formula) : Prop :=
  slentails : lentails A B.

Hint Extern 1 (SimpleEntail _ _) => match goal with
                                    | |- ?X => idtac X; red; charge_tauto
                                    end : typeclass_instances.

Global Instance subrelation_RW_Impl P Q (H : SimpleEntail Q P)
: subrelation (RW_Impl P) (RW_Impl Q).
Proof. do 4 red. unfold RW_Impl; intros.
       red in H. rewrite H. assumption.
Qed.

Global Add Parametric Morphism P Q (H : SimpleEntail P Q)
: (@lentails Formula _ P) with
  signature (RW_Impl Q --> Basics.flip Basics.impl)
  as RW_Impl_weaken_flip_entails_mor.
Proof.
  unfold RW_Impl, Basics.impl. intros.
  red in H. charge_tauto.
Qed.

Global Add Parametric Morphism P Q (H : SimpleEntail P Q)
: (@lentails Formula _ P) with
  signature (RW_Impl Q ==> Basics.impl)
  as RW_Impl_weaken_entails_mor.
Proof.
  unfold RW_Impl, Basics.impl. intros.
  red in H. charge_tauto.
Qed.
*)

Arguments rw_impl {P A B} _ _ _ _.

Export ChargeCore.Tactics.Tactics.


(*
Copyright © 2008 Russell O’Connor

Permission is hereby granted, free of charge, to any person obtaining a copy of
this proof and associated documentation files (the "Proof"), to deal in
the Proof without restriction, including without limitation the rights to
use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of
the Proof, and to permit persons to whom the Proof is furnished to do so,
subject to the following conditions:

The above copyright notice and this permission notice shall be included in all
copies or substantial portions of the Proof.

THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS
FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR
COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER
IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF.
*)
Require Import CoRN.metric2.Metric.
Require Import CoRN.metric2.UniformContinuity.
Require Import CoRN.model.totalorder.QposMinMax.
Require Import CoRN.reals.fast.CRArith.
Require Import CoRN.stdlib_omissions.List.
Require Import CoRN.model.metric2.Qmetric.

Local Open Scope Q_scope.

(* Equi-distribute the error e on all terms, which is on average
   faster than dividing e by 2 for each term. *)
Definition CRsum_list_raw (l:list CR) (e:QposInf) : Q :=
fold_left Qplus
match l with
| nil => nil
| cons h t =>
  let e' := QposInf_mult (Qpos2QposInf (1#(P_of_succ_nat (length t))))%Qpos e in
   (map (fun x => approximate x e') l)
end
0.

Lemma CRsum_list_prf : forall l,
    is_RegularFunction Qball (CRsum_list_raw l).
Proof.
 intros [|a t] e1 e2.
  apply ball_refl. apply (Qpos_nonneg (e1 + e2)).
 unfold CRsum_list_raw.
 simpl.
 set (p:=P_of_succ_nat (@length (RegularFunction Qball) t)).
 set (e1':=((1 # p) * e1)%Qpos).
 set (e2':=((1 # p) * e2)%Qpos).
 simpl in e1'. fold e1'.
 simpl in e2'. fold e2'.
 assert (Qball (proj1_sig e1' + proj1_sig e2')
               (0 + @approximate Q Qball a e1') (0 + @approximate Q Qball a e2')) as H.
 { rewrite Qplus_0_l, Qplus_0_l.
   apply (regFun_prf a). }
 assert (forall e:Qpos,
            proj1_sig ((1 # p) * e)%Qpos * inject_Z (Z.of_nat (length t)) +
            proj1_sig ((1 # p) * e)%Qpos <= proj1_sig e) as X.
 { intros e.
   simpl.
   setoid_replace ((1 # p) * proj1_sig e * (Z.of_nat (length t) # 1) + (1 # p) * proj1_sig e)%Q
     with ((1#p)*((Z.of_nat (length t) #1) + (1#1))* proj1_sig e)%Q
     by (unfold canonical_names.equiv, stdlib_rationals.Q_eq; simpl; ring).
   rewrite <- (Qmult_1_l (proj1_sig e)) at 2.
   apply Qmult_le_r. apply Qpos_ispos.
   unfold Qmult, Qplus, Qle, Qnum, Qden.
   rewrite Z.mul_1_r, Z.mul_1_r, Z.mul_1_r.
   rewrite Z.mul_1_l, Z.mul_1_l, Pos.mul_1_r.
   unfold p. rewrite Z.P_of_succ_nat_Zplus.
   apply Z.le_refl. }
 generalize (X e1) (X e2).
 simpl ((1 # p) * e1)%Qpos. simpl ((1 # p) * e2)%Qpos.
 fold e1' e2'.
 unfold e1' at 1 3.
 unfold e2' at 1 3.
 generalize (Qpos_mult
               (@exist Q (Qlt {| Qnum := Z0; Qden := xH |})
                       {| Qnum := Zpos xH; Qden := p |} (@eq_refl comparison Lt)) e1)
            (Qpos_mult
               (@exist Q (Qlt {| Qnum := Z0; Qden := xH |})
                       {| Qnum := Zpos xH; Qden := p |} (@eq_refl comparison Lt)) e2)
            e1' e2'
            (0 + @approximate Q Qball a e1') (0 + @approximate Q Qball a e2') H.
 clear - t.
 induction t; intros e1'' e2'' e1' e2' x y Hxy H1 H2.
 - simpl in *.
  ring_simplify in H1.
  ring_simplify in H2.
  apply (@ball_weak_le Q_as_MetricSpace (proj1_sig e1' + proj1_sig e2')); auto.
  apply Qplus_le_compat; auto.
 - simpl in *.
 change (Zpos (P_of_succ_nat (length t))) with (Z_of_nat (1+(length t))) in H1.
 change (Zpos (P_of_succ_nat (length t))) with (Z_of_nat (1+(length t))) in H2.
 rewrite ->  inj_plus in *.
 rewrite -> Q.Zplus_Qplus in *.
 ring_simplify in H1.
 ring_simplify in H2.
 apply (IHt e1'' e2'' (e1'' + e1')%Qpos (e2'' + e2')%Qpos);
   try (autorewrite with QposElim; ring_simplify; assumption).
 unfold Qball.
 autorewrite with QposElim.
 unfold QAbsSmall.
 setoid_replace (x + approximate a e1'' - (y + approximate a e2''))%Q
   with ((x - y) + (approximate a e1'' - approximate a e2''))
   by (unfold canonical_names.equiv, stdlib_rationals.Q_eq; simpl; ring).
 simpl.
 setoid_replace (proj1_sig e1'' + proj1_sig e1' + (proj1_sig e2'' + proj1_sig e2'))%Q
   with ((proj1_sig e1' + proj1_sig e2') + (proj1_sig e1'' + proj1_sig e2''))%Q
   by (unfold canonical_names.equiv, stdlib_rationals.Q_eq; simpl; ring).
 apply QAbsSmall_plus.
  auto.
 apply (regFun_prf a).
 simpl. rewrite Qplus_assoc. assumption.
 simpl. rewrite Qplus_assoc. assumption.
Qed.

Definition CRsum_list (l:list CR) : CR := Build_RegularFunction (CRsum_list_prf l).

Lemma CRsum_correct : forall l, (CRsum_list l == fold_right (fun x y => x + y) 0 l)%CR.
Proof.
 induction l.
  apply regFunEq_equiv, regFunEq_e; intros e.
  apply ball_refl. apply (Qpos_nonneg (e+e)).
 simpl (fold_right (fun x y : CR => (x + y)%CR) 0%CR (a :: l)).
 rewrite <- IHl.
 clear -l.
 apply regFunEq_equiv, regFunEq_e; intros e.
 simpl.
 unfold Cap_raw.
 simpl.
 unfold CRsum_list_raw.
 simpl.
 destruct l; simpl.
 rewrite Qplus_0_l, Qplus_0_r.
  setoid_replace (proj1_sig e+proj1_sig e)
    with (proj1_sig ((1 # 1) *e + (1 # 2) * e + (1 # 2) * e))%Qpos
         by (unfold canonical_names.equiv, stdlib_rationals.Q_eq; simpl; ring).
  change (Qball (proj1_sig ((1 # 1) * e + (1 # 2) * e + (1 # 2) * e)%Qpos)
                (approximate a ((1 # 1) * e)%Qpos)
                (approximate a ((1 # 2) * e)%Qpos)).
  apply ball_weak. apply Qpos_nonneg.
  apply regFun_prf.
 set (n:=  (@length (RegularFunction Qball) l)).
 cut (forall (z1:Q) (e3 e5 e1 e2 e4 e6:Qpos) (z2 z3:Q),
         ball (proj1_sig e5) z1 z2 ->
         (z3 == approximate a e3 + z1)
         -> (proj1_sig e1*(Z.of_nat n#1) + proj1_sig e2*(Z.of_nat n#1) +proj1_sig e3 + proj1_sig e4 + proj1_sig e5  <= proj1_sig e6)
         -> Qball (proj1_sig e6) (fold_left Qplus
     (map (fun x : RegularFunction Qball => approximate x e1) l) z3) (approximate a e4 +
       fold_left Qplus (map (fun x : RegularFunction Qball => approximate x e2) l) z2)).
 { intros H.
  apply (H (approximate m ((1 # Pos.succ (P_of_succ_nat n)) * e)%Qpos)
           ((1 # Pos.succ (P_of_succ_nat n)) * e)%Qpos
           ((1 # Pos.succ (P_of_succ_nat n)) * e +
            (1 # P_of_succ_nat n) * ((1 # 2) * e))%Qpos
           _ _ _ (e+e)%Qpos).
  2: rewrite Qplus_0_l; reflexivity.
  pose proof (Qplus_0_l (approximate m ((1 # Pos.of_succ_nat n) * ((1 # 2) * e))%Qpos)).
  apply Qball_0 in H0. rewrite H0.
    apply regFun_prf.
    simpl.
    apply (Qle_trans _
((1 # Pos.succ (P_of_succ_nat n)) * ((2#1)+(Z.of_nat n#1)) *proj1_sig e +
                    ((1 # P_of_succ_nat n) * ((1#1) + (Z.of_nat n#1)) * ((1 # 2) * proj1_sig e)  + (1 # 2) * proj1_sig e))).
    ring_simplify; apply Qle_refl.
    setoid_replace ((1 # Pos.succ (Pos.of_succ_nat n)) * ((2#1) + (Z.of_nat n#1)))
      with (1#1)%Q.
  setoid_replace ((1 # Pos.of_succ_nat n) * ((1#1) + (Z.of_nat n#1))) with (1#1)%Q.
  field_simplify.
  setoid_replace (8 # 4) with (2#1) by reflexivity. apply Qle_refl.
  unfold Qmult, inject_Z, Qplus, Qeq, Qnum, Qden.
  ring_simplify. rewrite Pos.mul_1_r.
  unfold canonical_names.equiv, stdlib_rationals.Q_eq.
  rewrite Z.mul_1_l, Z.mul_1_l, Z.mul_1_r, Z.add_comm.
  rewrite <- Z.P_of_succ_nat_Zplus.
  unfold Qeq; simpl. rewrite Pos.mul_1_r. reflexivity.
  unfold canonical_names.equiv, stdlib_rationals.Q_eq.
  unfold Qmult, inject_Z, Qplus, Qeq, Qnum, Qden.
  ring_simplify. rewrite Pos.mul_1_r.
  rewrite <- SuccNat2Pos.inj_succ.
  rewrite Z.P_of_succ_nat_Zplus.
  replace (S n) with (1+n)%nat by reflexivity.
  rewrite Nat2Z.inj_add.
  rewrite (Z.add_comm 1). rewrite <- Z.add_assoc. reflexivity. }
 unfold n.
 clear n.
 induction l; intros z1 e3 e5 e1 e2 e4 e6 z2 z3 Hz H0 H.
  simpl in *.
  ring_simplify in H.
  ring_simplify.
  apply Qball_0 in H0.
  rewrite -> H0.
  unfold Qball.
  unfold QAbsSmall.
  setoid_replace (approximate a e3 + z1 - (approximate a e4 + z2))
    with ((approximate a e3 - approximate a e4) + (z1 - z2))
    by (unfold canonical_names.equiv, stdlib_rationals.Q_eq; simpl; ring).
  pose proof (@ball_weak_le Q_as_MetricSpace
                       (proj1_sig e3 + proj1_sig e4 + proj1_sig e5)
                       (proj1_sig e6)
                       (approximate a e3 - approximate a e4 + (z1 - z2)) 0).
  simpl in H1.
  unfold Qball, QAbsSmall, Qminus in H1. rewrite Qplus_0_r in H1.
  apply H1. exact H.
  apply QAbsSmall_plus; auto.
  apply (regFun_prf a).
 simpl.
 apply (IHl (z1 + approximate a0 e1) e3 (e5 + (e1 + e2))%Qpos).
   simpl.
   unfold Qball.
   unfold QAbsSmall.
   setoid_replace (z1 + approximate a0 e1 - (z2 + approximate a0 e2))
     with ((z1 - z2) + (approximate a0 e1 - approximate a0 e2))
     by (unfold canonical_names.equiv, stdlib_rationals.Q_eq; simpl; ring).
   apply QAbsSmall_plus.
    auto.
   apply (regFun_prf a0).
  rewrite -> H0.
  simpl; ring.
  simpl.
 simpl in H.
 set (n:=  (@length (RegularFunction Qball) l)) in *.
 change (Zpos (P_of_succ_nat n)) with (Z_of_nat (1+n)) in H.
 rewrite inj_plus in H.
 refine (Qle_trans _ _ _ _ H). clear H.
 setoid_replace (Z.of_nat 1 + Z.of_nat n # 1)%Q
   with ((1#1) + (Z.of_nat n # 1)).
 ring_simplify. apply Qle_refl.
 unfold canonical_names.equiv, stdlib_rationals.Q_eq.
 unfold Qeq, Qplus, Qnum, Qden.
 rewrite Z.mul_1_r, Z.mul_1_r, Z.mul_1_r, Z.mul_1_r.
 reflexivity.
Qed.


Require Export SystemFR.Judgments.
Require Export SystemFR.AnnotatedTactics.
Require Export SystemFR.ErasedSubtype.

Opaque reducible_values.

Lemma annotated_subtype_arrow:
  forall Θ Γ A1 A2 B1 B2 x,
    ~(x ∈ fv_context Γ) ->
    ~(x ∈ fv A2) ->
    ~(x ∈ fv B2) ->
    ~(x ∈ fv B1) ->
    ~(x ∈ Θ) ->
    is_annotated_type A2 ->
    is_annotated_type B2 ->
    [[ Θ; Γ ⊨ B1 <: A1 ]] ->
    [[ Θ; (x,B1) :: Γ ⊨ open 0 A2 (fvar x term_var) <: open 0 B2 (fvar x term_var) ]] ->
    [[ Θ; Γ ⊨ T_arrow A1 A2 <: T_arrow B1 B2 ]].
Proof.
  unfold open_subtype;
    repeat step.
  apply reducible_arrow_subtype_subst with (erase_type A1) (erase_type A2) (erase_context Γ) x;
    repeat step;
    side_conditions.

  unshelve epose proof (H7 ρ l0 _ _ _ v0 _);
    repeat step || erase_open.
Qed.

Lemma annotated_subtype_arrow2:
  forall Θ Γ T A B x f,
    ~(x ∈ fv_context Γ) ->
    ~(f ∈ fv_context Γ) ->
    ~(x = f) ->
    ~(x ∈ fv B) ->
    ~(f ∈ fv B) ->
    ~(x ∈ fv A) ->
    ~(f ∈ fv A) ->
    ~(x ∈ fv T) ->
    ~(f ∈ fv T) ->
    ~(x ∈ Θ) ->
    ~(f ∈ Θ) ->
    is_annotated_type B ->
    [[ Θ; (x,A) :: (f,T) :: Γ ⊨
         app (fvar f term_var) (fvar x term_var) : open 0 B (fvar x term_var) ]] ->
    [[ Θ; Γ ⊨ T <: T_arrow A B ]].
Proof.
  unfold open_subtype;
    repeat step.

  apply subtype_arrow2 with (support ρ) x f (erase_context Γ) (erase_type T);
    repeat step || erase_open;
    side_conditions.
Qed.


(*
  vim: filetype=coq
*)
(*
Copyright (C) 2016-2018 Philip H. Smith

This program 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 3 of the License, or
(at your option) any later version.

This program 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.
*)

Require Import Way.Tactics.

Require Import Way.Preterm.

(* Collect the names of the free variables in a preterm into a list. *)
Fixpoint free_variables (p : preterm) : list atom :=
  match p with

  | free_variable a => [a]

  | bound_variable _ => []

  | product a b => (free_variables a) ++ (free_variables b)

  | abstraction a b => (free_variables a) ++ (free_variables b)

  | application f a => (free_variables f) ++ (free_variables a)

  | type _ => []

  end.

Module Examples.

Import Aliases.

Example free_variables_of_fvar_is_singleton :
  forall (a : atom), free_variables (fvar a) = [a].
Proof.
  infer.
Defined.

Example free_variables_of_bvar_are_empty : free_variables (bvar 0) = [].
Proof.
  infer.
Defined.

Example free_variables_of_prod_are_those_of_domain_and_codomain :
  forall (a b : atom), free_variables (prod (fvar a) (fvar b)) = [a; b].
Proof.
  infer.
Defined.

Example free_variables_of_abs_are_those_of_annotation_and_body :
  forall (a b : atom), free_variables (abs (fvar a) (fvar b)) = [a; b].
Proof.
  infer.
Defined.

Example free_variables_of_app_are_those_of_function_and_argument :
  forall (a b : atom), free_variables (abs (fvar a) (fvar b)) = [a; b].
Proof.
  infer.
Defined.

Example free_variables_of_type_are_empty : free_variables (type 0) = [].
Proof.
  infer.
Defined.

End Examples.


(**
Content :
- Some lemma on Yoneda
- Famillies of Types in CwF (DepTypes prefixe mostly)
- Pi Types in CwF (CwF_Pi prefixe)
- Sigma Types in CwF (CwF_Sig prefixe)
- Identity Types in CwF (CwF_Id prefixe)
**)

Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import TypeTheory.Auxiliary.CategoryTheoryImports.
Require Import TypeTheory.Auxiliary.Auxiliary.
Require Import TypeTheory.Auxiliary.CategoryTheory.
Require Import TypeTheory.Auxiliary.Pullbacks.
Require Import TypeTheory.Auxiliary.TypeOfMorphisms.
Require Import TypeTheory.Auxiliary.SetsAndPresheaves.

Require Import TypeTheory.CwF.CwF_def.

Section Fix_Category.
(** * Preliminaries *)
(** General context for a category with famillies and some usefull notations *)
Context {CwF : cwf}.

(* TODO: CwF’s have access functions; use them instead of projections here (and maybe use them throughout, for uniformity)? *)
Local Definition C : category := pr1(CwF).
Local Definition pp : mor_total(preShv(C)) := pr12 CwF.
Local Definition Ty : functor _ _ := target pp.
Local Definition Tm : functor _ _ := source pp.
(* extension of context *)
Local Definition ext (Γ : C) (A : Ty Γ : hSet) : C := pr11 pr22 CwF Γ A.
Local Notation "Γ .: A" :=  (ext Γ A) (at level 24).

Local Definition pi {Γ : C} (A : Ty Γ : hSet) : C⟦Γ.:A,Γ⟧ := pr21 pr22 CwF _ A.
(* just a simple to use pp as a nat_trans *)
Local Definition Nat_trans_morp {C : category} (Γ : C) (p : mor_total(preShv C))
: HSET_univalent_category ⟦ (pr21 p : functor _ _) Γ, (pr11 p : functor _ _) Γ ⟧ := pr12 p Γ.

Notation "p __: Γ" := (Nat_trans_morp Γ p)  (at level 24).
Local Definition pp_ (Γ : C) : (Tm Γ : hSet) → (Ty Γ : hSet) := pp __: Γ.

Lemma Ty_composition {Γ Γ' Γ'' : C} (f : C⟦Γ,Γ'⟧) (g : C⟦Γ',Γ''⟧) (A : Ty Γ'' : hSet)
: #Ty (f;;g) A = #Ty f (#Ty g A).
Proof.
  apply functor_comp_pshf.
Qed.

Lemma Tm_composition {Γ Γ' Γ'' : C} (f : C⟦Γ,Γ'⟧) (g : C⟦Γ',Γ''⟧) (A : Tm Γ'' : hSet)
: #Tm (f;;g) A = #Tm f (#Tm g  A).
Proof.
  apply functor_comp_pshf.
Qed.

Lemma Ty_identity {Γ : C} (A : Ty Γ : hSet) : A = #Ty (identity Γ) A.
Proof.
  apply pathsinv0, functor_id_pshf.
Qed.

(** * Tm as a Display **)
Section tm.
Local Definition tm {Γ : C} (A : Ty Γ : hSet) : UU
:= ∑ (a : Tm Γ : hSet), pp_ _ a = A.

Local Definition pr1_tm {Γ : C} {A : Ty Γ : hSet} (a : tm A) : Tm Γ : hSet := pr1 a.
Coercion pr1_tm : tm >-> pr1hSet.

Lemma ppComp1 {Γ Δ : C} {A : Ty Γ : hSet} (f : C^op ⟦Γ,Δ⟧) (a : tm A) :
  pp_ _ (# Tm f a ) = # Ty f A.
Proof.
  etrans. { apply nat_trans_ax_pshf. }
  cbn. apply maponpaths, (pr2 a).
Qed.

Definition reind_cwf {Γ : C} (A : Ty Γ : hSet) {Γ'} (f : C⟦Γ',Γ⟧)
: Ty Γ' : hSet := #Ty f A.
Local Definition reind_tm {Γ Δ} (f : C^op ⟦Γ,Δ⟧) {A : Ty Γ : hSet} (x : tm A)
: tm (#Ty f A) := #Tm f x,,ppComp1 f x.

Local Definition te {Γ : C} (A : Ty Γ : hSet) : tm (#Ty (pi A) A)
:= pr12 pr22 CwF _ A.
(* proof of pp (te A) = Ty (pi A) A*)
Local Definition te' {Γ : C} (A : Ty Γ : hSet) : pp_ _ (te A) = #Ty (pi A) A := pr212 pr22 CwF Γ A.

Definition CwF_isPullback {Γ} (A : Ty Γ : hSet) : isPullback (cwf_square_comm (te' A))
:= pr22 pr22 CwF Γ A.

Definition CwF_Pullback {Γ : C} (A : Ty Γ : hSet)
:= make_Pullback _ (CwF_isPullback A).

Local Definition tm_transportf {Γ} {A A' : Ty Γ : hSet} (e : A = A')
: tm A ≃ tm A'.
Proof.
  use weqbandf.
  -  exact (idweq (Tm Γ : hSet)).
  -  induction e. intro x. exact (idweq _).
Defined.

Local Definition tm_transportb {Γ} {A A' : Ty Γ : hSet} (e : A = A')
: tm A' ≃ tm A := invweq(tm_transportf e).

Lemma tm_transportf_idpath {Γ} {A : Ty Γ : hSet} (t : tm A)
: tm_transportf (idpath A) t = t.
Proof.
  reflexivity.
Qed.

Lemma tm_transportb_idpath {Γ} {A : Ty Γ : hSet} (t : tm A)
: tm_transportb (idpath A) t = t.
Proof.
  reflexivity.
Qed.

Lemma tm_transportbf {Γ} {A A' : Ty Γ : hSet} (e : A = A') : tm_transportb e = tm_transportf (!e).
Proof.
  induction e.
  refine (subtypePath isapropisweq _).
  apply (idpath _).
Qed.

Lemma reind_compose_tm
{Γ Γ' Γ'' : C} (f : C⟦Γ',Γ⟧) (g : C⟦Γ'',Γ'⟧) {A : Ty Γ : hSet} (a : tm A)
  : reind_tm (g ;; f) a
= tm_transportb (Ty_composition _ _ _) (reind_tm g (reind_tm f a)).
Proof.
  apply subtypePath.
  -  intro x. apply (setproperty (Ty Γ'' : hSet)).
  -  rewrite tm_transportbf. apply Tm_composition.
Qed.

Lemma maponpaths_2_reind_tm
{Γ Γ' : C} {f f' : C⟦Γ',Γ⟧} (e : f = f') {A : Ty Γ : hSet} (a : tm A)
: reind_tm f a = tm_transportb (maponpaths (fun g => #Ty g A) e) (reind_tm f' a).
Proof.
  induction e.
  rewrite maponpaths_eq_idpath; [|apply idpath].
  now rewrite tm_transportb_idpath.
Qed.

Lemma tm_transportf_compose {Γ : C} {A A' A'' : Ty Γ : hSet} (e : A = A')
(e' : A' = A'') (a : tm A)
: tm_transportf (e @ e') a = tm_transportf e' (tm_transportf e a).
Proof.
  induction e.
  induction e'.
  reflexivity.
Qed.

Lemma tm_transportf_irrelevant {Γ} {A A' : Ty Γ : hSet} (e e' : A = A')
(t : tm A)
: tm_transportf e t = tm_transportf e' t.
Proof.
  apply (maponpaths (fun e => tm_transportf e t)).
  apply (setproperty (Ty Γ : hSet)).
Qed.

Lemma tm_transport_compose {Γ Γ' Γ'' : C} (f : C⟦Γ',Γ⟧) (g : C⟦Γ'',Γ'⟧) (A : Ty Γ : hSet) (a : tm A)
: tm_transportf ((Ty_composition g f A)) (reind_tm (g;;f) a) = reind_tm g (reind_tm f a).
Proof.
  rewrite reind_compose_tm.
  rewrite tm_transportbf.
  rewrite <- tm_transportf_compose ,pathsinv0l.
  reflexivity.
Qed.

Lemma tm_transportf_bind {Γ} {A A' A'': Ty Γ : hSet} {e : A' = A} {e' : A'' = A'}
{t} {t'} {t''} (ee : t = tm_transportf e t') (ee' : t' = tm_transportf e' t'')
: t = tm_transportf (e' @ e) t''.
Proof.
  etrans. 2: { apply pathsinv0, tm_transportf_compose. }
  etrans. { eassumption. }
  apply maponpaths; assumption.
Qed.

Lemma reind_compose_tm'
{Γ Γ' Γ'' : C} (f : C⟦Γ',Γ⟧) (g : C⟦Γ'',Γ'⟧) {A : Ty Γ : hSet} (a : tm A)
: tm_transportf (Ty_composition _ _ _)
        (reind_tm (g ;; f) a)
      = reind_tm g (reind_tm f a).
Proof.
  rewrite reind_compose_tm. rewrite tm_transportbf.
  now rewrite <- tm_transportf_compose, pathsinv0l, tm_transportf_idpath.
Qed.

Lemma reind_id_tm {Γ : C}{A : Ty Γ : hSet} (a : tm A)
: reind_tm (identity _) a
= tm_transportb (functor_id_pshf _) a.
Proof.
  apply subtypePath.
  - intros x. apply setproperty.
  - apply (functor_id_pshf a).
Qed.

End tm.

Section Yoneda.

(** * Few usefull lemma on yoneda **)

Lemma yonedainv {A B : C} (f : C⟦A,B⟧) : Yo^-1 (#Yo f) = f.
Proof.
  apply id_left.
Qed.

Lemma transportyo {A B : C} {f g : C⟦A,B⟧} (e : #Yo f = #Yo g) : f = g.
Proof.
  apply (pathscomp0 (!(yonedainv f))), pathsinv0
  ,(pathscomp0 (!(yonedainv g))), (!(maponpaths Yo^-1 e)).
Qed.

Lemma yonedacarac {Γ Δ : C} (f  : _ ⟦Yo Γ,Yo Δ⟧)
: # Yo ((f :nat_trans _ _) Γ (identity Γ)) = f.
Proof.
  etrans. 2: { apply yoneda_map_1_2. }
  apply pair_path_in2, isaprop_is_nat_trans, homset_property.
Qed.

Lemma invyoneda {A B : C} (f : _⟦Yo A,Yo B⟧) : #Yo (Yo^-1 f) = f.
Proof.
  apply yonedacarac.
Qed.

Lemma yyidentity {Γ : C} {A : Ty Γ : hSet} (B : Ty (Γ.:A) : hSet)
: B = (@yy C Ty (Γ.:A) B : nat_trans _ _) (Γ.:A) (identity (Γ.:A)).
Proof.
  apply pathsinv0, functor_id_pshf.
Qed.

End Yoneda.

Section qq.
(** morphism between contexts *)

Local Definition qq_yoneda {Γ  Δ : C} (A : Ty Γ : hSet) (f : C ⟦Δ,Γ⟧)
: (preShv C) ⟦Yo (Δ .: (#Ty f A)), Yo (Γ.: A) ⟧.
Proof.
  use (PullbackArrow (CwF_Pullback A)).
  -  apply (#Yo (pi _) ;; #Yo f ).
  -  apply (yy (te _)).
  -  abstract (
        assert (XT := (cwf_square_comm (te' (#Ty f A) )));
        eapply pathscomp0; try apply XT; clear XT;
        rewrite <- assoc; apply maponpaths;
        apply pathsinv0, yy_natural
     ).
Defined.

Lemma qq_yoneda_commutes_1 {Γ Δ : C} (A : Ty Γ : hSet) (f : C ⟦Δ,Γ⟧)
: (# Yo (pi (#Ty f A)) ;; # Yo f) = (qq_yoneda A f) ;; # Yo (pi A ) .
Proof.
  apply pathsinv0.
  apply (PullbackArrow_PullbackPr1 (CwF_Pullback _)).
Qed.

Lemma qq_yoneda_commutes {Γ Δ : C} (A : Ty Γ : hSet) (f : C^op ⟦Γ,Δ⟧)
  : (qq_yoneda A f ;; (@yy C Tm (Γ .: A)) (te A)) = (@yy C Tm (Δ .: # Ty f A)) (te (# Ty f A)).
Proof.
  apply (PullbackArrow_PullbackPr2 (CwF_Pullback A)).
Qed.

Local Definition qq_term {Γ  Δ : C} (A : Ty Γ : hSet) (f : C^op ⟦Γ,Δ⟧)
: C ⟦ Δ.:(#Ty f A) , Γ.: A⟧.
Proof.
  apply (invweq (make_weq _ (yoneda_fully_faithful _ _ _ ))) ,
  (qq_yoneda A f).
Defined.

Lemma qq_yoneda_compatibility {Γ  Δ : C} (A : Ty Γ : hSet) (f : C^op ⟦Γ,Δ⟧) :
 #Yo(qq_term A f) = qq_yoneda A f.
Proof.
  apply (homotweqinvweq
  (make_weq _ (yoneda_fully_faithful _ ( _ .:(#Ty f A)) (Γ.:A)))).
Qed.

Lemma qq_term_te {Γ Δ : C} (A : Ty Γ : hSet) (f : C^op ⟦Γ,Δ⟧)
: #Tm (qq_term A f) (te A) = te (#Ty f A).
Proof.
  assert (Hyp := qq_yoneda_commutes A f).
  rewrite <- qq_yoneda_compatibility in Hyp.
  apply (pathscomp0 (yy_natural  _ _ _ _ _)) in Hyp.
  apply (invmaponpathsweq (@yy _ _ _) ).
  exact Hyp.
Qed.

Lemma qq_term_pullback {Γ  Δ :C} (A : Ty Γ : hSet) (f : C^op ⟦Γ,Δ⟧)
: f ;; pi (#Ty f A) = (qq_term A f);; pi A.
Proof.
  cbn; cbn in f.
  assert (XT := (qq_yoneda_commutes_1 A f)).
  rewrite <- qq_yoneda_compatibility in XT.
  do 2 rewrite <- functor_comp in XT.
  apply (invmaponpathsweq (make_weq _ (yoneda_fully_faithful _ _ _ ))).
  exact XT.
Qed.

Section Familly_Of_Types.
(** Famillies of types in a Category with famillies**)
Lemma Subproof_γ {Γ : C} {A : Ty Γ : hSet} (a : tm A)
  : (identity (Yo Γ) ;; (@yy C Ty Γ) A) =
      ((@yy C Tm Γ) a ;; pp).
Proof.
  apply pathsinv0, (pathscomp0(yy_comp_nat_trans Tm Ty pp Γ a)) ,pathsinv0,
  (pathscomp0(id_left _ )), ((maponpaths yy) (!(pr2 a))).
Qed.

Definition γ {Γ : C} {A : Ty Γ : hSet} (a : tm A) : (preShv C)⟦Yo Γ,Yo (Γ.:A)⟧
  := (map_into_Pb (CwF_isPullback A) (identity _) (@yy C Tm Γ a) (Subproof_γ a)).

Lemma  γ_pull {Γ : C} (A : Ty Γ : hSet) (a : tm A)
  : (γ a ;; (@yy C Tm (Γ .: A)) (te A)) = (@yy C Tm Γ) a.
Proof.
  apply Pb_map_commutes_2.
Qed.

Lemma pull_γ {Γ : C} {A : Ty Γ : hSet} (a : tm A) : γ a ;; #Yo (pi A) = identity _.
Proof.
  apply Pb_map_commutes_1.
Qed.

Lemma γNat {Γ Δ : C} {A : Ty Γ : hSet} (f : C^op ⟦Γ,Δ⟧) (a : tm A)
: (f : C⟦Δ,Γ⟧) ;; (γ a : nat_trans _ _) Γ (identity Γ) =
  (γ (reind_tm f a ) ;; #Yo (qq_term A f) : nat_trans _ _) Δ (identity Δ).
Proof.
  apply transportyo.
  assert (Yoγ : #Yo ((f : C⟦Δ,Γ⟧) ;; (γ a : nat_trans _ _) Γ (identity Γ)) =
  #Yo((γ (reind_tm f a) : nat_trans _ _) Δ (identity Δ) ;; qq_term A f)).
  2 : { apply Yoγ. }
  do 2 (rewrite functor_comp; rewrite yonedacarac).
  cbn in f. apply (MorphismsIntoPullbackEqual (CwF_isPullback A)).
  - rewrite <- assoc.
    etrans. { apply maponpaths, pull_γ. }
    etrans. { apply id_right. }
    rewrite qq_yoneda_compatibility.
    rewrite <- assoc.
    apply pathsinv0.
    etrans. { apply maponpaths, pathsinv0, qq_yoneda_commutes_1. }
    rewrite assoc.
    etrans. { apply maponpaths_2, pull_γ. }
    apply id_left.
  - rewrite <- assoc.
    etrans. { apply maponpaths, γ_pull. }
    rewrite qq_yoneda_compatibility.
    rewrite <- assoc.
    apply pathsinv0.
    etrans. { apply maponpaths, qq_yoneda_commutes. }
    etrans. { apply γ_pull. }
    apply yy_natural.
Qed.

Lemma γPullback1 {Γ : C} (A : Ty Γ : hSet)
  : γ (te A)
     ;; #Yo (qq_term A (pi A))
     ;; (@yy C Tm (Γ .: A)) (te A)
    = identity _ ;; (@yy C Tm (Γ .: A)) (te A).
Proof.
  rewrite id_left.
  rewrite (qq_yoneda_compatibility A (pi A)), <- assoc.
  etrans. 2: { apply γ_pull. }
  apply maponpaths, qq_yoneda_commutes.
Qed.

Lemma  γPullback2 {Γ : C} (A : Ty Γ : hSet)
: γ (te A) ;; #Yo (qq_term A (pi A)) ;; #Yo (pi A) = identity _;;(#Yo (pi A)).
Proof.
  rewrite (qq_yoneda_compatibility A (pi A)), <- assoc.
  etrans. { apply maponpaths, pathsinv0, qq_yoneda_commutes_1. }
  rewrite assoc.
  apply maponpaths_2.
  apply pull_γ.
Qed.

Definition γ_qq {Γ} {A : Ty Γ: hSet} {Γ'} (f : C⟦Γ',Γ⟧) (a : tm (#Ty f A)) : C⟦Γ',Γ.: A⟧.
Proof.
  exact (Yo^-1 (γ a) ;; qq_term A f).
Defined.

Lemma γ_pi {Γ:C} {A : Ty Γ: hSet} (a : tm A) : Yo^-1 (γ a) ;; pi A = identity _.
Proof.
  assert (Yoeq : #Yo(Yo^-1 (γ a) ;; pi A) = #Yo (identity Γ)).
  - etrans. { apply functor_comp. }
    apply pathsinv0. etrans. { apply functor_id. }
    rewrite (!(pull_γ a)).
    apply maponpaths_2.
    apply pathsinv0, invyoneda.
  - apply (maponpaths (Yo^-1) ) in Yoeq.
    rewrite yonedainv, yonedainv in Yoeq.
    exact Yoeq.
Qed.

Lemma te_substitution {Γ} {A : Ty Γ : hSet} (a : tm A) : #Tm (Yo^-1(γ a)) (te A) = a.
Proof.
  assert (inter : @yy _ _ _ (#Tm (Yo^-1(γ a)) (te A)) = yy a).
  -  rewrite yy_natural, invyoneda.
     apply γ_pull.
  -  apply (maponpaths (invmap yy) ) in inter.
     do 2 rewrite homotinvweqweq in inter.
     exact inter.
Qed.

Lemma reind_id_tm' {Γ : C} {A : Ty Γ : hSet}  (a : tm A) (b : tm A)
(e : # Ty (identity Γ) A = # Ty (Yo^-1 (γ b) ;; pi A) A)
: tm_transportf e (reind_tm (identity _) a)
= tm_transportf ((Ty_identity _) @ e) a.
Proof.
  apply subtypePath.
  -  intros x. apply (setproperty (Ty Γ : hSet)).
  -  apply (functor_id_pshf a).
Qed.

Lemma Ty_γ_id {Γ : C} {A : Ty Γ : hSet} (a : tm A)
: # Ty (Yo^-1 (γ a)) (# Ty (pi A) A) = A.
Proof.
  simple refine (!(Ty_composition _ _ _) @ _).
  apply (pathscomp0 ((toforallpaths (maponpaths _ (γ_pi _)) )A)).
  apply functor_id_pshf.
Qed.

Definition DepTypesType {Γ : C} {A : Ty Γ : hSet}
  (B : Ty(Γ.:A) : hSet) (a : tm A)
  : Ty Γ : hSet
  := (γ a ;; (@yy C Ty (Γ .: A) B) : nat_trans _ _) Γ (identity Γ).

Definition DepTypesElem_pr1 {Γ : C} {A : Ty Γ : hSet} {B : Ty(Γ.:A) : hSet}
  (b : tm B)
  (a : tm A)
  : Tm Γ : hSet
  := (γ a ;; (@yy C Tm (Γ .: A) b) : nat_trans _ _) Γ (identity Γ).

Lemma DepTypesComp {Γ : C} { A : Ty Γ : hSet} {B : Ty(Γ.:A) : hSet}
(b : tm B) (a : tm A)
: pp_  Γ (DepTypesElem_pr1 b a) = DepTypesType B a.
Proof.
  etrans. 2: { exact (maponpaths _ (pr2 b)). }
  apply nat_trans_ax_pshf.
Qed.

Definition DepTypesElems {Γ : C} { A : Ty Γ : hSet} {B : Ty(Γ.:A) : hSet}
(b : tm B) (a : tm A)
: tm (DepTypesType B a) := DepTypesElem_pr1 b a ,, DepTypesComp b a.

Lemma DepTypesNat {Γ Δ : C} {A : Ty Γ : hSet} (B : Ty (Γ.: A) : hSet)
(f : C^op ⟦Γ,Δ⟧) (a : tm A)
: #Ty f (DepTypesType B a) = DepTypesType (#Ty (qq_term A f) B) (reind_tm f a).
Proof.
  unfold DepTypesType, reind_tm; rewrite yy_natural, assoc.
  etrans. { apply pathsinv0, functor_comp_pshf. }
  apply (toforallpaths (maponpaths (# Ty) (γNat f a)) B).
Qed.

Lemma DepTypesEta {Γ : C} {A : Ty Γ : hSet} (B : Ty (Γ.:A) : hSet)
: DepTypesType (#Ty (qq_term A (pi A)) B) (te A) = B.
Proof.
  unfold DepTypesType.
  etrans. 2: { apply pathsinv0, yyidentity. }
  assert (Natu0 : (γ (te A) ;; yy (# Ty (qq_term A (pi A)) B))%mor = yy B).
  2: rewrite Natu0; reflexivity.
  etrans. { apply maponpaths, yy_natural. }
  etrans. { apply assoc. }
  etrans. 2: { apply id_left. }
        apply maponpaths_2.
  apply (MorphismsIntoPullbackEqual (CwF_isPullback _)).
  - apply γPullback2.
  - apply γPullback1.
Qed.

Lemma DepTypesrewrite {Γ : C} {A : Ty Γ : hSet} (B : Ty (Γ.:A) : hSet)
(a b : tm A) (e : pr1 a = pr1 b)
: DepTypesType B a = DepTypesType B b.
Proof.
  destruct a as [a pa]; destruct b as [b pb].
  cbn in e; induction e.
  assert (ProofIrr : pa = pb) by apply (setproperty( Ty Γ : hSet)).
  destruct ProofIrr.
  reflexivity.
Qed.

End Familly_Of_Types.
End qq.

(** ** Pi Type over Category with famillies *)

Section Pi_structure.

Definition CwF_PiTypeFormer : UU
:= ∏ (Γ : C) (A : Ty Γ : hSet) (B : Ty (Γ.:A) : hSet), (Ty Γ : hSet).

Definition CwF_PiTypeNat (π : CwF_PiTypeFormer) : UU
:= ∏ (Γ Δ : C) (f : C^op ⟦Γ,Δ⟧) (A : Ty Γ : hSet) (B : Ty(Γ.:A) : hSet),
  reind_cwf (π _ A B) f  = π _ (reind_cwf A f) (reind_cwf B (qq_term A f)).

Definition CwF_pi_form_struct : UU
:= ∑ pi : CwF_PiTypeFormer, CwF_PiTypeNat pi.

Definition pr1_PiFormer (π : CwF_pi_form_struct) : CwF_PiTypeFormer := pr1 π.
Coercion pr1_PiFormer : CwF_pi_form_struct >-> CwF_PiTypeFormer.

Lemma ppComp3 {Γ Δ : C} {A : Ty Γ : hSet} (f : C^op ⟦Γ,Δ⟧) {π : CwF_PiTypeFormer}
(nπ : CwF_PiTypeNat π) {B : Ty (Γ.: A) : hSet} (c : tm (π _ A B))
: pp_ _ (# Tm f c)  = (π Δ (# Ty f A) (# Ty (qq_term A f) B)).
Proof.
  etrans. 2: { apply (nπ _ _ f A B). }
  etrans. 2: { eapply (maponpaths (# Ty f)), (pr2 c). }
  apply nat_trans_ax_pshf.
Qed.

Definition CwF_PiAbs (π : CwF_PiTypeFormer): UU
:= ∏ (Γ : C) (A : Ty Γ : hSet) (B : Ty (Γ.:A) : hSet) (b : tm B), tm (π _ A B) .

Definition CwF_PiAbsNat (π : CwF_PiTypeFormer) (nπ : CwF_PiTypeNat π) (Λ : CwF_PiAbs π)
: UU := ∏ (Γ Δ : C) (f : C^op ⟦ Γ, Δ ⟧) (A : Ty Γ : hSet)
(B : Ty (Γ .: A) : hSet) (b : tm B), reind_tm f (Λ Γ A B b) =
tm_transportf (! (! ppComp1 f (Λ Γ A B b) @ ppComp3 f nπ (Λ Γ A B b)))
(Λ Δ (# Ty f A) (# Ty (qq_term A f) B) (reind_tm (qq_term A f) b)).

Definition CwF_Pi_intro_struct (π : CwF_pi_form_struct) : UU
:= ∑ Λ : CwF_PiAbs π, CwF_PiAbsNat π (pr2 π) Λ.

Definition CwF_PiApp (π : CwF_PiTypeFormer) : UU
:= ∏ (Γ : C) (A : Ty Γ : hSet) (B : Ty(Γ.: A) : hSet) (c : tm (π _ A B)) (a : tm A),
tm (DepTypesType B a).

Definition CwF_PiAppNat  (π : CwF_PiTypeFormer) (nπ : CwF_PiTypeNat π) (app : CwF_PiApp π) : UU
:= ∏ (Γ Δ : C) (f : C^op ⟦Γ,Δ⟧) (A : Ty Γ : hSet) (B : Ty(Γ.: A) : hSet)
(c : tm (π _ A B)) (a : tm A),
reind_tm f (app _ _ _ c a) = (tm_transportf  (!(DepTypesNat B f a))
(app _ (#Ty f A) (# Ty (qq_term A f) B)
 (tm_transportf (nπ _ _ f A B) (reind_tm f c)) (reind_tm f a))).

Definition CwF_Pi_app_struct (π : CwF_pi_form_struct) : UU
:= ∑ app : CwF_PiApp π, CwF_PiAppNat π (pr2 π) app.

Definition CwF_PiAppAbs (π : CwF_PiTypeFormer) (Λ : CwF_PiAbs π) (app : CwF_PiApp π)
:= ∏ Γ ( A : Ty Γ : hSet) (B : Ty(Γ.: A) : hSet) (b : tm B) (a : tm A),
app _ _ _ (Λ _ A _ b) a = DepTypesElems b a.

Definition CwF_Pi_comp_struct (π : CwF_pi_form_struct)
(lam : CwF_Pi_intro_struct π) (app : CwF_Pi_app_struct π) : UU
:= CwF_PiAppAbs π (pr1 lam) (pr1 app).

Definition CwF_PiAbsAppComp (π : CwF_PiTypeFormer) (nπ : CwF_PiTypeNat π)
(Λ : CwF_PiAbs π) (app : CwF_PiApp π)
: UU
:= ∏ (Γ : C) (A : Ty Γ: hSet) (B : Ty (Γ .: A) : hSet) (c : tm (π Γ A B)),
c = Λ Γ A B (tm_transportf (DepTypesEta B)
(app (Γ .: A) (# Ty (pi A) A) (# Ty (qq_term A (pi A)) B)
(tm_transportf (nπ Γ (Γ .: A) (pi A) A B) (reind_tm (pi A) c)) (te A))).

End Pi_structure.

(** ** Sigma Type over Category with famillies *)
Section Sigma_structure.

Definition CwF_SigTypeFormer : UU
:= ∏ (Γ : C) (A : Ty Γ : hSet) (B : Ty (Γ.:A) : hSet), Ty Γ : hSet.

Definition CwF_SigTypeNat (σ : CwF_SigTypeFormer) : UU
:= ∏ (Γ Δ : C) (f : C^op ⟦Γ,Δ⟧) (A : Ty Γ : hSet) (B : Ty(Γ.:A) : hSet),
#Ty f (σ _ A B) = σ _ (#Ty f A) (#Ty (qq_term A f) B).

Definition CwF_SigAbs (σ : CwF_SigTypeFormer) : UU
:= ∏ (Γ : C) (A : Ty Γ : hSet) (B : Ty(Γ.:A) : hSet) (a : tm A)
(b : tm (DepTypesType B a) ), tm (σ _ A B).

Definition CwF_SigAbsNat (σ : CwF_SigTypeFormer) (nσ : CwF_SigTypeNat σ)
(pair : CwF_SigAbs σ)
: UU := ∏ (Γ Δ : C) (f : C^op ⟦ Γ, Δ ⟧) (A : Ty Γ : hSet) (B : Ty (Γ .: A) : hSet)
(a : tm A) (b : tm (DepTypesType B a)), reind_tm f (pair Γ A B a b) =
tm_transportf (! nσ Γ Δ f A B)
(pair Δ (# Ty f A) (# Ty (qq_term A f) B) (reind_tm f a)
(tm_transportf (DepTypesNat B f a) (reind_tm f b))).

Definition CwF_SigPr1 (σ : CwF_SigTypeFormer) : UU
:= ∏ Γ (A : Ty Γ : hSet) (B : Ty(Γ.:A) : hSet) (c: tm (σ _ A B)), tm A.

Definition CwF_SigPr1Nat (σ : CwF_SigTypeFormer) (nσ : CwF_SigTypeNat σ) (p1 : CwF_SigPr1 σ) : UU
:= ∏ (Γ Δ : C)  (f : C^op ⟦Γ,Δ⟧) (A : Ty Γ : hSet) (B : Ty(Γ.:A) : hSet) (c : tm (σ _ A B)),
reind_tm f (p1 _ _ _ c) =
p1 _ (#Ty f A) (#Ty (qq_term A f) B) (tm_transportf (nσ _ _ f _ _) (reind_tm f c)).

Definition CwF_SigPr2 (σ : CwF_SigTypeFormer) (p1 : CwF_SigPr1 σ) :UU
:= ∏ Γ (A : Ty Γ : hSet) (B : Ty(Γ.:A) : hSet)
(c : tm (σ _ A B) ), tm (DepTypesType B (p1 _ _ _ c)).

Definition CwF_SigPr2Nat (σ : CwF_SigTypeFormer) (nσ : CwF_SigTypeNat σ) (p1 : CwF_SigPr1 σ)
(np1 : CwF_SigPr1Nat σ nσ p1) (p2 : CwF_SigPr2 σ p1)
: UU := ∏ (Γ Δ : C) (f : C^op ⟦ Γ, Δ ⟧) (A : Ty Γ : hSet) (B : Ty (Γ .: A) : hSet)
(c : tm (σ Γ A B)),
reind_tm f (p2 Γ A B c) = tm_transportf (! DepTypesNat B f (p1 Γ A B c))
(tm_transportf (DepTypesrewrite (# Ty (qq_term A f) B)
(p1 Δ (# Ty f A) (# Ty (qq_term A f) B) (tm_transportf (nσ Γ Δ f A B) (reind_tm f c)))
(reind_tm f (p1 Γ A B c)) (maponpaths pr1 (! np1 Γ Δ f A B c)))
(p2 Δ (# Ty f A) (# Ty (qq_term A f) B) (tm_transportf (nσ Γ Δ f A B) (reind_tm f c)))).

Definition CwF_SigAbsPr1 (σ : CwF_SigTypeFormer) (pair : CwF_SigAbs σ) (p1 : CwF_SigPr1 σ)
: UU := ∏ Γ (A : Ty Γ : hSet) (B : Ty(Γ.:A) : hSet) (a : tm A) (b : tm (DepTypesType B a)),
p1 _ _ _ (pair _  _ _ a b) = a.

Definition CwF_SigAbsPr2 (σ : CwF_SigTypeFormer) (pair : CwF_SigAbs σ) (p1 : CwF_SigPr1 σ)
(p2 : CwF_SigPr2 σ p1) (Ap1 : CwF_SigAbsPr1 σ pair p1)
: UU := ∏ (Γ : C^op) (A : Ty Γ : hSet) (B : Ty (Γ .: A) : hSet)
(a : tm A) (b : tm (DepTypesType B a)),
b = tm_transportf
(DepTypesrewrite B (p1 Γ A B (pair Γ A B a b)) a (maponpaths pr1 (Ap1 Γ A B a b)))
(p2 Γ A B (pair Γ A B a b)).

Definition CwF_SigAbsPr (σ : CwF_SigTypeFormer) (pair : CwF_SigAbs σ)
(p1 : CwF_SigPr1 σ) (p2 : CwF_SigPr2 σ p1) : UU
:= ∏ Γ (A : Ty Γ : hSet) (B : Ty(Γ.:A) : hSet) (c : tm (σ _ A B)),
pair _ _ _ (p1 _ _ _ c) (p2 _ _ _ c ) = c.

End Sigma_structure.

Section Identity_Structure.
  (** Identity Types over a Category with famillies *)

Definition CwF_IdTypeFormer : UU
:= ∏ (Γ : C) (A : Ty Γ : hSet) (a b : tm A), Ty Γ : hSet.

Definition CwF_IdTypeNat (id : CwF_IdTypeFormer) : UU
:= ∏ (Γ Δ : C) (f : C^op ⟦Γ,Δ⟧) (A : Ty Γ : hSet) (a b : tm A),
#Ty f (id _ A a b)  = id _ (#Ty f A) (reind_tm f a) (reind_tm f b).

Definition CwF_IdRefl (Id : CwF_IdTypeFormer) : UU
:= ∏ Γ (A: Ty Γ :hSet) (a :tm A), tm (Id _ _ a a).

Definition CwF_IdReflNatContext (Id : CwF_IdTypeFormer) (nid : CwF_IdTypeNat Id)
(refl : CwF_IdRefl Id) : UU
:= ∏ (Γ Δ : C) (f : C^op ⟦Γ,Δ⟧) (A : Ty Γ : hSet) (a : tm A),
reind_tm f (refl _ A a) =
tm_transportf (!(nid _ _ f _ a a)) (refl _ (#Ty f A) (reind_tm f a)).

Definition CwF_maponpathsIdForm {Id : CwF_IdTypeFormer}
{Γ} {A A'} (e_A : A = A')
{a} {a'} (e_a : a = tm_transportb e_A a')
{b} {b'} (e_b : b = tm_transportb e_A b')
: Id Γ A a b = Id Γ A' a' b'.
Proof.
  destruct e_A.
  rewrite (tm_transportbf _) in e_a, e_b;
   cbn in e_a, e_b.
  apply maponpaths_12; assumption.
Qed.

Definition CwF_IdBasedFam (Id : CwF_IdTypeFormer) {Γ : C} (A : Ty Γ : hSet) (a : tm A)
: Ty (Γ.:A) : hSet := Id _ _ (reind_tm _ a) (te A).

Definition CwF_IdBasedFamNatural (Id : CwF_IdTypeFormer) (nid : CwF_IdTypeNat Id)
{Γ Δ : C} (f : C^op ⟦Γ,Δ⟧) (A : Ty Γ : hSet) (a : tm A)
: #Ty (qq_term A f) (CwF_IdBasedFam Id A a) = CwF_IdBasedFam Id _ (reind_tm f a).
Proof.
  unfold CwF_IdBasedFam.
  etrans.
  -  exact (nid _ _ (qq_term A f) _ _ _).
  -  use CwF_maponpathsIdForm.
     --  refine (!(Ty_composition _ _ A) @ _).
         apply pathsinv0, (pathscomp0 (!(Ty_composition _ _ A))).
         refine (toforallpaths _ A).
         exact (maponpaths _ (qq_term_pullback _ _)).
     --  etrans. {apply pathsinv0, tm_transport_compose. }
         etrans. 2: { apply maponpaths, tm_transport_compose. }
         etrans. 2: {rewrite tm_transportbf; apply  tm_transportf_compose. }
         etrans. {eapply maponpaths. refine (maponpaths_2_reind_tm _ _).
         apply (!(qq_term_pullback _ _)). }
         etrans. { rewrite tm_transportbf; apply (!(tm_transportf_compose _ _ _)). }
         apply tm_transportf_irrelevant.
     --  apply subtypePath; [intro x; apply (setproperty (Ty _ : hSet))|
         rewrite tm_transportbf ;apply qq_term_te].
Qed.

Definition CwF_Id_map {Id} (nid : CwF_IdTypeNat Id) {Γ} {A : Ty Γ : hSet} (a : tm A) (b : tm A) (eqab : tm (Id _ _ a b))
: C⟦Γ,_.:CwF_IdBasedFam Id A a⟧.
Proof.
  simple refine (γ_qq (Yo^-1 (γ b)) _). unfold CwF_IdBasedFam.
  simple refine (tm_transportb _ eqab).
  abstract(
  simple refine (nid  _ _ _ _ _ _ @ _);
  use CwF_maponpathsIdForm;
  [ apply Ty_γ_id
  | rewrite tm_transportbf ;
    refine (_ @ tm_transportf_irrelevant _ _ _);
    simple refine (tm_transportf_bind (!reind_compose_tm' _ _ _) _);
    [ apply (pathscomp0 (!(Ty_γ_id b))) , (!(Ty_composition _ _ _)) |
      simple refine (maponpaths_2_reind_tm _ _ @ _);
      [exact (identity _) | apply γ_pi |
      rewrite tm_transportbf; apply (pathscomp0 (reind_id_tm' _ _ _));
      apply tm_transportf_irrelevant ]]
  | apply subtypePath;
    [  intros x; apply (setproperty (Ty Γ : hSet))
     | rewrite tm_transportbf; apply te_substitution]]).
Defined.

Definition CwF_IdBased_path_induction {Id} (nid : CwF_IdTypeNat Id) (refl : CwF_IdRefl Id) := ∏ Γ (A : Ty Γ : hSet) (a : tm A)
(P : Ty (_ .: CwF_IdBasedFam Id A a) :  hSet)
(d : tm  (#Ty (CwF_Id_map nid a a (refl _ _ a)) P))
(b : tm A) (eqab : tm (Id _ _ a b)),
tm (#Ty (CwF_Id_map nid a b eqab) P).

End Identity_Structure.
End Fix_Category.


(* 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.CRings.
Require Export CoRN.tactics.AlgReflection.

Section Ring_Interpretation_Function.

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

Inductive interpR : expr -> R -> CProp :=
  | interpR_var :
      forall (i:varindex) (z:R), (val i[=]z) -> interpR (expr_var i) z
  | interpR_int : forall (k:Z) (z:R), (zring k[=]z) -> interpR (expr_int k) z
  | interpR_plus :
      forall (e f:expr) (x y z:R),
        (x[+]y[=]z) ->
        interpR e x -> interpR f y -> interpR (expr_plus e f) z
  | interpR_mult :
      forall (e f:expr) (x y z:R),
        (x[*]y[=]z) ->
        interpR e x -> interpR f y -> interpR (expr_mult e f) z
  | interpR_unop :
      forall (e:expr) (f:unopindex) (x z:R),
        (unop f x[=]z) -> interpR e x -> interpR (expr_unop f e) z
  | interpR_binop :
      forall (e e':expr) (f:binopindex) (x y z:R),
        (binop f x y[=]z) ->
        interpR e x -> interpR e' y -> interpR (expr_binop f e e') z
  | interpR_part :
      forall (e:expr) (f:pfunindex) (x z:R) (Hx:Dom (pfun f) x),
        (pfun f x Hx[=]z) -> interpR e x -> interpR (expr_part f e) z.

Definition wfR (e:expr) := sigT (interpR e).

Inductive xexprR : R -> Type :=
  | xexprR_var : forall i:varindex, xexprR (val i)
  | xexprR_int : forall k:Z, xexprR (zring k)
  | xexprR_plus : forall (x y:R) (e:xexprR x) (f:xexprR y), xexprR (x[+]y)
  | xexprR_mult : forall (x y:R) (e:xexprR x) (f:xexprR y), xexprR (x[*]y)
  | xexprR_unop : forall (x:R) (f:unopindex) (e:xexprR x), xexprR (unop f x)
  | xexprR_binop :
      forall (x y:R) (f:binopindex) (e:xexprR x) (e':xexprR y),
        xexprR (binop f x y)
  | xexprR_part :
      forall (x:R) (f:pfunindex) (e:xexprR x) (Hx:Dom (pfun f) x),
        xexprR (pfun f x Hx)
        (* more things rrational translates: *)
  | xexprR_zero : xexprR [0]
  | xexprR_one : xexprR [1]
  | xexprR_nat : forall n:nat, xexprR (nring n)
  | xexprR_inv : forall (x:R) (e:xexprR x), xexprR [--]x
  | xexprR_minus : forall (x y:R) (e:xexprR x) (f:xexprR y), xexprR (x[-]y)
  | xexprR_power : forall (x:R) (e:xexprR x) (n:nat), xexprR (x[^]n).

Fixpoint xforgetR (x:R) (e:xexprR x) {struct e} : expr :=
  match e with
  | xexprR_var i => expr_var i
  | xexprR_int k => expr_int k
  | xexprR_plus _ _ e f => expr_plus (xforgetR _ e) (xforgetR _ f)
  | xexprR_mult _ _ e f => expr_mult (xforgetR _ e) (xforgetR _ f)
  | xexprR_unop _ f e => expr_unop f (xforgetR _ e)
  | xexprR_binop _ _ f e e' => expr_binop f (xforgetR _ e) (xforgetR _ e')
  | xexprR_part _ f e _ => expr_part f (xforgetR _ e)
  | xexprR_zero => expr_zero
  | xexprR_one => expr_one
  | xexprR_nat n => expr_nat n
  | xexprR_inv _ e => expr_inv (xforgetR _ e)
  | xexprR_minus _ _ e f => expr_minus (xforgetR _ e) (xforgetR _ f)
  | xexprR_power _ e n => expr_power n (xforgetR _ e)
  end.

Definition xinterpR (x:R) (e:xexprR x) := x.

Lemma xexprR2interpR : forall (x:R) (e:xexprR x), interpR (xforgetR _ e) x.
Proof.
 intros x e.
 induction e.
             apply (interpR_var i); algebra.
            apply (interpR_int k); algebra.
           apply (interpR_plus (xforgetR _ e1) (xforgetR _ e2) x y (x[+]y)); algebra.
          apply (interpR_mult (xforgetR _ e1) (xforgetR _ e2) x y (x[*]y)); algebra.
         apply (interpR_unop (xforgetR _ e) f x (unop f x)); algebra.
        apply (interpR_binop (xforgetR _ e1) (xforgetR _ e2) f x y (binop f x y)); algebra.
       eapply (interpR_part (xforgetR _ e) f x (pfun f x Hx)).
        apply eq_reflexive_unfolded.
       algebra.
      apply (interpR_int 0); algebra.
     apply (interpR_int 1); Step_final ([1]:R).
    apply (interpR_int (Z_of_nat n)); algebra.
   apply (interpR_mult (xforgetR _ e) (expr_int (-1)) x (zring (-1)) [--]x); auto.
    Step_final (zring (-1)[*]x).
   apply (interpR_int (-1)); algebra.
  apply (interpR_plus (xforgetR _ e1) (xforgetR _ (xexprR_inv _ e2)) x [--]y (x[-]y)); algebra.
  apply (interpR_mult (xforgetR _ e2) (expr_int (-1)) y (zring (-1)) [--]y); auto.
   Step_final (zring (-1)[*]y).
  apply (interpR_int (-1)); algebra.
 induction n.
  apply (interpR_int 1); Step_final ([1]:R).
 apply (interpR_mult (xforgetR _ e) (expr_power n (xforgetR _ e)) x ( x[^]n) (x[^]S n)); algebra.
Qed.

Definition xexprR_diagram_commutes :
  forall (x:R) (e:xexprR x), interpR (xforgetR _ e) (xinterpR _ e) :=
  xexprR2interpR.

Lemma xexprR2wfR : forall (x:R) (e:xexprR x), wfR (xforgetR _ e).
Proof.
 intros x e.
 exists x.
 apply xexprR2interpR.
Qed.

Record fexprR : Type :=  {finterpR : R; fexprR2xexprR : xexprR finterpR}.

Definition fexprR_var (i:varindex) := Build_fexprR _ (xexprR_var i).
Definition fexprR_int (k:Z) := Build_fexprR _ (xexprR_int k).
Definition fexprR_plus (e e':fexprR) :=
  Build_fexprR _
    (xexprR_plus (finterpR e) (finterpR e') (fexprR2xexprR e)
       (fexprR2xexprR e')).
Definition fexprR_mult (e e':fexprR) :=
  Build_fexprR _
    (xexprR_mult (finterpR e) (finterpR e') (fexprR2xexprR e)
       (fexprR2xexprR e')).

Definition fforgetR (e:fexprR) := xforgetR (finterpR e) (fexprR2xexprR e).

Lemma fexprR2interp : forall e:fexprR, interpR (fforgetR e) (finterpR e).
Proof.
 intros e.
 elim e. intros x e'.
 unfold fforgetR in |- *. simpl in |- *.
 apply xexprR2interpR.
Qed.

Lemma fexprR2wf : forall e:fexprR, wfR (fforgetR e).
Proof.
 intro e.
 unfold fforgetR in |- *.
 apply xexprR2wfR.
Qed.

Opaque csg_crr.
Opaque cm_crr.
Opaque cg_crr.
Opaque cr_crr.
Opaque csf_fun.
Opaque csbf_fun.
Opaque csr_rel.
Opaque cs_eq.
Opaque cs_neq.
Opaque cs_ap.
Opaque cm_unit.
Opaque csg_op.
Opaque cg_inv.
Opaque cg_minus.
Opaque cr_one.
Opaque cr_mult.
Opaque nexp_op.

Lemma refl_interpR :
 forall (e:expr) (x y:R), interpR e x -> interpR 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:R).
      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.
   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 interpR_wd :
 forall (e:expr) (x y:R), interpR e x -> (x[=]y) -> interpR e y.
Proof.
 intros e x y H H0.
 inversion H; (* inversion bug fixed in V8.1 makes these rewritings useless *)
 try (rewrite <- H2; rewrite H3 in H1).
       apply interpR_var. Step_final x.
       apply interpR_int. Step_final x.
      apply interpR_plus with x0 y0; auto. Step_final x.
     apply interpR_mult with x0 y0; auto. Step_final x.
    apply interpR_unop with x0; auto. Step_final x.
   apply interpR_binop with x0 y0; auto. Step_final x.
  apply interpR_part with x0 Hx; auto. Step_final x.
Qed.

End Ring_Interpretation_Function.

Section Ring_NormCorrect.

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

Notation II := (interpR R 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_R :
 forall (e f:expr) (x y:R), II e x -> II f y -> II (MI_mult e f) (x[*]y).
Proof.
 cut (forall x y:R, II (expr_int 0) y -> II (expr_int 0) (x[*]y)).
  cut (forall (e1 e2 f:expr) (x y:R),
    (forall (f:expr) (x y:R), 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:R),
     II (expr_int i) x -> II (expr_int j) y -> II (expr_int (i * j)) (x[*]y)).
    cut (forall (e f:expr) (x y:R), 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 interpR_mult with x y; algebra.
   intros; apply interpR_wd with (zring (i * j):R).
    apply interpR_int; algebra.
   inversion X. inversion X0.
   Step_final (zring i[*]zring j:R).
  intros. inversion X0.
  try (rewrite H in X2; rewrite H1 in X3; rewrite H0 in H2). (* compat 8.0 *)
  apply interpR_wd with (x0[*](y0[*]y)); algebra.
   apply interpR_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 interpR_wd with (zring 0:R).
  apply interpR_int; algebra.
 astepl ([0]:R).
 astepl (x[*][0]).
 Step_final (x[*]zring 0).
Qed.
Transparent Zmult.

Opaque MI_mult.
Lemma MV_mult_corr_R :
 forall (e f:expr) (x y:R), II e x -> II f y -> II (MV_mult e f) (x[*]y).
Proof.
 cut (forall (e1 e2 f:expr) (x y:R),
   (forall (f:expr) (x y:R), 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:R), II e x -> II f y -> II (MI_mult (expr_mult f expr_one) e) (x[*]y)).
   cut (forall (e f:expr) (x y:R), II e x -> II f y -> II (expr_mult f e) (x[*]y)).
    cut (forall (e f:expr) (x y:R), 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. inversion X1.
        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 interpR_mult with x y; algebra.
   intros; apply interpR_wd with (y[*]x); algebra.
   apply interpR_mult with y x; algebra.
  intros; apply interpR_wd with (y[*][1][*]x).
   apply MI_mult_corr_R; auto.
   apply interpR_mult with y ([1]:R); algebra.
   apply (interpR_int R 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 interpR_wd with (x0[*](y0[*]y)).
  apply interpR_mult with x0 (y0[*]y); algebra.
 Step_final (x0[*]y0[*]y).
Qed.
Transparent MI_mult.

Opaque MV_mult MI_mult.
Lemma MM_mult_corr_R :
 forall (e f:expr) (x y:R), II e x -> II f y -> II (MM_mult e f) (x[*]y).
Proof.
 cut (forall (e1 e2 f:expr) (x y:R),
   (forall (f:expr) (x y:R), 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:R),
    II (expr_int i) x -> II f y -> II (MI_mult f (expr_int i)) (x[*]y)).
   cut (forall (e f:expr) (x y:R), 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 interpR_mult with x y; algebra.
  intros; apply interpR_wd with (y[*]x); algebra.
  apply MI_mult_corr_R; auto.
 intros. inversion X0.
 try (rewrite H0 in H2; rewrite H in X2; rewrite H1 in X3). (* compat 8.0 *)
 apply interpR_wd with (y0[*]y[*]x0).
  apply MV_mult_corr_R; auto.
 astepl (x0[*](y0[*]y)).
 Step_final (x0[*]y0[*]y).
Qed.
Transparent MV_mult MI_mult.

Opaque MV_mult.
Lemma MM_plus_corr_R :
 forall (e f:expr) (x y:R), II e x -> II f y -> II (MM_plus e f) (x[+]y).
Proof.
 cut (forall (i j:Z) (x y:R),
   II (expr_int i) x -> II (expr_int j) y -> II (expr_int (i + j)) (x[+]y)).
  cut (forall (e f:expr) (x y:R), 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 interpR_wd with ((y0[+]y1)[*]x0).
            apply MV_mult_corr_R; auto.
           astepl (x0[*](y0[+]y1)).
           astepl (x0[*]y0[+]x0[*]y1).
           cut (x0[=]x1). intro.
            Step_final (x0[*]y0[+]x1[*]y1).
           apply refl_interpR 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 interpR_wd with ((y0[+]y1)[*]x0).
            apply MV_mult_corr_R; 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_interpR 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 interpR_wd with ((y0[+]y1)[*]x0).
            apply MV_mult_corr_R; 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_interpR 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 interpR_wd with ((y0[+]y1)[*]x0).
          apply MV_mult_corr_R; 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_interpR 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 interpR_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 interpR_wd with (zring (i + j):R).
  apply interpR_int; algebra.
 Step_final (zring i[+]zring j:R).
Qed.
Transparent MV_mult.

Opaque MM_plus.
Lemma PM_plus_corr_R :
 forall (e f:expr) (x y:R), II e x -> II f y -> II (PM_plus e f) (x[+]y).
Proof.
 cut (forall (e1 e2 f:expr) (x y:R),
   (forall (f:expr) (x y:R), 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:R),
    (forall (f:expr) (x y:R), 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:R), II e x -> II f y -> II (MM_plus e f) (x[+]y)).
    cut (forall (e f:expr) (x y:R), II e x -> II f y -> II (expr_plus e f) (x[+]y)).
     cut (forall (e f:expr) (x y:R), 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 interpR_wd with (y[+]x); algebra.
     apply interpR_plus with y x; algebra.
    intros; apply interpR_plus with x y; algebra.
   intros; apply MM_plus_corr_R; auto.
  intros. inversion X0.
  try (rewrite H in X2; rewrite H1 in X3; rewrite H0 in H2). (* compat 8.0 *)
  apply interpR_wd with (y0[+](x0[+]y)).
   apply X; auto.
   apply MM_plus_corr_R; 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 interpR_wd with (x0[+](y0[+]y)).
  apply interpR_plus with x0 (y0[+]y); algebra.
 Step_final (x0[+]y0[+]y).
Qed.
Transparent MM_plus.

Opaque PM_plus.
Lemma PP_plus_corr_R :
 forall (e f:expr) (x y:R), II e x -> II f y -> II (PP_plus e f) (x[+]y).
Proof.
 cut (forall (e1 e2 f:expr) (x y:R),
   (forall (f:expr) (x y:R), 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:R),
    II (expr_int i) x -> II f y -> II (PM_plus f (expr_int i)) (x[+]y)).
   cut (forall (e f:expr) (x y:R), 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 interpR_plus with x y; algebra.
   intros. apply interpR_wd with (y[+]x); algebra.
  apply PM_plus_corr_R; auto.
 intros. inversion X0.
 try (rewrite H in X2; rewrite H1 in X3; rewrite H0 in H2). (* compat 8.0 *)
 apply interpR_wd with (y0[+]y[+]x0).
  apply PM_plus_corr_R; 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_R :
 forall (e f:expr) (x y:R), II e x -> II f y -> II (PM_mult e f) (x[*]y).
Proof.
 cut (forall (e1 e2 f:expr) (x y:R),
   (forall (f:expr) (x y:R), 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:R), 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:R), 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 interpR_mult with x y; algebra.
   intros. apply interpR_wd with (zring 0[+]y[*]x).
  apply PM_plus_corr_R.
    apply interpR_int; algebra.
   apply MI_mult_corr_R; 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 interpR_wd with (y0[*]y[+]x0[*]y).
  apply PM_plus_corr_R; auto.
  apply MM_mult_corr_R; auto.
 astepl ((y0[+]x0)[*]y).
 Step_final ((x0[+]y0)[*]y).
Qed.

Opaque PM_mult.
Lemma PP_mult_corr_R :
 forall (e f:expr) (x y:R), II e x -> II f y -> II (PP_mult e f) (x[*]y).
Proof.
 cut (forall (e1 e2 f:expr) (x y:R),
   (forall (f:expr) (x y:R), 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:R),
    II (expr_int i) x -> II f y -> II (PM_mult f (expr_int i)) (x[*]y)).
   cut (forall (e f:expr) (x y:R), 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 interpR_mult with x y; algebra.
   intros. apply interpR_wd with (y[*]x); algebra.
  apply PM_mult_corr_R; auto.
 intros. inversion X0.
 try (rewrite H in X2; rewrite H1 in X3; rewrite H0 in H2). (* compat 8.0 *)
 apply interpR_wd with (y[*]x0[+]y0[*]y).
  apply PP_plus_corr_R; auto.
  apply PM_mult_corr_R; 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_R : (e,f:expr; x,y:R)
  (II e x)->(II f y)->(II (FF_plus e f) x[+]y).
Cut (e1,e2,f1,f2:expr; x,y:R)
     (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 (e,f:expr; x,y:R)(II e x)->(II f y)->(II (expr_plus e f) x[+]y).
Intros H H0 e f.
Elim e; Elim f; Intros; Simpl; Auto.
Intros. Apply interpR_plus with x y; algebra.
Intros. Inversion H. Inversion H0.
Apply interpR_div_one with x[+]y.
algebra.
Apply interpR_wd with x0[*][1][+][1][*]x1.
Apply PP_plus_corr_R; Apply PP_mult_corr_R; Auto;
  Apply interpR_int with k:=`1`; algebra.
Step_final x0[+]x1.
Apply interpR_wd with ([1]::R)[*][1]; algebra.
Apply PP_mult_corr_R; Auto.
Qed.

Lemma FF_mult_corr_R : (e,f:expr; x,y:R)
  (II e x)->(II f y)->(II (FF_mult e f) x[*]y).
Cut (e1,e2,f1,f2:expr; x,y:R)
     (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 (e,f:expr; x,y:R)(II e x)->(II f y)->(II (expr_mult e f) x[*]y).
Intros H H0 e f.
Elim e; Elim f; Intros; Simpl; Auto.
Intros. Apply interpR_mult with x y; algebra.
Intros. Inversion H. Inversion H0.
Apply interpR_div_one with x0[*]x1.
algebra.
Apply PP_mult_corr_R; Auto.
Apply interpR_wd with ([1]::R)[*][1]; algebra.
Apply PP_mult_corr_R; Auto.
Qed.

Transparent FF_div.
Lemma FF_div_corr_R : (e,f:expr; x:R)
  (II (expr_div e f) x)->(II (FF_div e f) x).
Intro e; Case e; Simpl; Auto.
Intros e0 e1 f; Case f; Simpl; Auto.
Intros.
Inversion H; Simpl.
Inversion H3; Inversion H5.
Apply interpR_div_one with x1[*][1].
astepl x1. Step_final x0.
Apply PP_mult_corr_R; Auto.
Apply interpR_wd with [1][*]x2.
Apply PP_mult_corr_R; Auto.
Step_final x2.
Qed.
*)

Lemma NormR_corr : forall (e:expr) (x:R), II e x -> II (NormR e) x.
Proof.
 intro; induction e; intros; simpl in |- *.
        apply (interpR_plus R val unop binop pfun (expr_mult (expr_var v) expr_one) expr_zero x ([0]:R) x).
          algebra.
         apply (interpR_mult R val unop binop pfun (expr_var v) expr_one x ([1]:R) x); algebra.
         apply (interpR_int R val unop binop pfun 1); algebra.
        apply (interpR_int R val unop binop pfun 0); algebra.
       assumption.
      inversion X.
      try (rewrite H in X0; rewrite H1 in X1; rewrite H0 in H2). (* compat 8.0 *)
      apply interpR_wd with (x0[+]y). apply PP_plus_corr_R; auto. auto.
       inversion X.
     try (rewrite H in X0; rewrite H1 in X1; rewrite H0 in H2). (* compat 8.0 *)
     apply interpR_wd with (x0[*]y). apply PP_mult_corr_R; auto. auto.
      assumption.
   inversion X.
   try (rewrite H in H2; rewrite H1 in X0; rewrite H0 in H2). (* compat 8.0 *)
   apply (interpR_plus R val unop binop pfun (expr_mult (expr_unop u (NormR e)) expr_one) expr_zero x (
     [0]:R) x).
     algebra.
    apply (interpR_mult R val unop binop pfun (expr_unop u (NormR e)) expr_one x ([1]:R) x); algebra.
     apply (interpR_unop R val unop binop pfun (NormR e) u x0); algebra.
    apply (interpR_int R val unop binop pfun 1); algebra.
   apply (interpR_int R val unop binop pfun 0); algebra.
  inversion X.
  (* compat 8.0 *)
  try (rewrite H in H3; rewrite H1 in X0; rewrite H2 in X1; rewrite H0 in H3).
  apply (interpR_plus R val unop binop pfun
    (expr_mult (expr_binop b (NormR e1) (NormR e2)) expr_one) expr_zero x ([0]:R) x).
    algebra.
   apply (interpR_mult R val unop binop pfun (expr_binop b (NormR e1) (NormR e2))
     expr_one x ([1]:R) x); algebra.
    apply (interpR_binop R val unop binop pfun (NormR e1) (NormR e2) b x0 y); algebra.
   apply (interpR_int R val unop binop pfun 1); algebra.
  apply (interpR_int R val unop binop pfun 0); algebra.
 inversion X.
 try ((generalize Hx H2; clear Hx H2; rewrite H; intros Hx H2);
   rewrite H1 in X0; rewrite H0 in H2). (* compat 8.0 *)
 apply (interpR_plus R val unop binop pfun (expr_mult (expr_part p (NormR e)) expr_one) expr_zero x (
   [0]:R) x).
   algebra.
  apply (interpR_mult R val unop binop pfun (expr_part p (NormR e)) expr_one x ([1]:R) x); algebra.
   apply (interpR_part R val unop binop pfun (NormR e) p x0) with (Hx := Hx); algebra.
  apply (interpR_int R val unop binop pfun 1); algebra.
 apply (interpR_int R val unop binop pfun 0); algebra.
Qed.

Lemma Tactic_lemmaR :
 forall (x y:R) (e:xexprR R val unop binop pfun x)
   (f:xexprR R val unop binop pfun y),
   eq_expr (NormR (xforgetR _ _ _ _ _ _ e)) (NormR (xforgetR _ _ _ _ _ _ f)) =
   true -> x[=]y.
Proof.
 intros x y e f H.
 apply refl_interpR with val unop binop pfun (NormR (xforgetR _ _ _ _ _ _ e)).
  apply NormR_corr; apply xexprR2interpR.
 rewrite (eq_expr_corr _ _ H).
 apply NormR_corr; apply xexprR2interpR.
Qed.

End Ring_NormCorrect.

Ltac QuoteR 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:(xexprR_int R a b c d k)
    end
 | (csbf_fun _ _ _ csg_op ?x ?y) =>
    let x' := QuoteR R l x in
    let y' := QuoteR R l y in
    constr:(xexprR_plus R a b c d _ _ x' y')
 | (csbf_fun _ _ _ cr_mult ?x ?y) =>
    let x' := QuoteR R l x in
    let y' := QuoteR R l y in
    constr:(xexprR_mult R a b c d _ _ x' y')
 | ([0]) => constr:(xexprR_zero R a b c d)
 | ([1]) => constr:(xexprR_one R a b c d)
 | (nring ?n) =>
    match (ClosedNat n) with
    | true => constr:(xexprR_nat R a b c d n)
    end
 | (csf_fun _ _ cg_inv ?x) =>
    let x' := QuoteR R l x in
    constr:(xexprR_inv R a b c d _ x')
 | (cg_minus ?x ?y) =>
    let x' := QuoteR R l x in
    let y' := QuoteR R l y in
    constr:(xexprR_minus R a b c d _ _ x' y')
 | (csf_fun _ _ (@nexp_op _ ?n) ?x) =>
    match (ClosedNat n) with
    | true => let x' := QuoteR R l x in
              constr:(xexprR_power R a b c d _ x' n)
    end
 | (pfpfun ?f ?x ?h) =>
    let x' := QuoteR R l x in
    let i := FindIndex f pl in
    constr:(xexprR_part R a b c d _ i x' h)
 | (csf_fun _ _ ?f ?x) =>
    let x' := QuoteR R l x in
    let i := FindIndex f ul in
    constr:(xexprR_unop R a b c d _ i x')
 | (csbf_fun _ _ _ ?f ?x ?y) =>
    let x' := QuoteR R l x in
    let y' := QuoteR R l y in
    let i := FindIndex f bl in
    constr:(xexprR_binop R a b c d _ _ i x' y')
 | ?t =>
    let i := FindIndex t vl in
    constr:(xexprR_var R a b c d i)
end)
end.

Ltac FindTermVariablesR t l :=
match t with
| (zring ?k) =>
    match (ClosedZ k) with
    | true => constr:(l)
    end
| (csbf_fun _ _ _ csg_op ?x ?y) =>
    let l1 := FindTermVariablesR x l in
    let l2 := FindTermVariablesR y l1 in
    constr:(l2)
| (csbf_fun _ _ _ cr_mult ?x ?y) =>
    let l1 := FindTermVariablesR x l in
    let l2 := FindTermVariablesR 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 := FindTermVariablesR x l in
    constr:(l1)
| (cg_minus ?x ?y) =>
    let l1 := FindTermVariablesR x l in
    let l2 := FindTermVariablesR y l1 in
    constr:(l2)
| (csf_fun _ _ (@nexp_op _ ?n) ?x) =>
    match (ClosedNat n) with
    | true => let l1 := FindTermVariablesR x l in
              constr:(l1)
    end
| (pfpfun ?f ?x ?h) =>
    let l1 := FindTermVariablesR 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 := FindTermVariablesR 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 := FindTermVariablesR x l in
    let l2 := FindTermVariablesR 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 FindTermsVariablesR fn t1 t2 :=
    let l1 := FindTermVariablesR t1 (Quad (Mnil fn) (Mnil (CSetoid_un_op fn)) (Mnil (CSetoid_bin_op fn)) (Mnil (PartFunct fn))) in
    let l2 := FindTermVariablesR t2 l1 in
    constr:(l2).

Ltac rationalR R x y :=
                 let l:=FindTermsVariablesR R x y in
                 let t1:=(QuoteR R l x) in
                 let t2:=(QuoteR R l y) in
                 eapply Tactic_lemmaR with (e:=t1) (f:=t2)
                 ; reflexivity.

(* end hide *)


Require Import CMap CMapDomain CMapPartialOrder Infra.PartialOrder Terminating.

Lemma terminating_Dom_eq_add_some X `{OrderedType X} Y `{PartialOrder Y} U x (NIN:x ∉ U)
      (TRM:Terminating Y poLt)
      (T:Terminating ({ X : Map [X, Y] | domain X ⊆ U }) poLt)
  : forall (y : Y) m p,
    find x m === ⎣ y ⎦ ->
    terminates poLt (exist (fun X0 : Map [X, Y] => domain X0 [<=] {x; U}) m p).
Proof.
  intros y m pr FEQ.
  pose proof (TRM y).
  revert dependent m.
  induction H1; intros.

  assert (RD:domain (remove x m) ⊆ U). {
    rewrite domain_remove; eauto. cset_tac.
  }
  specialize (T (exist _ (remove x m) RD)).
  remember_arguments T. revert dependent m.
  induction T; intros; clear_trivial_eqs.

  econstructor; intros [m' d'] [LE1 LE2]. simpl in *.

  decide (poLt (find x m) (find x m')).
  - rewrite FEQ in p. destruct p as [p1 p2]. inv p1.
    eapply H2; eauto.
    split; eauto. rewrite <- H6 in *. clear_trivial_eqs.
    intro; eapply p2; eauto.
    rewrite H6; eauto.
  - assert (RD':domain (remove x m') ⊆ U). {
      rewrite domain_remove; eauto. cset_tac.
    }
    eapply H4; try reflexivity. instantiate (1:=RD').
    split; simpl.
    + eapply leMap_remove; eauto.
    + intro.
      specialize (LE1 x).
      eapply not_poLt_poLe_poEq in n; eauto.
      eapply LE2.
      hnf; intros.
      decide (x1 === x).
      * rewrite e. symmetry in n; eauto.
      * specialize (H5 x1). simpl in *. lud.
        rewrite !MapFacts.remove_neq_o in H5; eauto.
    + specialize (LE1 x).
      rewrite FEQ in *.
      inv LE1.  econstructor.
      eapply poLe_antisymmetric; eauto.
      decide (y ⊑ x0); eauto.
      exfalso. eapply n.
      rewrite <- H6. split; try econstructor. eauto.
      intro. eapply n0. inv H5. rewrite H10. eauto.
Qed.

Lemma terminating_Dom_eq_add_none X `{OrderedType X} Y `{PartialOrder Y} U x (NIN:x ∉ U)
      (TRM:Terminating Y poLt)
      (TA:Terminating ({ X : Map [X, Y] | domain X ⊆ U }) poLt)
  : forall m p,
    find x m = None ->
    terminates poLt (exist (fun X0 : Map [X, Y] => domain X0 [<=] {x; U}) m p).
Proof.
  intros m pr FEQ.
  assert (RD:domain m ⊆ U). {
    eapply not_find_domain in FEQ. cset_tac.
  }
  pose proof (TA (exist _ m RD)) as T.
  remember_arguments T. revert dependent m.
  induction T; intros; clear_trivial_eqs.

  econstructor; intros [m' d'] [LE1 LE2]. simpl in *.

  decide (poLt (find x m) (find x m')).
  - rewrite FEQ in p. destruct p as [p1 p2].
    case_eq (find x m').
    + intros.
      eapply terminating_Dom_eq_add_some; eauto.
      rewrite H3; eauto.
    + intros.
      assert (RD':domain m' ⊆ U). {
        eapply not_find_domain in H3. cset_tac.
      }
      eapply H2; eauto. instantiate (1:=RD').
      split; eauto.
  - pose proof (LE1 x) as LE1x.
    eapply not_poLt_poLe_poEq in n; eauto.
    rewrite FEQ in n. inv n.
    symmetry in H3.
    assert (RD':domain m' ⊆ U). {
      eapply not_find_domain in H3. cset_tac.
    }
    eapply H2; eauto.
    + instantiate (1:=RD'). split; simpl; eauto.
Qed.

Instance terminating_Dom_eq_add X `{OrderedType X} Y `{PartialOrder Y} U x (NIN:x ∉ U)
      (TRM:Terminating Y poLt)
      (T:Terminating ({ X : Map [X, Y] | domain X ⊆ U }) poLt)
  : Terminating ({ X : Map [X, Y] | domain X ⊆ {x; U} }) poLt.
Proof.
  hnf; intros [m d].
  case_eq (find x m).
  - intros.
    eapply terminating_Dom_eq_add_some; eauto.
    rewrite H1; eauto.
  - intros.
    eapply terminating_Dom_eq_add_none; eauto.
Qed.

Lemma terminates_bound_inv X `{OrderedType X} Y `{PartialOrder Y} (P P':Map [X, Y] -> Prop)
      (IMPL: forall x, P' x -> P x )
      (x: Map [X, Y]) (px:P x) (py:P' x)
  : terminates (@poLt { x : Map [X, Y] | P x } _ ) (exist _ x px)
    -> terminates (@poLt { x : Map [X, Y] | P' x } _ ) (exist _ x py).
Proof.
  intros T.
  general induction T.
  econstructor; intros [] [LE1 LE2]; simpl in *.
  eapply H2; eauto. instantiate (1:=IMPL x p).
  split; eauto.
Qed.

Instance terminating_bound_inv X `{OrderedType X} Y `{PartialOrder Y} (P P':Map [X, Y] -> Prop)
      (IMPL: forall x, P' x -> P x )
  : Terminating ({ x : Map [X, Y] | P x }) poLt
    -> Terminating ({ x : Map [X, Y] | P' x }) poLt.
Proof.
  intros T. hnf; intros [x p].
  eapply terminates_bound_inv; eauto.
  Unshelve. eauto.
Qed.

Instance terminating_Dom X `{OrderedType X} Y `{PartialOrder Y} U
      (TRM:Terminating Y poLt)
  : Terminating ({ X : Map [X, Y] | domain X ⊆ U }) poLt.
Proof.
  pattern U.
  eapply set_induction; intros.
  - eapply empty_is_empty_1 in H1.
    hnf; intros [m d].
    econstructor; intros [m' d'] [LE1 LE2].
    simpl in *.
    exfalso. eapply LE2. hnf; intros.
    rewrite eq_domain_find; intros. reflexivity.
    cset_tac.
  - eapply terminating_bound_inv.
    instantiate (1:=fun x0 => domain x0 ⊆ {x; s}); simpl.
    cset_tac.
    eapply terminating_Dom_eq_add; eauto.
Qed.