Require Import Coq.Program.Tactics.
From Coq.Logic Require Import FunctionalExtensionality ProofIrrelevance.
From mathcomp Require Import ssreflect ssrfun eqtype fintype seq bigop.

Require Import Algebras.

Set Warnings "-parsing". (* Some weird bug in ssrbool throws out parsing warnings*)
  From mathcomp Require Import ssrbool.
Set Warnings "parsing".

Set Warnings "-ambiguous-paths". (* Some weird bug in ssralg throws out coercion warnings*)
    From mathcomp Require Import ssralg.
Set Warnings "ambiguous-paths".

Open Scope ring_scope.
Set Implicit Arguments.
Unset Strict Implicit.

Reserved Notation "\basisProj_ b ^( B )"
  (at level 36, B at level 36, b at level 0,
    right associativity,
          format "'[' \basisProj_ b '^(' B ) ']'").

Reserved Notation "\finBasisProj_ b ^( B )"
(at level 36, B at level 36, b at level 0,
  right associativity,
        format "'[' \finBasisProj_ b '^(' B ) ']'").

Module lmodSet.
  Section Def.
    Variable (R : ringType) (M : lmodType R).
    Definition non_degenerate {T : Type} (elem : T -> M) := forall b : T, elem b != 0%R.

    Record mixin (T : eqType) := Mixin {
      elem : T -> M;
      _ : injective elem;
      _ : non_degenerate elem;
    }.

    Record type := Pack { sort : _; class_of : mixin sort; }.

    Definition Build {T : eqType} (elem : T -> M) (I : injective elem) (ND : non_degenerate elem)
     := Pack (Mixin I ND).

    Lemma typeIsInjective (T : type) : injective (elem (class_of T)).
    Proof. by destruct (class_of T)=>/=. Qed.

    Lemma typeIsNonDegenerate (T : type) : non_degenerate (elem (class_of T)).
    Proof. by destruct (class_of T)=>/=. Qed.

    Definition to_Type (T : type) : Type := (sort T).
  End Def.

  Module Exports.
    Notation lmodSetType := type.
    Notation non_degenerate := non_degenerate.
    Notation typeIsInjective := typeIsInjective.
    Notation typeIsNonDegenerate := typeIsNonDegenerate.
    Coercion to_Type : type >-> Sortclass.
    Coercion elem : mixin >-> Funclass.
    Coercion class_of : type >-> mixin.
  End Exports.
End lmodSet.
Export lmodSet.Exports.

Module lmodOrthoSet.
  Section Def.
    Variable (R : ringType) (M : lmodType R).

    Definition orthonormP (B : lmodSetType M) (proj : B -> {scalar M})
    := forall b1 b2 : B, proj b1 (B b2) = if b1 == b2 then 1 else 0.

    Record mixin (B : lmodSetType M) := Mixin {
      proj : B -> {scalar M};
      orthonormal : orthonormP proj;
    }.

    Record type := Pack { sort : _; class_of : mixin sort; }.

    Definition Build (T : eqType) (elem : T -> M)
      (I : injective elem) (ND : non_degenerate elem)
      (proj : (lmodSet.Build I ND) -> {scalar M})
      (O : orthonormP proj)
    : type := Pack (Mixin O).
  End Def.

  Module Exports.
    Notation lmodOrthoType := type.
    Notation lmodBasisProj := proj.
    Notation orthonormP := orthonormP.
    Coercion sort : type >-> lmodSetType.
    Coercion class_of : type >-> mixin.
  End Exports.
End lmodOrthoSet.
Export lmodOrthoSet.Exports.
Notation "\basisProj_ b ^( B )" := (@lmodBasisProj _ _ B b).

Module lmodBasis.
  Section Def.
    Variable (R : ringType) (M : lmodType R).

    Definition basisP (B : lmodSetType M) (proj : B -> {scalar M})
     := forall m1 m2 : M, reflect (forall b : B, proj b m1 = proj b m2) (m1 == m2).

    Record mixin (T : lmodOrthoType M) := Mixin {
      is_basisP : basisP (lmodBasisProj T);
    }.

    Record type := Pack { sort : _; class_of : mixin sort; }.

    Definition Build (T : eqType) (elem : T -> M)
      (I : injective elem) (ND : non_degenerate elem)
      (proj : (lmodSet.Build I ND) -> {scalar M})
      (O : orthonormP proj)
      (B : @basisP (lmodOrthoSet.Build O) proj)
    : type := Pack (Mixin B).
  End Def.

  Module Exports.
    Notation lmodBasisType := type.
    Notation basisP := basisP.
    Coercion class_of : type >-> mixin.
    Coercion sort : type >-> lmodOrthoType.
  End Exports.
