(* ------------- CoreSyn midamble.v ------------ *)
Require Import Coq.ZArith.ZArith.
Require Import Omega.

Ltac termination_by_omega :=
  Coq.Program.Tactics.program_simpl;
  simpl;Omega.omega.

Ltac intro_split :=
  try intros [? [? [? ?]]];
  try intros [? [? ?]];
  try intros [? ?].

Ltac distinguish3 :=
  split; intros; unfold not;  intro_split; discriminate.

Ltac solve_collectAnnArgsTicks :=
  Tactics.program_simpl;
  try solve [distinguish3];
  try solve [repeat match goal with [ f : AnnExpr _ _ |- _ ] => destruct f end;
             Tactics.program_simpl;
             omega].

(* This function is needed to show the termination of collectAnnArgs,
   collectAnnArgsTicks. *)
Fixpoint size_AnnExpr' {a}{b} (e: AnnExpr' a b) :=
  match e with
  | AnnVar _ => 0
  | AnnLit _ => 0
  | AnnLam _ (_ , bdy) => S (size_AnnExpr' bdy)
  | AnnApp (_,e1) (_, e2) => S (size_AnnExpr' e1 + size_AnnExpr' e2)
  | AnnCase (_,scrut) bndr _ alts =>
    S (size_AnnExpr' scrut +
       List.fold_right plus 0
                          (List.map (fun p =>
                                       match p with
                                         | (_,_,(_,e)) => size_AnnExpr' e
                                    end)
                                    alts))
  | AnnLet (AnnNonRec v (_,rhs)) (_,body) =>
        S (size_AnnExpr' rhs + size_AnnExpr' body)
  | AnnLet (AnnRec pairs) (_,body) =>
        S (Lists.List.fold_right plus 0
          (Lists.List.map (fun p => size_AnnExpr' (snd (snd p))) pairs) +
           size_AnnExpr' body)

  | AnnCast (_,e) _ => S (size_AnnExpr' e)
(*  | AnnTick _ (_,e) => S (size_AnnExpr' e) *)
  | AnnType _ => 0
  | AnnCoercion _ => 0
  end.

(* ---------------------------------- *)

Instance Default__Expr {b} : GHC.Err.Default (Expr b) :=
  GHC.Err.Build_Default _ (Mk_Var GHC.Err.default).

Instance Default__Tickish {a} : GHC.Err.Default (Tickish a) :=
  GHC.Err.Build_Default _ (Breakpoint GHC.Err.default GHC.Err.default).

Instance Default_TaggedBndr {t}`{GHC.Err.Default t} : GHC.Err.Default (TaggedBndr t) :=
  GHC.Err.Build_Default _ (TB GHC.Err.default GHC.Err.default).

Instance Default__AnnExpr' {a}{b} : GHC.Err.Default (AnnExpr' a b) :=
  GHC.Err.Build_Default _ (AnnVar GHC.Err.default).

Instance Default__AnnBind {a}{b} : GHC.Err.Default (AnnBind a b) :=
  GHC.Err.Build_Default _ (AnnRec GHC.Err.default).

Instance Default__Bind {b} : GHC.Err.Default (Bind b) :=
  GHC.Err.Build_Default _ (Rec GHC.Err.default).

Instance Default__CoreVect : GHC.Err.Default CoreVect :=
  GHC.Err.Build_Default _ (Vect GHC.Err.default GHC.Err.default).

Instance Default__CoreRule : GHC.Err.Default CoreRule :=
  GHC.Err.Build_Default _ (BuiltinRule GHC.Err.default GHC.Err.default GHC.Err.default GHC.Err.default).

Instance Default__RuleEnv : GHC.Err.Default RuleEnv :=
  GHC.Err.Build_Default _ (Mk_RuleEnv GHC.Err.default GHC.Err.default).

(* ---------------------------------- *)

(* See comments in CoreSyn/edits file. We can't use termination edits for collect. *)

Definition collectNAnnBndrs {bndr} {annot}`{GHC.Err.Default annot}
    : nat -> AnnExpr bndr annot -> (list bndr * AnnExpr bndr annot)%type :=
          fun orig_n e =>
            let fix collect (arg_0__:nat) (arg_1__ : list bndr) (arg_2__:AnnExpr bndr annot) :=
                               match arg_0__, arg_1__, arg_2__ with
                               | O, bs, body =>
                                 pair (GHC.List.reverse bs) body
                               | S m, bs, body =>
                                   match arg_0__, arg_1__, arg_2__ with
                                   | n, bs, pair _ (AnnLam b body) => collect m (cons b bs) body
                                   | _, _, _ =>
                                       Panic.panicStr (GHC.Base.hs_string__ "collectNBinders") Panic.someSDoc
                                   end
                               end in
            collect orig_n nil e.


From iris.algebra Require Export ofe.
From iris.prelude Require Import options.

Record solution (F : oFunctor) := Solution {
  solution_car :> ofe;
  solution_cofe : Cofe solution_car;
  solution_iso :> ofe_iso (oFunctor_apply F solution_car) solution_car;
}.
Global Existing Instance solution_cofe.

Module solver. Section solver.
Context (F : oFunctor) `{Fcontr : !oFunctorContractive F}.
Context `{Fcofe : ∀ (T : ofe) `{!Cofe T}, Cofe (oFunctor_apply F T)}.
Context `{Finh : Inhabited (oFunctor_apply F unitO)}.
Notation map := (oFunctor_map F).

Fixpoint A' (k : nat) : { C : ofe & Cofe C } :=
  match k with
  | 0 => existT (P:=Cofe) unitO _
  | S k => existT (P:=Cofe) (@oFunctor_apply F (projT1 (A' k)) (projT2 (A' k))) _
  end.
Notation A k := (projT1 (A' k)).
Local Instance A_cofe k : Cofe (A k) := projT2 (A' k).

Fixpoint f (k : nat) : A k -n> A (S k) :=
  match k with 0 => OfeMor (λ _, inhabitant) | S k => map (g k,f k) end
with g (k : nat) : A (S k) -n> A k :=
  match k with 0 => OfeMor (λ _, ()) | S k => map (f k,g k) end.
Definition f_S k (x : A (S k)) : f (S k) x = map (g k,f k) x := eq_refl.
Definition g_S k (x : A (S (S k))) : g (S k) x = map (f k,g k) x := eq_refl.
Global Arguments f : simpl never.
Global Arguments g : simpl never.

Lemma gf {k} (x : A k) : g k (f k x) ≡ x.
Proof using Fcontr.
  induction k as [|k IH]; simpl in *; [by destruct x|].
  rewrite -oFunctor_map_compose -{2}[x]oFunctor_map_id.
  by apply (contractive_proper map).
Qed.
Lemma fg {k} (x : A (S (S k))) : f (S k) (g (S k) x) ≡{k}≡ x.
Proof using Fcontr.
  induction k as [|k IH]; simpl.
  - rewrite f_S g_S -{2}[x]oFunctor_map_id -oFunctor_map_compose.
    apply (contractive_0 map).
  - rewrite f_S g_S -{2}[x]oFunctor_map_id -oFunctor_map_compose.
    by apply (contractive_S map).
Qed.

Record tower := {
  tower_car k :> A k;
  g_tower k : g k (tower_car (S k)) ≡ tower_car k
}.
Global Instance tower_equiv : Equiv tower := λ X Y, ∀ k, X k ≡ Y k.
Global Instance tower_dist : Dist tower := λ n X Y, ∀ k, X k ≡{n}≡ Y k.
Definition tower_ofe_mixin : OfeMixin tower.
Proof.
  split.
  - intros X Y; split; [by intros HXY n k; apply equiv_dist|].
    intros HXY k; apply equiv_dist; intros n; apply HXY.
  - intros k; split.
    + by intros X n.
    + by intros X Y ? n.
    + by intros X Y Z ?? n; trans (Y n).
  - intros k j X Y HXY Hlt n. apply (dist_le k); [|lia].
    by rewrite -(g_tower X) (HXY (S n)) g_tower.
Qed.
Definition T : ofe := Ofe tower tower_ofe_mixin.

Program Definition tower_chain (c : chain T) (k : nat) : chain (A k) :=
  {| chain_car i := c i k |}.
Next Obligation. intros c k n i ?; apply (chain_cauchy c n); lia. Qed.
Program Definition tower_compl : Compl T := λ c,
  {| tower_car n := compl (tower_chain c n) |}.
Next Obligation.
  intros c k; apply equiv_dist=> n.
  by rewrite (conv_compl n (tower_chain c k))
    (conv_compl n (tower_chain c (S k))) /= (g_tower (c _) k).
Qed.
Global Program Instance tower_cofe : Cofe T := { compl := tower_compl }.
Next Obligation.
  intros n c k; rewrite /= (conv_compl n (tower_chain c k)).
  apply (chain_cauchy c); lia.
Qed.

Fixpoint ff {k} (i : nat) : A k -n> A (i + k) :=
  match i with 0 => cid | S i => f (i + k) ◎ ff i end.
Fixpoint gg {k} (i : nat) : A (i + k) -n> A k :=
  match i with 0 => cid | S i => gg i ◎ g (i + k) end.
Lemma ggff {k i} (x : A k) : gg i (ff i x) ≡ x.
Proof using Fcontr. induction i as [|i IH]; simpl; [done|by rewrite (gf (ff i x)) IH]. Qed.
Lemma f_tower k (X : tower) : f (S k) (X (S k)) ≡{k}≡ X (S (S k)).
Proof using Fcontr. intros. by rewrite -(fg (X (S (S k)))) -(g_tower X). Qed.
Lemma ff_tower k i (X : tower) : ff i (X (S k)) ≡{k}≡ X (i + S k).
Proof using Fcontr.
  intros; induction i as [|i IH]; simpl; [done|].
  by rewrite IH Nat.add_succ_r (dist_le _ _ _ _ (f_tower _ X)); last lia.
Qed.
Lemma gg_tower k i (X : tower) : gg i (X (i + k)) ≡ X k.
Proof. by induction i as [|i IH]; simpl; [done|rewrite g_tower IH]. Qed.

Global Instance tower_car_ne k : NonExpansive (λ X, tower_car X k).
Proof. by intros X Y HX. Qed.
Definition project (k : nat) : T -n> A k := OfeMor (λ X : T, tower_car X k).

Definition coerce {i j} (H : i = j) : A i -n> A j :=
  eq_rect _ (λ i', A i -n> A i') cid _ H.
Lemma coerce_id {i} (H : i = i) (x : A i) : coerce H x = x.
Proof. unfold coerce. by rewrite (proof_irrel H (eq_refl i)). Qed.
Lemma coerce_proper {i j} (x y : A i) (H1 H2 : i = j) :
  x = y → coerce H1 x = coerce H2 y.
Proof. by destruct H1; rewrite !coerce_id. Qed.
Lemma g_coerce {k j} (H : S k = S j) (x : A (S k)) :
  g j (coerce H x) = coerce (Nat.succ_inj _ _ H) (g k x).
Proof. by assert (k = j) by lia; subst; rewrite !coerce_id. Qed.
Lemma coerce_f {k j} (H : S k = S j) (x : A k) :
  coerce H (f k x) = f j (coerce (Nat.succ_inj _ _ H) x).
Proof. by assert (k = j) by lia; subst; rewrite !coerce_id. Qed.
Lemma gg_gg {k i i1 i2 j} : ∀ (H1: k = i + j) (H2: k = i2 + (i1 + j)) (x: A k),
  gg i (coerce H1 x) = gg i1 (gg i2 (coerce H2 x)).
Proof.
  intros Hij -> x. assert (i = i2 + i1) as -> by lia. revert j x Hij.
  induction i2 as [|i2 IH]; intros j X Hij; simplify_eq/=;
    [by rewrite coerce_id|by rewrite g_coerce IH].
Qed.
Lemma ff_ff {k i i1 i2 j} : ∀ (H1: i + k = j) (H2: i1 + (i2 + k) = j) (x: A k),
  coerce H1 (ff i x) = coerce H2 (ff i1 (ff i2 x)).
Proof.
  intros ? <- x. assert (i = i1 + i2) as -> by lia.
  induction i1 as [|i1 IH]; simplify_eq/=;
    [by rewrite coerce_id|by rewrite coerce_f IH].
Qed.

Definition embed_coerce {k} (i : nat) : A k -n> A i :=
  match le_lt_dec i k with
  | left H => gg (k-i) ◎ coerce (eq_sym (Nat.sub_add _ _ H))
  | right H => coerce (Nat.sub_add k i (Nat.lt_le_incl _ _ H)) ◎ ff (i-k)
  end.
Lemma g_embed_coerce {k i} (x : A k) :
  g i (embed_coerce (S i) x) ≡ embed_coerce i x.
Proof using Fcontr.
  unfold embed_coerce; destruct (le_lt_dec (S i) k), (le_lt_dec i k); simpl.
  - symmetry; by erewrite (@gg_gg _ _ 1 (k - S i)); simpl.
  - exfalso; lia.
  - assert (i = k) by lia; subst.
    rewrite (ff_ff _ (eq_refl (1 + (0 + k)))) /= gf.
    by rewrite (gg_gg _ (eq_refl (0 + (0 + k)))).
  - assert (H : 1 + ((i - k) + k) = S i) by lia.
    rewrite (ff_ff _ H) /= -{2}(gf (ff (i - k) x)) g_coerce.
    by erewrite coerce_proper by done.
Qed.
Program Definition embed (k : nat) (x : A k) : T :=
  {| tower_car n := embed_coerce n x |}.
Next Obligation. intros k x i. apply g_embed_coerce. Qed.
Global Instance: Params (@embed) 1 := {}.
Global Instance embed_ne k : NonExpansive (embed k).
Proof. by intros n x y Hxy i; rewrite /= Hxy. Qed.
Definition embed' (k : nat) : A k -n> T := OfeMor (embed k).
Lemma embed_f k (x : A k) : embed (S k) (f k x) ≡ embed k x.
Proof.
  rewrite equiv_dist=> n i; rewrite /embed /= /embed_coerce.
  destruct (le_lt_dec i (S k)), (le_lt_dec i k); simpl.
  - assert (H : S k = S (k - i) + (0 + i)) by lia; rewrite (gg_gg _ H) /=.
    by erewrite g_coerce, gf, coerce_proper by done.
  - assert (S k = 0 + (0 + i)) as H by lia.
    rewrite (gg_gg _ H); simplify_eq/=.
    by rewrite (ff_ff _ (eq_refl (1 + (0 + k)))).
  - exfalso; lia.
  - assert (H : (i - S k) + (1 + k) = i) by lia; rewrite (ff_ff _ H) /=.
    by erewrite coerce_proper by done.
Qed.
Lemma embed_tower k (X : T) : embed (S k) (X (S k)) ≡{k}≡ X.
Proof.
  intros i; rewrite /= /embed_coerce.
  destruct (le_lt_dec i (S k)) as [H|H]; simpl.
  - rewrite -(gg_tower i (S k - i) X).
    apply (_ : Proper (_ ==> _) (gg _)); by destruct (eq_sym _).
  - rewrite (ff_tower k (i - S k) X). by destruct (Nat.sub_add _ _ _).
Qed.

Program Definition unfold_chain (X : T) : chain (oFunctor_apply F T) :=
  {| chain_car n := map (project n,embed' n) (X (S n)) |}.
Next Obligation.
  intros X n i Hi.
  assert (∃ k, i = k + n) as [k ?] by (exists (i - n); lia); subst; clear Hi.
  induction k as [|k IH]; simpl; first done.
  rewrite -IH -(dist_le _ _ _ _ (f_tower (k + n) _)); last lia.
  rewrite f_S -oFunctor_map_compose.
  by apply (contractive_ne map); split=> Y /=; rewrite ?g_tower ?embed_f.
Qed.
Definition unfold (X : T) : oFunctor_apply F T := compl (unfold_chain X).
Global Instance unfold_ne : NonExpansive unfold.
Proof.
  intros n X Y HXY. by rewrite /unfold (conv_compl n (unfold_chain X))
    (conv_compl n (unfold_chain Y)) /= (HXY (S n)).
Qed.

Program Definition fold (X : oFunctor_apply F T) : T :=
  {| tower_car n := g n (map (embed' n,project n) X) |}.
Next Obligation.
  intros X k. apply (_ : Proper ((≡) ==> (≡)) (g k)).
  rewrite g_S -oFunctor_map_compose.
  apply (contractive_proper map); split=> Y; [apply embed_f|apply g_tower].
Qed.
Global Instance fold_ne : NonExpansive fold.
Proof. by intros n X Y HXY k; rewrite /fold /= HXY. Qed.

Theorem result : solution F.
Proof using Type*.
  refine (Solution F T _ (OfeIso (OfeMor fold) (OfeMor unfold) _ _)).
  - move=> X /=. rewrite equiv_dist=> n k; rewrite /unfold /fold /=.
    rewrite -g_tower -(gg_tower _ n); apply (_ : Proper (_ ==> _) (g _)).
    trans (map (ff n, gg n) (X (S (n + k)))).
    { rewrite /unfold (conv_compl n (unfold_chain X)).
      rewrite -(chain_cauchy (unfold_chain X) n (S (n + k))) /=; last lia.
      rewrite -(dist_le _ _ _ _ (f_tower (n + k) _)); last lia.
      rewrite f_S -!oFunctor_map_compose; apply (contractive_ne map); split=> Y.
      + rewrite /embed' /= /embed_coerce.
        destruct (le_lt_dec _ _); simpl; [exfalso; lia|].
        by rewrite (ff_ff _ (eq_refl (S n + (0 + k)))) /= gf.
      + rewrite /embed' /= /embed_coerce.
        destruct (le_lt_dec _ _); simpl; [|exfalso; lia].
        by rewrite (gg_gg _ (eq_refl (0 + (S n + k)))) /= gf. }
    assert (∀ i k (x : A (S i + k)) (H : S i + k = i + S k),
      map (ff i, gg i) x ≡ gg i (coerce H x)) as map_ff_gg.
    { intros i; induction i as [|i IH]; intros k' x H; simpl.
      { by rewrite coerce_id oFunctor_map_id. }
      rewrite oFunctor_map_compose g_coerce; apply IH. }
    assert (H: S n + k = n + S k) by lia.
    rewrite (map_ff_gg _ _ _ H).
    apply (_ : Proper (_ ==> _) (gg _)); by destruct H.
  - intros X; rewrite equiv_dist=> n /=.
    rewrite /unfold /= (conv_compl' n (unfold_chain (fold X))) /=.
    rewrite g_S -!oFunctor_map_compose -{2}[X]oFunctor_map_id.
    apply (contractive_ne map); split => Y /=.
    + rewrite f_tower. apply dist_S. by rewrite embed_tower.
    + etrans; [apply embed_ne, equiv_dist, g_tower|apply embed_tower].
Qed.
End solver. End solver.


(** * Reduction from Rowing Machines to Flattened System Fsub *)

(* begin details : Imports *)
Require Import RM FsubF.
Require Import Utils.psyntax Utils.RM_facts Utils.Various_utils.
From Equations Require Import Equations.
Require Import Relations Vector Lia.
Import VectorNotations.
(* end details *)

(** ** Translation *)

Section argument.
Context {w : nat}.

Definition row2ntype {m} : @row (S w) m -> @ntype (S (S w)) m.
Proof. intros r. refine (row_rec (fun _ _ _ => _) _ _ _ _ m r).
  -intros m' i j. exact (var_ntype (shift i) j).
  -intros m' v H. apply uAllN. apply bAllN. apply cons. exact (var_ntype var_zero var_zero).
   apply (map H). exact (proj1_sig (mkvect' (S w))).
   apply (ren_ntype ↑), H, None.
  -intros. apply uAllN. exact top.
Defined.

Fact row2ntype_unfold {m} (ρ : @row (S w) m): row2ntype ρ = match ρ with
  | var_row i j => var_ntype (↑ i) j
  | abst t => uAllN (bAllN (var_ntype var_zero var_zero :: map row2ntype t) (ren_ntype ↑ (row2ntype (nth' t None))))
  | halt => uAllN top
end.
Proof. destruct ρ; unfold row2ntype; rewrite row_rec_unfold; auto.
  apply congr_uAllN,congr_bAllN; auto.
  apply congr_cons. auto. destruct (mkvect' (S w)). simpl. apply ext_nth'.
  intro. repeat rewrite nth'_map. now rewrite e.
Qed.

Opaque row2ntype.

Definition sigma (n : nat) : @ntype (S n) 0  := uAllN (
  bAllN (map (fun i => var_ntype i var_zero) (proj1_sig (mkvect' (S n)))) (var_ntype var_zero (↑ var_zero))).

Definition RM2type  (R : @RM w) : ptype 0 := caseS' R (fun _ => ptype _)
   (fun h _ => bAllN (sigma (S w) :: map row2ntype R) (ren_ntype ↑ (row2ntype h))).

(* begin details : Utilities for the translation *)

Fact subst_sigma n σ: subst_ntype σ (sigma n) = sigma n.
Proof. now apply idSubst_ntype. Qed.

Fact ninst_up {w' n} v t : @ninst w' n v (ren_ntype ↑ t) = t.
Proof. unfold ninst. rewrite (compRenSubst_ntype _ _ (fun i => var_ntype i)). now apply idSubst_ntype. auto.
Qed.

Fact pinst_sigma : forall (t1 : @ntype (S (S w)) 0) t,
  pinst (t1::t) (bAllN (map (fun i => var_ntype i var_zero) (proj1_sig (mkvect' (S (S w))))) (var_ntype var_zero (↑ var_zero)))
  = bAllN (t1::t) (ren_ntype ↑ t1).
Proof. intros. destruct (mkvect' (S (S w))). simpl. unfold pinst. asimpl.
  rewrite map_map. apply congr_bAllN.
  -apply ext_nth'. intro. rewrite nth'_map. rewrite e. now simpl.
  -now apply extRen_ntype.
Qed.

Fact congr_F : forall n (s : @ntype (S n) 0) t1 t2 h, t1=t2-> |-F h; s <: t1 -> |-F h; s <: t2.
Proof. congruence. Qed.

Fact congr_up : (forall w n (s t : @ntype w n), s=t -> ren_ntype ↑ s = ren_ntype ↑ t).
Proof. congruence. Qed.

Fixpoint upSigma {m} : @ntype (S (S w)) m.
Proof. destruct m. apply sigma. apply (ren_ntype ↑),upSigma.
Defined.

Fact subst_up : (forall w n (σ : fin w -> fin (S n) -> ntype n) t, subst_ntype (up_ntype_ntype σ) (ren_ntype ↑ t) = ren_ntype ↑ (subst_ntype σ t)).
Proof. intros. erewrite (compRenSubst_ntype _ _ (fun i j => ren_ntype ↑ (σ i j))). 2: auto.
  erewrite (compSubstRen_ntype _ _ (fun i j => ren_ntype ↑ (σ i j))); auto.
Qed.

Fixpoint upSubstRow {m} (σ : fin (S w) -> fin 1 -> @row (S w) 0) {struct m} : fin (S w) -> fin (S m) -> @row (S w) m.
Proof. destruct m. exact σ. apply up_row_row,upSubstRow,σ. Defined.

Fixpoint upSubstNType {m} (σ : fin (S (S w)) -> fin 1 -> @ntype (S (S w)) 0) {struct m} : fin (S (S w)) -> fin (S m) -> @ntype (S (S w)) m.
Proof. destruct m. exact σ. apply up_ntype_ntype,upSubstNType,σ. Defined.

Fact row_rec_Swm (P : forall m, @row (S w) m -> Type)
  (Hv: forall m i j, P m (var_row i j))
  (Ha: forall m v, (forall i, P (S m) (nth' v i)) -> P m (abst v) )
  (Ht: forall m, P m halt) : forall m r, P m r.
Proof. assert (Hsize : forall (P : forall m, @row (S w) m -> Type) m, (forall m x, (forall m y, size y < size x -> P m y) -> P m x)-> forall x, P m x).
  { intros. apply X. induction (size x); intros. lia. destruct (lt_S _ _ H). apply X. rewrite e. apply IHn. apply IHn,l. }
  intros. eapply Hsize. destruct x. 1,3: auto. intros. apply Ha. intro. apply X,inSize,In_nth'.
Qed.

Fact trans_ren {m n} (r : @row (S w) m) (s : fin m -> fin n) : row2ntype (ren_row s r) = ren_ntype s (row2ntype r).
Proof. revert n s. revert m r. refine (row_rec_Swm _ _ _ _); intros; repeat rewrite row2ntype_unfold. 1,3: auto.
  apply congr_uAllN,congr_bAllN.
  - simpl. apply congr_cons. auto. repeat rewrite map_map. apply ext_nth'.
    intro. repeat rewrite nth'_map. now rewrite (H i (S n) _).
  - rewrite nth'_map. rewrite <- row2ntype_unfold.
    rewrite (H None (S n) _). erewrite compRenRen_ntype. 2: eauto. fold (@ren_ntype (S (S w))).
    erewrite compRenRen_ntype. 2:eauto. apply extRen_ntype. unfold funcomp.
    destruct x; simpl; unfold funcomp; simpl; unfold funcomp; auto.
Qed.

Fact row_rec_SwSm (P : forall m, @row (S w) (S m) -> Type)
  (Hv: forall m i j, P m (var_row i j))
  (Ha: forall m v, (forall i, P (S m) (nth' v i)) -> P m (abst v) )
  (Ht: forall m, P m halt) : forall m r, P m r.
Proof. assert (Hsize : forall (P : forall m, @row (S w) (S m) -> Type) m, (forall m x, (forall m y, size y < size x -> P m y) -> P m x)-> forall x, P m x).
  { intros. apply X. induction (size x); intros. lia. destruct (lt_S _ _ H). apply X. rewrite e. apply IHn. apply IHn,l. }
  intros. eapply Hsize. destruct x. 1,3: auto. intros. apply Ha. intro. apply X,inSize,In_nth'.
Qed.

Fact trans_subst {m} (R : Vector.t (@row (S w) 0) (S w)) (r : @row (S w) (S m)) : row2ntype (subst_row (upSubstRow (fun i => nth' R i .; (fun j : fin 0 => False_rect _ j))) r) = subst_ntype (upSubstNType (fun i => nth' (sigma (S w) :: map row2ntype R) i .; var_ntype i)) (row2ntype r).
Proof. revert R. revert r. revert m. refine (row_rec_SwSm _ _ _ _ ); intros.
  -unfold subst_row. symmetry. rewrite row2ntype_unfold. asimpl. induction m.
    destruct j. contradiction. simpl. now rewrite nth'_map. destruct j. 2: auto. simpl. unfold funcomp.
    rewrite trans_ren. simpl in IHm. now rewrite (IHm f).
  -simpl. repeat rewrite row2ntype_unfold. apply congr_uAllN,congr_bAllN.
    +simpl. apply congr_cons. auto. repeat rewrite map_map. apply ext_nth'. intro. repeat rewrite nth'_map.
      pose (H i R). simpl in e. now rewrite e.
    +rewrite nth'_map. repeat rewrite <- row2ntype_unfold. fold (@subst_ntype (S (S w))).
      pose (H None). simpl in e. rewrite e. now rewrite subst_up.
  -now repeat rewrite row2ntype_unfold.
Qed.

Fixpoint trans_subst' ρ ρ' ρ1' i : row2ntype (subst_row (fun i0 : fin (S w) => match i0 with
    | Some f => nth' ρ f
    | None => abst (ρ1' :: ρ')
    end .; (fun j : fin 0 => False_rect (row 0) j)) match i with Some f => nth' ρ' f | None => ρ1' end) =
subst_ntype (fun i0 : fin (S (S w)) => match i0 with
   | Some (Some f0) => nth' (map row2ntype ρ) f0
   | Some None => row2ntype (abst (ρ1' :: ρ'))
   | None => sigma (S w)
   end .; var_ntype i0) (row2ntype match i with | Some f => nth' ρ' f | None => ρ1' end).
Proof.
  pose (@trans_subst 0 ((abst (ρ1'::ρ'))::ρ)  (nth' (ρ1' :: ρ') i)). now simpl in *.
Qed.

Fact congr_in : forall w (s1 : @ntype w 0 ) t1 s2 t2 h,  s1=s2 -> t1=t2 -> |-F h; s1 <: t1 -> |-F h; s2 <: t2.
Proof. congruence. Qed.

Fact map_mkVect ρ ρ1 : ((VectorDef.map (fun x : (fin (S (S w))) => (match x with
       | Some (Some f0) => nth' (map row2ntype ρ) f0
       | Some None => row2ntype ρ1
       | None => sigma (S w)
       end .; var_ntype x) var_zero) (proj1_sig (mkvect' (S (S w))))) = sigma (S w) :: map row2ntype (ρ1 :: ρ)).
Proof. destruct (mkvect' (S (S w))). simpl. apply ext_nth'. intro. rewrite nth'_map. now rewrite e. Qed.

Fact ext_cons : forall A B (f:A->B) n h (tl : Vector.t A n), map f (h::tl) = (f h) :: (map f tl).
Proof. auto. Qed.
(* end details *)
(** ** Reduction *)

Derive Signature for subF.
Lemma step2flat {R R' : @RM w} h : step_to R R' ->
  |-F h; sigma (S w) <: RM2type R' <-> |-F S (S h); sigma (S w) <: RM2type R.
Proof.
  unfold step_to. unfold RM.step. destruct (hd R) eqn:rH. contradiction. 2: discriminate.
  inversion 1. clear H H1. unfold RM2type.
  apply (caseSEq t). intros ρ1' ρ' Ht. simpl. apply (caseSEq R). intros ρ1 ρ HR. simpl. split.
  -intro.  apply FAllNeg. rewrite ninst_up. rewrite pinst_sigma.
    rewrite HR in rH. simpl in rH. rewrite rH at 1. rewrite row2ntype_unfold. apply FAllNeg.
    rewrite ninst_up. rewrite Ht at 2. simpl. unfold pinst.
    revert H. repeat rewrite <- ext_cons. rewrite <- HR. apply congr_in. auto. apply congr_bAllN.
    + simpl. apply congr_cons. auto. repeat rewrite <- ext_cons. rewrite <- Ht. repeat rewrite map_map.
      apply ext_nth'. intro. repeat rewrite nth'_map. rewrite HR. rewrite rH. rewrite Ht.
      pose (trans_subst' ρ ρ' ρ1' i). now simpl in *.
    + simpl. rewrite (subst_up (S (S w)) 0). apply congr_up. rewrite HR.
      assert (ρ1' = nth' t None). now rewrite Ht. rewrite H. rewrite rH. rewrite Ht.
      pose (trans_subst' ρ ρ' ρ1' None). now simpl in *.
  -intro H. rewrite <- ext_cons in H. rewrite <- HR in *. depind H. clear IHsubF.
   inversion H1. rewrite <- H4 in H. rewrite ninst_up in H. unfold pinst in H. simpl in rH.
   rewrite rH in H at 1. rewrite row2ntype_unfold in H. remember (ρ1' :: ρ').
   rewrite <- H3 in H. rewrite <- ext_cons in H. (* remember (ρ1 ::ρ) as R. *)
   asimpl in H. inversion H0. rewrite <- H5 in H. inversion H. revert H8. rewrite map_map. apply congr_in.
    + unfold ninst. asimpl. apply subst_sigma.
    + repeat rewrite <- ext_cons. remember (ρ1' :: ρ'). remember (abst t :: ρ) as R.
      rewrite map_mkVect. apply congr_bAllN.
      ++ simpl. apply congr_cons. auto. repeat rewrite map_map. apply ext_nth'. intro. repeat rewrite nth'_map.
         rewrite rH. rewrite Heqt. rewrite Heqt4. pose (trans_subst' ρ ρ' ρ1' i0). now simpl in *.
      ++assert (ρ1' = nth' t None). rewrite Heqt. now rewrite Heqt4. rewrite H8. rewrite Heqt. rewrite Heqt4.
        remember None. simpl. change (option (fin w)) with (fin (S w)). rewrite rH. rewrite Heqt. rewrite Heqt4.
        erewrite  (trans_subst'). now erewrite <- subst_up.
Qed.

Lemma halt2flat (R : @RM w) : halting R -> |-F 2; sigma (S w) <: RM2type R.
Proof. unfold halting. unfold RM.step. destruct (hd R) eqn:rH. contradiction. discriminate. intros _.
  apply (caseSEq R). intros. rewrite H in rH. simpl in *. rewrite rH. simpl. apply FAllNeg,FAllNeg,FTop.
Qed.

Lemma flat2RM_HALT (R : @RM w) : (exists h, |-F h; sigma (S w) <: RM2type R) ->
  @halting w R \/ (exists s : @RM w, R ~|> s).
Proof. intros [n H]. revert H. revert R. induction n using Wf_nat.lt_wf_ind.
  intro. apply (caseSEq R). intros ρ ρs HR Hin. destruct n. inversion Hin.
  destruct n. inversion Hin. inversion H3. destruct ρ. contradiction. 2: now left.
  apply (caseSEq t). intros ρ' ρs' Ht. assert (Hn: n<S(S n)). auto.
  edestruct (H n Hn (map (subst_row (fun i => nth' R i .; fun j:fin 0 => False_rect _ j))  t)).
  -assert (Hstep : step_to R (map (subst_row (fun i => nth' R i .; fun j:fin 0 => False_rect _ j))  t)).
   { unfold step_to. unfold RM.step. now rewrite HR. }
   destruct (step2flat n Hstep). apply H1. now rewrite HR.
  -right. exists (map (subst_row (fun i => nth' R i .; fun j:fin 0 => False_rect _ j)) t). split. 2: auto.
   constructor. unfold step_to. unfold RM.step. rewrite HR. now rewrite Ht.
  -right. destruct H0 as [S HS]. destruct HS. exists S. split. 2: auto.
   apply (Relation_Operators.t1n_trans _ _ _ (map (subst_row (fun i => nth' R i .; fun j:fin 0 => False_rect _ j)) t)).
   2: auto. unfold step_to. unfold RM.step. rewrite HR. now rewrite Ht.
Qed.

End argument.

(** *** Synthetic reduction *)
Require Import Undecidability.Synthetic.Definitions.

Theorem reduction : RM_HALT ⪯  FsubF_SUBTYPE.
Proof. exists (fun wR : {w & @RM w} => let (w, R) := wR in
  existT (fun n => (@ntype n 0 * @ptype n 0)%type) (S (S w)) (sigma (S w), @RM2type w R)).
  intro wR. destruct wR as [w R]. unfold RM_HALT. simpl. split.
  -destruct 1. exists 2. now apply halt2flat. destruct H as [R' [HR HR']].
   induction HR. exists 4. apply (step2flat _ H). now apply halt2flat.
   destruct (IHHR HR') as [h H']. exists (S (S h)). now apply (step2flat _ H).
  -apply flat2RM_HALT.
Qed.


From LogRel.AutoSubst Require Import core unscoped Ast Extra.
From LogRel Require Import Utils BasicAst Notations Context NormalForms UntypedValues Weakening GenericTyping LogicalRelation DeclarativeInstance Validity.
From LogRel.LogicalRelation Require Import Irrelevance Escape Reflexivity Weakening Neutral Induction.
From LogRel.Substitution Require Import Irrelevance.

Set Universe Polymorphism.

Section Properties.
Context `{GenericTypingProperties}.

Lemma wellformedSubst {Γ σ Δ} (VΓ : [||-v Γ]) (wfΔ : [|- Δ]) :
  [Δ ||-v σ : Γ | VΓ| wfΔ] -> [Δ |-s σ : Γ ].
Proof.
  revert σ; pattern Γ, VΓ; apply validity_rect; clear Γ VΓ.
  - intros. apply well_sempty.
  - intros * ih σ [tl hd].
    eapply well_scons.
    + now apply ih.
    + now escape.
Qed.

Lemma wellformedSubstEq {Γ σ σ' Δ} (VΓ : [||-v Γ]) (wfΔ : [|- Δ]) (Vσ : [Δ ||-v σ : Γ | VΓ | wfΔ]) :
  [Δ ||-v σ ≅ σ' : Γ | VΓ | wfΔ | Vσ] -> [Δ |-s σ ≅ σ' : Γ].
Proof.
  revert σ σ' Vσ; pattern Γ, VΓ; apply validity_rect; clear Γ VΓ.
  - intros. apply conv_sempty.
  - intros * ih ??? [tl hd]. apply conv_scons.
    + now eapply ih.
    + now escape.
Qed.

Lemma consSubstS {Γ σ t l A Δ} (VΓ : [||-v Γ]) (wfΔ : [|- Δ])
  (Vσ : [Δ ||-v σ : Γ | VΓ | wfΔ]) (VA : [Γ ||-v<l> A | VΓ])
  (Vt : [ Δ ||-<l> t : A[σ] | validTy VA wfΔ Vσ]) :
  [Δ ||-v (t .: σ) : Γ ,, A | validSnoc VΓ VA | wfΔ].
Proof.  unshelve econstructor; eassumption. Defined.

Lemma consValid {Γ Δ σ a A l} {VΓ : [||-v Γ]} {wfΔ : [|- Δ]}
  (Vσ : [Δ ||-v σ : Γ | VΓ | wfΔ])
  {VA : [Γ ||-v<l> A| VΓ]}
  (Va : [Γ ||-v<l> a : A | VΓ | VA])
  (VΓA := validSnoc VΓ VA) :
  [Δ ||-v (a[σ] .: σ) : Γ,, A | VΓA | wfΔ].
Proof.
  unshelve eapply consSubstS; tea; now eapply validTm.
Qed.

Lemma consSubstSEq {Γ σ σ' t l A Δ} (VΓ : [||-v Γ]) (wfΔ : [|- Δ])
  (Vσ : [Δ ||-v σ : Γ | VΓ | wfΔ])
  (Vσσ' : [Δ ||-v σ ≅ σ' : Γ | VΓ | wfΔ | Vσ])
  (VA : [Γ ||-v<l> A | VΓ])
  (Vt : [Δ ||-<l> t : A[σ] | validTy VA wfΔ Vσ]) :
  [Δ ||-v (t .: σ) ≅  (t .: σ') : Γ ,, A | validSnoc VΓ VA | wfΔ | consSubstS VΓ wfΔ Vσ VA Vt].
Proof.
  unshelve econstructor.
  1: eassumption.
  eapply LRTmEqRefl; [apply (validTy VA wfΔ)| exact Vt].
Qed.

Lemma consSubstSEq' {Γ σ σ' t u l A Δ} (VΓ : [||-v Γ]) (wfΔ : [|- Δ])
  (Vσ : [Δ ||-v σ : Γ | VΓ | wfΔ])
  (Vσσ' : [Δ ||-v σ ≅ σ' : Γ | VΓ | wfΔ | Vσ])
  (VA : [Γ ||-v<l> A | VΓ])
  (Vt : [Δ ||-<l> t : A[σ] | validTy VA wfΔ Vσ])
  (Vtu : [Δ ||-<l> t ≅ u : A[σ] | validTy VA wfΔ Vσ]) :
  [Δ ||-v (t .: σ) ≅  (u .: σ') : Γ ,, A | validSnoc VΓ VA | wfΔ | consSubstS VΓ wfΔ Vσ VA Vt].
Proof.
  unshelve econstructor; tea.
Qed.

Lemma consSubstSvalid {Γ σ t l A Δ} (VΓ : [||-v Γ]) (wfΔ : [|- Δ])
  (Vσ : [Δ ||-v σ : Γ | VΓ | wfΔ]) (VA : [Γ ||-v<l> A | VΓ])
  (Vt : [ Γ ||-v<l> t : A | VΓ | VA]) :
  [Δ ||-v (t[σ] .: σ) : Γ ,, A | validSnoc VΓ VA | wfΔ].
Proof. unshelve eapply consSubstS; tea; now eapply validTm. Defined.

Set Printing Primitive Projection Parameters.

Lemma consSubstSEqvalid {Γ σ σ' t l A Δ} (VΓ : [||-v Γ]) (wfΔ : [|- Δ])
  (Vσ : [Δ ||-v σ : Γ | VΓ | wfΔ])
  (Vσ' : [Δ ||-v σ' : Γ | VΓ | wfΔ])
  (Vσσ' : [Δ ||-v σ ≅ σ' : Γ | VΓ | wfΔ | Vσ])
  (VA : [Γ ||-v<l> A | VΓ])
  (Vt : [Γ ||-v<l> t : A | VΓ | VA]) :
  [Δ ||-v (t[σ] .: σ) ≅  (t[σ'] .: σ') : Γ ,, A | validSnoc VΓ VA | wfΔ | consSubstSvalid VΓ wfΔ Vσ VA Vt].
Proof.
  unshelve econstructor; intros; tea.
  now apply validTmExt.
Qed.

Lemma wkSubstS {Γ} (VΓ : [||-v Γ]) :
  forall {σ  Δ Δ'}  (wfΔ : [|- Δ]) (wfΔ' : [|- Δ']) (ρ : Δ' ≤ Δ),
  [Δ ||-v σ : Γ | VΓ | wfΔ] -> [Δ' ||-v σ ⟨ ρ ⟩ : Γ | VΓ | wfΔ'].
Proof.
  pattern Γ, VΓ ; apply validity_rect; clear Γ VΓ.
  - constructor.
  - intros * ih * [tl hd]. unshelve econstructor.
    + eapply ih; eassumption.
    + eapply LRTmRedIrrelevant'.
      2: eapply (wkTerm _ wfΔ') ; exact hd.
      now asimpl.
Defined.

Lemma wkSubstSEq {Γ} (VΓ : [||-v Γ]) :
  forall {σ σ' Δ Δ'}  (wfΔ : [|- Δ]) (wfΔ' : [|- Δ']) (ρ : Δ' ≤ Δ)
  (Vσ : [Δ ||-v σ : Γ | VΓ | wfΔ]),
  [Δ  ||-v σ ≅ σ' : Γ | VΓ | wfΔ | Vσ] ->
  [Δ' ||-v σ ⟨ ρ ⟩ ≅ σ' ⟨ ρ ⟩ : Γ | VΓ | wfΔ' | wkSubstS VΓ wfΔ wfΔ' ρ Vσ].
Proof.
  pattern Γ, VΓ; apply validity_rect; clear Γ VΓ.
  - constructor.
  - intros * ih * [tl hd]; unshelve econstructor.
    + eapply ih ; eassumption.
    + eapply LRTmEqIrrelevant'.
      2: eapply (wkTermEq _ wfΔ') ; exact hd.
      now asimpl.
Qed.

Lemma wk1SubstS {Γ σ Δ F} (VΓ : [||-v Γ]) (wfΔ : [|- Δ]) (wfF : [Δ |- F]) :
  [Δ ||-v σ : Γ | VΓ | wfΔ ] ->
  [Δ ,, F ||-v σ ⟨ @wk1 Δ F ⟩ : Γ | VΓ | wfc_cons wfΔ wfF].
Proof. eapply wkSubstS. Defined.

Lemma wk1SubstSEq {Γ σ σ' Δ F} (VΓ : [||-v Γ])
  (wfΔ : [|- Δ]) (wfF : [Δ |- F])
  (Vσ : [Δ ||-v σ : Γ | VΓ | wfΔ ]) :
  [Δ ||-v σ ≅ σ' : Γ | VΓ | wfΔ | Vσ] ->
  let ρ := @wk1 Δ F in
  [Δ ,, F ||-v σ ⟨ ρ ⟩ ≅ σ' ⟨ ρ ⟩ : Γ | VΓ | wfc_cons wfΔ wfF | wk1SubstS VΓ wfΔ wfF Vσ].
Proof.
  intro vσσ'. eapply wkSubstSEq ; eassumption.
Qed.

Lemma consWkSubstS {Γ F Δ Ξ σ a l VΓ wfΔ } VF
  (ρ : Ξ ≤ Δ) wfΞ {RF}:
  [Δ ||-v σ : Γ | VΓ | wfΔ] ->
  [Ξ ||-<l> a : F[σ]⟨ρ⟩ | RF] ->
  [Ξ ||-v (a .: σ⟨ρ⟩) : Γ,, F | validSnoc (l:=l) VΓ VF | wfΞ].
Proof.
  intros. unshelve eapply consSubstS.  2: irrelevance.
  now eapply wkSubstS.
Qed.

Lemma liftSubstS {Γ σ Δ lF F} (VΓ : [||-v Γ]) (wfΔ : [|- Δ])
  (VF : [Γ ||-v<lF> F | VΓ])
  (Vσ : [Δ ||-v σ : Γ | VΓ | wfΔ ]) :
  let VΓF := validSnoc VΓ VF in
  let ρ := @wk1 Δ F[σ] in
  let wfΔF := wfc_cons wfΔ (escape (validTy VF wfΔ Vσ)) in
  [Δ ,, F[σ] ||-v (tRel 0 .: σ ⟨ ρ ⟩) : Γ ,, F | VΓF | wfΔF ].
Proof.
  intros; unshelve econstructor.
  - now eapply wk1SubstS.
  - eapply var0; unfold ρ; [now bsimpl|].
    now eapply escape, VF.
Defined.

Lemma liftSubstSrealign {Γ σ σ' Δ lF F} {VΓ : [||-v Γ]} {wfΔ : [|- Δ]}
  (VF : [Γ ||-v<lF> F | VΓ])
  {Vσ : [Δ ||-v σ : Γ | VΓ | wfΔ ]} :
  let VΓF := validSnoc VΓ VF in
  let ρ := @wk1 Δ F[σ]  in
  let wfΔF := wfc_cons wfΔ (escape (validTy VF wfΔ Vσ)) in
  [Δ ||-v σ ≅ σ' : Γ | VΓ | wfΔ | Vσ] ->
  [Δ ||-v σ' : Γ | VΓ | wfΔ ] ->
  [Δ ,, F[σ] ||-v (tRel 0 .: σ'⟨ρ⟩) : Γ ,, F | VΓF | wfΔF].
Proof.
  intros; unshelve econstructor.
  + now eapply wk1SubstS.
  + cbn.
    assert [Δ,, F[σ] |-[ ta ] tRel 0 : F[S >> (tRel 0 .: σ'⟨ρ⟩)]].
    { replace F[_ >> _] with F[σ']⟨S⟩ by (unfold ρ; now bsimpl).
      eapply ty_conv. 1: apply (ty_var wfΔF (in_here _ _)).
      cbn; renToWk. eapply convty_wk; tea.
      eapply escapeEq;  unshelve eapply validTyExt; cycle 3; tea. }
    apply neuTerm; tea.
    - assert ([Δ |-[ ta ] F[σ]]).
      { now eapply escape, VF. }
      eapply tm_ne_conv; [now eapply tm_ne_rel| |].
      * replace F[_ >> _] with F[σ']⟨ρ⟩ by (unfold ρ; now bsimpl).
        apply wft_wk; [eassumption|].
        now eapply escape, VF.
      * replace F[_ >> _] with (F[σ'])⟨↑⟩ by (unfold ρ; now bsimpl).
        do 2 erewrite <- wk1_ren_on.
        apply convty_wk; [tea|].
        eapply escapeEq, VF; tea.
    - apply convneu_var; tea.
Qed.

Lemma liftSubstS' {Γ σ Δ lF F} {VΓ : [||-v Γ]} {wfΔ : [|- Δ]}
  (VF : [Γ ||-v<lF> F | VΓ])
  (Vσ : [Δ ||-v σ : Γ | VΓ | wfΔ ]) :
  let VΓF := validSnoc VΓ VF in
  let wfΔF := wfc_cons wfΔ (escape (validTy VF wfΔ Vσ)) in
  [Δ ,, F[σ] ||-v up_term_term σ : Γ ,, F | VΓF | wfΔF ].
Proof.
  eapply irrelevanceSubstExt.
  2: eapply liftSubstS.
  intros ?; now bsimpl.
Qed.

Lemma liftSubstSEq {Γ σ σ' Δ lF F} (VΓ : [||-v Γ]) (wfΔ : [|- Δ])
  (VF : [Γ ||-v<lF> F | VΓ])
  (Vσ : [Δ ||-v σ : Γ | VΓ | wfΔ ]) :
  let VΓF := validSnoc VΓ VF in
  let ρ := @wk1 Δ F[σ] in
  let wfΔF := wfc_cons wfΔ (escape (validTy VF wfΔ Vσ)) in
  let Vliftσ := liftSubstS VΓ wfΔ VF Vσ in
  [Δ ||-v σ ≅ σ' : Γ | VΓ | wfΔ | Vσ] ->
  [Δ ,, F[σ] ||-v (tRel 0 .: σ ⟨ ρ ⟩) ≅ (tRel 0 .: σ' ⟨ ρ ⟩) : Γ ,, F | VΓF | wfΔF | Vliftσ].
Proof.
  intros; unshelve econstructor.
  + now apply wk1SubstSEq.
  + apply LREqTermRefl_; exact (validHead Vliftσ).
Qed.

Lemma liftSubstSEq' {Γ σ σ' Δ lF F} {VΓ : [||-v Γ]} {wfΔ : [|- Δ]}
  (VF : [Γ ||-v<lF> F | VΓ])
  {Vσ : [Δ ||-v σ : Γ | VΓ | wfΔ ]} :
  let VΓF := validSnoc VΓ VF in
  let ρ := wk_up F (@wk_id Γ) in
  let wfΔF := wfc_cons wfΔ (escape (validTy VF wfΔ Vσ)) in
  let Vliftσ := liftSubstS' VF Vσ in
  [Δ ||-v σ ≅ σ' : Γ | VΓ | wfΔ | Vσ] ->
  [Δ ,, F[σ] ||-v up_term_term σ ≅ up_term_term σ' : Γ ,, F | VΓF | wfΔF | Vliftσ].
Proof.
  intros.
  eapply irrelevanceSubstEq.
  unshelve eapply irrelevanceSubstEqExt.
  6: now eapply liftSubstSEq.
  all: intros ?; now bsimpl.
  Unshelve. all: tea.
Qed.

Lemma liftSubstSrealign' {Γ σ σ' Δ lF F} {VΓ : [||-v Γ]} {wfΔ : [|- Δ]}
  (VF : [Γ ||-v<lF> F | VΓ])
  {Vσ : [Δ ||-v σ : Γ | VΓ | wfΔ ]} :
  let VΓF := validSnoc VΓ VF in
  let ρ := wk_up F (@wk_id Γ) in
  let wfΔF := wfc_cons wfΔ (escape (validTy VF wfΔ Vσ)) in
  [Δ ||-v σ ≅ σ' : Γ | VΓ | wfΔ | Vσ] ->
  [Δ ||-v σ' : Γ | VΓ | wfΔ ] ->
  [Δ ,, F[σ] ||-v up_term_term σ' : Γ ,, F | VΓF | wfΔF].
Proof.
  intros.
  eapply irrelevanceSubstExt.
  2: eapply liftSubstSrealign; tea.
  intros ?; now bsimpl.
Qed.

Lemma wk1ValidTy {Γ lA A lF F} {VΓ : [||-v Γ]} (VF : [Γ ||-v<lF> F | VΓ]) :
  [Γ ||-v<lA> A | VΓ] ->
  [Γ ,, F ||-v<lA> A ⟨ @wk1 Γ F ⟩ | validSnoc VΓ VF ].
Proof.
  assert (forall σ, (A ⟨@wk1 Γ F⟩)[σ] = A[↑ >> σ]) as h by (intros; asimpl; now rewrite wk1_ren) ;
  intros [VA VAext]; unshelve econstructor.
  - abstract (intros * [tl _]; rewrite h; exact (VA _ _ wfΔ tl)).
  - intros * [tl _] [tleq _].
    rewrite (h σ'); unshelve eapply LRTyEqSym.
    2: eapply VA; eassumption.
    rewrite (h σ).
    eapply VAext. 1: exact (validTail vσ).
    eapply symmetrySubstEq. eassumption.
Qed.

Lemma wk1ValidTyEq {Γ lA A B lF F} {VΓ : [||-v Γ]} (VF : [Γ ||-v<lF> F | VΓ])
  {VA : [Γ ||-v<lA> A | VΓ]} :
  [Γ ||-v<lA> A ≅ B | VΓ | VA] ->
  [Γ ,, F ||-v<lA> A ⟨ @wk1 Γ F ⟩ ≅ B ⟨ @wk1 Γ F ⟩ | validSnoc VΓ VF | wk1ValidTy VF VA].
Proof.
  assert (forall A σ, (A ⟨@wk1 Γ F⟩)[σ] = A[↑ >> σ]) as h by (intros; asimpl; now rewrite wk1_ren).
  intros []; constructor; intros.
  rewrite h. irrelevance0.
  1: symmetry; apply h.
  unshelve intuition; tea; now eapply validTail.
Qed.

Lemma wk1ValidTm {Γ lA t A lF F} {VΓ : [||-v Γ]}
  (VF : [Γ ||-v<lF> F | VΓ])
  (VA : [Γ ||-v<lA> A | VΓ])
  (Vt : [Γ ||-v<lA> t : A | VΓ | VA]) (ρ := @wk1 Γ F):
  [Γ,, F ||-v<lA> t⟨ρ⟩ : A⟨ρ⟩ | validSnoc VΓ VF | wk1ValidTy VF VA].
Proof.
  assert (forall A σ, (A ⟨@wk1 Γ F⟩)[σ] = A[↑ >> σ]) as h by (intros; asimpl; now rewrite wk1_ren).
  constructor; intros; repeat rewrite h.
  - instValid (validTail Vσ); irrelevance.
  - instValidExt (validTail Vσ') (eqTail Vσσ'); irrelevance.
Qed.

Lemma wk1ValidTmEq {Γ lA t u A lF F} {VΓ : [||-v Γ]}
  (VF : [Γ ||-v<lF> F | VΓ])
  (VA : [Γ ||-v<lA> A | VΓ])
  (Vtu : [Γ ||-v<lA> t ≅ u : A | VΓ | VA]) (ρ := @wk1 Γ F):
  [Γ,, F ||-v<lA> t⟨ρ⟩ ≅ u⟨ρ⟩ : A⟨ρ⟩ | validSnoc VΓ VF | wk1ValidTy VF VA].
Proof.
  assert (forall A σ, (A ⟨@wk1 Γ F⟩)[σ] = A[↑ >> σ]) as h by (intros; asimpl; now rewrite wk1_ren).
  constructor; intros; repeat rewrite h.
  instValid (validTail Vσ); irrelevance.
Qed.

Lemma embValidTy@{u i j k l} {Γ l l' A}
    {VΓ : [VR@{i j k l}| ||-v Γ]} (h : l << l')
    (VA : typeValidity@{u i j k l} Γ VΓ l A (*[Γ ||-v<l> A |VΓ]*)) :
    typeValidity@{u i j k l} Γ VΓ l' A (*[Γ ||-v<l'> A |VΓ]*).
Proof.
  unshelve econstructor.
  - intros ??? Vσ; destruct (validTy VA _  Vσ) as [pack]; exists pack.
    eapply LR_embedding; tea.
  - intros; now eapply validTyExt.
Defined.

Lemma embValidTyOne @{u i j k l} {Γ l A}
    {VΓ : [VR@{i j k l}| ||-v Γ]}
    (VA : typeValidity@{u i j k l} Γ VΓ l A (*[Γ ||-v<l> A |VΓ]*)) :
    typeValidity@{u i j k l} Γ VΓ one A (*[Γ ||-v<one> A |VΓ]*).
Proof.
  destruct l; tea; now eapply (embValidTy Oi).
Defined.

Lemma soundCtxId {Γ} (VΓ : [||-v Γ]) :
  ∑ wfΓ : [|- Γ], [Γ ||-v tRel : Γ | VΓ | wfΓ].
Proof.
  enough (G : ∑ Δ (e : Δ = Γ) (wfΔ : [|-Δ]), [VΓ |Δ ||-v tRel : Γ | wfΔ]).
  1: now destruct G as [? [-> ?]].
  pattern Γ, VΓ; apply validity_rect; clear Γ VΓ.
  - exists ε, eq_refl, wfc_nil; constructor.
  - intros * [Δ [e [wfΔ Vid]]].
    exists (Δ,, A[tRel]); unshelve eexists.
    1: asimpl; now rewrite e.
    unshelve eexists.
    + apply wfc_cons; tea.
      eapply escape.
      apply (validTy VA wfΔ Vid).
    + eapply irrelevanceSubstExt.
      2: eapply irrelevanceSubst; now unshelve eapply liftSubstS.
      intros []; [| bsimpl]; reflexivity.
Qed.

Definition soundCtx {Γ} (VΓ : [||-v Γ]) : [|-Γ] := (soundCtxId VΓ).π1.

Definition idSubstS {Γ} (VΓ : [||-v Γ]) : [Γ ||-v tRel : Γ | VΓ | _] := (soundCtxId VΓ).π2.

Lemma reflIdSubstS {Γ} (VΓ : [||-v Γ]) : [Γ ||-v tRel ≅ tRel : Γ | VΓ | _ | idSubstS VΓ].
Proof.  apply reflSubst. Qed.

End Properties.


Require Import Rel.Definitions_closed.
Require Import Lang.Static.
Set Implicit Arguments.

Implicit Types EV HV V L : Set.

Section section_𝜩𝑷𝜞.
Context (EV HV V : Set).
Implicit Type (Ξ : XEnv EV HV).
Implicit Type (P : HV → F).
Implicit Type (Γ : V → ty EV HV ∅).
Implicit Type (ω : vars).
Implicit Type (δ₁ δ₂ : EV → eff0) (δ : EV → IRel 𝓤_Sig).
Implicit Type (ρ₁ ρ₂ : HV → hd0) (ρ : HV → IRel 𝓣_Sig).
Implicit Type (γ₁ γ₂ : V → val0).

Definition 𝜞 Ξ Γ δ₁ δ₂ δ ρ₁ ρ₂ ρ ξ₁ ξ₂ γ₁ γ₂ :=
∀ᵢ x, 𝓥⟦ Ξ ⊢ Γ x ⟧ δ₁ δ₂ δ ρ₁ ρ₂ ρ ξ₁ ξ₂ (γ₁ x) (γ₂ x).

Definition 𝑷 P ξ₁ ξ₂ ρ₁ ρ₂ ρ :=
∀ᵢ p, ∃ᵢ r₁ r₂ X₁ X₂,
( ρ₁ p = hd_def (P p) (lid_f X₁) r₁ ∧
  ρ₂ p = hd_def (P p) (lid_f X₂) r₂ )ᵢ
∧ᵢ
▷ 𝓗_Fun' (𝓥_Fun_Fix) (P p) (ρ p) ξ₁ ξ₂ r₁ r₂.

Definition 𝜩 Ξ ξ₁ ξ₂ := dom Ξ \c from_list ξ₁ ∧ dom Ξ \c from_list ξ₂.

Definition closed_δ ξ₁ ξ₂ δ : IProp := ∀ᵢ α, closed_φ ξ₁ ξ₂ (δ α).

Definition closed_ρ ξ₁ ξ₂ ρ₁ ρ₂ : Prop :=
∀ p X,
(lbl_hd (ρ₁ p) = lbl_id (lid_f X) → X ∈ from_list ξ₁) ∧
(lbl_hd (ρ₂ p) = lbl_id (lid_f X) → X ∈ from_list ξ₂).

End section_𝜩𝑷𝜞.

Notation "'𝜞⟦' Ξ ⊢ Γ ⟧ δ₁ δ₂ δ ρ₁ ρ₂ ρ" := (𝜞 Ξ Γ δ₁ δ₂ δ ρ₁ ρ₂ ρ)
(at level 25, Ξ at level 0, Γ at level 0,
δ₁ at level 0, δ₂ at level 0, δ at level 0,
ρ₁ at level 0, ρ₂ at level 0, ρ at level 0).

Notation "'𝑷⟦' ⊢ P ⟧" := (𝑷 P)
(at level 25, P at level 0).

Section section_EV_HV_V_open.
Context (EV HV V : Set).
Context (Ξ : XEnv EV HV).
Context (P : HV → F).
Context (Γ : V → ty EV HV ∅).

Definition 𝓣_EV_HV_V_open (T : ty EV HV ∅) (𝓔 : eff EV HV ∅) (t₁ t₂ : tm EV HV V ∅) : IProp :=
  ∀ᵢ ξ₁ ξ₂ δ₁ δ₂ δ ρ₁ ρ₂ ρ γ₁ γ₂,
  (𝜩 Ξ ξ₁ ξ₂)ᵢ ⇒
  closed_δ ξ₁ ξ₂ δ ⇒
  (closed_ρ ξ₁ ξ₂ ρ₁ ρ₂)ᵢ ⇒
  𝑷⟦ ⊢ P ⟧ ξ₁ ξ₂ ρ₁ ρ₂ ρ ⇒
  𝜞⟦ Ξ ⊢ Γ ⟧ δ₁ δ₂ δ ρ₁ ρ₂ ρ ξ₁ ξ₂ γ₁ γ₂ ⇒
  𝓣⟦ Ξ ⊢ T # 𝓔 ⟧ δ₁ δ₂ δ ρ₁ ρ₂ ρ
    ξ₁ ξ₂
    (subst_tm δ₁ ρ₁ γ₁ t₁)
    (subst_tm δ₂ ρ₂ γ₂ t₂).

Definition 𝓥_EV_HV_V_open (T : ty EV HV ∅) v₁ v₂ : IProp :=
  ∀ᵢ ξ₁ ξ₂ δ₁ δ₂ δ ρ₁ ρ₂ ρ γ₁ γ₂,
  (𝜩 Ξ ξ₁ ξ₂)ᵢ ⇒
  closed_δ ξ₁ ξ₂ δ ⇒
  (closed_ρ ξ₁ ξ₂ ρ₁ ρ₂)ᵢ ⇒
  𝑷⟦ ⊢ P ⟧ ξ₁ ξ₂ ρ₁ ρ₂ ρ ⇒
  𝜞⟦ Ξ ⊢ Γ ⟧ δ₁ δ₂ δ ρ₁ ρ₂ ρ ξ₁ ξ₂ γ₁ γ₂ ⇒
  𝓥⟦ Ξ ⊢ T ⟧ δ₁ δ₂ δ ρ₁ ρ₂ ρ
    ξ₁ ξ₂
    (subst_val δ₁ ρ₁ γ₁ v₁)
    (subst_val δ₂ ρ₂ γ₂ v₂).

Definition 𝓗_EV_HV_V_open (𝔽 : F) (ℓ : lbl HV ∅) h₁ h₂ : IProp :=
  ∀ᵢ ξ₁ ξ₂ δ₁ δ₂ δ ρ₁ ρ₂ ρ γ₁ γ₂,
  (𝜩 Ξ ξ₁ ξ₂)ᵢ ⇒
  closed_δ ξ₁ ξ₂ δ ⇒
  (closed_ρ ξ₁ ξ₂ ρ₁ ρ₂)ᵢ ⇒
  𝑷⟦ ⊢ P ⟧ ξ₁ ξ₂ ρ₁ ρ₂ ρ ⇒
  𝜞⟦ Ξ ⊢ Γ ⟧ δ₁ δ₂ δ ρ₁ ρ₂ ρ ξ₁ ξ₂ γ₁ γ₂ ⇒
  𝓗⟦ Ξ ⊢ 𝔽 # ℓ ⟧ δ₁ δ₂ δ ρ₁ ρ₂ ρ
    ξ₁ ξ₂
    (subst_hd δ₁ ρ₁ γ₁ h₁)
    (subst_hd δ₂ ρ₂ γ₂ h₂).

Definition 𝓚_EV_HV_V_open (Ta Tb : ty EV HV ∅) (𝓔a 𝓔b : eff EV HV ∅) K₁ K₂ : IProp :=
  ∀ᵢ ξ₁ ξ₂ δ₁ δ₂ δ ρ₁ ρ₂ ρ γ₁ γ₂,
  (𝜩 Ξ ξ₁ ξ₂)ᵢ ⇒
  closed_δ ξ₁ ξ₂ δ ⇒
  (closed_ρ ξ₁ ξ₂ ρ₁ ρ₂)ᵢ ⇒
  𝑷⟦ ⊢ P ⟧ ξ₁ ξ₂ ρ₁ ρ₂ ρ ⇒
  𝜞⟦ Ξ ⊢ Γ ⟧ δ₁ δ₂ δ ρ₁ ρ₂ ρ ξ₁ ξ₂ γ₁ γ₂ ⇒
  𝓚⟦ Ξ ⊢ Ta # 𝓔a ⇢ Tb # 𝓔b ⟧ δ₁ δ₂ δ ρ₁ ρ₂ ρ
    ξ₁ ξ₂
    (subst_ktx δ₁ ρ₁ γ₁ K₁)
    (subst_ktx δ₂ ρ₂ γ₂ K₂).

End section_EV_HV_V_open.

Notation "⟦ Ξ P Γ ⊢ t₁ '≼ˡᵒᵍ' t₂ : T # 𝓔 ⟧" := (𝓣_EV_HV_V_open Ξ P Γ T 𝓔 t₁ t₂)
  (Ξ at level 0, P at level 0, Γ at level 0,
    t₁ at level 0, t₂ at level 0, T at level 0).

Notation "⟦ Ξ P Γ ⊢ v₁ '≼ˡᵒᵍᵥ' v₂ : T ⟧" := (𝓥_EV_HV_V_open Ξ P Γ T v₁ v₂)
  (Ξ at level 0, P at level 0, Γ at level 0,
    v₁ at level 0, v₂ at level 0).

Notation "⟦ Ξ P Γ ⊢ h₁ '≼ˡᵒᵍₕ' h₂ : 𝔽 # ℓ ⟧" := (𝓗_EV_HV_V_open Ξ P Γ 𝔽 ℓ h₁ h₂)
  (Ξ at level 0, P at level 0, Γ at level 0,
    h₁ at level 0, h₂ at level 0, 𝔽 at level 0).

Notation "⟦ Ξ P Γ ⊢ K₁ '≼ˡᵒᵍ' K₂ : Ta # 𝓔a ⇢ Tb # 𝓔b ⟧" :=
  (𝓚_EV_HV_V_open Ξ P Γ Ta Tb 𝓔a 𝓔b K₁ K₂)
  (Ξ at level 0, P at level 0, Γ at level 0,
    K₁ at level 0, K₂ at level 0, Ta at level 0, Tb at level 0).

Section section_EV_HV_V_L_open.
Context (EV HV V L : Set).
Context (Π : LEnv EV HV L).
Context (P : HV → F).
Context (Γ : V → ty EV HV L).

Definition 𝓣_EV_HV_V_L_open T 𝓔 t₁ t₂ : IProp :=
∀ᵢ Ξ f,
(XLEnv Ξ Π f)ᵢ ⇒
⟦ Ξ P (L_bind_ty f ∘ Γ) ⊢ (L_bind_tm f t₁) ≼ˡᵒᵍ (L_bind_tm f t₂) :
  (L_bind_ty f T) # (L_bind_eff f 𝓔) ⟧.

Definition 𝓥_EV_HV_V_L_open T v₁ v₂ : IProp :=
∀ᵢ Ξ f,
(XLEnv Ξ Π f)ᵢ ⇒
⟦ Ξ P (L_bind_ty f ∘ Γ) ⊢ (L_bind_val f v₁) ≼ˡᵒᵍᵥ (L_bind_val f v₂) :
  (L_bind_ty f T) ⟧.

Definition 𝓚_EV_HV_V_L_open Ta Tb 𝓔a 𝓔b K₁ K₂ : IProp :=
∀ᵢ Ξ f,
(XLEnv Ξ Π f)ᵢ ⇒
⟦ Ξ P (L_bind_ty f ∘ Γ) ⊢ (L_bind_ktx f K₁) ≼ˡᵒᵍ (L_bind_ktx f K₂) :
  (L_bind_ty f Ta) # (L_bind_eff f 𝓔a) ⇢ (L_bind_ty f Tb) # (L_bind_eff f 𝓔b) ⟧.

Definition 𝓗_EV_HV_V_L_open 𝔽 ℓ h₁ h₂ : IProp :=
∀ᵢ Ξ f,
(XLEnv Ξ Π f)ᵢ ⇒
⟦ Ξ P (L_bind_ty f ∘ Γ) ⊢ (L_bind_hd f h₁) ≼ˡᵒᵍₕ (L_bind_hd f h₂) : 𝔽 # (L_bind_lbl f ℓ) ⟧.

End section_EV_HV_V_L_open.

Notation "【 Π P Γ ⊢ t₁ '≼ˡᵒᵍ' t₂ : T # 𝓔 】" := (𝓣_EV_HV_V_L_open Π P Γ T 𝓔 t₁ t₂)
  (Π at level 0, P at level 0, Γ at level 0, t₁ at level 0, t₂ at level 0, T at level 0).

Notation "【 Π P Γ ⊢ v₁ '≼ˡᵒᵍᵥ' v₂ : T 】" := (𝓥_EV_HV_V_L_open Π P Γ T v₁ v₂)
  (Π at level 0, P at level 0, Γ at level 0, v₁ at level 0, v₂ at level 0).

(* Notation "【 Π P Γ ⊢ K₁ '≼ˡᵒᵍ' K₂ : Ta # 𝓔a ⇢ Tb # 𝓔b 】" :=
  (𝓚_EV_HV_V_L_open Π P Γ Ta Tb 𝓔a 𝓔b K₁ K₂)
  (Π at level 0, Γ at level 0, K₁ at level 0, K₂ at level 0, Ta at level 0, Tb at level 0).

Notation "【 Π P Γ ⊢ h₁ '≼ˡᵒᵍₕ' h₂ : 𝔽 # ℓ 】" := (𝓗_EV_HV_V_open Π P Γ 𝔽 ℓ h₁ h₂)
  (Π at level 0, P at level 0, Γ at level 0,
    h₁ at level 0, h₂ at level 0, 𝔽 at level 0). *)


(* (c) Copyright 2006-2018 Microsoft Corporation and Inria.                  *)
(* Distributed under the terms of CeCILL-B.                                  *)
From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat seq.
From fourcolor Require Import cfmap cfreducible configurations.

(******************************************************************************)
(* Reducibility of configurations number 283 to 286, whose indices in         *)
(* the_configs range over segment [282, 286).                                 *)
(******************************************************************************)

Lemma red282to286 : reducible_in_range 282 286 the_configs.
Proof. CheckReducible. Qed.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* 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.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

Require Import IZF_logic.
Require Import IZF_base.

Definition PRED := forall X : Typ1, Rel X -> X -> Prop.

Definition Compat (P : PRED) : Prop :=
  forall (X : Typ1) (A : Rel X) (a : X) (Y : Typ1) (B : Rel Y) (b : Y),
  EQV X A a Y B b -> P X A a -> P Y B b.

Definition SELECT (X : Typ1) (A : Rel X) (a : X) (P : PRED) :
  Rel (opt X) :=
  fun z' z : opt X =>
  forall E : Prop,
  (forall x x' : X,
   eq (opt X) z (some X x) -> eq (opt X) z' (some X x') -> A x' x -> E) ->
  (forall x' : X,
   eq (opt X) z' (some X x') ->
   eq (opt X) z (none X) -> A x' a -> P X A x' -> E) -> E.

Lemma SELECT_in :
 forall (X : Typ1) (A : Rel X) (a : X) (P : PRED) (x x' : X),
 A x' x -> SELECT X A a P (some X x') (some X x).

Proof
  fun X A a P x x' H E e _ =>
  e x x' (eq_refl (opt X) (some X x)) (eq_refl (opt X) (some X x')) H.

Lemma SELECT_rt :
 forall (X : Typ1) (A : Rel X) (a : X) (P : PRED) (x' : X),
 A x' a -> P X A x' -> SELECT X A a P (some X x') (none X).

Proof
  fun X A a P x' H1 H2 E _ e =>
  e x' (eq_refl (opt X) (some X x')) (eq_refl (opt X) (none X)) H1 H2.

Lemma SELECT_deloc :
 forall (X : Typ1) (A : Rel X) (a : X) (P : PRED),
 deloc X A (opt X) (SELECT X A a P) (some X).

Proof.
intros X A a P; unfold deloc in |- *; apply and_intro.
(* Deloc 1 *)
exact (SELECT_in X A a P).
(* Deloc 2 (case distinction *)
intros x z' H; apply H; clear H.
(* Deloc 2, case 1 *)
intros x0 x' H1 H2 H3; apply ex2_intro with x'.
apply (eq_sym _ _ _ (eq_some_some X x x0 H1)); assumption.
assumption.
(* Deloc 2, case 2 (absurd) *)
intros x' H1 H2 H3 H4; apply (eq_some_none X x H2).
Qed.

Lemma SELECT_eqv :
 forall (X : Typ1) (A : Rel X) (a : X) (P : PRED) (x : X),
 EQV X A x (opt X) (SELECT X A a P) (some X x).

Proof.
intros X A a P x; apply EQV_deloc; apply SELECT_deloc.
Qed.

Lemma selection_intro :
 forall (X : Typ1) (A : Rel X) (a : X) (P : PRED),
 Compat P ->
 forall (Y : Typ1) (B : Rel Y) (b : Y),
 ELT Y B b X A a -> P Y B b -> ELT Y B b (opt X) (SELECT X A a P) (none X).

Proof.
intros X A a P H1 Y B b H H2; apply H; clear H; intros x' H3 H4.
apply ELT_intro with (some X x').
apply SELECT_rt; [ assumption | exact (H1 _ _ _ _ _ _ H4 H2) ].
apply EQV_trans with X A x'; [ assumption | apply SELECT_eqv ].
Qed.

Lemma selection_elim :
 forall (X : Typ1) (A : Rel X) (a : X) (P : PRED),
 Compat P ->
 forall (Y : Typ1) (B : Rel Y) (b : Y),
 ELT Y B b (opt X) (SELECT X A a P) (none X) ->
 and (ELT Y B b X A a) (P Y B b).

Proof.
intros X A a P H1 Y B b H; apply H; clear H.
intros z' H H2; apply H; clear H.
(* Case 1 (absurd) *)
intros x x' H3 H4 H5; apply (eq_none_some X x H3).
(* Case 2 *)
intros x' H3 H4 H5 H6; apply and_intro.
(* Case 2, first conclusion *)
apply ELT_intro with x'. assumption.
apply EQV_trans with (opt X) (SELECT X A a P) z'. assumption.
apply (eq_sym _ _ _ H3); apply EQV_sym; apply SELECT_eqv.
(* Case 2, second conclusion *)
apply H1 with X A x'.
apply EQV_trans with (opt X) (SELECT X A a P) z'.
apply (eq_sym _ _ _ H3); apply SELECT_eqv.
apply EQV_sym; assumption. assumption.
Qed.

Theorem selection :
 forall (X : Typ1) (A : Rel X) (a : X) (P : PRED),
 Compat P ->
 forall (Y : Typ1) (B : Rel Y) (b : Y),
 iff (ELT Y B b (opt X) (SELECT X A a P) (none X))
   (and (ELT Y B b X A a) (P Y B b)).

Proof.
intros X A a P H1 Y B b; unfold iff in |- *; apply and_intro.
intro; apply selection_elim; assumption.
intro H; apply H; intros; apply selection_intro; assumption.
Qed.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* 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.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

Require Import Reals.
Require Import trajectory_const.
Require Import rrho.

Record Trajectory : Type := mkTrajectory
  {x : Differential;
   y : Differential;
   theta : Differential;
   phi : Differential;
   h : TypeSpeed;
   cond_x :
    forall t : R, derive_pt x t (cond_diff x t) = (h * cos (theta t))%R;
   cond_y :
    forall t : R, derive_pt y t (cond_diff y t) = (h * sin (theta t))%R;
   cond_phi : forall t : R, (- MaxBank <= phi t <= MaxBank)%R;
   cond_theta :
    forall t : R,
    derive_pt theta t (cond_diff theta t) = (g * (tan (phi t) / h))%R}.

Record EvaderTrajectory : Type := mkEvaderTrajectory
  {tr : Trajectory;
   tr_cond1 : forall t : R, x tr t = (x tr 0 + h tr * t)%R;
   tr_cond2 : forall t : R, y tr t = y tr 0%R;
   tr_cond3 : forall t : R, theta tr t = 0%R;
   tr_cond4 : forall t : R, phi tr t = 0%R}.

Lemma init_tr_derivable_x :
 forall h : TypeSpeed, derivable (fun t : R => (h * t)%R).
intro; reg.
Qed.

Lemma init_tr_derivable_y :
 forall h : TypeSpeed, derivable (fun t : R => 0%R).
intro; reg.
Qed.

Lemma init_tr_cond_x :
 forall (h : TypeSpeed) (t : R),
 derive_pt (fun t : R => (h * t)%R) t (init_tr_derivable_x h t) =
 (h * cos ((fun t : R => 0) t))%R.
intros; reg.
rewrite cos_0; ring.
Qed.

Lemma init_tr_cond_y :
 forall (h : TypeSpeed) (t : R),
 derive_pt (fun t : R => 0%R) t (init_tr_derivable_y h t) =
 (h * sin ((fun t : R => 0) t))%R.
intros; reg.
rewrite sin_0; ring.
Qed.

Lemma init_tr_cond_phi :
 forall t : R,
 (- MaxBank <= (fun t : R => 0) t)%R /\ ((fun t : R => 0) t <= MaxBank)%R.
intros; simpl in |- *; cut (0 < MaxBank)%R.
split.
left; rewrite <- Ropp_0; apply Ropp_lt_gt_contravar; assumption.
left; assumption.
unfold MaxBank in |- *; unfold Rdiv in |- *; apply Rmult_lt_0_compat;
 [ prove_sup | apply Rinv_0_lt_compat; prove_sup ].
Qed.

Lemma fct_der1 : forall t : R, derivable_pt (fun t : R => 0%R) t.
intro; reg.
Qed.

Lemma init_tr_cond_theta :
 forall (h : TypeSpeed) (t : R),
 derive_pt (fun t : R => 0%R) t (init_tr_derivable_y h t) =
 (fun t : R => (g * (tan 0 / h))%R) t.
intros; reg.
unfold Rdiv in |- *; rewrite tan_0; ring.
Qed.

(**********)
Definition init_tr (h : TypeSpeed) : Trajectory :=
  mkTrajectory
    (mkDifferential (fun t : R => (h * t)%R) (init_tr_derivable_x h))
    (mkDifferential (fun t : R => 0%R) (init_tr_derivable_y h))
    (mkDifferential (fun t : R => 0%R) (init_tr_derivable_y h))
    (mkDifferential (fun t : R => 0%R) (init_tr_derivable_y h)) h
    (init_tr_cond_x h) (init_tr_cond_y h) init_tr_cond_phi
    (init_tr_cond_theta h).

(**********)
Lemma MaxBank_encadr : (0 < MaxBank < PI / 4)%R.
split.
unfold MaxBank in |- *; unfold Rdiv in |- *; apply Rmult_lt_0_compat;
 [ prove_sup | apply Rinv_0_lt_compat; prove_sup ].
apply Rlt_trans with (PI_lb / 4)%R.
unfold MaxBank in |- *; unfold Rdiv in |- *; apply Rmult_lt_reg_l with 100%R.
prove_sup0.
rewrite <- Rmult_comm; rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
rewrite Rmult_1_r; apply Rmult_lt_reg_l with 4%R.
prove_sup.
repeat rewrite (Rmult_comm 4); repeat rewrite Rmult_assoc;
 rewrite <- Rinv_l_sym.
unfold PI_lb in |- *; prove_sup.
discrR.
discrR.
unfold Rdiv in |- *; repeat rewrite <- (Rmult_comm (/ 4));
 apply Rmult_lt_compat_l.
apply Rinv_0_lt_compat; prove_sup.
elim PI_approx; trivial.
Qed.

(**********)
Lemma dtheta_rho :
 forall (tr : Trajectory) (t : R),
 (- rho (h tr) <= derive_pt (theta tr) t (cond_diff (theta tr) t) <=
  rho (h tr))%R.
intros; generalize (cond_theta tr0); intro; rewrite (H t); unfold rho in |- *;
 generalize (cond_phi tr0); intro; elim (H0 t); intros H1 H2;
 generalize MaxBank_encadr; intro H3; elim H3; intros H4 H5;
 split.
unfold Rdiv in |- *;
 replace (- (g * (tan MaxBank * / h tr0)))%R with
  (g * (- tan MaxBank * / h tr0))%R.
apply Rmult_le_compat_l.
left; apply g_pos.
  setoid_rewrite Rmult_comm at 1 2.
  apply Rmult_le_compat_l.
left; apply (Rinv_0_lt_compat (h tr0) (TypeSpeed_pos (h tr0))).
rewrite <- tan_neg.
generalize
 (Rlt_le (- (PI / 4)) (- MaxBank) (Ropp_lt_gt_contravar MaxBank (PI / 4) H5));
 intro H6; generalize (Ropp_lt_gt_contravar 0 MaxBank H4);
 rewrite Ropp_0; intro H7;
 generalize
  (Rlt_le (- MaxBank) (PI / 4)
     (Rlt_trans (- MaxBank) 0 (PI / 4) H7 PI4_RGT_0));
 intro H8;
 generalize
  (Rlt_le (phi tr0 t) (PI / 4)
     (Rle_lt_trans (phi tr0 t) MaxBank (PI / 4) H2 H5));
 intro H9; generalize (Rle_trans (- (PI / 4)) (- MaxBank) (phi tr0 t) H6 H1);
 intro H10; apply tan_incr_1; assumption.
replace (- tan MaxBank)%R with (-1 * tan MaxBank)%R.
repeat rewrite <- Rmult_assoc; rewrite <- (Rmult_comm (-1));
 repeat rewrite <- Rmult_assoc;
 replace (- (g * tan MaxBank * / h tr0))%R with
  (-1 * g * tan MaxBank * / h tr0)%R; [ reflexivity | ring ].
ring.
apply Rmult_le_compat_l;
 [ left; apply g_pos
 | unfold Rdiv in |- *; rewrite (Rmult_comm (tan MaxBank));
    rewrite (Rmult_comm (tan (phi tr0 t))); apply Rmult_le_compat_l;
    [ left; apply (Rinv_0_lt_compat (h tr0) (TypeSpeed_pos (h tr0)))
    | generalize (Rlt_le MaxBank (PI / 4) H5); intro H6;
       generalize (Rle_trans (phi tr0 t) MaxBank (PI / 4) H2 H6);
       intro H7; generalize PI4_RGT_0; intro H8;
       generalize (Ropp_lt_gt_contravar 0 (PI / 4) H8);
       rewrite Ropp_0; intro H9;
       generalize
        (Rlt_le (- (PI / 4)) MaxBank (Rlt_trans (- (PI / 4)) 0 MaxBank H9 H4));
       intro H10; generalize (Ropp_le_ge_contravar MaxBank (PI / 4) H6);
       intro H11; generalize (Rge_le (- MaxBank) (- (PI / 4)) H11);
       intro H12;
       generalize (Rle_trans (- (PI / 4)) (- MaxBank) (phi tr0 t) H12 H1);
       intro H13; apply tan_incr_1; assumption ] ].
Qed.


(* This file is an automatic translation, the licence of the source can be found here: *)
(* https://github.com/herd/herdtools7/blob/master/LICENSE.txt *)
(* Translation of model Uniproc model *)
From Coq Require Import Relations Ensembles String.
From RelationAlgebra Require Import lattice prop monoid rel kat.
From Catincoq.lib Require Import Cat proprel.
Section Model.
Variable c : candidate.
Definition events := events c.
Definition R := R c.
Definition W := W c.
Definition IW := IW c.
Definition FW := FW c.
Definition B := B c.
Definition RMW := RMW c.
Definition F := F c.
Definition rf := rf c.
Definition po := po c.
Definition int := int c.
Definition ext := ext c.
Definition loc := loc c.
Definition addr := addr c.
Definition data := data c.
Definition ctrl := ctrl c.
Definition amo := amo c.
Definition rmw := rmw c.
Definition unknown_set := unknown_set c.
Definition unknown_relation := unknown_relation c.
Definition M := R ⊔ W.
Definition emptyset : set events := empty.
Definition classes_loc : set events -> Ensemble (Ensemble events) := partition loc.
Definition tag2events := unknown_relation "tag2events".
Definition emptyset_0 : set events := domain 0.
Definition partition := classes_loc.
Definition tag2instrs := tag2events.
Definition po_loc := po ⊓ loc.
Definition rfe := rf ⊓ ext.
Definition rfi := rf ⊓ int.
Definition co0 := loc ⊓ ([IW] ⋅ top ⋅ [(W ⊓ !IW)] ⊔ [(W ⊓ !FW)] ⋅ top ⋅ [FW]).
Definition toid (s : set events) : relation events := [s].
Definition fencerel (B : set events) := (po ⊓ [top] ⋅ top ⋅ [B]) ⋅ po.
Definition ctrlcfence (CFENCE : set events) := (ctrl ⊓ [top] ⋅ top ⋅ [CFENCE]) ⋅ po.
Definition imply (A : relation events) (B : relation events) := !A ⊔ B.
Definition nodetour (R1 : relation events) (R2 : relation events) (R3 : relation events) := R1 ⊓ !(R2 ⋅ R3).
Definition singlestep (R : relation events) := nodetour R R R.
(* Definition of map already included in the prelude *)
Definition LKW := (*failed: try LKW with emptyset_0*) emptyset_0.
Definition mfence : relation events := (*failed: try fencerel MFENCE with 0*) 0.
Definition lfence : relation events := (*failed: try fencerel LFENCE with 0*) 0.
Definition sfence : relation events := (*failed: try fencerel SFENCE with 0*) 0.
Definition dmb_st : relation events := (*failed: try fencerel DMB.ST with 0*) 0.
Definition dsb_st : relation events := (*failed: try fencerel DSB.ST with 0*) 0.
Definition dmb : relation events := (*failed: try fencerel DMB with 0*) 0.
Definition dsb : relation events := (*failed: try fencerel DSB with 0*) 0.
Definition isb : relation events := (*failed: try fencerel ISB with 0*) 0.
Definition ctrlisb : relation events := (*failed: try ctrlcfence ISB with 0*) 0.
Definition sync : relation events := (*failed: try fencerel SYNC with 0*) 0.
Definition lwsync : relation events := (*failed: try fencerel LWSYNC with 0*) 0.
Definition eieio : relation events := (*failed: try fencerel EIEIO with 0*) 0.
Definition isync : relation events := (*failed: try fencerel ISYNC with 0*) 0.
Definition ctrlisync : relation events := (*failed: try ctrlcfence ISYNC with 0*) 0.
Definition DMB_ISH := (*failed: try DMB.ISH with emptyset_0*) emptyset_0.
Definition DMB_ISHLD := (*failed: try DMB.ISHLD with emptyset_0*) emptyset_0.
Definition DMB_ISHST := (*failed: try DMB.ISHST with emptyset_0*) emptyset_0.
Definition DSB_ISH := (*failed: try DSB.ISH with emptyset_0*) emptyset_0.
Definition DSB_ISHLD := (*failed: try DSB.ISHLD with emptyset_0*) emptyset_0.
Definition DSB_ISHST := (*failed: try DSB.ISHST with emptyset_0*) emptyset_0.
Definition DMB_SY := (*failed: try DMB.SY with emptyset_0*) emptyset_0.
Definition DMB_ST := (*failed: try DMB.ST with emptyset_0*) emptyset_0.
Definition DMB_LD := (*failed: try DMB.LD with emptyset_0*) emptyset_0.
Definition DSB_SY := (*failed: try DSB.SY with emptyset_0*) emptyset_0.
Definition DSB_ST := (*failed: try DSB.ST with emptyset_0*) emptyset_0.
Definition DSB_LD := (*failed: try DSB.LD with emptyset_0*) emptyset_0.
Definition DMB_OSH := (*failed: try DMB.OSH with emptyset_0*) emptyset_0.
Definition DSB_OSH := (*failed: try DSB.OSH with emptyset_0*) emptyset_0.
Definition DMB_OSHLD := (*failed: try DMB.OSHLD with emptyset_0*) emptyset_0.
Definition DSB_OSHLD := (*successful: try DSB.OSH with emptyset_0*) DSB_OSH.
Definition DMB_OSHST := (*failed: try DMB.OSHST with emptyset_0*) emptyset_0.
Definition DSB_OSHST := (*failed: try DSB.OSHST with emptyset_0*) emptyset_0.
Definition ISB := (*failed: try ISB with emptyset_0*) emptyset_0.
Definition A := (*failed: try A with emptyset_0*) emptyset_0.
Definition L := (*failed: try L with emptyset_0*) emptyset_0.
Definition Q := (*failed: try Q with emptyset_0*) emptyset_0.
Definition NoRet := (*failed: try NoRet with emptyset_0*) emptyset_0.
Definition dmb_ish := fencerel DMB_ISH.
Definition dmb_ishld := fencerel DMB_ISHLD.
Definition dmb_ishst := fencerel DMB_ISHST.
Definition dmb_fullsy := fencerel DMB_SY.
Definition dmb_fullst := fencerel DMB_ST.
Definition dmb_fullld := fencerel DMB_LD.
Definition dmb_sy := dmb_fullsy ⊔ dmb_ish.
Definition dmb_st_0 := dmb_fullst ⊔ dmb_ishst.
Definition dmb_ld := dmb_fullld ⊔ dmb_ishld.
Definition dsb_sy := fencerel DSB_SY.
Definition dsb_st_0 := fencerel DSB_ST.
Definition dsb_ld := fencerel DSB_LD.
Definition isb_0 := fencerel ISB.
Definition ctrlisb_0 := (*successful: try ctrlcfence ISB with 0*) ctrlcfence ISB.
Definition ctrlcfence_0 := ctrlisb_0 ⊔ ctrlisync.
(* Definition of co_locs already included in the prelude *)
(* Definition of cross already included in the prelude *)
Definition generate_orders s pco := cross (co_locs pco (partition s)).
Definition generate_cos pco := generate_orders W pco.
Definition cobase := co0.
Variable co : relation events.
Definition coi := co ⊓ int.
Definition coe := co ⊓ !coi.
Definition fr := rf° ⋅ co ⊓ !id.
Definition fri := fr ⊓ int.
Definition fre := fr ⊓ !fri.
Definition sc_per_location := acyclic (po_loc ⊔ (fr ⊔ (rf ⊔ co))).
Definition witness_conditions := generate_cos cobase co.
Definition model_conditions := sc_per_location.
End Model.

Hint Unfold events R W IW FW B RMW F rf po int ext loc addr data ctrl amo rmw unknown_set unknown_relation M emptyset classes_loc tag2events emptyset_0 partition tag2instrs po_loc rfe rfi co0 toid fencerel ctrlcfence imply nodetour singlestep LKW mfence lfence sfence dmb_st dsb_st dmb dsb isb ctrlisb sync lwsync eieio isync ctrlisync DMB_ISH DMB_ISHLD DMB_ISHST DSB_ISH DSB_ISHLD DSB_ISHST DMB_SY DMB_ST DMB_LD DSB_SY DSB_ST DSB_LD DMB_OSH DSB_OSH DMB_OSHLD DSB_OSHLD DMB_OSHST DSB_OSHST ISB A L Q NoRet dmb_ish dmb_ishld dmb_ishst dmb_fullsy dmb_fullst dmb_fullld dmb_sy dmb_st_0 dmb_ld dsb_sy dsb_st_0 dsb_ld isb_0 ctrlisb_0 ctrlcfence_0 generate_orders generate_cos cobase coi coe fr fri fre sc_per_location witness_conditions model_conditions : cat.

Definition valid (c : candidate) :=
  exists co : relation (events c),
    witness_conditions c co /\
    model_conditions c co.

(* End of translation of model Uniproc model *)


Require Import SpecDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import AbsAccessor.Spec.
Require Import RmiOps.Spec.

Local Open Scope Z_scope.

Section SpecLow.

  Definition smc_granule_undelegate_spec0 (addr: Z64) (adt: RData) : option (RData * Z64) :=
    match addr with
    | VZ64 _addr =>
      rely is_int64 _addr;
      when'' _g_base, _g_ofst, adt == find_lock_granule_spec (VZ64 _addr) (VZ64 1) adt;
      when _t'2 == is_null_spec (_g_base, _g_ofst) adt;
      rely is_int _t'2;
      if (_t'2 =? 0) then
        when adt == granule_undelegate_ops_spec (_g_base, _g_ofst) (VZ64 _addr) adt;
        let _ret := 0 in
        Some (adt, (VZ64 _ret))
      else
        let _ret := 1 in
        Some (adt, (VZ64 _ret))
     end
    .

End SpecLow.


Require Import Axioms.
Require Import Tactics.
Require Import Sigma.
Require Import Equality.
Require Import Relation.
Require Import Syntax.
Require Import Ofe.
Require Import Uniform.
Require Import Spaces.
Require Import Dynamic.
Require Import Hygiene.
Require Import Equivalence.
Require Import Intensional.
Require Import Ordinal.
Require Import Candidate.
Require Import System.
Require Import MapTerm.
Require Import Extend.
Require Import Model.
Require Import Standard.
Require Import Truncate.
Require Import Equivalences.
Require Import Ceiling.
Require Import Page.

Definition kuniv_action (system : System) (i : nat) (pg : page) (h : lt_page pg toppg)
  : nat -> relation sterm
  :=
  fun j a b =>
    j <= i
    /\ exists (K : qkind) (R : siurel),
         sintk system pg true j a K
         /\ sintk system pg false j b K
         /\ sint system (succ_page pg h) true j a R
         /\ sint system (succ_page pg h) false j b R.

Lemma kuniv_uniform :
  forall system i pg h, uniform _ (kuniv_action system i pg h).
Proof.
intros system i pg.
do2 3 split.

(* closed *)
{
intros j a b H.
decompose H.
intros Hj K R _ _ HaR HbR.
eauto using sint_closed.
}

(* equiv *)
{
intros j a a' b b' Hcla' Hclb' Ha Hb H.
decompose H.
intros Hj K R Hc Hd Hct Hdt.
split; auto.
exists K, R.
do2 3 split; eauto using sint_equiv, sintk_equiv.
}

(* zigzag *)
{
intros j a b c d Hab Hcb Hcd.
decompose Hab.
intros Hj K R HaK HbK HaR HbR.
decompose Hcb.
intros _ K' R' HcK HbK' HcR HbR'.
so (sintk_fun _#7 HbK HbK'); subst K'.
so (sint_fun _#7 HbR HbR'); subst R'.
decompose Hcd.
intros _ K' R' HcK' HdK HcR' HdR.
so (sintk_fun _#7 HcK HcK'); subst K'.
so (sint_fun _#7 HcR HcR'); subst R'.
split; auto.
exists K, R.
auto.
}

(* downward *)
{
intros j a b H.
decompose H.
intros Hj K R Hl Hr Hlt Hrt.
assert (j <= S j) as Hle by omega.
so (sintk_downward _#7 Hle Hl) as Hl'.
so (sintk_downward _#7 Hle Hr) as Hr'.
so (sint_downward _#7 Hle Hlt) as Hlt'.
so (sint_downward _#7 Hle Hrt) as Hrt'.
split; [omega |].
exists (approx j K), (iutruncate (S j) R).
auto.
}
Qed.

Definition kuniv_urel system i pg h : surel :=
  mk_urel (kuniv_action system i pg h) (kuniv_uniform _ _ _ _).

Definition iukuniv system i pg h : siurel :=
  (kuniv_urel system i pg h,
   meta_page pg).

Lemma den_iukuniv :
  forall system i pg h,
    den (iukuniv system i pg h) = kuniv_urel system i pg h.
Proof.
reflexivity.
Qed.

Lemma iukuniv_inj :
  forall system i i' pg pg' h h',
    iukuniv system i pg h = iukuniv system i' pg' h'
    -> pg = pg'.
Proof.
intros system i i' pg pg' h h' Heq.
unfold iukuniv in Heq.
so (f_equal (fun z => snd z) Heq) as Heq'.
cbn in Heq'.
exact (meta_page_inj _#3 Heq').
Qed.

Lemma ceiling_kuniv_urel :
  forall n system i pg h,
    ceiling (S n) (kuniv_urel system i pg h)
    =
    kuniv_urel system (min i n) pg h.
Proof.
intros n system i pg h.
apply urel_extensionality.
fextensionality 3.
intros j m p.
cbn.
pextensionality.
  {
  intros (Hj & Hj' & Hmp).
  split; auto.
  apply Nat.min_glb; omega.
  }

  {
  intros (Hj & Hmp).
  so (Nat.min_glb_l _#3 Hj).
  so (Nat.min_glb_r _#3 Hj).
  split; [omega |].
  split; auto.
  }
Qed.

Lemma iutruncate_iukuniv :
  forall n system i pg h,
    iutruncate (S n) (iukuniv system i pg h)
    =
    iukuniv system (min i n) pg h.
Proof.
intros n system i pg h.
unfold iukuniv, iutruncate.
cbn [fst snd].
f_equal.
  {
  apply ceiling_kuniv_urel.
  }

  {
  rewrite -> meta_truncate_page; auto.
  omega.
  }
Qed.


Require Import FSetInterface.
Require Import Tactics Algebra.Utils SetoidUtils Algebra.SetoidCat  Algebra.Monad Algebra.SetoidCat.PairUtils Algebra.SetoidCat.MaybeUtils Algebra.Monad.Maybe Algebra.Alternative Algebra.Functor Algebra.FoldableFunctor Algebra.Applicative Algebra.Monoid Algebra.SetoidCat.NatUtils Algebra.SetoidCat.BoolUtils Algebra.Monoid.PropUtils QAL.Concrete.Definitions QAL.Definitions.

Require Import FMapWeakList  RelationClasses Relation_Definitions Morphisms SetoidClass.

Require Import Coq.Structures.DecidableTypeEx.

Module Type Heap  (TT : TypeType) (AT : AddrType) (PT : PredType) (VT : ValType).
  Import TT AT PT VT.
  Open Scope type_scope.
  Parameter t : Type.
  Parameter tS : Setoid t.

  Parameter extractAddr : valS ~> maybeS addrS.
  Parameter addrToVal: addrS ~> valS.
  Parameter predOfType : predS ~> typeS ~~> tS ~~> iff_setoid.
  Parameter typeOfHeap : typeS ~> tS ~~> iff_setoid.

  Parameter emptyH : t.
  Parameter newAddr : typeS ~> tS ~~> optionS (tS ~*~ addrS).
  Parameter update : addrS ~> predS ~~> valS ~~> tS ~~> tS.
  Parameter delete : addrS ~> tS ~~> tS.
  Parameter union : tS ~> tS ~~> tS.

  Parameter allocated : addrS ~> tS ~~> iff_setoid.
  Parameter readType : addrS ~> tS ~~> optionS typeS.
  Parameter read : addrS ~> predS ~~> tS ~~> optionS valS.

  Parameter l : forall A, (Setoid A) -> Type.
  Parameter lS : forall A (AS : Setoid A), Setoid (l A AS).
  Parameter (func : @Functor l lS).
  Parameter (alt : @Alternative l lS).
  Parameter (foldable : @FoldableFunctor l lS func).
  Parameter (app : @Applicative l lS func).
  Parameter lookupByObject : predS ~> valS ~~> tS ~~> lS _ addrS.
  Parameter lookupByPred : predS ~> tS ~~> lS _ (addrS ~*~ valS).

  Notation "heap [ val , pred ]" := (read @ val @ pred @ heap) (at level 11).
  Notation "heap [ val , pred  ↦  val2 ]  " := (update @ val @ pred @ val2 @ heap) (at level 11).

  Axiom eq_heap : forall (h1 h2 : t) ,
                    (forall t, typeOfHeap @ t @ h1 <-> typeOfHeap @ t @ h2) ->
                    (forall p t, predOfType @ p @ t @ h1 <-> predOfType @ p @ t @ h2) ->
                    (forall v, allocated @ v @ h1 == allocated @ v @ h2) ->
                    (forall v, readType @ v @ h1 == readType @ v @ h2) ->
                    (forall v p, read @ v @ p @ h1 == read @ v @ p @ h2) ->
                    h1 == h2.

  Axiom extractAddr_addrToVal :
    forall addr,
      extractAddr @ (addrToVal @ addr) == Some addr.

  Axiom addrToVal_extractAddr :
    forall val addr,
      extractAddr @ val == Some addr ->
      addrToVal @ addr == val.

  Axiom read_unallocated_addr:
    forall h pred1 addr,
      ~ allocated @ addr @ h -> read @ addr @ pred1 @ h == None.

  Axiom readType_unallocated_addr:
    forall h addr,
      ~ allocated @ addr @ h -> readType @ addr @ h == None.

  Axiom update_unallocated_addr :
    forall h addr pred val2,
      ~ allocated @ addr @ h -> h [ addr , pred ↦  val2 ] == h.

  Axiom delete_unallocated_addr :
    forall h addr,
      ~ allocated @ addr @ h -> delete @ addr @ h == h.

  Axiom readType_allocated_addr:
    forall h addr,
      allocated @ addr @ h -> exists type1, readType @ addr @ h == Some type1.

  Axiom read_diff_pred :
    forall h val pred t,
      readType @ val @ h == Some t ->
      ~ predOfType @ pred @ t @ h ->
      h [ val , pred ] == None.

  Axiom update_diff_pred :
    forall h val pred val2 t,
      readType @ val @ h == Some t ->
      ~ predOfType @ pred @ t @ h ->
      h [ val , pred ↦ val2 ] == h.

  Axiom allocated_empty : forall v, ~ allocated @ v @ emptyH.

  Axiom allocated_newAddr_1:
    forall h type1 addr h',
      Some (h', addr) == newAddr @ type1 @ h -> ~ allocated @ addr @ h.

  Axiom allocated_newAddr_2:
    forall h type1 addr h',
      Some (h', addr) == newAddr @ type1 @ h -> allocated @ addr @ h'.

  Axiom readType_newAddr:
    forall h type1 addr h',
      Some (h', addr) == newAddr @ type1 @ h -> readType @ addr @ h' == Some type1.

  Axiom read_update :
    forall h val pred val2 t,
      readType @ val @ h == Some t ->
      predOfType @ pred @ t @ h ->
      h [ val , pred ↦  val2 ] [ val , pred ] == Some val2.

  Axiom read_update_diff_addr :
    forall h val val' pred pred' val2,
      val <> val' ->
      h [ val , pred ↦ val2 ] [ val' , pred' ] == h [ val' , pred' ].

  Axiom allocated_update :
    forall h val pred val2 addr,
      allocated @ addr @ (h [ val , pred ↦  val2 ]) == allocated @ addr @ h.

  Axiom readType_update :
    forall h val pred val2 addr,
      readType @ addr @ (h [ val , pred ↦  val2 ]) == readType @ addr @ h.

  Axiom allocated_delete :
    forall h val,
      ~ allocated @ val @ (delete @ val @ h).

  Axiom allocated_delete_diff_addr :
    forall h addr1 addr',
      ~ addr1 == addr' ->
      allocated @ addr1 @ (delete @ addr' @ h) == allocated @ addr1 @ h.

  Axiom read_delete_diff_addr :
    forall h val val' pred,
      ~ val == val' ->
      (delete @ val @ h) [ val' , pred ] == h [val', pred].

  Axiom readType_delete_diff_addr :
    forall h val val',
      ~ val == val' ->
      readType @ val' @ (delete @ val @ h) == readType @ val' @ h.

  Axiom update_update :
    forall h val pred val2 val3,
      h [ val , pred ↦  val2 ] [ val , pred ↦ val3 ] == h  [ val , pred ↦ val3 ].

  Axiom update_update_diff_addr :
    forall h val val' pred val2 val3,
      ~ val == val' ->
      h [ val , pred ↦  val2 ] [ val' , pred ↦ val3 ] == h [ val' , pred ↦ val3 ] [ val , pred ↦ val2 ].

  Axiom update_update_diff_pred :
    forall h val pred pred' val2 val3,
      ~ pred == pred' ->
      h [ val , pred ↦  val2 ] [ val , pred' ↦ val3 ] == h [ val , pred' ↦ val3 ] [ val , pred ↦ val2 ].

  Axiom delete_update :
    forall h val pred val2,
      delete @ val @ (h [ val , pred ↦  val2 ]) == delete @ val @ h.

  Axiom delete_update_diff_addr :
    forall h val val' pred val2,
      ~ val == val' ->
      delete @ val' @ (h [ val , pred ↦  val2 ]) == (delete @ val' @ h) [ val , pred ↦ val2 ].

  Axiom delete_delete :
    forall h val val',
      delete @ val' @ (delete @ val @ h) == delete @ val @ (delete @ val' @ h).

  Axiom update_newAddr_1 :
    forall h val pred val2 type1 h' addr,
      newAddr @ type1 @ h == Some (h', addr) ->
      val <> addr ->
      newAddr @ type1 @ (h [ val , pred ↦  val2 ]) == Some (h' [ val , pred ↦  val2 ], addr).

  Axiom update_newAddr_2 :
    forall h val pred val2 type1,
      newAddr @ type1 @ h == None ->
      newAddr @ type1 @ (h [ val , pred ↦  val2 ]) == None.

  Axiom delete_newAddr :
    forall h type1 h' addr,
      newAddr @ type1 @ h == Some (h', addr) ->
      delete @ addr @ h' == h.

  Section AndMonoid.

    Existing Instance and_Monoid.

    Axiom read_lookupByObject :
      forall pred val h,
        fold @ ((equivS @  Some val) ∘ (cycle3S @ read @ pred @ h )  <$> lookupByObject @ pred @ val @ h) == True.

    Axiom read_lookupByPred :
      forall pred h,
             fold @ (uncurryS @ equivS ∘ (cycle3S @ read @ pred @ h *** SomeS ) <$> lookupByPred @ pred @ h) == True.

  End AndMonoid.

  Section OrMonoid.

    Existing Instance or_Monoid.

    Axiom lookupByObject_read :
      forall addr pred val h,
        h [addr, pred] == Some val ->
        fold @ (equivS @ addr <$> lookupByObject @ pred @ val @ h) == True.

    Axiom lookupByPred_read :
      forall addr pred val h,
        h [addr, pred] == Some val ->
        fold @ (equivS @ (addr, val)  <$> lookupByPred @ pred @ h) == True.

  End OrMonoid.

End Heap.

Module HeapUtils (TT : TypeType) (AT : AddrType) (PT : PredType) (VT : ValType) (H : Heap TT AT PT VT).
  Import TT AT PT VT H.

  Definition lookupBySPO :  addrS ~> predS ~~> valS ~~> tS ~~> boolS.
    simple refine (injF4 (fun addr1 pred1 val1 h =>
                            match h[addr1, pred1] with
                              | Some val2 => if equiv_dec val1 val2 then true else false
                              | None => false
                            end) _).
    Lemma lookupBySPO_1 : Proper (equiv ==> equiv ==> equiv ==> equiv ==> equiv)
     (fun (addr1 : addr) (pred1 : pred) (val1 : val) (h : t) =>
      match h [addr1, pred1] with
      | Some val2 => if equiv_dec val1 val2 then true else false
      | None => false
      end).
    Proof.
      autounfold. intros. matchequiv. simpl in H3. destruct (equiv_dec x1 v). destruct (equiv_dec y1 v0). reflexivity. destruct n. transitivity x1. symmetry. auto. transitivity v. auto. auto. destruct (equiv_dec y1 v0). destruct n. transitivity y1. auto. transitivity v0. auto. symmetry. auto. reflexivity.
    Qed.
    apply lookupBySPO_1.
  Defined.

  Definition inDom : addrS ~> tS ~~> iff_setoid.
    simple refine (injF2 (fun addr h => exists pred1 a, read @ addr @ pred1 @ h == Some a) _).
    apply optionS.
    apply valS.
    Lemma inDom_1 : Proper (equiv ==> equiv ==> equiv)
     (fun (addr : addr) (h : t) =>
        exists (pred1 : pred) (a : val), h [addr, pred1] == Some a).
    Proof.
      solve_proper.
    Qed.
    apply inDom_1.
  Defined.

  Definition disjoint : tS ~> tS ~~> iff_setoid.
   refine (injF2 (fun h1 h2 => forall addr, ~(inDom @ addr @ h1) \/ ~ (inDom @ addr @ h2)) _).
   Lemma disjoint_1 : Proper (equiv ==> equiv ==> equiv)
     (fun h1 h2 => forall addr, ~(inDom @ addr @ h1) \/ ~ (inDom @ addr @ h2)).
   Proof.
     solve_proper.
   Qed.
   apply disjoint_1.
  Defined.

  Definition singleton : addrS ~> predS ~~> valS ~~> tS ~~> iff_setoid.
     refine (injF4 (fun addr1 pred1 val1 h =>
                            h [ addr1 , pred1 ] == Some val1 /\
                            forall addr2 pred2 val2,
                              h [ addr2 , pred2 ] == Some val2 ->
                              addr1 == addr2 /\
                              pred1 == pred2 /\
                              val2 == val1) _).
    Lemma singleton_1 : Proper (equiv ==> equiv ==> equiv ==> equiv ==> equiv)
     (fun (addr1 : addr) (pred1 : pred) (val1 : val) (h : t) =>
      h [addr1, pred1] == Some val1 /\
      (forall (addr2 : addr) (pred2 : pred) (val2 : val),
       h [addr2, pred2] == Some val2 ->
       addr1 == addr2 /\ pred1 == pred2 /\ val2 == val1)).
    Proof.
      autounfold. intros. rewrites. split.
      intros. destruct H3. split.
      rewrite H3. simpl.  reflexivity.
      intros. rewrite <- H1, <- H, <- H0. apply H4. rewrite H2. auto.
      intros. destruct H3. split.
      rewrite H3. simpl. reflexivity.
      intros. rewrite H1, H, H0.  apply H4. rewrite <- H2. auto.
    Qed.
    apply singleton_1.
  Defined.

  Notation "heap [ val , pred ]" := (read @ val @ pred @ heap) (at level 11).
  Notation "heap [ val , pred  ↦  val2 ]  " := (update @ val @ pred @ val2 @ heap) (at level 11).
  Notation "h1 ⊥ h2" := (disjoint @ h1 @ h2) (at level 15).
  Notation "h1 ⋅ h2" := (union @ h1 @ h2) (at level 15).

End HeapUtils.


Require Import Metatheory.
Require Import alist.
Require Import monad.
Require Import targetdata.
Require Import genericvalues.
Require Import Values.
Require Import Memory.
Require Import Integers.
Require Import Coqlib.
Require Import syntax.
Require Import typings.
Require Import static.
Require Import opsem.
Require Import opsem_props.
Require Import opsem_wf.
Require Import vellvm_tactics.
Require Import infrastructure.
Require Import infrastructure_props.

Import LLVMsyntax.
Import LLVMgv.
Import LLVMtd.
Import LLVMtypings.
Import LLVMinfra.

(* This file defines the deterministic instance of Vellvm's operational
   semantics. *)

(* Properties of deterministic operational semantics. *)

(*************************************)
Definition DGVMap := Opsem.GVsMap.

(*************************************)
(* Aux invariants of wf ECs *)

Definition wfEC_inv s m (EC: Opsem.ExecutionContext) : Prop :=
uniqFdef (Opsem.CurFunction EC) /\
blockInFdefB (Opsem.CurBB EC) (Opsem.CurFunction EC) = true /\
match Opsem.CurCmds EC with
| nil => wf_insn s m (Opsem.CurFunction EC) (Opsem.CurBB EC)
           (insn_terminator (Opsem.Terminator EC))
| c::_ => wf_insn s m (Opsem.CurFunction EC) (Opsem.CurBB EC)
           (insn_cmd c)
end /\
exists l0, exists ps0, exists cs0,
  Opsem.CurBB EC = (l0, stmts_intro ps0 (cs0 ++ Opsem.CurCmds EC)
    (Opsem.Terminator EC)).

Definition wfECs_inv s m (ECs: list Opsem.ExecutionContext) : Prop :=
List.Forall (wfEC_inv s m) ECs.

Definition uniqEC (EC: Opsem.ExecutionContext) : Prop :=
uniqFdef (Opsem.CurFunction EC) /\
blockInFdefB (Opsem.CurBB EC) (Opsem.CurFunction EC) = true /\
exists l0, exists ps0, exists cs0,
  Opsem.CurBB EC = (l0, stmts_intro ps0 (cs0 ++ Opsem.CurCmds EC)
    (Opsem.Terminator EC)).

Definition uniqECs (ECs: list Opsem.ExecutionContext) : Prop :=
List.Forall uniqEC ECs.

Ltac find_uniqEC :=
repeat match goal with
| H: uniqECs (Opsem.ECS {|Opsem.ECS := _; Opsem.Mem := _ |}) |- uniqEC _ =>
  simpl in H
| H: uniqECs (?EC::_) |- uniqEC ?EC => inv H; auto
| H: uniqECs (_::?EC::_) |- uniqEC ?EC => inv H; auto
| H: Forall uniqEC (?EC::_) |- uniqEC ?EC => inv H; auto
| H: Forall uniqEC (_::?EC::_) |- uniqEC ?EC => inv H; auto
end.

(*************************************)
(* More dynamic properties *)

Lemma GEP_inv: forall TD t (mp1 : GenericValue) inbounds0 vidxs mp2 t'
  (H1 : Opsem.GEP TD t mp1 vidxs inbounds0 t' = ret mp2),
  gundef TD (typ_pointer t') = ret mp2 \/
  exists blk, exists ofs1, exists ofs2 : int32, exists m1, exists m2,
    mp1 = (Vptr blk ofs1, m1) :: nil /\ mp2 = (Vptr blk ofs2, m2) :: nil.
Proof.
  intros.
  unfold Opsem.GEP in H1.
  unfold gep in H1. unfold GEP in H1.
  remember (GV2ptr TD (getPointerSize TD) mp1) as R1.
  destruct R1; auto.
  destruct (GVs2Nats TD vidxs); auto.
  remember (mgep TD t v l0) as R2.
  destruct R2; auto.
  inv H1.
  unfold mgep in HeqR2.
  destruct v; tinv HeqR2.
  destruct l0; tinv HeqR2.
  destruct (mgetoffset TD (typ_array 0%nat t) (z :: l0)) as [[]|];
    inv HeqR2.
  unfold GV2ptr in HeqR1.
  destruct mp1 as [|[]]; tinv HeqR1.
  destruct v; tinv HeqR1.
  destruct mp1; inv HeqR1.
  unfold ptr2GV. unfold val2GV. right. exists b0. exists i1.
  exists (Int.add 31 i1 (Int.repr 31 z0)). exists m.
  exists (AST.Mint (Size.mul Size.Eight (getPointerSize TD) - 1)).
  eauto.
Qed.


(*
 * Licensed under the Apache License, Version 2.0 (the "License");
 * you may not use this file except in compliance with the License.
 * You may obtain a copy of the License at
 *
 * http://www.apache.org/licenses/LICENSE-2.0
 *
 * Unless required by applicable law or agreed to in writing, software
 * distributed under the License is distributed on an "AS IS" BASIS,
 * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
 * See the License for the specific language governing permissions and
 * limitations under the License.
 *)

Require Import String.
Require Import ZArith.
Require Import List.
Require Import Arith.
Require Import EquivDec.
Require Import Utils.
Require Import DataRuntime.
Require Import SQL.

Section SQLSize.
  Context {fruntime:foreign_runtime}.

  Section size.
    Fixpoint sql_query_size (q:sql_query) := (* XXX To check XXX *)
      match q with
      | SUnion _ q1 q2 =>
        (sql_query_size q1) + (sql_query_size q2) + 1 (* XXX to check XXX *)
      | SIntersect _ q1 q2 =>
        (sql_query_size q1) + (sql_query_size q2) + 1 (* XXX to check XXX *)
      | SExcept _ q1 q2 =>
        (sql_query_size q1) + (sql_query_size q2) + 1 (* XXX to check XXX *)
      | SQuery selects froms opt_where opt_group opt_order =>
        List.fold_left (fun acc select => acc + sql_select_size select) selects 0
        + List.fold_left (fun acc from => acc + sql_from_size from) froms 0
        + match opt_where with
          | None => 0
          | Some cond => sql_condition_size cond
          end
        + match opt_group with
          | None => 0
          | Some (_, Some cond) => sql_condition_size cond
          | Some (_, _) => 1
          end
        + match opt_order with
          | None => 0
          | Some cond => 1
          end
      end

    with sql_select_size (select: sql_select) :=
      match select with
      | SSelectColumn _ => 1
      | SSelectColumnDeref _ _ => 1
      | SSelectStar => 1
      | SSelectExpr _ e => sql_expr_size e
      end

    with sql_from_size (from: sql_from) :=
      match from with
      | SFromTable _ => 1
      | SFromTableAlias _ _ => 1
      | SFromQuery _ q => sql_query_size q
      end

    with sql_condition_size (cond: sql_condition) :=
      match cond with
      | SCondAnd c1 c2
      | SCondOr c1 c2 =>
        1 + sql_condition_size c1 + sql_condition_size c2
      | SCondNot c =>
        1 + sql_condition_size c
      | SCondBinary _ e1 e2 =>
        1 + sql_expr_size e1 + sql_expr_size e2
      | SCondExists q =>
        1 + sql_query_size q
      | SCondIn e1 e2 =>
        1 + sql_expr_size e1 + sql_expr_size e2
      | SCondLike e _ =>
        1 + sql_expr_size e
      | SCondBetween e1 e2 e3 =>
        1 + sql_expr_size e1 + sql_expr_size e2 + sql_expr_size e3
      end

    with sql_expr_size (expr: sql_expr) :=
      match expr with
      | SExprConst _ => 1
      | SExprColumn _ => 1
      | SExprColumnDeref _ _ => 1
      | SExprStar => 1
      | SExprUnary _ e => 1 + sql_expr_size e
      | SExprBinary _ e1 e2 => 1 + sql_expr_size e1 + sql_expr_size e2
      | SExprCase c e1 e2 =>
        1 + sql_condition_size c + sql_expr_size e1 + sql_expr_size e2
      | SExprAggExpr _ e => 1 + sql_expr_size e
      | SExprQuery q => 1 + sql_query_size q
      end.

    Definition sql_statement_size (st:sql_statement) :=
      match st with
      | SRunQuery q => sql_query_size q
      | SCreateView _ q => sql_query_size q
      | SDropView _ => 1
      end.

    Definition sql_size (q:sql) :=
      List.fold_left (fun acc st => acc + sql_statement_size st) q 0.

  End size.

  Section depth.

    Fixpoint sql_query_depth (q:sql_query) := (* XXX To check XXX *)
      match q with
      | SUnion _ q1 q2 =>
        1 + (max (sql_query_depth q1) (sql_query_depth q2)) (* XXX To check with Louis XXX *)
      | SIntersect _ q1 q2 =>
        1 + (max (sql_query_depth q1) (sql_query_depth q2)) (* XXX To check with Louis XXX *)
      | SExcept _ q1 q2 =>
        1 + (max (sql_query_depth q1) (sql_query_depth q2)) (* XXX To check with Louis XXX *)
      | SQuery selects froms opt_where opt_group opt_order =>
        max (List.fold_left (fun acc select => max acc (sql_select_depth select)) selects 0)
            (max (List.fold_left (fun acc from => max acc (sql_from_depth from)) froms 0)
                 (max (match opt_where with
                       | None => 0
                       | Some cond => sql_condition_depth cond
                       end)
                      (max (match opt_group with
                            | None => 0
                            | Some (_, Some cond) => sql_condition_depth cond
                            | Some (_, _) => 1
                            end)
                           (match opt_order with
                            | None => 0
                            | Some cond => 1
                            end))))
      end

    with sql_select_depth (select: sql_select) :=
      match select with
      | SSelectColumn _ => 0
      | SSelectColumnDeref _ _ => 0
      | SSelectStar => 0
      | SSelectExpr _ e => sql_expr_depth e
      end

    with sql_from_depth (from: sql_from) :=
      match from with
      | SFromTable _ => 0
      | SFromTableAlias _ _ => 0
      | SFromQuery _ q => 1 + sql_query_depth q
      end

    with sql_condition_depth (cond: sql_condition) :=
      match cond with
      | SCondAnd c1 c2
      | SCondOr c1 c2 =>
        max (sql_condition_depth c1) (sql_condition_depth c2)
      | SCondNot c =>
        sql_condition_depth c
      | SCondBinary _ e1 e2 =>
        max (sql_expr_depth e1) (sql_expr_depth e2)
      | SCondExists q =>
        sql_query_depth q
      | SCondIn e1 e2 =>
        max (sql_expr_depth e1) (sql_expr_depth e2)
      | SCondLike e _ =>
        sql_expr_depth e
      | SCondBetween e1 e2 e3 =>
        max (sql_expr_depth e1) (max (sql_expr_depth e2) (sql_expr_depth e3))
      end

    with sql_expr_depth (expr: sql_expr) :=
      match expr with
      | SExprConst _ => 0
      | SExprColumn _ => 0
      | SExprColumnDeref _ _ => 0
      | SExprStar => 0
      | SExprUnary _ e => sql_expr_depth e
      | SExprBinary _ e1 e2 => max (sql_expr_depth e1) (sql_expr_depth e2)
      | SExprCase c e1 e2 =>
        max (sql_condition_depth c) (max (sql_expr_depth e1) (sql_expr_depth e2))
      | SExprAggExpr _ e => sql_expr_depth e
      | SExprQuery q => sql_query_depth q
      end.

    Definition sql_statement_depth (st:sql_statement) :=
      match st with
      | SRunQuery q => 1 + sql_query_depth q
      | SCreateView _ q => sql_query_depth q
      | SDropView _ => 1
      end.

    Definition sql_depth (q:sql) :=
      List.fold_left (fun acc st => max acc (sql_statement_depth st)) q 0.

  End depth.

End SQLSize.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* 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.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(*****************************************************************************)
(*          Projet Formel - Calculus of Inductive Constructions V5.10        *)
(*****************************************************************************)
(*									     *)
(*	              Equalizers in SET                  		     *)
(*									     *)
(*****************************************************************************)
(*									     *)
(*                     A. SAIBI	  May 95                  		     *)
(*									     *)
(*****************************************************************************)

Require Export Equalizers.
Require Export Setoid_prop.
Require Export SET.

Set Implicit Arguments.
Unset Strict Implicit.

Section s_equaz_def.

Variables (A B : Setoid) (I : Type) (f : I -> Map A B).

Definition S_equaz_pred (a : A) := forall i j : I, f i a =_S f j a.

Lemma S_equaz_reg : Reg_law S_equaz_pred.
Proof.
unfold Reg_law, S_equaz_pred in |- *; intros x y H1 H2 i j.
apply Trans with (f i x).
apply Pres1; apply Sym; assumption.
apply Trans with (f j x).
apply H2.
apply Pres1; assumption.
Qed.

Canonical Structure S_equaz_constr := Build_Setoid_pred S_equaz_reg.

Definition S_equaz_ob := SubSetoid S_equaz_constr.

Definition S_equaz_mor := RestrictedMap (Id_map A) S_equaz_constr.

Lemma S_equaz_law1 : Equalizer_law1 f S_equaz_mor.
Proof.
unfold Equalizer_law1, Equalizer_eq, S_equaz_mor in |- *; simpl in |- *.
unfold Ext in |- *; simpl in |- *; unfold Comp_fun in |- *; simpl in |- *;
 unfold Id_fun in |- *.
intros i j x; elim x; simpl in |- *; auto with v62.
Qed.

 Section s_equaz_diese_def.

 Variables (D : Setoid) (h : Map D A).
 Hypothesis p : Equalizer_eq f h.

 Lemma Check_S_equaz_constr : forall d : D, S_equaz_pred (h d).
 Proof.
 unfold S_equaz_pred in |- *; intros d i j; exact (p i j d).
 Qed.

 Canonical Structure S_equaz_fun (d : D) :=
   Build_SubType (Check_S_equaz_constr d).

 Lemma S_equaz_map_law : Map_law S_equaz_fun.
 Proof.
 unfold Map_law in |- *; simpl in |- *.
 unfold Equal_SubType in |- *; simpl in |- *.
 exact (Pres h).
 Qed.

 Canonical Structure S_equaz_diese := Build_Map S_equaz_map_law.

 End s_equaz_diese_def.

Lemma S_equaz_law2 : Equalizer_law2 S_equaz_mor S_equaz_diese.
Proof.
unfold Equalizer_law2 in |- *; simpl in |- *.
unfold Ext in |- *; simpl in |- *; unfold Id_fun in |- *.
intros r h p x; apply Refl.
Qed.

Lemma S_equaz_law3 : Equalizer_law3 S_equaz_mor S_equaz_diese.
Proof.
unfold Equalizer_law3 in |- *; simpl in |- *.
unfold Ext in |- *; simpl in |- *; unfold Equal_SubType in |- *;
 simpl in |- *.
unfold Id_fun, S_equaz_ob in |- *; intros r h p l H x.
apply Sym; apply H.
Qed.

Canonical Structure S_equaz :=
  Build_Equalizer S_equaz_law1 S_equaz_law2 S_equaz_law3.

End s_equaz_def.