End lmodBasis.
Export lmodBasis.Exports.
(*
Module lmodFinSubSet.
  Section Def.
    Variable (R : ringType) (M : lmodType R) (B : lmodSetType M).
    Record type  := Pack { sort : finType; incl : sort -> B; _ : injective incl; }.

    Definition sigmaType (T : type) := {m : M | [exists b, B (@incl T b) == m]}.
    Definition sigmaEnum (T : type) := map (fun b => B (incl b)) (enum (sort T)).
    Definition to_sigma (T : type) := Eval hnf in [subFinType of (seq_sub (sigmaEnum T))].

    Definition Empty : type
     := Pack (fun x y : void_finType =>
      match x as x return
          ((match x return B with end = match y return B with end)
            -> (x = y))
        with end).

    Definition intersection_finType (F1 F2 : type)
     := [subFinType of {f1 : sort F1 | [exists f2 , incl f1 == @incl F2 f2]}].

    Program Definition Intersection (F1 F2 : type) : type
     := @Pack (intersection_finType F1 F2) (fun x => incl (sval x)) _.
    Next Obligation.
     move=>[x Hx] [y Hy]/=.
     destruct F1 as [F1 L1 I1]=>H.
     apply I1 in H; destruct H.
     apply eq_sig_hprop=>//=z; apply proof_irrelevance.
    Qed.

    Definition difference_finType (F1 F2 : type)
     := [subFinType of {f1 : sort F1 | ~~[exists f2 , incl f1 == @incl F2 f2]}].

    Program Definition Difference (F1 F2 : type) : type
     := @Pack (difference_finType F1 F2) (fun x => incl (sval x)) _.
    Next Obligation.
     move=>[x Hx] [y Hy]/=.
     destruct F1 as [F1 L1 I1]=>H.
     apply I1 in H; destruct H.
     apply eq_sig_hprop=>//=z; apply proof_irrelevance.
    Qed.
(*
    Program Definition DisjointUnion (F1 F2 : type) (_ : Intersection F1 F2 = Empty) : type
     := @Pack (sum_finType (sort F1) (sort F2))
         (fun x => match x with inl x' => incl x'|inr x' => incl x' end)
          _.
    Next Obligation.
    move=> x y.
    destruct F1 as [F1 L1 I1].
    destruct F2 as [F2 L2 I2].
    destruct x, y=>H1.
    apply I1 in H1; by destruct H1.

    case H.
    rewrite /Intersection/Empty in H. simpl in H.
    destruct s, s0; simpl in H1; destruct H1.
    assert((exist
    (fun x0 : sort (Pack I1) =>
     ~~ ~~ FiniteQuant.quant0b (T:=sort F2)
       (fun f2 : sort F2 => FiniteQuant.ex (, incl x0 == incl f2) f2)
       ) x i)
            = (exist _ x i0)).
    apply eq_sig_hprop=>//=z; apply proof_irrelevance.
    by destruct H.

    move=>/=H1.
    destruct s as [s Hs]; simpl in H1.
    Admitted.

    Definition Union (F1 F2 : type) : type
     := DisjointUnion .*)
  End Def.

  Section Coercion.
    Variable (R : ringType) (M : lmodType R) (S : lmodSetType M) (F : type S).

    Lemma inj : injective (S \o incl (t:=F)).
    Proof. rewrite /comp=> x y; destruct F as [F' f I].
    by rewrite !(rwP eqP) (inj_eq (@typeIsInjective _ _ S)) (inj_eq I).
    Qed.

    Lemma non_deg : non_degenerate (S \o incl (t:=F)).
    Proof. rewrite/comp => b.
      by apply (@typeIsNonDegenerate _ _ S (incl (t:=F) b)).
    Qed.

    Definition to_set  : lmodSetType M
      := @lmodSet.Build _ _ _ (S \o (@incl _ _ S F)) inj non_deg.
  End Coercion.

  Module Exports.
    Notation lmodFinSubSetType := type.
    Notation to_FinType := sort.
    Notation lmodFinSubSetIncl := incl.
    Coercion to_set : type >-> lmodSetType.
  End Exports.
End lmodFinSubSet.
Export lmodFinSubSet.Exports.

Module lmodLISet.
  Section Def.
    Variable (R : ringType) (M : lmodType R).

    Definition li_of (B : lmodSetType M) (F : lmodFinSubSetType B) :=
        forall (c : F -> R), (\sum_(f : F) (c f) *: (B (lmodFinSubSetIncl f))) == 0
          -> forall b, c b == 0.

    Lemma li_of_cascade (B : lmodSetType M) (F : lmodFinSubSetType B)
      : forall (G : lmodFinSubSetType F), li_of F -> li_of G.
    Proof. rewrite/li_of=>G H1 c H2.
    destruct G. simpl in H2.
     Admitted.

    Definition axiom (B : lmodSetType M) :=
        forall (f : lmodFinSubSetType B), li_of f.

    Record mixin (B : lmodSet.type M) := Mixin { _ : axiom B; }.

    Record class (B : lmodSet.type M)
    := Class { base := lmodSet.class_of B; mixin_of : mixin B; }.

    Record type := Pack { sort : _; class_of : class sort; }.

    Definition Build {T : eqType} (elem : T -> M)
      (I : injective elem) (ND : non_degenerate elem)
      (Ax : axiom (lmodSet.Build I ND))
    := Pack (Class (Mixin  Ax)).

    Definition to_set (T : type)
    := lmodSet.Pack (base (class_of T)).

    (*Lemma finLI_axiom (L : lmodFinBasis.LISet.type M) : axiom L.
    Proof. move=>f c H b.
    assert (a := @typeIsLi _ _ L).
    destruct f as [F f I].
    unfold finSubsetFrom in c; simpl in c.
    unfold finSubsetFrom in H; simpl in H.
    unfold finSubsetFrom in b; simpl in b.
    Admitted.

    Definition finLI_to_type (L : lmodFinBasis.LISet.type M)
      := @Build _ _ (@typeIsInjective _ _ L) (@typeIsNonDegenerate _ _ L) (@finLI_axiom L).
      *)
  End Def.

  Module Exports.
    (* Coercion LI_to_set : type >-> lmodSet.type. *)
    Coercion sort : type >-> lmodSet.type.
    Coercion class_of : type >-> class.
    Notation li := axiom.
    Notation lmodLISetType := type.
  End Exports.
End lmodLISet.
Export lmodLISet.Exports.
*)
(*
Module lmodBasis.
  Section Def.
    Variable (R : ringType) (M : lmodType R).

    Record class (T : lmodSet.type M) := Class {
      li_mixin_of : lmodLISet.mixin T;
      gen_mixin_of : lmodSpanningSet.mixin T;
    }.

    Record type := Pack { sort : _; class_of : class sort; }.

    Definition Build (T : eqType) (elem : T -> M)
      (I : injective elem) (ND : non_degenerate elem)
      (proj : (lmodSet.Build I ND) -> {scalar M})
      (LI : li (lmodSet.Build I ND))
      (Sp : lmodSpanningSet.spanP proj)
      (Sp1 : lmodSpanningSet.span1 proj)
    := Pack (Class (lmodLISet.Mixin LI) (lmodSpanningSet.Mixin Sp Sp1)).

    Definition to_LI (T : type)
    := lmodLISet.Pack (lmodLISet.Class (li_mixin_of (class_of T))).
    Definition to_Spantype (T : type)
    := lmodSpanningSet.Pack (lmodSpanningSet.Class (gen_mixin_of (class_of T))).
  End Def.

  Module Exports.
    Notation lmodBasisType := type.
    Coercion to_LI : type >-> lmodLISet.type.
    Coercion to_Spantype : type >-> lmodSpanningSetType.
    Coercion class_of : type >-> class.
    Coercion sort : type >-> lmodSetType.
  End Exports.
End lmodBasis.
Export lmodBasis.Exports.

Module lmodLocalFinGenSet.
  Section Def.
    Variable (R : ringType) (M : lmodType R).

    Definition spanProp (B : lmodSetType M) (F : lmodFinSubSetType B) (proj : F -> {scalar M}) (m : M)
     := (\sum_(f : F) proj f m *: B (lmodFinSubSetIncl f)) == m.
    Definition spanProj (B : lmodSetType M) (F : lmodFinSubSetType B) (m : M)
      := exists proj : F -> {scalar M}, spanProp proj m.
    Definition spanSubSet (B : lmodSetType M) (m : M)
     := {F : lmodFinSubSetType B | spanProj F m}.
    Definition spanning (B : lmodSetType M) :=
      forall m : M, spanSubSet B m.

    Record mixin (T : lmodSetType M) := Mixin {_ : spanning T; }.

    Record class (T : lmodOrthoType M) := Class {
      mixin_of : mixin T;
    }.

    Record type := Pack {sort : _; class_of : class sort;}.

    Lemma typeIsLocallySpanning (T : type) : spanning (sort T).
    Proof. by destruct (mixin_of (class_of T)). Qed.
  End Def.

  Module Exports.
    Notation spanning := spanning.
    Notation typeIsSpanning := typeIsLocallySpanning.
    Coercion sort : type >-> lmodOrthoType.
  End Exports.
  Export Exports.

  Section Results.
    Variable (R : ringType) (M : lmodType R) (B : type M).
  End Results.

End lmodLocalFinGenSet.
Export lmodLocalFinGenSet.Exports.
*)
Module lmodFinSet.
  Section Def.
    Variable (R : ringType) (M : lmodType R).
    Record class (T : finType) := Class {
      base : lmodSet.mixin M T;
    }.

    Record type := Pack { sort : _; class_of : class sort; }.

    Definition Build {T : finType} (elem : T -> M) (I : injective elem) (ND : non_degenerate elem)
    := Pack (Class (lmodSet.Build I ND)).

    Section Lemmas.
    Variable (T : type).
    Definition to_set
    := lmodSet.Pack (base (class_of T)).

    Variable (n : nat) (K : n = size (enum (sort T))).
    Definition to_ord
      : sort T -> 'I_n :=
    eq_rect_r (fun n : nat => sort T -> 'I_n)
      (eq_rect #|sort T| (fun n : nat => sort T -> 'I_n)
        enum_rank (size (enum (sort T))) (cardT (sort T))) K.

    Definition from_ord
      : 'I_n -> sort T :=
    eq_rect_r (fun n : nat => 'I_n -> sort T)
      (eq_rect #|sort T| (fun n : nat => 'I_n -> sort T)
        enum_val (size (enum (sort T))) (cardT (sort T))) K.

    Lemma tofrom_ordK : cancel to_ord from_ord.
    Proof.
      rewrite/to_ord/from_ord/eq_rect_r/eq_rect.
      destruct (cardT (sort T)), (Logic.eq_sym K)=>x.
      by rewrite enum_rankK.
    Qed.

    Lemma fromto_ordK : cancel from_ord to_ord.
    Proof.
      rewrite/to_ord/from_ord/eq_rect_r/eq_rect.
      destruct (cardT (sort T)), (Logic.eq_sym K)=>x.
      by rewrite enum_valK.
    Qed.
    End Lemmas.
  End Def.

  Module Exports.
    Notation lmodFinSetType := type.
    Notation to_FinType := sort.
    Coercion to_set : type >-> lmodSetType.
  End Exports.
End lmodFinSet.
Export lmodFinSet.Exports.

Module lmodFinBasis.
  Section Def.
    Variable (R : ringType) (M : lmodType R).

    (* Linear Independence Of A Finite Set *)
    Definition li (F : lmodFinSetType M) :=
        forall (c : F -> R), (\sum_(f : F) (c f) *: (F f)) == 0
          -> forall b, c b == 0.

    (* Linear Independence Implies All Linear Combinations
      of the Same Element are Equal *)
    Lemma li_coefs_eq (F : lmodFinSetType M)
     : li F -> forall (c1 c2 : F -> R), (\sum_(f : F) (c1 f) *: (F f)) == (\sum_(f : F) (c2 f) *: (F f)) -> c1 = c2.
    Proof. move=> L c1 c2 E.
      rewrite -GRing.subr_eq0 -GRing.sumrB in E.
      assert(\sum_i (c1 i - c2 i) *: F i == 0). {
        apply (rwP eqP) in E.
        rewrite -(rwP eqP) -{2}E.
        apply eq_bigr=>i _; apply GRing.scalerBl.
      }
      apply (functional_extensionality)=>x.
      apply (rwP eqP).
      by rewrite -GRing.subr_eq0 (L _ H x).
    Qed.

    (* The spanning property of a finite set *)
    Definition spanProp (F : lmodFinSetType M) (proj : F -> {scalar M}) (m : M)
     := (\sum_(f : F) proj f m *: F f) == m.
    Definition spanProj (F : lmodFinSetType M) (m : M)
      := {proj : F -> {scalar M} | spanProp proj m}.
    Definition spanning (F : lmodFinSetType M) :=
      forall m : M, spanProj F m.

    Record mixin (T : lmodFinSet.type M) := Mixin {
      li_ax : li T;
      span_ax : spanning T;
    }.

    Record type := Pack { sort : _; class_of : mixin sort; }.

    Definition Build (T : finType) (elem : T -> M)
      (I : injective elem) (ND : non_degenerate elem)
      (LI : li (lmodFinSet.Build I ND))
      (Sp : spanning (lmodFinSet.Build I ND))
    : type := Pack (Mixin LI Sp).

    Definition basis_number (B : type) := #|(to_FinType (sort B))|.

    Lemma typeSpanning (T : type) : spanning (sort T).
    Proof. by destruct (class_of T). Qed.

    Lemma typeLI (T : type) : li (sort T).
    Proof. by destruct (class_of T). Qed.
  End Def.

  Module Exports.
    Notation basis_number := basis_number.
    Notation lmodFinBasisType := type.
    Notation li := li.
    Notation spanning := spanning.
    Notation typeIsSpanning := typeSpanning.
    Notation typeIsLI := typeLI.
    Coercion class_of : type >-> mixin.
    Coercion sort : type >-> lmodFinSetType.
  End Exports.
  Export Exports.

  Section Results.
    Variable (R : ringType) (M : lmodType R) (T : type M).

    Definition coef_fn (t : T) : M -> R
      := fun m => (sval ((span_ax T) m)) t m.

    Lemma coef_sca (t : T) : scalar (coef_fn t).
    Proof. rewrite/coef_fn=> r m1 m2/=.
      destruct T as [T' [li sp]]=>/=; simpl in t.
      destruct sp as [c H], sp as [c1 H1], sp as [c2 H2] =>/=.
      rewrite /spanProp in H, H1, H2.
      apply (rwP eqP) in H1; apply (rwP eqP) in H2.
      rewrite -{2}H1 -{2}H2 GRing.scaler_sumr -big_split in H.
      assert(forall i (_ : true),
        (r *: (c1 i m1 *: T' i) + c2 i m2 *: T' i)
          =
          (((r * c1 i m1) + c2 i m2) *: T' i)
      ). move =>i _;
      by rewrite GRing.scalerA GRing.scalerDl.
      rewrite (eq_bigr _ H0) in H.
      by apply (equal_f (li_coefs_eq li H) t).
    Qed.

    Definition coef (t : T) : {scalar M}
      := Linear (coef_sca t).

  Lemma coefP (m : M) : \sum_f coef f m *: T f = m.
  Proof. rewrite/coef=>/=; rewrite/coef_fn.
    destruct (span_ax T m) as [c H]=>/=.
    rewrite /spanProp in H.
    apply (rwP eqP) in H.
    by rewrite H.
  Qed.

  Definition coefAtBase (t : T) : T -> R
    := fun b : T => if b == t then 1 else 0.

  Lemma coefO : orthonormP coef.
  Proof. rewrite/orthonormP=>b1 b2; move: b1.
    apply equal_f.
    apply (li_coefs_eq (li_ax T)).
    destruct (span_ax T (lmodFinSet.base (lmodFinSet.class_of T) b2)) as [c H].
    rewrite /spanProp in H.
    assert(\sum_f (if f == b2 then 1 else 0) *: T f
    = \sum_f (if f == b2 then T f else 0)).
    apply (eq_bigr _). move=> i _.
    case (i == b2); [apply GRing.scale1r|apply GRing.scale0r].
    by rewrite H0 -big_mkcond big_pred1_eq coefP.
  Qed.

  Lemma coefB : lmodBasis.basisP coef.
  Proof. rewrite/coef=>b1 b2.
    apply (iffP idP).
    rewrite -(rwP eqP)=>H.
    by destruct H.

    rewrite /coef_fn=>/= H.
    destruct (span_ax T b1) as [c1 H1],
      (span_ax T b2) as [c2 H2]; simpl in H.
    rewrite /spanProp in H1, H2.
    apply (rwP eqP) in H1; apply (rwP eqP) in H2.
    rewrite -H1 -H2 -(rwP eqP).
    assert(H' : forall b : T, true -> c1 b b1 *: T b = c2 b b2 *: T b).
    move=>b _; by rewrite (H b).
    refine (eq_bigr _ H').
  Qed.

  Definition to_lmodBasis
  := @lmodBasis.Build _ _ _ _ (@typeIsInjective _ _ (sort T)) (@typeIsNonDegenerate _ _ (sort T)) coef coefO coefB.

  End Results.
  Module Exports2.
    Notation lmodFinBasisProj := coef.
  End Exports2.
End lmodFinBasis.
Export lmodFinBasis.Exports.
Export lmodFinBasis.Exports2.
Notation "\finBasisProj_ b ^( B )" := (@lmodFinBasisProj _ _ B b).

Section Results.

End Results.

Close Scope ring_scope.


Require Import ClassicalExtras.
Require Import Setoid.
Require Import Events.
Require Import CommonST.
Require Import TraceModel.
Require Import Robustdef.
Require Import Properties.
Require Import Criteria.

(** Equivalent formulations for the robust preservation
    of 2-relational (hyper)properties classes
    in terms of pair of (hyper)properties of the corresponding class
 *)

(** *Robust preservation of 2-relSafety  *)

Definition R2rSP_a :=
    forall P1 P2 S1 S2,
    Safety S1 -> Safety S2 ->
    (forall Cs, sat (Cs [P1]) S1 \/ sat (Cs[P2]) S2) ->
    (forall Ct, sat (Ct [P1↓]) S1 \/ sat (Ct[P2↓]) S2).

Definition R2rSP_a_contra :
  R2rSP_a <->
  (forall P1 P2 S1 S2,
    Safety S1 -> Safety S2 ->
    (exists Ct, ~ sat (Ct [P1 ↓]) S1 /\ ~ sat (Ct [P2 ↓]) S2) ->
    (exists Cs, ~ sat (Cs [P1]) S1 /\ ~ sat (Cs [P2]) S2)).
Proof.
  split; intros Hr.
  + intros P1 P2 S1 S2 Hs1 Hs2. rewrite contra.
    repeat rewrite not_ex_forall_not.
    intros Has Ct [Hf1 Hf2].
    specialize (Hr P1 P2 S1 S2 Hs1 Hs2).
    assert (Hp:  (forall Cs : ctx src, sat (Cs [P1]) S1 \/ sat (Cs [P2]) S2)).
    { intros Cs. specialize (Has Cs). rewrite de_morgan1 in Has.
      repeat rewrite <- dne in Has. assumption. }
    destruct (Hr Hp Ct); contradiction.
  + intros P1 P2 S1 S2 Hs1 Hs2. rewrite  contra.
    repeat rewrite not_forall_ex_not.
    intros [Ct Hct]. rewrite de_morgan2 in Hct.
    destruct (Hr P1 P2 S1 S2 Hs1 Hs2) as [Cs H].
    now exists Ct. exists Cs. now rewrite de_morgan2.
Qed.

Theorem alternative_R2rSP : R2rSP_a <-> R2rSP.
Proof.
  rewrite R2rSP_a_contra, <- R2rSC_R2rSP.
  split; intros H.
  + intros Ct P1 P2 m1 m2 H1 H2.
    specialize (H P1 P2 (fun t => ~ prefix m1 t) (fun t => ~ prefix m2 t)).
    assert (s1 : Safety  (fun t => ~ prefix m1 t)).
    { intros t Ht. apply NNPP in Ht. now exists m1. }
    assert (s2 : Safety  (fun t => ~ prefix m2 t)).
    { intros t Ht. apply NNPP in Ht. now exists m2. }
    specialize (H s1 s2). destruct H as [Cs [Hc1 Hc2]].
    exists Ct. split.
    ++ intros Hs.
       destruct (H1) as [t1 [Hpref Ht1]].
       specialize (Hs t1 Ht1). simpl in Hs. contradiction.
    ++ intros Hs.
       destruct (H2) as [t2 [Hpref Ht2]].
       specialize (Hs t2 Ht2). simpl in Hs. contradiction.
    ++ exists Cs. split.
       +++ unfold sat in Hc1. rewrite not_forall_ex_not in Hc1.
           destruct Hc1 as [t1 Hc1].
           rewrite not_imp in Hc1. exists t1.
           destruct Hc1 as [Hc11 Hc12].
           rewrite <- dne in Hc12. now auto.
       +++ unfold sat in Hc2. rewrite not_forall_ex_not in Hc2.
           destruct Hc2 as [t2 Hc2].
           rewrite not_imp in Hc2. exists t2.
           destruct Hc2 as [Hc21 Hc22].
           rewrite <- dne in Hc22. now auto.
  + intros P1 P2 S1 S2 HS1 HS2 [Ct [Hc1 Hc2]].
    unfold sat in Hc1,Hc2.
    rewrite not_forall_ex_not in Hc1,Hc2.
    destruct Hc1 as [t1 Hc1]. destruct Hc2 as [t2 Hc2].
    rewrite not_imp in Hc1,Hc2.
    destruct Hc1 as [Hc1 Ht1]. destruct Hc2 as [Hc2 Ht2].
    destruct (HS1 t1 Ht1) as [m1 [Hpref1 H1]].
    destruct (HS2 t2 Ht2) as [m2 [Hpref2 H2]].
    specialize (H Ct P1 P2 m1 m2). destruct H as [Cs [Hpsem1 Hpsem2]].
    ++ now exists t1.
    ++ now exists t2.
    ++ destruct Hpsem1 as [tt1 [Hm1 Hsem1]]. destruct Hpsem2 as [tt2 [Hm2 Hsem2]].
       exists Cs. split; unfold sat; rewrite not_forall_ex_not;
               [exists tt1 |exists tt2]; rewrite not_imp; now auto.
Qed.

(** *Robust preservation of relSafety  *)

Definition RrSP_a :=
 forall (I : Type), forall (ρ : I -> par src) (δ : I -> {π | Safety π}),
     (forall Cs, exists i, sat (Cs [(ρ i)]) (proj1_sig (δ i))) ->
     (forall Ct, exists j, sat (Ct [(ρ j) ↓]) (proj1_sig (δ j))).

Lemma RrSP_a_contra :
  RrSP_a <->
  ( forall (I : Type), forall (ρ : I -> par src) (δ : I -> {π | Safety π}),
     (exists Ct, forall i, ~ sat (Ct [(ρ i) ↓]) (proj1_sig (δ i))) ->
     (exists Cs, forall i, ~ sat (Cs [(ρ i)]) (proj1_sig (δ i))) ).
Proof.
  split; intros Hr.
  + intros I ρ δ.
    specialize (Hr I ρ δ). rewrite contra.
    repeat rewrite not_ex_forall_not.
    intros H Ct.
    assert (HH: (forall Cs : ctx src, exists i : I, sat (Cs [ρ i]) (proj1_sig (δ i)))).
    { intros Cs. specialize (H Cs). rewrite not_forall_ex_not in H.
      destruct H as [i H]. rewrite <- dne in H. now exists i. }
    specialize (Hr HH Ct). destruct Hr as [i Hr].
    rewrite not_forall_ex_not. exists i. now rewrite <- dne.
  + intros I ρ δ.
    specialize (Hr I ρ δ). rewrite contra.
    repeat rewrite not_forall_ex_not.
    intros [Ct H].
    assert (HH:  (exists Ct : ctx tgt, forall i : I, ~ sat (Ct [ρ i ↓]) (proj1_sig (δ i)))).
    { exists Ct. now rewrite not_ex_forall_not in H. }
    specialize (Hr HH). destruct Hr as [Cs Hr].
    exists Cs. now rewrite not_ex_forall_not.
Qed.

Theorem alternative_RrSP' : RrSP' <-> RrSP_a.
Proof.
  rewrite RrSP_a_contra, <- RrSC_RrSP'.
  split; intro Hr.
  + intros I ρ δ [Ct Hct].
    specialize (Hr Ct  (fun P m => psem (Ct [P↓]) m) ).
    destruct Hr as [Cs H].
    firstorder.
    exists Cs. intro i. specialize (Hct i). specialize (H (ρ i)).
    unfold sat in *.
    rewrite not_forall_ex_not in *.
    destruct Hct as [t Hct].
    rewrite not_imp in Hct.  destruct Hct as [Ht1 Ht2].
    destruct (proj2_sig (δ i) t) as [m [Hpref Hm]]; auto.
    destruct (H m) as [t' [Ht' HHt']].
    now exists t. exists t'.
    rewrite not_imp. firstorder.
  + intros Ct f H.
    remember (fun (mP : finpref * (par src) | (f (snd mP) (fst mP))) => (snd (proj1_sig mP))) as ρ.
    remember (fun m => (fun t => ~ prefix m t)) as δm.
    assert (Hs_m : forall m, Safety (δm m)).
    { intros m t Ht. rewrite Heqδm in *. rewrite <- dne in Ht.
      now exists m.  }
    remember (fun (mP : finpref * (par src)| f (snd mP) (fst mP)) =>
                @exist prop Safety (δm (fst (proj1_sig mP)))
                                   (Hs_m (fst (proj1_sig mP)))) as δ.
    specialize (Hr {mP | f (snd mP) (fst mP)} ρ δ).
    destruct Hr as [Cs Hr].
    exists Ct. intros [ (m,P) HH]. rewrite Heqδ, Heqρ. simpl in *.
    rewrite Heqδm. unfold sat. rewrite not_forall_ex_not.
    specialize (H P m HH). now firstorder.
    exists Cs. rewrite Heqδ, Heqρ in *. simpl in *.
    intros P m HPm.
    remember (fun x => f (snd x) (fst x)) as f_u.
    assert (Hu : f_u (m,P)). { rewrite Heqf_u. auto. }
    specialize (Hr (@exist (finpref * (par src)) f_u (m,P) Hu )).
    simpl in *. unfold sat in Hr.
    rewrite not_forall_ex_not in Hr. destruct Hr as [t Hr].
    rewrite not_imp in Hr.
    rewrite Heqδm in Hr. rewrite <- dne in Hr.
    now exists t.
Qed.

(* ANON
   What follows seems stronger than RrSP

Definition RrSP_a' :=
  forall (Pf : par src -> Prop) (Sf : { π | Safety π} -> Prop),
    (forall Cs, exists P S, Pf P /\ Sf S /\ sat (Cs [P]) (proj1_sig S) ->
    (forall Ct, exists P' S', Pf P' /\ Sf S' /\ sat (Ct [P' ↓]) (proj1_sig S'))).

Lemma RrSP_a'_contra :
  RrSP' <->
   forall (Pf : par src -> Prop) (Sf : { π | Safety π} -> Prop),
     (exists Ct, forall P' S', Pf P' -> Sf S' -> ~ sat (Ct [P' ↓]) (proj1_sig S')) ->
     (exists Cs, forall P S, Pf P -> Sf S -> ~ sat (Cs [P]) (proj1_sig S)).
Admitted.

*)

(** *Robust preservation of 2rel properties  *)

Definition R2rTP_a :=
  forall (P1 P2 : par src) (π1 π2 : prop),
    (forall Cs, sat (Cs[P1]) π1 \/ sat (Cs[P2]) π2) ->
    (forall Ct, sat (Ct[P1↓]) π1 \/  sat (Ct[P2↓]) π2).

Lemma R2rTP_a_contra :
  R2rTP_a <->
   forall (P1 P2 : par src) (π1 π2 : prop),
    (exists Ct, ~ sat (Ct[P1↓]) π1 /\ ~ sat (Ct[P2↓]) π2) ->
    (exists Cs, ~ sat (Cs[P1]) π1 /\ ~ sat (Cs[P2]) π2).
Proof.
  split; intros Hr.
  + intros P1 P2 π1 π2 [Ct H1].
    rewrite <- de_morgan2 in H1.
    specialize (Hr P1 P2 π1 π2). rewrite contra in Hr.
    repeat rewrite not_forall_ex_not in Hr.
    destruct Hr as [Cs Hr].
    now exists Ct. exists Cs. now rewrite <- de_morgan2.
  + intros P1 P2 π1 π2. specialize (Hr P1 P2 π1 π2).
    rewrite contra. repeat rewrite not_forall_ex_not.
    intros [Ct Ht]. destruct Hr as [Cs Hr].
    exists Ct. now rewrite <- de_morgan2.
    exists Cs. now rewrite de_morgan2.
Qed.

Theorem alternative_R2rTP : R2rTP <-> R2rTP_a.
Proof.
  rewrite <- R2rTC_R2rTP, R2rTP_a_contra.
  split; intros Hr.
  + intros P1 P2 π1 π2 [Ct [H1 H2]].
    unfold sat in H1, H2.
    rewrite not_forall_ex_not in H1, H2.
    destruct H1 as [t1 H1]. destruct H2 as [t2 H2].
    rewrite not_imp in H1, H2.
    destruct H1 as [H11 H12]. destruct H2 as [H21 H22].
    destruct (Hr Ct P1 P2 t1 t2) as [Cs [Hc1 Hc2]]; auto.
    exists Cs. split; unfold sat; rewrite not_forall_ex_not;
            [exists t1 | exists t2]; firstorder.
  + intros Ct P1 P2 t1 t2 Hsem1 Hsem2.
    destruct (Hr P1 P2 (fun t => t <> t1) (fun t => t <> t2)) as [Cs [H1 H2]].
    { exists Ct. split; unfold sat; rewrite not_forall_ex_not;
              [exists t1 | exists t2]; rewrite not_imp; now rewrite <- dne. }
    exists Cs. unfold sat in H1, H2. rewrite not_forall_ex_not in H1, H2.
    destruct H1 as [tt1 H1]. destruct H2 as [tt2 H2].
    rewrite not_imp in H1, H2.
    destruct H1 as [H11 H12]. destruct H2 as [H21 H22].
    rewrite <- dne in H12, H22. now subst.
Qed.

(** *Robust preservation of 2rel hyperproperties  *)

Definition R2rHP_a :=
  forall (P1 P2 : par src) (H1 H2 : hprop),
    (forall Cs, H1 (beh(Cs[P1])) \/ H2 (beh(Cs[P2]))) ->
    (forall Ct, H1 (beh(Ct[P1↓])) \/ H2 (beh(Ct[P2↓]))).

Lemma R2rHP_a_contra :
  R2rHP_a <->
   forall (P1 P2 : par src) (H1 H2 : hprop),
     (exists Ct, ~ H1 (beh(Ct[P1↓])) /\ ~ H2 (beh(Ct[P2↓]))) ->
     (exists Cs, ~ H1 (beh(Cs[P1])) /\ ~ H2 (beh(Cs[P2]))).
Proof.
  split; intros Hr.
  + intros P1 P2 H1 H2. rewrite contra.
    repeat rewrite not_ex_forall_not.
    specialize (Hr P1 P2 H1 H2). intros HH.
    assert (K : (forall Cs : ctx src, H1 (beh (Cs [P1])) \/ H2 (beh (Cs [P2])))).
    { intros Cs. specialize (HH Cs). rewrite de_morgan1 in HH.
      repeat rewrite <- dne in HH. assumption. }
    specialize (Hr K). intros Ct. specialize (Hr Ct).
    rewrite de_morgan1. repeat rewrite <- dne. assumption.
  + intros P1 P2 H1 H2. rewrite contra. repeat rewrite not_forall_ex_not.
    specialize (Hr P1 P2 H1 H2).
    intros [Ct HH]. destruct Hr as [Cs KK].
    { exists Ct. now rewrite <- de_morgan2. }
    exists Cs. now rewrite de_morgan2.
Qed.

Theorem alternative_R2rHP : R2rHP <-> R2rHP_a.
Proof.
  rewrite <- R2rHC_R2rHP, R2rHP_a_contra.
  split; intros Hr.
  + intros P1 P2 H1 H2 [Ct [HH1 HH2]].
    destruct (Hr P1 P2 Ct) as [Cs [Heq1 Heq2]].
    assert (beh (Ct[P1↓]) = beh (Cs[P1])).
    { unfold beh. now rewrite Heq1. }
    assert (beh (Ct[P2↓]) = beh (Cs[P2])).
    { unfold beh. now rewrite Heq2. }
    exists Cs. now rewrite <- H, <- H0.
  +  intros P1 P2 Ct.
     specialize (Hr P1 P2 (fun π => π <> beh(Ct[P1↓])) (fun π => π <> beh(Ct[P2↓]))).
     destruct Hr as [Cs [HH1 HH2]].
     { exists Ct. repeat rewrite <- dne. auto. }
     rewrite <- dne in HH1, HH2.
     now exists Cs.
Qed.

(** *Robust preservation of rel hyperproperties  *)

Definition RrHP_a :=
  forall (I : Type), forall (ρ : I -> par src) (δ : I -> hprop),
     (forall Cs, exists i, (δ i) (beh (Cs [(ρ i)]))) ->
     (forall Ct, exists j, (δ j) (beh (Ct [(ρ j)↓]))).

Lemma RrHP_a_contra :
  RrHP_a <->
    forall (I : Type), forall (ρ : I -> par src) (δ : I -> hprop),
        (exists Ct, forall j, ~ (δ j) (beh (Ct [(ρ j)↓]))) ->
        (exists Cs, forall j, ~ (δ j) (beh (Cs [(ρ j)]))).
Proof.
  split; intros Hr.
  + intros I ρ δ. specialize (Hr I ρ δ).
    rewrite contra in Hr.
    repeat rewrite not_forall_ex_not in Hr.
    intros [Ct Ht]. destruct Hr as [Cs Hs].
    { exists Ct. now rewrite not_ex_forall_not. }
    exists Cs. now rewrite <- not_ex_forall_not.
  + intros I ρ δ. specialize (Hr I ρ δ).
    rewrite contra.
    repeat rewrite not_forall_ex_not.
    intros [Ct Ht]. destruct Hr as [Cs Hs].
    { exists Ct. now rewrite <- not_ex_forall_not. }
    exists Cs. now rewrite not_ex_forall_not.
Qed.

Theorem alternative_RrHP' : RrHP' <-> RrHP_a.
Proof.
  rewrite <- RrHC_RrHP', RrHP_a_contra.
  split; intro Hr.
  + intros I ρ δ [Ct Ht].
    destruct (Hr Ct) as [Cs Hs].
    assert (forall j, beh (Ct [ρ j ↓]) = beh (Cs [ρ j])).
    { intro j. specialize (Hs (ρ j)). now unfold beh. }
    exists Cs. intros j. now rewrite <- (H j).
  + intros Ct.
    remember (fun P : (par src) => P) as ρ.
    remember (fun P : (par src) => (fun π => π <> (beh (Ct [P ↓])))) as δ.
    specialize (Hr (par src) ρ δ).
    destruct Hr as [Cs Hs].
    { exists Ct. intros k. rewrite Heqδ, Heqρ. tauto. }
    exists Cs. intros P. specialize (Hs P).
    rewrite Heqδ, Heqρ in Hs. rewrite <- dne in Hs.
    unfold beh in Hs. firstorder.
Qed.

(* random remarks from previous notes

   a 2-rel hyperproperty is an element of 2^(beh × beh)

   if X is an infinite set, then X × X ≅ X (using AC).

   This means that 2^(beh × beh) ≅ 2^beh × 2^beh.

   The bijection above is, in general, non constructive.

*)


Require Import
  FormTopC.FormTop
  FormTopC.Cont
  Algebra.OrderC
  Algebra.PreOrder
  Numbers.QPosFacts
  CoRN.metric2.Metric
  FormTopC.Metric
  CoRN.model.totalorder.QposMinMax
  QArith.Qminmax
  CoRN.algebra.COrdAbs
  CoRN.model.ordfields.Qordfield
  CoRN.model.metric2.Qmetric
  CoRN.metric2.ProductMetric
  Algebra.SetsC.

Definition unit_RSetoid : RSetoid.
Proof.
refine (
  {| st_car := unit
   ; st_eq := fun _ _ => True |}); firstorder.
Defined.

(* One-point metric space *)
Definition MOne : MetricSpace.
Proof.
unshelve econstructor.
- exact (unit_RSetoid).
- exact (fun _ _ _ => True).
- simpl. intros. split; intros; auto.
- simpl. constructor.
  + unfold Reflexive. auto.
  + unfold Symmetric. auto.
  + auto.
  + auto.
  + simpl. auto.
Defined.

Import Metric.

Existing Instances PreO PreO.PreOrder_I.

Lemma tt_cont : IGCont.pt Metric (fun _ : Ball MOne => True).
Proof.
constructor.
- exists (tt, Qpos1). unfold In. auto.
- intros. destruct b, c. destruct m, m0.
  exists (tt, Qpos_min q q0). split.
  split; le_down; apply le_ball_center.
  apply Qpos_min_lb_l. apply Qpos_min_lb_r.
  auto.
- auto.
- intros a c ix l H. destruct ix.
  destruct a, c. destruct H. destruct m, m0.
  simpl.
  + exists (tt, Qpos_min q0 q). split. auto.
    split. le_down. apply le_ball_center. apply Qpos_min_lb_l.
    exists (tt, q). reflexivity.
    apply le_ball_center. apply Qpos_min_lb_r.
  + simpl in *. destruct a, c, H.
    destruct m, m0.
    destruct (Qpos_smaller q).
    exists (tt, x). split. auto.
    split. le_down.
    apply le_ball_center. apply Qlt_le_weak. assumption.
    exists (tt, x). unfold In. apply lt_ball_center.
    apply (@le_ball_radius MOne (tt, q) (tt, q0)) in l.
    simpl in l.
    eapply Qlt_le_trans; eassumption. reflexivity.
Qed.

Section Yoneda.
Context {X : MetricSpace}.

Lemma from_One_lip
  (f : MOne -> X) (k : Qpos) : Lipschitz f k.
Proof.
unfold Lipschitz.
simpl. intros. destruct x, x'.
apply ball_refl.
Qed.

(** Applying this map to the unique point in the
    one-point space will give us the point which is
    the embedding of
    [x: X] into its metric completion.
*)
Definition from_One_cont (x : X) :
  IGCont.t (toPSL Metric) Metric
  (lift (fun _ : MOne => x) Qpos1).
Proof.
apply Cont. apply from_One_lip.
Qed.

End Yoneda.

(** Now let's get to the real numbers. *)

Definition MQ : MetricSpace := Q_as_MetricSpace.

Definition binop (f : MQ -> MQ -> MQ) (p : ProductMS MQ MQ) : MQ :=
  let (x, y) := p in f x y.

Lemma Qle_eq {x y : Q} : x == y -> x <= y.
Proof.
intros xeqy. rewrite xeqy. reflexivity.
Qed.

Lemma plus_Lip : Lipschitz (binop Qplus) (Qpos1 + Qpos1).
Proof.
unfold Lipschitz. intros.
destruct x, x', H.
unfold binop.
eapply ball_weak_le.
Focus 2.  eapply Qball_plus; eassumption.
simpl. apply Qle_eq. ring.
Qed.

Local Open Scope Q.

(* This lemma is taken from
  [QboundBelow_uc_prf] here:
  https://github.com/robbertkrebbers/corn/blob/8b864e218dd1a682746c25c4b56e225f120be957/reals/fast/CRGroupOps.v#L396
*)
Lemma Qball_between :
 forall e a b0 b1, Qball e b0 b1 -> b0 <= a <= b1 -> Qball e a b1.
Proof.
  intros e a b0 b1 H [H1 H2].
  unfold Qball in *.
  unfold AbsSmall in *.
  split.
   apply Qle_trans with (b0-b1).
    tauto.
   apply (minus_resp_leEq _ b0).
   assumption.
  apply Qle_trans with 0.
   apply (shift_minus_leEq _ a).
   stepr b1.
    assumption.
   simpl; ring.
  apply Qpos_nonneg.
Qed.

Lemma max_Lip : Lipschitz (binop Qmax) Qpos1.
Proof.
unfold Lipschitz. intros.
destruct x, x', H. unfold binop. simpl.
simpl in *.
eapply ball_weak_le. eapply Qle_eq. simpl. ring_simplify.
reflexivity.
apply Q.max_case_strong.
intros. rewrite <- H1.  assumption.
apply Q.max_case_strong. intros. rewrite <- H1.
auto. auto. intros.
eapply Qball_between.
admit. admit.
apply Q.max_case_strong. intros. rewrite <- H1. auto.
intros.
admit.
auto.
Admitted.

Lemma min_Lip : Lipschitz (binop Qmin) Qpos1.
Admitted.


From Categories Require Import Essentials.Notations.
From Categories Require Import Essentials.Types.
From Categories Require Import Essentials.Facts_Tactics.
From Categories Require Import Category.Main.
From Categories Require Import Functor.Functor Functor.Functor_Ops
        Functor.Representable.Hom_Func
        Functor.Representable.Representable.
From Categories Require Import Ext_Cons.Prod_Cat.Prod_Cat Ext_Cons.Prod_Cat.Operations.
From Categories Require Import Coq_Cats.Type_Cat.Type_Cat.
From Categories Require Import NatTrans.NatTrans NatTrans.Operations NatTrans.Func_Cat.
From Categories Require Import KanExt.Local.

Local Open Scope functor_scope.

(** A local kan extension is pointwise if it is preserved by representable
    functors. In other words, in the following diagram,

#
<pre>
           F            G
     C ———————–> D ——————–> Set
     |          ↗          ↗
     |        /          /
   p |      / R       /
     |    /        /   G ∘ R
     ↓  /       /
     C' ———–———
</pre>
#
where R is the left/right local kan extension of F along p, and G is a
representable functor and we have (G ∘ R) is the left/right kan extension
of (G ∘ F) along p.
*)

(** Pointwise-ness for local left kan extensions. *)
Section Pointwise_LRKE.
  Context {C C' : Category}
          {p : C –≻ C'}
          {D: Category}
          {F : C –≻ D}
          (lrke : Local_Right_KanExt p F)
  .

  Definition Pointwise_LRKE :=
    ∀ (G : D –≻ Type_Cat) (GR : Representable G),
    is_Local_Right_KanExt p (G ∘ F) (G ∘ lrke)
  .

End Pointwise_LRKE.

(** Pointwiseness for local right kan extensions. *)
Section Pointwise_LLKE.
  Context {C C' : Category}
          {p : C –≻ C'}
          {D: Category}
          {F : C –≻ D}
          (llke : Local_Left_KanExt p F)
  .

  Definition Pointwise_LLKE :=
    ∀ (G : D^op –≻ Type_Cat) (GR : CoRepresentable G),
    is_Local_Right_KanExt p (G^op ∘ F) ((G ∘ llke)^op)
  .

End Pointwise_LLKE.


(*
 This is the definition of formal syntax for Dan Grossman's Thesis,
  "SAFE PROGRAMMING AT THE C LEVEL OF ABSTRACTION".

  Defining type safety, page 67.

*)

Require Import List.
Export ListNotations.
Require Import ZArith.
Require Import Init.Datatypes.
Require Import Coq.Init.Logic.

Require Export FormalSyntax.
Require Export DynamicSemanticsTypeSubstitution.
Require Export DynamicSemanticsHeapObjects.
Require Export DynamicSemantics.
Require Export DynamicSemanticsTypeSubstitution.
Require Export StaticSemanticsKindingAndContextWellFormedness.
Require Export StaticSemantics.
Require Export TypeSafety.
Require Export CpdtTactics.

Theorem Type_Safety :
(*   If ·; ·; ·; τ styp s, ret s, and ·; s → H ; s *)
 forall (s : St) (tau : Tau),
        styp [] [] [] tau s ->
        ret s ->
        exists (h' : H) (s' : St),
           Sstar [] s h' s' ->
           NotStuck h' s'.
Proof.
 Definition Thm (s : St) (tau : Tau) : Prop :=
   (ret s ->
     exists (h' : H) (s' : St),
       Sstar [] s h' s' ->
       NotStuck h' s').
  intros s tau.
  apply (Term_ind_mutual
           (fun (s : St) =>
              forall (tau : Tau) (ts : (styp [] [] [] tau s)),
                Thm s tau)
           (fun (e : E ) =>
              forall (tau : Tau) (ts : (styp [] [] [] tau (e_s e))),
                Thm (e_s e) tau)
           (fun (f : F) =>
              forall (ts : (styp [] [] [] tau (e_s (f_e f)))),
                Thm (e_s (f_e f)) tau));
        repeat (unfold Thm; crush).
  (* Crush gets one. *)
Admitted.


From mathcomp Require Import ssreflect ssrbool ssrnat eqtype ssrfun seq.

Set Implicit Arguments.

Section Everything.

Variable A : Type.
Variable start : pred A.
Variable ended : pred A.
Variable inv : A -> Prop.
Variable step : A -> option A.

Variable O : Type. (* the power of the observer (e.g. a label) *)
Variable low : O -> pred A.
Variable indist : O -> rel A.

Hypothesis indistT : forall o, transitive (indist o).

Hypothesis indistS : forall o, symmetric (indist o).

Hypothesis indistR : forall o, reflexive (indist o).

Hypothesis ended_low : forall o, subpred ended (low o).

Hypothesis ended_indist :
  forall o s1 s2,
    indist o s1 s2 ->
    ended s1 = ended s2.

Hypothesis indist_low :
  forall o s1 s2,
    indist o s1 s2 ->
    low o s1 = low o s2.

Hypothesis invP :
  forall s s',
    inv s ->
    step s = Some s' ->
    inv s'.

Hypothesis initial_inv : forall st, start st -> inv st.

Definition high o := [pred s | ~~ low o s].

Definition stuck := [pred s | ~~ step s].

Hypothesis ended_stuck : subpred ended stuck.

Fixpoint exec (n : nat) (s : A) : A :=
  match n, step s with
  | S n', Some s' => exec n' s'
  | _, _ => s
  end.

Fixpoint trace (n : nat) (s : A) : seq A :=
  match n, step s with
  | S n', Some s' => s :: trace n' s'
  | _, _ => [:: s]
  end.

Definition rtrace (s : A) (ss : seq A) : Prop :=
  exists n, trace n s = ss.

Lemma exec_trace s' n s : exec n s = last s' (trace n s).
Proof.
  elim: n s s' => [|n IH] s s' //=.
  case E: (step s) => [s''|//=].
  rewrite (IH _ s) {IH} /=.
  case: n => [|n] //=.
Qed.

Lemma trace_ended n s :
  ended s -> trace n s = [:: s].
Proof.
move => H; case: n => [|n] //=.
move/ended_stuck: H.
by rewrite /stuck /=; case: (step s).
Qed.

Lemma exec_ended n s :
  ended s -> exec n s = s.
Proof.
  move => H.
  by rewrite (exec_trace s) (trace_ended _ H).
Qed.

Definition rexec (s1 s2 : A) : Prop :=
  exists n, exec n s1 = s2.

Definition eeni : Prop :=
  forall (o : O) (s1 s2 s1' s2' : A),
    start s1 ->
    start s2 ->
    indist o s1 s2 ->
    rexec s1 s1' ->
    rexec s2 s2' ->
    ended s1' ->
    ended s2' ->
    indist o s1' s2'.

Section WithO.
Variable o : O.

Inductive indistt : seq A -> seq A -> Prop :=
| IndisttNil : forall t, indistt [::] t
| IndisttConsLow : forall x1 x2 t1 t2,
                     indist o x1 x2 -> indistt t1 t2 ->
                     low o x1 -> low o x2 ->
                     indistt (x1 :: t1) (x2 :: t2)
| IndisttConsHigh : forall x1 t1 t2,
                      indistt t1 t2 ->
                      high o x1 ->
                      indistt (x1 :: t1) t2
| IndisttSym : forall t1 t2,
                 indistt t1 t2 ->
                 indistt t2 t1.

Definition indisttb (t1 t2 : seq A) : bool :=
  all id (map (prod_curry (indist o))
              (zip (filter (low o) t1) (filter (low o) t2))).

Lemma indisttbtN t : indisttb t [::].
Proof.
  case: t => [//=|x t] /=.
  rewrite /indisttb /=.
  case: (low o x); first by [].
  by case: ([seq x <- t | low o x]).
Qed.

Lemma indisttbNt t : indisttb [::] t.
  case: t => [//=|x t] /=.
  rewrite /indisttb /=.
  case: (low o x); first by [].
  by case: ([seq x <- t | low o x]).
Qed.

Lemma indistt_cons x1 x2 t1 t2 :
  indistt (x1 :: t1) (x2 :: t2) ->
  [\/ [/\ indist o x1 x2, low o x1, low o x2 & indistt t1 t2],
      [/\ indistt t1 (x2 :: t2) & high o x1] |
      [/\ indistt (x1 :: t1) t2 & high o x2] ].
Proof.
  move: {1 3}(x1 :: t1) (erefl (x1 :: t1))
        {1 3}(x2 :: t2) (erefl (x2 :: t2))
        => t1' Ht1' t2' Ht2' H.
  elim: H x1 t1 Ht1' x2 t2 Ht2'
        => {t1' t2'} //= [x1 x2 t1 t2 Ex Et IH L1 L2|x1 t1 t2 Et IH H1|t2 t1 Et IH].
  - move => ? ? [<- <-] ? ? [<- <-].
    apply Or31. by constructor.
  - move => ? ? [<- <-] ? ? ?.
    apply Or32.
    split; last by [].
    congruence.
  - move => x1 t1' H1 x2 t2' H2.
    move: IH => /(_ _ _ H2 _ _ H1) [[IH1 IH2 IH3 /(@IndisttSym _) IH4]|[IH1 IH2]|[IH1 IH2]].
    + apply Or31.
      rewrite indistS in IH1.
      by constructor.
    + apply Or33. split; last by [].
      apply IndisttSym. congruence.
    + apply Or32. split; last by [].
      apply IndisttSym. congruence.
Qed.

Lemma indistt_consH x1 t1 t2 :
  high o x1 ->
  indistt (x1 :: t1) t2 ->
  indistt t1 t2.
Proof.
  move => H1.
  move: {2}(size t1 + size t2) (leqnn (size t1 + size t2)) => n Hn.
  elim: n t1 t2 Hn => [t1 t2|n IH t1].
  - by rewrite leqn0 addn_eq0; case: t1; case:t2 => //; constructor.
  - case=> [|x2 t2] Hn E.
    { apply IndisttSym. by constructor. }
    move: E => /(@indistt_cons _) [[_ E _ _]|[E _] //=|[E1 E2]].
    + by rewrite /high /= E in H1.
    + apply IndisttSym. apply IndisttConsHigh; last by [].
      apply IndisttSym. apply IH; last by [].
      by rewrite /= addnS ltnS in Hn.
Qed.

Lemma indisttb_single s1 s2 : indist o s1 s2 -> indisttb [:: s1] [:: s2].
Proof.
  move => H.
  rewrite /indisttb /= (indist_low H).
  case: (low o s2) => //=.
  by rewrite andbT.
Qed.

Lemma indisttb_cons2 s1 t1 s2 t2 :
  indist o s1 s2 -> indisttb (s1 :: t1) (s2 :: t2) = indisttb t1 t2.
Proof.
  move => H.
  rewrite /indisttb /= (indist_low H).
  case: (low o s2) => //=.
  by rewrite H.
Qed.

Lemma indisttP t1 t2 : reflect (indistt t1 t2) (indisttb t1 t2).
Proof.
  move: {2}(size t1 + size t2) (leqnn (size t1 + size t2)) => n Hn.
  elim: n t1 t2 Hn => [|n IH] t1 t2.
  - by rewrite leqn0 addn_eq0; case: t1; case: t2 => //; do 2! constructor.
  - case: t1 => [|x1 t1].
    { rewrite indisttbNt.
      by do 2! constructor. }
    case: t2 => [|x2 t2] Hn.
    { rewrite indisttbtN.
      constructor. apply IndisttSym. by constructor. }
    rewrite /indisttb /=.
    have [L1|L1] := (boolP (low o x1)); have [L2|L2] := (boolP (low o x2)) => /=.
    + rewrite /= addSn addnS ltnS ltn_neqAle in Hn.
      move: Hn => /andP [_ /(IH _) Hn] {IH}.
      apply/(iffP idP).
      * move/andP => [E1 /Hn E2]. by constructor.
      * move => /(@indistt_cons _) H.
        rewrite /high /= L1 L2 in H.
        case: H => //=.
        move => [-> _ _ H] /=.
        by apply/Hn.
    + by move => [_ ?].
    + by move => [_ ?].
    + rewrite [size (x2 :: t2)]/= addnS ltnS in Hn.
      move: Hn => /(IH _) {IH} /= IH.
      rewrite /indisttb /= L1 in IH.
      apply/(iffP IH) => H.
      * apply IndisttSym. apply IndisttConsHigh; try done.
        by apply IndisttSym.
      * apply IndisttSym.
        apply (@indistt_consH x2); first by [].
        by apply IndisttSym.
    + rewrite [size (x1 :: t1)]/= addSn ltnS in Hn.
      move: Hn => /(IH _) {IH} Hn.
      rewrite /indisttb /= L2 /= in Hn.
      apply (iffP Hn) => H.
      * by apply IndisttConsHigh.
      * by apply (@indistt_consH x1).
    + rewrite /= addSn addnS ltnS ltn_neqAle in Hn.
      move: Hn => /andP [_ /(IH _) Hn] {IH}.
      apply (iffP Hn) => H.
      * apply IndisttConsHigh; last by [].
        apply IndisttSym.
        apply IndisttConsHigh; last by [].
        by apply IndisttSym.
      * apply (@indistt_consH x1); first by [].
        apply IndisttSym.
        apply (@indistt_consH x2); first by [].
        by apply IndisttSym.
Qed.

Inductive indistt_msni : seq A -> seq A -> Prop :=

| IndisttMsniLowSteps : forall s1 s1' s2 s2' t1 t2,
    low o s1 -> low o s2 ->
    indist o s1' s2' ->
    indistt_msni (s1' :: t1) (s2' :: t2) ->
    indistt_msni (s1 :: s1' :: t1) (s2 :: s2' :: t2)

| IndisttMsniHighToLowSteps : forall s1 s1' s2 s2' t1 t2,
    high o s1 -> low o s1' ->
    high o s2 -> low o s2' ->
    indist o s1' s2' ->
    indistt_msni (s1' :: t1) (s2' :: t2) ->
    indistt_msni (s1 :: s1' :: t1) (s2 :: s2' :: t2)

| IndisttMsniHighToHighSteps : forall s1 s1' s2 t1 t2,
    high o s1 -> high o s1' ->
    indist o s1 s1' ->
    indistt_msni (s1' :: t1) (s2 :: t2) ->
    indistt_msni (s1 :: s1' :: t1) (s2 :: t2)

| IndisttMsniLowStepEnd : forall s1 s1' s2 t1,
    (high o s1 \/ high o s1') ->
    indistt_msni (s1' :: t1) ([:: s2]) ->
    indistt_msni (s1 :: s1' :: t1) ([:: s2])

| IndisttMsniBothEnd : forall s1 s2,
    indistt_msni ([:: s1]) ([:: s2])

| IndisttMsniSym : forall t1 t2,
    indistt_msni t1 t2 ->
    indistt_msni t2 t1.

End WithO.

Definition llni : Prop :=
  forall (o : O) (s1 s2 : A) (t1 t2 : seq A),
    start s1 ->
    start s2 ->
    indist o s1 s2 ->
    rtrace s1 t1 ->
    rtrace s2 t2 ->
    indisttb o t1 t2.

Record ssni : Prop := {

  ssni_low_low : forall o s1 s2 s1' s2',
                   inv s1 -> inv s2 ->
                   low o s1 ->
                   indist o s1 s2 ->
                   step s1 = Some s1' ->
                   step s2 = Some s2' ->
                   indist o s1' s2';

  ssni_high_high : forall o s s',
                     inv s ->
                     high o s -> high o s' ->
                     step s = Some s' ->
                     indist o s s';

  ssni_high_low : forall o s1 s2 s1' s2',
                    inv s1 -> inv s2 ->
                    high o s1 ->
                    indist o s1 s2 ->
                    low o s1' -> low o s2' ->
                    step s1 = Some s1' ->
                    step s2 = Some s2' ->
                    indist o s1' s2'

  (* The fourth condition is now redundant given the assumption about
     indistiguishability and ended states, which seems to be needed for the
     LLNI -> EENI proof. *)

}.

Definition msni : Prop :=
  forall (o : O) (s1 s2 : A) (t1 t2 : seq A),
    indist o s1 s2 ->
    rtrace s1 t1 ->
    rtrace s2 t2 ->
    indistt_msni o t1 t2.

Lemma step_rtrace : forall s s',
  step s = Some s' ->
  rtrace s [:: s; s'].
Proof. exists 1. simpl. by rewrite H. Qed.

Ltac pnp :=
  match goal with
  | [HP : is_true ?x, HNP : is_true (negb ?x) |- _] => rewrite HP in HNP
  end.

Lemma llni_eeni : llni -> eeni.
Proof.
  move => LLNI o s1 s2 s1' s2' I1 I2 E12 [n1 <-] [n2 <-] {s1' s2'} H1 H2.
  move: LLNI => /(_ o s1 s2 (trace n1 s1) (trace n2 s2) I1 I2 E12
                    (ex_intro _ n1 erefl) (ex_intro _ n2 erefl)) /indisttP LLNI {I1 I2}.
  move: {1 3}(trace n1 s1) {1 3}(trace n2 s2) (erefl (trace n1 s1)) (erefl (trace n2 s2)) LLNI
        => t1 t2 Ht1 Ht2 LLNI {E12}.
  elim: LLNI n1 n2 s1 s2 H1 H2 Ht1 Ht2
        => [t|s1' s2' t1' t2' Ex Et IH Hx1 Hx2|s1' t1' t2' Et IH Hx1|t1' t2' Et IH] n1 n2 s1 s2 H1 H2 Ht1 Ht2.
  - case: n1 H1 Ht1 => [|n1] //= H1 Ht1.
    by case: (step s1) H1 Ht1 => [s1'|].
  - case: n1 H1 Ht1 => [|n1] //= H1 Ht1;
    case: n2 H2 Ht2 => [|n2] //= H2 Ht2.
    + by move: Ht1 Ht2 Ex => [-> ?] [-> ?].
    + move: Ht1 Ex Hx1 => [-> _] Ex Hx1.
      case S2: (step s2) s2' Ht2 H1 Hx2 H2 Ex => [s2'|] s2'' /= [-> Ht2] {s2''} H1 Hx2 H2 Ex; last by [].
      rewrite (ended_indist Ex) in H1.
      by have := ended_stuck H1; rewrite /stuck /= S2.
    + move: Ht2 Ex Hx2 => [-> _] Ex Hx2.
      case S1: (step s1) s1' Ht1 H2 Hx1 H1 Ex => [s1'|] s1'' /= [-> Ht1] {s1''} H2 Hx1 H1 Ex; last by [].
      rewrite -(ended_indist Ex) in H2.
      by have := ended_stuck H2; rewrite /stuck /= S1.
    + case S1: (step s1) s1' Ht1 Ex Hx1 H1 => [s1'|] s1'' [-> ?] {s1''} Ex Hx1 H1;
      case S2: (step s2) s2' Ht2 Ex Hx2 H2 => [s2'|] s2'' [-> ?] {s2''} Ex Hx2 H2 //=.
      * by apply IH.
      * rewrite -(ended_indist Ex) in H2.
        by have := ended_stuck H2; rewrite /stuck /= S1.
      * rewrite (ended_indist Ex) in H1.
        by have := ended_stuck H1; rewrite /stuck /= S2.
  - case: n1 H1 Ht1 => [|n1] //= H1 Ht1.
    { move: Ht1 Hx1 => [-> _] Hx1.
      by rewrite /ended /= (ended_low o H1) in Hx1. }
    case S1: (step s1) s1' Ht1 Hx1 H1 => [s1'|] s1'' [-> Ht1] {s1''} Hx1 H1; first by apply IH.
    by rewrite /ended /= (ended_low o H1) in Hx1.
  - by rewrite indistS; apply: IH.
Qed.

(* CH: TODO: allow the two indistinguishability relations to vary *)
Lemma ssni_llni : ssni -> llni.
Proof.
  move => SSNI o s1 s2 t1 t2 I1 I2 E12 [n1 <-] [n2 <-] {t1 t2}.
  move: {2}(n1 + n2) (leqnn (n1 + n2)) => n Hn.
  elim: n s1 s2 {I1 I2} (initial_inv I1) (initial_inv I2) E12 n1 n2 Hn => [|n IH] s1 s2 I1 I2 E12 n1 n2 Hn.
  - rewrite leqn0 addn_eq0 in Hn.
    move: Hn => /andP [/eqP -> /eqP ->] /=.
    exact: indisttb_single E12.
  - case: n1 Hn => [|n1] /= Hn;
    case: n2 Hn => [|n2] /= Hn.
    + exact: indisttb_single E12.
    + by case S2: (step s2) => [s2'|] /=; rewrite (indisttb_cons2 _ _ E12) indisttbNt.
    + by case S1: (step s1) => [s1'|] /=; rewrite (indisttb_cons2 _ _ E12) indisttbtN.
    + case S1: (step s1) => [s1'|]; case S2: (step s2) => [s2'|];
      try by rewrite (indisttb_cons2 _ _ E12) ?indisttbNt ?indisttbtN.
      move: (invP I1 S1) (invP I2 S2) => I1' I2'.
      rewrite /indisttb /= -(indist_low E12).
      have [L|L] := boolP (low o s1) => /=.
      * rewrite E12 /=.
        rewrite addnS addSn ltnS ltn_neqAle in Hn.
        move: Hn => /andP [? ?].
        apply IH; try by [].
        by eapply (ssni_low_low SSNI I1 I2).
      * have [L1'|L1'] := boolP (low o s1'); first have [L2'|L2'] := boolP (low o s2').
        - rewrite addnS addSn ltnS ltn_neqAle in Hn.
          move: Hn => /andP [_ ?].
          apply IH; try by [].
          by eapply (ssni_high_low SSNI I1 I2); eauto.
        - rewrite addnS ltnS in Hn.
          have E12': indist o s1 s2'.
          { apply: (indistT E12).
            eapply ssni_high_high; eauto.
            by rewrite /high /= -(indist_low E12). }
          move: IH => /(_ s1 s2' I1 I2' E12' _ _ Hn).
          by rewrite /indisttb /= S1 /= (negbTE L).
        - rewrite addSn ltnS in Hn.
          have E12': indist o s1' s2.
          { apply: (indistT _ E12).
            rewrite indistS.
            eapply ssni_high_high; eauto. }
          move: IH => /(_ s1' s2 I1' I2 E12' _ _ Hn).
          rewrite (indist_low E12) in L.
          by rewrite /indisttb /= S2 /= (negbTE L).
Qed.

End Everything.


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

From Undecidability.Shared.Libs.DLW
  Require Import pos vec sss.

From Undecidability.MinskyMachines
  Require Import mm_defs.

From Undecidability.FRACTRAN
  Require Import FRACTRAN fractran_utils mm_fractran prime_seq.

Require Import Undecidability.Synthetic.Undecidability.
Require Import Undecidability.Synthetic.ReducibilityFacts.

Set Default Proof Using "Type".

Set Implicit Arguments.

Section MM_HALTING_FRACTRAN_ALT_HALTING.

  Let f : MM_PROBLEM -> FRACTRAN_ALT_PROBLEM.
  Proof.
    intros (n & P & v); red.
    destruct (mm_fractran_n P) as (l & H1 & _).
    split.
    + exact l.
    + exists n; exact v.
  Defined.

  Theorem MM_FRACTRAN_ALT_HALTING : MM_HALTING ⪯ FRACTRAN_ALT_HALTING.
  Proof.
    exists f; intros (n & P & v); simpl.
    destruct (mm_fractran_n P) as (l & H1 & H2); simpl; auto.
  Qed.

End MM_HALTING_FRACTRAN_ALT_HALTING.

Section FRACTRAN_ALT_HALTING_HALTING.

  Let f : FRACTRAN_ALT_PROBLEM -> FRACTRAN_PROBLEM.
  Proof.
    intros (l & n & v).
    exact (l,(ps 1 * exp 1 v)).
  Defined.

  Theorem FRACTRAN_ALT_HALTING_HALTING : FRACTRAN_ALT_HALTING ⪯ FRACTRAN_HALTING.
  Proof.
    exists f; intros (n & P & v); simpl; tauto.
  Qed.

End FRACTRAN_ALT_HALTING_HALTING.

Corollary MM_FRACTRAN_HALTING : MM_HALTING ⪯ FRACTRAN_HALTING.
Proof.
  eapply reduces_transitive. apply MM_FRACTRAN_ALT_HALTING.
  exact FRACTRAN_ALT_HALTING_HALTING.
Qed.

Section MM_HALTING_FRACTRAN_REG_HALTING.

  Let f : MM_PROBLEM -> FRACTRAN_REG_PROBLEM.
  Proof.
    intros (n & P & v); red.
    destruct (mm_fractran_n P) as (l & H1 & _).
    exists l, (ps 1 * exp 1 v); assumption.
  Defined.

  Theorem MM_FRACTRAN_REG_HALTING : MM_HALTING ⪯ FRACTRAN_REG_HALTING.
  Proof.
    exists f; intros (n & P & v); simpl.
    destruct (mm_fractran_n P) as (l & H1 & H2); simpl; auto.
  Qed.

End MM_HALTING_FRACTRAN_REG_HALTING.

Check MM_FRACTRAN_REG_HALTING.

Section FRACTRAN_REG_FRACTRAN_HALTING.

  Let f : FRACTRAN_REG_PROBLEM -> FRACTRAN_PROBLEM.
  Proof.
    intros (l & v & _); exact (l,v).
  Defined.

  Theorem FRACTRAN_REG_FRACTRAN_HALTING : FRACTRAN_REG_HALTING ⪯ FRACTRAN_HALTING.
  Proof.
    exists f; intros (n & P & v); simpl; tauto.
  Qed.

End FRACTRAN_REG_FRACTRAN_HALTING.

Check FRACTRAN_REG_FRACTRAN_HALTING.


(* Minkwitz' brute-force short-word SGS search. *)

From CGT Require Import A1_setup B1_fmap B2_perm B3_word.
From CGT Require Import C1_Schreier_vector C3_subgroup_chain.

Module SGS.

Section Algorithm.

(***
:: Search table ::

The table is a list of triples (k, c, i ↦ (f, w)) representing each subgroup
generated by the Schreier-Sims algorithm. The only information needed from this
algorithm is the length of the orbits, such that the search can be terminated
when all generators are found. The triples carry the following information:
- The subgroup stabilizer point: k.
- The size of the orbit of k minus the orbit permutations already found: c.
- A map from an orbit value i to a flag f and a word w such that w is fully
  reduced and w maps i to k. The flag indicates if w is a new word.
*)
Definition orbit := fmap (bool × word).
Definition table := list (positive × nat × orbit).
Definition state := positive × nat × word × table.

(* Convert a subgroup chain to an orbit table. *)
Definition save_orbits (C : SGChain.chain) :=
  map (λ sg, match sg with (_, k, V) => (k, size V) end) C.

(* Initialize a triple given the stabilizer point k and orbit size n. *)
Definition initialize_triple (k : positive) (n : nat) :=
  (k, pred n, @create (bool × word) k (false, [])).

(* Create an empty SGS table from an orbit table. *)
Definition initialize (orbits : list (positive × nat)) :=
  map (λ kn, initialize_triple (fst kn) (snd kn)) orbits.

(* Determine if all orbits in the table are filled. *)
Fixpoint complete (T : table) :=
  match T with
  | [] => true
  | (_, O, _) :: T' => complete T'
  | _ => false
  end.

Section Fixed_generators.
Variable gen : generators.
Variable gen_size : positive.

Section Fixed_max_length.
Variable max_length : nat.

(* Subroutine of a round; add a new word to the orbit and try its inverse. *)
Definition round_finish (k : positive) (c : nat) (Ok : orbit) j w :=
  let w_inv := inv_word w in
  let Ok' := insert Ok j (true, w_inv) in
  let j' := apply_word gen w_inv k in
  match lookup Ok' j' with
  | None => (k, pred c, insert Ok' j' (true, w))
  | Some (_, w') =>
    if length_le_length w w'
    then (k, c, insert Ok' j' (true, w))
    else (k, c, Ok')
  end.

(* Update the table using the suggested word. *)
Fixpoint round (T : table) (w : word) : table :=
  if length_le_nat w max_length
  then match T with
  | [] => []
  | (k, c, Ok) :: T' =>
    let j := apply_word gen w k in
    match lookup Ok j with
    | None => round_finish k (pred c) Ok j w :: T'
    | Some (_, w') =>
      let w'' := reduce [] (w' ++ w) in
      let T'' := round T' w'' in
      if length_le_length w w'
      then round_finish k c Ok j w :: T''
      else (k, c, Ok) :: T''
    end
  end else T.

(* Clear all optimization flags in the given orbit. *)
Fixpoint clear_flags (O : orbit) :=
  match O with
  | Leaf => Leaf
  | Node None OO OI =>
    Node None (clear_flags OO) (clear_flags OI)
  | Node (Some (_, w)) OO OI =>
    Node (Some (false, w)) (clear_flags OO) (clear_flags OI)
  end.

(* Combine new short words for additional rounds. *)
Fixpoint recycle (T : table) : table :=
  match T with
  | [] => []
  | (k, c, Ok) :: T' =>
    let orbit_vals := values Ok in
    let vals_prod := list_prod orbit_vals orbit_vals in
    let new_table := (k, c, clear_flags Ok) :: recycle T' in
    let loop T' p :=
      (* For every two words w and w' in the k-orbit: *)
      match p with ((f, w), (f', w')) =>
        (* If either word is new; compute an extra round. *)
        if f || f' then round T' (reduce [] (w ++ w')) else T'
      end in
    fold_left loop vals_prod new_table
  end.

(* Complete higher orbits with words lower in the table (graph connectivity). *)
Fixpoint fill_orbits (T : table) : fmap (list (positive × word)) × table :=
  match T with
  | [] => (Leaf, [])
  | (k, c, Ok) :: T' =>
    let (sub, T'') := fill_orbits T' in
    let orbit_k := map (λ e, (fst e, snd (snd e))) (entries Ok xH) in
    let loop c_Ok i_w :=
      (* For every k-orbit entry (i, w): *)
      match i_w with (i, w) =>
        (* Does the subgroup chain contain an i-orbit? *)
        match lookup sub i with
        | None => c_Ok
        | Some i_orbit =>
          let loop' c_Ok' j_w :=
            (* For every i-orbit entry (j, w'): *)
            match c_Ok', j_w with (c', Ok'), (j, w') =>
              (* Note that w ++ w' is a word that maps j to k. *)
              (* Does the k-orbit already contain a word for j? *)
              match lookup Ok' j with
              | Some _ => c_Ok'
              | None =>
                (* Insert the new word if it is short enough. *)
                let w'' := reduce [] (w ++ w') in
                if length_le_nat w'' max_length
                then (pred c', insert Ok' j (true, w''))
                else c_Ok'
              end
            end in
          fold_left loop' i_orbit c_Ok
        end
      end in
    let (c', Ok') := fold_left loop orbit_k (c, Ok) in
    (insert sub k orbit_k, (k, c', Ok') :: T'')
  end.

End Fixed_max_length.

(* Add the next word to the table. *)
Definition cycle s_reset (S : state) : state :=
  match S with (s, l, w, T) =>
    let w' := next_word gen_size w in
    if (1 <? s) && length_le_nat w' l
    then
      let T' := round l T w' in
      (s - 1, l, w', T')
    else
      let T' := recycle l T in
      let T'' := snd (fill_orbits l T') in
      (s_reset, l + Nat.max 1 (l / 4), w, T'')%nat
  end.

(* Find a word to describe the permutation w ∘ π in T. *)
Fixpoint find_word (T : table) (w : word) (π : perm) :=
  match T with
  (* If the subgroup chain is complete, we must have w ∘ π = ident. *)
  | [] => Some []
  (* Otherwise map w ∘ π to the subgroup of T' by prepending a word. *)
  | (k, _, orbit) :: T' =>
    (* Compute j := (w ∘ π)⋅k. *)
    let j := apply_word gen w π⋅k in
    (* Find a word that maps j to k. *)
    match lookup orbit j with
    | Some (_, w_hd) =>
      match find_word T' (w_hd ++ w) π with
      (* w_tl = w_hd ∘ w ∘ π *)
      | Some w_tl => Some (inv_word w_hd ++ w_tl)
      | None => None
      end
    | None => None
    end
  end.

End Fixed_generators.

(***
:: Time bound ::

I believe that the search is certain to converge after checking all words of
length at most n! (track the maximum word length along the subgroup chain). Of
course in practice the search should converge _much_ faster.
*)

(* Apply f n times. *)
Fixpoint iter {X} n (f : X -> X) (x : X) : X :=
  match n with
  | 1 => f x
  | m~0 => iter m f (iter m f x)
  | m~1 => iter m f (iter m f (f x))
  end.

(***
Fill an SGS table.
- T: The table to fill.
- gen: The generating set.
- bound: Maximum number of cycles.
- s: Macro cycle size; recycle and orbit filling are done after every s cycles.
- l: Initial maximum word length; rounds are terminated beyond this length.
*)
Definition fill (T : table) (gen : list perm) bound s l : table :=
  let G := prepare_generators gen in
  let n := Pos.of_nat (length gen) in
  let S := iter bound (cycle G n s) (s, l, [], T) in
  snd S.

(* Find a permutation word using a strong generating set, and reduce it. *)
Definition factorize (T : table) (gen : list perm)  π : option word :=
  match find_word (prepare_generators gen) T [] π with
  | Some w => Some (reduce [] w)
  | None => None
  end.

(* Check the validity of all words in the table, and return the orbit sizes. *)
Fixpoint check_words (T : table) (gen : generators) (ks : list positive) :=
  match T with
  | [] => []
  | (k, _, Ok) :: T' =>
    let orbit := entries Ok xH in
    let valid := landb (map (λ e, match e with (i, (_, w)) =>
      landb (map (λ j, apply_word gen w j =? j) ks)
      && (k =? apply_word gen w i)
    end) orbit) in
    (k, length orbit, valid) ::
    check_words T' gen (k :: ks)
  end.

(* Determine if the table is valid. *)
Definition valid (T : table) (gen : list perm) orbits :=
  let G := prepare_generators gen in
  landb (map (λ p, match p with ((k, n), (l, m, b)) =>
    (k =? l) && (n =? m)%nat && b end)
  (combine orbits (check_words T G []))).

End Algorithm.

End SGS.


Set Universe Polymorphism.

Record TYPE@{i} := cType {
  type : Type@{i};
}.

Definition PROD@{i j k}
  (A : Type@{i})
  (B : A -> Type@{j})
  : TYPE@{k}.
Proof.
  refine (cType@{i} _).
+ refine (forall x : A, B x).
Defined.

Local Unset Strict Universe Declaration.
Definition PRODinj
  (A : Type@{i})
  (B : A -> Type)
  : TYPE.
Proof.
  refine (cType@{i} _).
+ refine (forall x : A, B x).
Defined.

  Monomorphic Universe i j.
  Monomorphic Constraint j < i.
Set Printing Universes.
Check PROD@{i i i}.
Check PRODinj@{i j}.
Fail Check PRODinj@{j i}.


Fail Inductive context: Type :=
| Empty: context
| Ext(G: context)(t: type G): context
(* Inductive-Inductive types: constructor of one type appears in index of other
   inductive type being defined at the same time.
   This definition cannot be made in Coq. *)
with type: context -> Type :=
| Unit(G: context): type G
| Sigma(G: context)(A: type G)(B: type (Ext G A)): type G.


Require Import Charge.Logics.ILogic.
Require Import Setoid Morphisms RelationClasses Program.Basics Omega.

Set Implicit Arguments.
Unset Strict Implicit.
Set Maximal Implicit Insertion.

Section ILogicEmbed.
  Context {A} `{ILOpsA: ILogicOps A}.
  Context {B} `{ILOpsB: ILogicOps B}.

  Class EmbedOp := { embed : A -> B }.

  Class Embed {EmbOp: EmbedOp} := {
     embed_sound p q : p |-- q -> embed p |-- embed q;

     embedlforall T f : Forall x : T, embed (f x) -|- embed (Forall x : T, f x);
     embedlexists T f : Exists x : T, embed (f x) -|- embed (Exists x : T, f x);
     embedImpl a b : (embed a) -->> (embed b) -|- embed (a -->> b)
  }.
End ILogicEmbed.

Implicit Arguments EmbedOp [].
Implicit Arguments Embed [[ILOpsA] [ILOpsB] [EmbOp]].

Section ILogicEmbedOps.
  Context {A B} `{HAB: Embed A B} {ILA: ILogic A} {ILB: ILogic B}.

  Definition lembedand (a : A) (b : B) := (embed a) //\\ b.
  Definition lembedimpl (a : A) (b : B) := (embed a) -->> b.

End ILogicEmbedOps.

Section ILEmbedId.

	Context {A : Type} `{ILA : ILogic A}.

	Instance EmbedOpId : EmbedOp A A := { embed := id }.
	Global Instance EmbedId : Embed A A.
	Proof.
		split; firstorder.
	Qed.

End ILEmbedId.

Section ILogicEmbedCompose.
  Context {A B} `{HAB: Embed A B} {ILA: ILogic A} {ILB: ILogic B}.
  Context {C} {HC: ILogicOps C} {HE: EmbedOp B C} {HBC : Embed B C} {ILC: ILogic C}.

  Instance embedOpCompose : EmbedOp A C := { embed := fun x => embed (embed x) }.

  Program Instance embedCompose : Embed A C.
  Next Obligation.
  	do 2 apply embed_sound; assumption.
  Qed.
  Next Obligation.
  	split;
  	rewrite embedlforall; apply embed_sound; rewrite embedlforall; reflexivity.
  Qed.
  Next Obligation.
  	split;
  	rewrite embedlexists; apply embed_sound; rewrite embedlexists; reflexivity.
  Qed.
  Next Obligation.
  	split;
  	rewrite embedImpl; apply embed_sound; rewrite embedImpl; reflexivity.
  Qed.

End ILogicEmbedCompose.

Infix "/\\" := lembedand (at level 75, right associativity).
Infix "->>" := lembedimpl (at level 77, right associativity).

Section ILogicEmbedFacts.
  Context {A B} `{HAB: Embed A B} {ILA: ILogic A} {ILB: ILogic B}.

  Global Instance embed_lentails_m :
    Proper (lentails ==> lentails) embed.
  Proof.
    intros a b Hab; apply embed_sound; assumption.
  Qed.

  Global Instance embed_lequiv_m :
    Proper (lequiv ==> lequiv) embed.
  Proof.
    intros a b Hab; split; destruct Hab; apply embed_sound; assumption.
  Qed.

  Global Instance lembedimpl_lentails_m:
    Proper (lentails --> lentails ++> lentails) lembedimpl.
  Proof.
    intros P P' HP Q Q' HQ; red in HP.
    unfold lembedimpl. rewrite <- HP, HQ; reflexivity.
  Qed.

  Global Instance lembedimpl_lequiv_m:
    Proper (lequiv ==> lequiv ==> lequiv) lembedimpl.
  Proof.
    intros P P' HP Q Q' HQ.
    split; apply lembedimpl_lentails_m; (apply HP || apply HQ).
  Qed.

  Global Instance lembedand_lentails_m:
    Proper (lentails ==> lentails ==> lentails) lembedand.
  Proof.
    intros P P' HP Q Q' HQ.
    unfold lembedand. rewrite HP, HQ. reflexivity.
  Qed.

  Global Instance lembedand_lequiv_m:
    Proper (lequiv ==> lequiv ==> lequiv) lembedand.
  Proof.
    intros P P' HP Q Q' HQ.
    split; apply lembedand_lentails_m; (apply HP || apply HQ).
  Qed.

  Lemma embedland a b : embed a //\\ embed b -|- embed (a //\\ b).
  Proof.
    do 2 rewrite land_is_forall; rewrite <- embedlforall; split;
    apply lforallR; intro x; apply lforallL with x;
    destruct x; reflexivity.
  Qed.

  Lemma embedlor a b : embed a \\// embed b -|- embed (a \\// b).
  Proof.
    do 2 rewrite lor_is_exists; erewrite <- embedlexists; split;
    apply lexistsL; intro x; apply lexistsR with x;
    destruct x; reflexivity.
  Qed.

  Lemma embedlfalse : embed lfalse -|- lfalse.
  Proof.
    rewrite lfalse_is_exists; erewrite <- embedlexists; split;
    [apply lexistsL; intro x; destruct x | apply lfalseL].
  Qed.

  Lemma embedltrue : embed ltrue -|- ltrue.
  Proof.
    rewrite ltrue_is_forall; rewrite <- embedlforall; split;
    [apply ltrueR | apply lforallR; intro x; destruct x].
  Qed.

  Lemma embedlandC (P R : B) (Q : A) : P //\\ Q /\\ R -|- Q /\\ P //\\ R.
  Proof.
  	unfold lembedand; rewrite <- landA, (landC P), landA; reflexivity.
  Qed.

  Lemma embedlimplC (P R : B) (Q : A) : P -->> Q ->> R -|- Q ->> P -->> R.
  Proof.
    unfold lembedimpl. do 2 rewrite limplAdj2.
    rewrite landC. reflexivity.
  Qed.

  Lemma limpllandC (P Q R : B) : P //\\ (Q -->> R) |-- Q -->> P //\\ R.
  Proof.
  	apply limplAdj; rewrite landA; apply landR.
  	+ apply landL1. reflexivity.
  	+ apply landL2. apply limplL; [reflexivity | apply landL1; reflexivity].
  Qed.

  Lemma embed_existsL (P : A) : Exists x : |-- P, ltrue |-- embed P.
  Proof.
  	apply lexistsL; intro H.
  	rewrite <- H. rewrite embedltrue. apply ltrueR.
  Qed.

End ILogicEmbedFacts.

Section EmbedProp.
  Context {A : Type} `{HIL: ILogic A} {HPropOp: EmbedOp Prop A} {HProp: Embed Prop A}.

  Lemma embedPropExists (p : Prop) : embed p |-- Exists x : p, ltrue.
  Proof.
    assert (p |-- Exists x : p, (|-- ltrue)). {
      intros Hp. exists Hp. apply ltrueR.
    } etransitivity.
    rewrite H. reflexivity.
    rewrite <- embedlexists. apply lexistsL. intros Hp.
    apply lexistsR with Hp. apply ltrueR.
  Qed.

  Lemma embedPropExistsL (p : Prop) (P : A) : Exists x : p, P |-- embed p.
  Proof.
    assert (Exists x : p, ltrue |-- p). {
      intros HP. destruct HP as [HP _]. apply HP.
    }
    etransitivity; [|rewrite <- H]; [reflexivity|].
    rewrite <- embedlexists. apply lexistsL; intro Hp.
    apply lexistsR with Hp. rewrite embedltrue. apply ltrueR.
  Qed.

  (* TODO rename embedPropExists to embedPropExistsR *)
  Lemma embedPropExists' (p : Prop) : Exists x : p, ltrue -|- embed p.
  Proof.
  	split; [apply embedPropExistsL | apply embedPropExists].
  Qed.

  Lemma embedPropL (p : Prop) C (H: p -> |-- C) :
    embed p |-- C.
  Proof.
  	rewrite embedPropExists.
  	apply lexistsL; intro Hp.
  	apply H; apply Hp.
  Qed.

  Lemma embedPropR (p : Prop) (P : A) (H : p) : P |-- embed p.
  Proof.
    assert (ltrue |-- p) by (intros _; assumption).
    rewrite <- H0, embedltrue; apply ltrueR.
  Qed.

  Lemma lpropandL (p: Prop) Q C (H: p -> Q |-- C) :
    p /\\ Q |-- C.
  Proof.
    unfold lembedand.
    apply landAdj.
    apply embedPropL.
    intros Hp.
    apply limplAdj.
    apply landL2.
    apply H. assumption.
  Qed.

  Lemma lpropandR C (p: Prop) Q (Hp: p) (HQ: C |-- Q) :
    C |-- p /\\ Q.
  Proof.
    unfold lembedand.
    apply landR; [|assumption].
    rewrite <- embedPropR. apply ltrueR. assumption.
  Qed.

  Lemma lpropimplL (p: Prop) (Q C: A) (Hp: p) (HQ: Q |-- C) :
    p ->> Q |-- C.
  Proof.
    unfold lembedimpl.
    rewrite <- embedPropR, limplTrue; assumption.
  Qed.

  Lemma lpropimplR C (p: Prop) Q (H: p -> C |-- Q) :
    C |-- p ->> Q.
  Proof.
    unfold lembedimpl.
    apply limplAdj. rewrite landC. apply lpropandL. assumption.
  Qed.

  (* Derivable but useful *)
  Lemma lpropandTrue P : True /\\ P -|- P.
  Proof.
    split.
    + apply lpropandL; intros _; reflexivity.
    + apply landR.
      * replace True with (@ltrue Prop _) by reflexivity.
        rewrite embedltrue. apply ltrueR.
      * reflexivity.
  Qed.

  Lemma lpropandFalse P : False /\\ P -|- lfalse.
  Proof.
    split.
    + apply lpropandL; intros H; destruct H.
    + apply lfalseL.
  Qed.

End EmbedProp.

Section EmbedProp'.
  Context {A : Type} `{HILA: ILogic A} {HPropOpA: EmbedOp Prop A} {HPropA: Embed Prop A}.
  Context {B : Type} `{HILB: ILogic B} {HPropOpB: EmbedOp Prop B} {HPropB: Embed Prop B}.
  Context {HEmbOp : EmbedOp B A} {Hemb: Embed B A}.

  Lemma lpropandAL (p : B) (q : A) (P : Prop) : P /\\ p /\\ q |-- (P /\\ p) /\\ q.
  Proof.
  	apply lpropandL; intros HP; apply landR.
  	+ apply landL1; apply embed_sound; apply landR.
  	  * apply embedPropR. assumption.
  	  * reflexivity.
  	+ apply landL2; reflexivity.
  Qed.

  Lemma lpropandAC (p : B) (q : A) (P : Prop) : p /\\ P /\\ q -|- P /\\ p /\\ q.
  Proof.
  	unfold lembedand. do 2 rewrite <- landA; rewrite (landC (embed p)); reflexivity.
  Qed.

  Lemma lpropandAR (p : B) (q : A) (P : Prop) : (P /\\ p) /\\ q |-- P /\\ p /\\ q.
  Proof.
  	apply landR.
  	+ apply landL1.
  	  unfold lembedand; rewrite <- embedland; apply landL1.
  	  rewrite embedPropExists, <- embedlexists.
  	  apply lexistsL; intro Hp.
  	  apply embedPropR; apply Hp.
  	+ unfold lembedand; rewrite <- embedland; apply landR.
  	  * apply landL1; apply landL2. reflexivity.
  	  * apply landL2; reflexivity.
 Qed.

 Lemma lpropimplAL (p : B) (q : A) (P : Prop) : (P ->> p) /\\ q |-- P ->> (p /\\ q).
 Proof.
    unfold lembedimpl, lembedand. apply limplAdj. rewrite landA.
    rewrite <- embedImpl. apply limplL. apply landL2.
    rewrite embedPropExists. apply lexistsL; intro Hp.
    rewrite <- (embedPropR ltrue); [apply embedltrue | apply Hp].
    apply landR; [apply landL1|apply landL2; apply landL1]; reflexivity.
 Qed.

 Lemma lpropimplAR (p : B) (q : A) (P : Prop) : p /\\ (P ->> q) |-- P ->> (p /\\ q).
 Proof.
    unfold lembedimpl, lembedand. rewrite landC. apply limplAdj. rewrite landA.
    apply limplL. apply landL2; reflexivity.
    apply landR; [apply landL2; apply landL1|apply landL1]; reflexivity.
 Qed.

  Lemma embedPropR2 (p : Prop) (P : A) (H : p) : P |-- embed (embed p).
  Proof.
    assert (ltrue |-- p) by (intros _; assumption).
    rewrite <- H0. do 2 rewrite embedltrue. apply ltrueR.
  Qed.

  Lemma embedPropL2 (p : Prop) (C : A) (H: p -> |-- C) :
    embed (embed p) |-- C.
  Proof.
  	rewrite embedPropExists, <- embedlexists.
  	apply lexistsL; intro Hp. rewrite embedltrue.
  	apply H; apply Hp.
  Qed.

End EmbedProp'.

Section EmbedPropProp.

Instance EmbedOpPropProp : EmbedOp Prop Prop := { embed := fun P => P }.
Instance EmbedPropProp : Embed Prop Prop.
Proof.
  split; firstorder.
Qed.

End EmbedPropProp.

Section EmbedPropInj.
	Context {A : Type} `{ILA : ILogic A}.
	Context {EmbOp1 : EmbedOp Prop A} {Emb1 : Embed Prop A}.
	Context {EmbOp2 : EmbedOp Prop A} {Emb2 : Embed Prop A}.

	Lemma emb_prop_eq (P : Prop) : @embed _ _ EmbOp1 P -|- @embed _ _ EmbOp2 P.
	Proof.
		split; rewrite embedPropExists; apply lexistsL; intro Hp;
		(rewrite <- (embedPropR ltrue); [apply ltrueR | apply Hp]).
	Qed.

End EmbedPropInj.


From Undecidability.FOL Require Import Syntax.Facts Semantics.Tarski.FullFacts Deduction.FullNDFacts.
Require Import Undecidability.FOL.Arithmetics.FA.
Require Import Undecidability.FOL.Arithmetics.Signature.
Require Import Undecidability.FOL.Arithmetics.Problems.
Require Import Lia List Vector.
Import Vector.VectorNotations.

Set Default Proof Using "Type".

Local Set Implicit Arguments.
Local Unset Strict Implicit.

(* ** The standard model *)

Section StdModel.

  Definition interp_nat : interp nat.
  Proof.
    split.
    - destruct f; intros v.
      + exact 0.
      + exact (S (Vector.hd v) ).
      + exact (Vector.hd v + Vector.hd (Vector.tl v) ).
      + exact (Vector.hd v * Vector.hd (Vector.tl v) ).
    - destruct P. intros v.
      exact (Vector.hd v = Vector.hd (Vector.tl v) ).
  Defined.

  Fact nat_extensional : extensional interp_nat.
  Proof.
    now intros x y.
  Qed.

  Lemma nat_is_FA_model : forall rho phi,  List.In phi FAeq -> sat interp_nat rho phi.
  Proof.
    intros rho phi. intros H.
    repeat (destruct H as [<- | H]; auto).
    all: cbn; try congruence. inversion H.
  Qed.

  Lemma nat_is_Q_model : forall rho phi,  List.In phi Qeq -> sat interp_nat rho phi.
  Proof.
    intros rho phi. intros H.
    repeat (destruct H as [<- | H]; auto).
    all: cbn; try congruence.
    2: inversion H.
    induction d. now left.
    right. destruct IHd.
    exists 0. congruence.
    exists d. reflexivity.
  Qed.

  Fact nat_eval_num (sigma : env nat) n : @eval _ _ _ interp_nat sigma (μ n) = n.
  Proof.
    induction n.
    - reflexivity.
    - cbn. now rewrite IHn.
  Qed.

  Fact nat_induction phi : forall rho, sat interp_nat rho (ax_induction phi).
  Proof.
    intros rho H0 IH d. induction d; cbn in *.
    rewrite <-sat_single in H0. apply H0.
    apply IH in IHd. rewrite sat_comp in IHd.
    revert IHd. apply sat_ext. intros []; reflexivity.
  Qed.

  Fact nat_is_PAeq_model : forall ax rho, PAeq ax -> sat interp_nat rho ax.
  Proof.
    intros rho psi [].
    now apply nat_is_FA_model.
    all: cbn; try congruence.
    apply nat_induction.
 Qed.

  Fact nat_is_PA_model : forall ax rho, PA ax -> sat interp_nat rho ax.
  Proof.
    intros rho psi [].
    repeat (destruct H as [<- | H]; auto).
    all: cbn; try congruence. inversion H.
    apply nat_induction.
  Qed.

End StdModel.


Require Export Iron.Language.SystemF2Cap.Type.Exp.Base.
Require Export Iron.Language.SystemF2Cap.Type.TyEnv.
Require Export Iron.Language.SystemF2Cap.Type.Operator.SubstTT.
Require Export Iron.Language.SystemF2Cap.Type.Operator.MaskOnT.
Require Export Iron.Language.SystemF2Cap.Type.Relation.FreshT.

(********************************************************************)
Fixpoint mergeT (p1 p2 : nat) (tt : ty)  : ty :=
 match tt with
 | TVar    _            => tt
 | TForall k t          => TForall k (mergeT p1 p2 t)
 | TApp    t1 t2        => TApp (mergeT p1 p2 t1) (mergeT p1 p2 t2)
 | TSum    t1 t2        => TSum (mergeT p1 p2 t1) (mergeT p1 p2 t2)
 | TBot    k            => TBot k
 | TCon0   tc0          => TCon0 tc0
 | TCon1   tc1 t1       => TCon1 tc1 (mergeT p1 p2 t1)
 | TCon2   tc2 t1 t2    => TCon2 tc2 (mergeT p1 p2 t1) (mergeT p1 p2 t2)
 | TCap (TyCapRegion p) => if beq_nat p p2 then TRgn p1 else tt
 end.

Definition mergeTE p1 p2 te := map (mergeT p1 p2) te.
Hint Unfold mergeTE.

(********************************************************************)
Lemma mergeT_wfT
 :  forall n t1 t2 p1 p2
 ,  mergeT p1 p2 t1 = t2
 -> WfT n t1
 -> WfT n t2.
Proof.
 intros. gen n t2.
 induction t1; snorm; inverts H0; rewrite <- H; eauto.
 destruct t. snorm.
Qed.
Hint Resolve mergeT_wfT.

Lemma mergeT_freshT_id
 :  forall p1 p2 t
 ,  FreshT p2 t
 -> mergeT p1 p2 t = t.
Proof.
 intros.
 induction t; snorm; rewritess; auto.
 - destruct t. snorm.
Qed.

Lemma mergeT_kindT
 :  forall ke sp t k p1 p2
 ,  In (SRegion p1) sp
 -> KindT ke sp t k
 -> KindT ke sp (mergeT p1 p2 t) k.
Proof.
 intros. induction H0; snorm; eauto.
Qed.
Hint Resolve mergeT_kindT.

Lemma mergeT_kindT_chop
 :  forall ke sp t k p1 p2
 ,  In (SRegion p2) sp
 -> KindT ke sp (mergeT p1 p2 t) k
 -> KindT ke sp t k.
Proof.
 intros. gen ke k.
 induction t; intros; snorm; inverts_kind; eauto 4.

 - destruct t; snorm. subst.
   inverts_kind. eauto.
Qed.
Hint Resolve mergeT_kindT_chop.

Lemma mergeT_substTT
 :  forall ke sp t k p1 p2 ix
 ,  FreshT p2 t
 -> KindT ke sp t k
 -> mergeT p1 p2 (substTT ix (TRgn p2) t)
 =  substTT ix (TRgn p1) t.
Proof.
 intros. gen ix ke k.
 induction t; snorm;
  try (inverts H0; espread; eauto; snorm).
Qed.

Lemma mergeT_liftTT_comm
 : forall n d p1 p2 t
 , liftTT n d (mergeT p1 p2 t)
 = mergeT p1 p2 (liftTT n d t).
Proof.
 intros. gen n d.
 induction t; intros; snorm;
  try (solve [f_equal; rewritess; auto]).
 destruct t. snorm.
Qed.
Hint Resolve mergeT_liftTT_comm.

Lemma mergeTE_liftTE_comm
 : forall d p1 p2 ts
 , liftTE d (mergeTE p1 p2 ts)
 = mergeTE p1 p2 (liftTE d ts).
Proof.
 intros.
 induction ts; snorm.
 - rewritess.
   rewrite mergeT_liftTT_comm; auto.
Qed.
Hint Resolve mergeTE_liftTE_comm.

Lemma mergeT_substTT_comm
 : forall d t1 t2 p1 p2
 , substTT d (mergeT p1 p2 t1) (mergeT p1 p2 t2)
 = mergeT p1 p2 (substTT d t1 t2).
Proof.
 intros. gen d t1.
 induction t2; intros; snorm;
  try (solve [f_equal; repeat (rewrite mergeT_liftTT_comm); espread; auto]).

 - Case "TCap".
   destruct t. snorm.
Qed.
Hint Resolve mergeT_substTT_comm.

Lemma mergeT_lowerTT
 :  forall d p1 p2 t1 t2
 ,  Some t2                = lowerTT d t1
 -> Some (mergeT p1 p2 t2) = lowerTT d (mergeT p1 p2 t1).
Proof.
 intros. gen d t2.
 induction t1;
  try (solve [snorm]).

 - snorm.
   + f_equal. f_equal.
     eapply IHt1 in HeqH1.
     congruence.
   + eapply IHt1 in HeqH1.
     congruence.

 - snorm.
   + eapply IHt1_1 in HeqH2.
     eapply IHt1_2 in HeqH3.
     congruence.
   + eapply IHt1_1 in HeqH2.
     eapply IHt1_2 in HeqH3.
     congruence.
   + eapply IHt1_1 in HeqH1.
     eapply IHt1_2 in HeqH2.
     congruence.

 - snorm.
   + eapply IHt1_1 in HeqH2.
     eapply IHt1_2 in HeqH3.
     congruence.
   + eapply IHt1_1 in HeqH2.
     eapply IHt1_2 in HeqH3.
     congruence.
   + eapply IHt1_1 in HeqH1.
     eapply IHt1_2 in HeqH2.
     congruence.

 - snorm.
   + eapply IHt1 in HeqH1.
     congruence.
   + eapply IHt1 in HeqH1.
     congruence.

 - snorm.
   + eapply IHt1_1 in HeqH2.
     eapply IHt1_2 in HeqH3.
     congruence.
   + eapply IHt1_1 in HeqH2.
     eapply IHt1_2 in HeqH3.
     congruence.
   + eapply IHt1_1 in HeqH1.
     eapply IHt1_2 in HeqH2.
     congruence.

 - destruct t; snorm; nope.
Qed.
Hint Resolve mergeT_lowerTT.

Lemma mergeT_maskOnVarT
 :  forall ix p1 p2 t
 ,  maskOnVarT ix (mergeT p1 p2 t)
 =  mergeT p1 p2 (maskOnVarT ix t).
Proof.
 intros. gen ix.
 induction t; intros;
  try (solve [try (unfold maskOnVarT); snorm; try f_equal; eauto]).

 - Case "TCon1".
   unfold maskOnVarT. simpl.
   unfold maskOnT. snorm.
   + firstorder.
     * nope.
     * destruct t0; snorm; nope.
       destruct t0. snorm. nope. nope.
   + firstorder.
     * nope.
     * destruct t0; snorm; nope.

 - Case "TCap".
   simpl.
   destruct t.
   snorm.
Qed.
Hint Resolve mergeT_maskOnVarT.

(********************************************************************)
Lemma mergeTE_rewind
 :  forall p1 p2 te t
 ,  FreshT p2 t
 -> mergeTE p1 p2 te :> t
 =  mergeTE p1 p2 (te :> t).
Proof.
 intros.

 have HT1: (t = mergeT p1 p2 t)
  by (symmetry; apply mergeT_freshT_id; auto).
 rewrite HT1 at 1.
 snorm.
Qed.

Lemma mergeTE_rewind_app
 :  forall p1 p2 te1 te2
 ,  Forall (FreshT p2) te2
 -> mergeTE p1 p2 te1  >< te2
 =  mergeTE p1 p2 (te1 >< te2).
Proof.
 intros.
 induction te2.
 - snorm.
 - simpl.
   erewrite IHte2. f_equal.
   symmetry. eapply mergeT_freshT_id. snorm. snorm.
Qed.


From stdpp Require Export list gmap.
From iris.algebra Require Export list cmra.
From iris.algebra Require Import gset gmap.
From iris.algebra Require Import updates local_updates proofmode_classes big_op.
From iris.prelude Require Import options.
From iris_ora.algebra Require Export ora.

Lemma list_choice : forall {A B} (P : A -> B -> Prop) l, Forall (fun a => exists b, P a b) l ->
  exists l', Forall2 P l l'.
Proof.
  induction l.
  - exists nil; constructor.
  - inversion 1 as [| ?? [??]]; subst.
    destruct IHl; eauto.
Qed.

Section ora.

Context `{Countable K} {A : ora}.
Implicit Types m : gmap K A.

Instance gmap_orderN : OraOrderN (gmap K A) := λ n, map_relation (ora_orderN A n) (λ _, False) Increasing.
Instance gmap_order : OraOrder (gmap K A) := map_relation (ora_order A) (λ _, False) Increasing.

Lemma lookup_increasing : forall m i, Increasing m -> Increasing (m !! i).
Proof.
  intros ?? Hincr [a|].
  - specialize (Hincr {[ i := a ]} i).
    by rewrite lookup_op lookup_singleton in Hincr.
  - specialize (Hincr ε i).
    by rewrite lookup_op lookup_empty in Hincr.
Qed.

Definition gmap_ora_mixin : OraMixin (gmapR K A).
Proof.
  apply ora_total_mixin; try apply _; try done.
  - intros ???; simpl.
    rewrite lookup_op lookup_core.
    eapply (@ora_core_increasing (optionR A)), _.
  - intros ??? Hincr Hord z i.
    rewrite lookup_op; eapply (@ora_increasing_closed (optionR A)), Hord.
    by apply lookup_increasing.
  - intros ??? Hord i.
    rewrite !lookup_core.
    specialize (Hord i).
    apply (ora_core_monoN n (x !! i)); auto.
  - intros ???? Hx Hord.
    hnf in Hord.
    destruct (list_choice (λ '(i, a) yy,
      yy.1 ⋅ yy.2 ≼ₒ{S n} Some a ∧ yy.1 ≡{n}≡ y1 !! i ∧ yy.2 ≡{n}≡ y2 !! i) (map_to_list x)) as [gg Hgg].
    { rewrite (Forall_iff _ _ (uncurry (λ i a, (∃ yy,
        yy.1 ⋅ yy.2 ≼ₒ{S n} Some a ∧ yy.1 ≡{n}≡ y1 !! i ∧ yy.2 ≡{n}≡ y2 !! i)))); last by intros (?, ?).
      rewrite -map_Forall_to_list; intros ? a Ha.
      destruct (ora_op_extend n (Some a) (y1 !! i) (y2 !! i)) as (z1&z2&Hz).
      * by specialize (Hx i); rewrite Ha in Hx.
      * rewrite -lookup_op; specialize (Hord i); rewrite Ha in Hord; apply Hord.
      * exists (z1, z2); eauto. }
    exists (map_imap (λ i _, (list_find(A := (_ * ora_car A) * _) (λ e, e.1.1 = i) (zip (map_to_list x) gg)) ≫= (fun e => e.2.2.1)) x),
           (map_imap (λ i _, (list_find(A := (_ * ora_car A) * _) (λ e, e.1.1 = i) (zip (map_to_list x) gg)) ≫= (fun e => e.2.2.2)) x).
    assert (forall i a, x !! i = Some a -> exists ni yy1 yy2, list_find (λ e, e.1.1 = i) (zip (map_to_list x) gg) =
      Some (ni, ((i, a), (yy1, yy2))) /\ yy1 ⋅ yy2 ≼ₒ{S n} Some a ∧ yy1 ≡{n}≡ y1 !! i ∧ yy2 ≡{n}≡ y2 !! i) as Hgg'.
    { intros ?? Hxi.
      pose proof (proj2 (elem_of_map_to_list _ _ _) Hxi) as Helem.
      apply elem_of_list_lookup_1 in Helem as (ni & Hmap).
      eapply Forall2_lookup_l in Hgg as ((yy1, yy2) & ? & Hgg); eauto; simpl in *.
      exists ni, yy1, yy2.
      rewrite (proj2 (list_find_Some _ _ ni ((i, a), (yy1, yy2)))) /=; first done.
      rewrite lookup_zip_with_Some; split; [|split]; eauto.
      intros ? (? & ? & ?) Hzip ??; subst; simpl in *.
      apply lookup_zip_with_Some in Hzip as (e & ? & Heq & Hj & ?); inversion Heq; subst.
      pose proof (NoDup_lookup _ j ni e.1 (NoDup_fst_map_to_list x)) as Hnodup.
      rewrite !list_lookup_fmap Hmap Hj in Hnodup; destruct Hnodup; try done; lia. }
    split.
    + intros i.
      rewrite lookup_op !map_lookup_imap.
      destruct (x !! i) eqn: Hxi; rewrite Hxi /= //.
      destruct (Hgg' _ _ Hxi) as (? & ? & ? & -> & ? & _); auto.
    + split; intros i; rewrite map_lookup_imap; destruct (x !! i) eqn: Hxi; rewrite Hxi /=.
      * destruct (Hgg' _ _ Hxi) as (? & ? & ? & -> & ? & ? & ?); auto.
      * specialize (Hord i); rewrite Hxi lookup_op in Hord.
        destruct (op _ _) eqn: Hop; try done.
        rewrite op_None in Hop; destruct Hop as [Hy1 _].
        by rewrite Hy1.
      * destruct (Hgg' _ _ Hxi) as (? & ? & ? & -> & ? & ? & ?); auto.
      * specialize (Hord i); rewrite Hxi lookup_op in Hord.
        destruct (op _ _) eqn: Hop; try done.
        rewrite op_None in Hop; destruct Hop as [_ Hy2].
        by rewrite Hy2.
  - intros ??? Hx Hord.
    destruct (list_choice (λ '(i, a) yy, yy ≼ₒ{S n} Some a ∧ yy ≡{n}≡ y !! i) (map_to_list x)) as [gg Hgg].
    { rewrite (Forall_iff _ _ (uncurry (λ i a, (∃ yy, yy ≼ₒ{S n} Some a ∧ yy ≡{n}≡ y !! i)))); last by intros (?, ?).
      rewrite -map_Forall_to_list; intros ? a Ha.
      destruct (ora_extend n (Some a) (y !! i)) as (z&Hz).
      * by specialize (Hx i); rewrite Ha in Hx.
      * specialize (Hord i); rewrite Ha in Hord; apply Hord.
      * exists z; eauto. }
    exists (map_imap (λ i _, (list_find(A := (_ * ora_car A) * _) (λ e, e.1.1 = i) (zip (map_to_list x) gg)) ≫= (fun e => e.2.2)) x).
    assert (forall i a, x !! i = Some a -> exists ni yy, list_find (λ e, e.1.1 = i) (zip (map_to_list x) gg) =
      Some (ni, ((i, a), yy)) /\ yy ≼ₒ{S n} Some a ∧ yy ≡{n}≡ y !! i) as Hgg'.
    { intros ?? Hxi.
      pose proof (proj2 (elem_of_map_to_list _ _ _) Hxi) as Helem.
      apply elem_of_list_lookup_1 in Helem as (ni & Hmap).
      eapply Forall2_lookup_l in Hgg as (yy & ? & Hgg); eauto; simpl in *.
      exists ni, yy.
      rewrite (proj2 (list_find_Some _ _ ni ((i, a), yy))) /=; first done.
      rewrite lookup_zip_with_Some; split; [|split]; eauto.
      intros ? (? & ?) Hzip ??; subst; simpl in *.
      apply lookup_zip_with_Some in Hzip as (e & ? & Heq & Hj & ?); inversion Heq; subst.
      pose proof (NoDup_lookup _ j ni e.1 (NoDup_fst_map_to_list x)) as Hnodup.
      rewrite !list_lookup_fmap Hmap Hj in Hnodup; destruct Hnodup; try done; lia. }
    split.
    + intros i.
      rewrite !map_lookup_imap.
      destruct (x !! i) eqn: Hxi; rewrite Hxi /= //.
      destruct (Hgg' _ _ Hxi) as (? & ? & -> & ? & _); auto.
    + intros i; rewrite map_lookup_imap; destruct (x !! i) eqn: Hxi; rewrite Hxi /=.
      * destruct (Hgg' _ _ Hxi) as (? & ? & -> & ? & ?); auto.
      * specialize (Hord i); rewrite Hxi in Hord.
        destruct (y !! i) eqn: Hy; rewrite Hy in Hord |- *; done.
  - intros ?????.
    apply (@ora_dist_orderN (optionR A)); auto.
  - intros ??? Hord i.
    apply (@ora_orderN_S (optionR A)), Hord.
  - intros ???? Hxy Hyz i.
    eapply (@ora_orderN_trans (optionR A)); [apply Hxy | apply Hyz].
  - intros ???? Hord i.
    rewrite !lookup_op.
    eapply (@ora_orderN_op (optionR A)), Hord.
  - intros ???? Hord i.
    eapply (@ora_validN_orderN (optionR A)), Hord; auto.
  - split; intros; intros i; eapply (@ora_order_orderN (optionR A)).
    + apply H0.
    + intros; apply H0.
  - intros ??? Hcx.
    eexists; split; [constructor; reflexivity|].
    inversion Hcx as [?? Heq|]; subst.
    intros i.
    rewrite -Heq !lookup_omap lookup_op.
    edestruct (ora_pcore_order_op (x !! i)) as (? & Hcore & ?).
    { constructor; reflexivity. }
    inversion Hcore as [?? Hxy|]; subst.
    by rewrite Hxy.
Qed.
Canonical Structure gmapR : ora := Ora (gmap K A) gmap_ora_mixin.

Global Instance gmap_ora_discrete : OraDiscrete A → OraDiscrete gmapR.
Proof. split; [apply _|..].
  - intros m ? i. by apply: ora_discrete_valid.
  - intros ?? Hord i.
    specialize (Hord i).
    by apply (ora_discrete_order(A := optionR A)).
Qed.

Global Instance gmap_ora_total : OraTotal gmapR.
Proof. rewrite /OraTotal; eauto. Qed.

Canonical Structure gmapUR : uora := Uora (gmap K A) (gmap_ucmra_mixin(H := H)(A := A)).

End ora.

Global Arguments gmapR _ {_ _} _.
Global Arguments gmapUR _ {_ _} _.

Section properties.
Context `{Countable K} {A : ora}.
Implicit Types m : gmap K A.
Implicit Types i : K.
Implicit Types x y : A.

Global Instance gmap_core_id m : (∀ x : A, OraCoreId x) → OraCoreId m.
Proof.
  intros; apply core_id_total=> i.
  rewrite lookup_core. apply (core_id_core _).
Qed.
Global Instance gmap_singleton_core_id i (x : A) :
  OraCoreId x → OraCoreId {[ i := x ]}.
Proof. intros. by apply core_id_total, (singleton_core'(A := A)). Qed.

End properties.

Global Instance gmap_fmap_ora_morphism `{Countable K} {A B : ora} (f : A → B)
  `{!OraMorphism f} : OraMorphism (fmap f : gmap K A → gmap K B).
Proof.
  split; try apply _.
  - intros ??? Hord ?.
    rewrite !lookup_fmap.
    apply option_fmap_ora_morphism, Hord; auto.
  - intros ? Hincr ??.
    rewrite lookup_op lookup_fmap.
    apply option_fmap_ora_morphism; auto.
    by apply lookup_increasing.
Qed.

Program Definition gmapURF K `{Countable K} (F : OrarFunctor) : uorarFunctor := {|
  uorarFunctor_car A _ B _ := gmapUR K (orarFunctor_car F A B);
  uorarFunctor_map A1 _ A2 _ B1 _ B2 _ fg := gmapO_map (orarFunctor_map F fg)
|}.
Next Obligation.
  by intros K ?? F A1 ? A2 ? B1 ? B2 ? n f g Hfg; apply gmapO_map_ne, orarFunctor_map_ne.
Qed.
Next Obligation.
  intros K ?? F A ? B ? x. rewrite /= -{2}(map_fmap_id x).
  apply map_fmap_equiv_ext=>y ??; apply orarFunctor_map_id.
Qed.
Next Obligation.
  intros K ?? F A1 ? A2 ? A3 ? B1 ? B2 ? B3 ? f g f' g' x. rewrite /= -map_fmap_compose.
  apply map_fmap_equiv_ext=>y ??; apply orarFunctor_map_compose.
Qed.

Global Instance gmapURF_contractive K `{Countable K} F :
  OrarFunctorContractive F → uorarFunctorContractive (gmapURF K F).
Proof.
  by intros ? A1 ? A2 ? B1 ? B2 ? n f g Hfg; apply gmapO_map_ne, orarFunctor_map_contractive.
Qed.

Program Definition gmapRF K `{Countable K} (F : OrarFunctor) : OrarFunctor := {|
  orarFunctor_car A _ B _ := gmapR K (orarFunctor_car F A B);
  orarFunctor_map A1 _ A2 _ B1 _ B2 _ fg := gmapO_map (orarFunctor_map F fg)
|}.
Solve Obligations with apply gmapURF.

Global Instance gmapRF_contractive K `{Countable K} F :
  OrarFunctorContractive F → OrarFunctorContractive (gmapRF K F).
Proof. apply gmapURF_contractive. Qed.


Add LoadPath "somePath".

Require Export complete.

(*sound & complete*)

Lemma prv_system_sound_and_complete : forall E:BES, forall x y:propVar, bnd E x -> bnd E y ->
  ((cc_max E) x y <-> prv_tree E (stmt empty_relation (var x) (var y))).
Proof.
split;intro.
apply prv_system_complete;auto.
apply prv_system_sound;auto.
Qed.


(** Proof Reflection in Coq ; eval_lift_lems.v ; 050128 ; Dimitri Hendriks; Coq 8.0pl1 *)

Require Export eval.
Require Export lift.

Set Implicit Arguments.

Section eval_lift_lemmas.

Variable A : Set.
Variable l1 l2 : list nat.
Variable FUN : fun_piT A l1.
Variable REL : rel_piT A l2.

Let P := prf l1 l2.
Let F := frm l1 l2.
Let T := trm l1.
Let Ts := trms l1.
Let C := list F.
Let E := eval_frm' FUN REL.
Let Etrm := eval_trm FUN.
Let Ecxt := eval_cxt' FUN REL.

Lemma insVARswap :
 forall (x y : A) (n : nat) (VAR : nat -> A) (m : nat),
 insertVAR_O x (insertVAR y VAR n) m =
 insertVAR y (insertVAR_O x VAR) (S n) m.
Proof.
simple destruct n; simple destruct m.
reflexivity.
intro m'. case m'; reflexivity.
reflexivity.
reflexivity.
Qed.

Lemma insVAR_shift :
 forall (x : A) (n : nat) (V : nat -> A) (i : nat),
 shiftVAR (insertVAR_O x V) (S n) i = shiftVAR V n i.
Proof.
simple destruct n; reflexivity.
Qed.

Lemma shiftVAR_lift_trm_O :
 forall (VAR : nat -> A) (t : T),
 Etrm VAR (lift_trm 0 t) = Etrm (fun n => VAR (S n)) t.
Proof.
fix 2.
destruct t.
reflexivity.
simpl in |- *.
rewrite mapn_mapn.
assert
 (h0 :
  mapn (fun t : T => Etrm VAR (lift_trm 0 t)) l =
  mapn (Etrm (fun n : nat => VAR (S n))) l).
induction l.
reflexivity.
simpl in |- *; rewrite IHl; rewrite shiftVAR_lift_trm_O; reflexivity.
apply (f_equal (A:=listn A (select i)) (B:=A)).
exact h0.
Qed.

Lemma shiftVAR_lift_trms_O :
 forall (VAR : nat -> A) (k : nat) (l : Ts k),
 eval_trms FUN VAR (lift_trms 0 l) = eval_trms FUN (fun n => VAR (S n)) l.
Proof.
intros V k l.
induction l; simpl in |- *.
reflexivity.
rewrite shiftVAR_lift_trm_O; rewrite IHl; reflexivity.
Qed.

Lemma VARexteq_eval_trm :
 forall VAR VAR' : nat -> A,
 (forall n : nat, VAR n = VAR' n) -> forall t : T, Etrm VAR t = Etrm VAR' t.
Proof.
intros V V' h.
induction t.
exact (h n).
simpl in |- *.
rewrite mapn_inn with (1:=H).
reflexivity.
Qed.

Lemma VARexteq_eval_trms :
 forall VAR VAR' : nat -> A,
 (forall n : nat, VAR n = VAR' n) ->
 forall (k : nat) (l : Ts k), eval_trms FUN VAR l = eval_trms FUN VAR' l.
Proof.
intros V V' h k l.
induction l; simpl in |- *.
reflexivity.
rewrite VARexteq_eval_trm with (1 := h); rewrite IHl; reflexivity.
Qed.

Definition piffp (p : Prop) : p <-> p := conj (fun h => h) (fun h => h).

Lemma VARexteq_eval_frm :
 forall (p : F) (VAR VAR' : nat -> A),
 (forall n : nat, VAR n = VAR' n) -> (E VAR p <-> E VAR' p).
Proof.
simple induction p; clear p.
intros. apply piffp.
intros. apply piffp.
intros i l V V' H.
simpl in |- *.
rewrite VARexteq_eval_trms with (1:=H).
apply piffp.
intros p IHp q IHq V V' H.
elim (IHq V V' H); elim (IHp V V' H); intros IHp1 IHp2 IHq1 IHq2.
simpl in |- *; split; intros H0 H1.
exact (IHq1 (H0 (IHp2 H1))).
exact (IHq2 (H0 (IHp1 H1))).
intros p IHp q IHq V V' H.
elim (IHq V V' H); elim (IHp V V' H); intros IHp1 IHp2 IHq1 IHq2.
split; intro H0; elim H0; intros H1 H2; split.
exact (IHp1 H1).
exact (IHq1 H2).
exact (IHp2 H1).
exact (IHq2 H2).
intros p IHp q IHq V V' H.
elim (IHq V V' H); elim (IHp V V' H); intros IHp1 IHp2 IHq1 IHq2.
split; intro H0; elim H0; intro H1.
left. exact (IHp1 H1).
right. exact (IHq1 H1).
left. exact (IHp2 H1).
right. exact (IHq2 H1).
intros p IH V V' H. simpl in |- *.
split; intros H0 x.
elim (IH (insertVAR_O x V) (insertVAR_O x V'));
 [ intros IH1 IH2
 | simple destruct n; [ reflexivity | intro n'; simpl in |- *; apply H ] ].
exact (IH1 (H0 x)).
elim (IH (insertVAR_O x V) (insertVAR_O x V'));
 [ intros IH1 IH2
 | simple destruct n; [ reflexivity | intro n'; simpl in |- *; apply H ] ].
exact (IH2 (H0 x)).
intros p IH V V' H. simpl in |- *.
split; intros H0; elim H0; intros x H1; exists x.
elim (IH (insertVAR_O x V) (insertVAR_O x V'));
 [ intros IH1 IH2
 | simple destruct n; [ reflexivity | intro n'; simpl in |- *; apply H ] ].
exact (IH1 H1).
elim (IH (insertVAR_O x V) (insertVAR_O x V'));
 [ intros IH1 IH2
 | simple destruct n; [ reflexivity | intro n'; simpl in |- *; apply H ] ].
exact (IH2 H1).
Qed.

Lemma thinning_eval_var :
 forall (n i : nat) (x : A) (VAR : nat -> A),
 VAR i = insertVAR x VAR n (lift n i).
Proof.
simple induction n.
reflexivity.
intros n' IH i x VAR. case i.
reflexivity.
intro i'. exact (IH i' x (fun p => VAR (S p))).
Qed.

Lemma thinning_eval_trm :
 forall (x : A) (VAR : nat -> A) (n : nat) (t : T),
 Etrm VAR t = Etrm (insertVAR x VAR n) (lift_trm n t).
Proof.
intros x V n.
induction t.
exact (thinning_eval_var n n0 x V).
simpl in |- *.
rewrite mapn_mapn.
set (g := fun t => Etrm (insertVAR x V n) (lift_trm n t)) in *.
rewrite (mapn_inn (Etrm V) g l H).
reflexivity.
Qed.

Lemma thinning_eval_trms :
 forall (x : A) (k : nat) (l : Ts k) (n : nat) (VAR : nat -> A),
 eval_trms FUN VAR l = eval_trms FUN (insertVAR x VAR n) (lift_trms n l).
Proof.
intros x k l n V.
induction l; simpl in |- *.
reflexivity.
rewrite <- thinning_eval_trm; rewrite <- IHl; reflexivity.
Qed.

Lemma thinning_eval_frm :
 forall (p : F) (x : A) (VAR : nat -> A) (n : nat),
 E VAR p <-> E (insertVAR x VAR n) (lift_frm n p).
Proof.
simple induction p; clear p; simpl in |- *.
(*top*) intros. apply piffp.
(*bot*) intros. apply piffp.
(*rel i l*) intros i l x VAR n.
rewrite (thinning_eval_trms x l n VAR).
apply piffp.
(*imp p q*) intros p IHp q IHq x VAR n.
elim (IHp x VAR n); intros.
elim (IHq x VAR n); intros.
split; intros; auto.
(*cnj p q*) intros p IHp q IHq x VAR n.
elim (IHp x VAR n); intros.
elim (IHq x VAR n); intros.
split; intro H3; elim H3; split; intros; auto.
(*dsj p q*) intros p IHp q IHq x VAR n.
elim (IHp x VAR n); intros.
elim (IHq x VAR n); intros.
split; intro H3; elim H3; auto.
(*uvq p*) intros p IHp x VAR n.
split; intros H y; elim (IHp x (insertVAR_O y VAR) (S n)); intros IH1 IH2;
 elim
  (VARexteq_eval_frm
     (lift_frm (S n) p)
     (insertVAR_O y (insertVAR x VAR n))
     (insertVAR x (insertVAR_O y VAR)(S n))
     (insVARswap y x n VAR)); intros H0 H1.
apply H1. apply IH1. apply H.
apply IH2. apply H0. apply H.
(*exq p*) intros p IHp x VAR n.
split; intro H; elim H; intros y H0; exists y;
 elim (IHp x (insertVAR_O y VAR) (S n)); intros IH1 IH2;
 elim
  (VARexteq_eval_frm
     (lift_frm (S n) p)
     (insertVAR_O y (insertVAR x VAR n))
     (insertVAR x (insertVAR_O y VAR)(S n))
     (insVARswap y x n VAR)); intros H1 H2.
apply H2. apply IH1. exact H0.
apply IH2. apply H1. exact H0.
Qed.

Lemma thinning_eval_frm1 :
 forall (p : F) (x : A) (VAR : nat -> A) (n : nat),
 E VAR p -> E (insertVAR x VAR n) (lift_frm n p).
Proof fun p x V n => proj1 (thinning_eval_frm p x V n).

Lemma thinning_eval_frm2 :
 forall (p : F) (x : A) (VAR : nat -> A) (n : nat),
 E (insertVAR x VAR n) (lift_frm n p) -> E VAR p.
Proof fun p x V n => proj2 (thinning_eval_frm p x V n).

Lemma thinning_eval_cxt_O :
 forall (x : A) (G : C) (VAR : nat -> A),
 Ecxt VAR G -> Ecxt (insertVAR_O x VAR) (lift_cxt 0 G).
Proof.
simple induction G.
trivial.
intros p G' IH V H.
elim H.
intros H0 H1.
split.
exact (thinning_eval_frm1 p x V 0 H0).
exact (IH V H1).
Qed.

End eval_lift_lemmas.