Require Import LibTactics.
Require Import Metalib.Metatheory.

Require Import
        syntax_ott
        syntaxb_ott
        rules_inf
        rulesb_inf
        Infrastructure
        Infrastructure_b
        Deterministic
        Typing_b
        Typing
        Type_Safety
        ttyping
        soundness_completeness.

Require Import List. Import ListNotations.
Require Import Arith Omega.
Require Import Strings.String.

Require Import Omega.

Ltac size_ind_auto :=
  ( eapply_first_lt_hyp ;
    try reflexivity;
    try omega ;
    try eauto ).

Lemma eq_type: forall A,
 (A = t_dyn) \/ ~(A = t_dyn).
Proof.
  introv.
  inductions A;
  try solve[left;
  reflexivity];
  try solve[right;
  unfold not; intros H;
  inverts* H].
Qed.

Lemma BA_AB: forall B A,
  sim A B -> sim B A.
Proof.
  introv H.
  induction* H.
Qed.

Lemma principle_if: forall v A t,
 value v -> typing nil v Inf3 A t -> principal_type v = A.
Proof.
  introv H typ.
  inductions H; inverts* typ; eauto.
Qed.

Lemma fillb_cast: forall v p b A B,
  (trm_cast v p b A B) = (fillb (castCtxb p b A B)  v).
Proof.
  introv.
  eauto.
Qed.

Lemma sim_refl: forall A,
 sim A A.
Proof.
  intros.
  inductions A; eauto.
Qed.

Lemma Tred_blame_soundness: forall v t p b A,
  typing nil (e_anno v p b A) Inf3 A t->
  value v ->
  TypedReduce v p b A (e_blame p b) ->
  t ->* (t_blame p b) .
Proof.
  introv Typ val Red.
  inductions Red; intros.
  inverts Typ. inverts H7.
  inverts H3.
  forwards* h1: typing_regular_3 H11.
  inverts H11; simpl in *.
  -
    destruct A; try solve[exfalso; apply H;eauto].
    inverts val.
    eapply bstep_b.
    apply bStep_vanyp; eauto.
    unfold not; intros n;inverts n.
    inverts* h1.
  -
    inverts val; simpl in *.
    forwards*: value_valueb1 H3.
    forwards* h2: principle_if H3.
    rewrite h2 in *.
    inverts H4.
    +
    rewrite <- TEMP in *.
    destruct A; try solve[exfalso; apply H; auto].
    destruct(eq_type A2). destruct(eq_type A1).
    subst.
    *
    eapply bstep_b.
    apply bStep_vanyp; eauto.
    unfold not; intros n;inverts n.
    *
    eapply bstep_nb.
    eapply bStep_dyna; auto.
    unfold not; intros n;inverts n.
    unfold not; intros n;inverts* n.
    rewrite fillb_cast.
    eapply bstep_b.
    apply blame_stepb; auto.
    eapply bStep_vanyp; auto.
    unfold not; intros n;inverts* n.
    *
    eapply bstep_nb.
    eapply bStep_dyna; auto.
    unfold not; intros n;inverts n.
    unfold not; intros n;inverts* n.
    rewrite fillb_cast.
    eapply bstep_b.
    apply blame_stepb; auto.
    eapply bStep_vanyp; auto.
    unfold not; intros n;inverts* n.
    +
    rewrite <- TEMP in *.
    destruct A; try solve[exfalso; apply H; auto].
    eapply bstep_b.
    apply bStep_vanyp; eauto.
    unfold not; intros n;inverts n.
Qed.

Lemma Soundness_blame_two: forall e t dir p b A,
  typing nil e dir A t->
  step e (e_blame p b) ->
  t ->* (t_blame p b).
Proof.
  introv Typ J. gen A dir t.
  inductions J; intros.
  - destruct E; unfold fill in *.
    + inverts Typ.
      * forwards*: IHJ H8.
      apply multi_blame_app2; eauto.
      forwards*: typing_regular_3 H9.
      *
      inverts H0.
      ++
      forwards*: IHJ H10.
      apply multi_blame_cast; eauto.
      apply multi_blame_app2; eauto.
      forwards*: typing_regular_3 H11.
      ++
      forwards*: typing_regular_3 H11.
      forwards*: IHJ H10.
      apply multi_blame_cast; eauto.
      apply multi_blame_app2; eauto.
      apply multi_blame_cast; eauto.
      *
      forwards*: typing_regular_3 H9.
      forwards*: IHJ H8.
      apply multi_blame_app2; eauto.
      apply multi_blame_cast; eauto.
    +
      inverts Typ.
      *
      forwards*: typing_regular_1 H9.
      forwards*: IHJ H9.
      apply multi_blame_app; eauto.
      inverts H.
      forwards*: value_valueb1 H8.
      *
      inverts H0.
      --
      forwards*: typing_regular_1 H10.
      forwards*: IHJ H11.
      inverts H.
      forwards*: value_valueb1 H10.
      apply multi_blame_cast; eauto.
      apply multi_blame_app; eauto.
      --
      inverts H.
      forwards*: principle_if H10.
      rewrite H in *. inverts H4.
      *
      inverts H.
      forwards*: principle_if H8.
      rewrite H in *. inverts H2.
    +
      forwards*: typing_regular_1 Typ. inverts H0.
      inverts Typ; try solve[forwards*: step_not_value J].
      forwards*: IHJ H9.
      inverts H0; try solve[forwards*: step_not_value J].
      forwards*: IHJ H11.
      apply multi_blame_cast; eauto.
    +
      inverts Typ.
      *
      inverts H0.
      forwards*: IHJ H5.
      apply multi_blame_cast; eauto.
      apply multi_blame_app2; eauto.
      forwards*: typing_regular_3 H7.
      *
      forwards*: typing_regular_3 H4.
      forwards*: IHJ H2.
      apply multi_blame_app2; eauto.
    +
      inverts Typ.
      *
      inverts H0.
      forwards*: IHJ H7.
      apply multi_blame_cast; eauto.
      apply multi_blame_app; eauto.
      inverts H.
      forwards*: value_valueb1 H5.
      *
      forwards*: IHJ H4.
      apply multi_blame_app; eauto.
      inverts H.
      forwards*: value_valueb1 H3.
  -
    inverts Typ.
    +
      forwards*: principle_if H11.
      rewrite H3 in *. inverts H1.
      forwards*: Tred_blame_soundness H2.
      apply multi_blame_app; eauto.
      forwards*: value_valueb1 H11.
    + inverts H3.
      forwards*: principle_if H13.
      rewrite H3 in *. inverts H1.
      forwards*: Tred_blame_soundness H2.
      apply multi_blame_cast; eauto.
      apply multi_blame_app; eauto.
      forwards*: value_valueb1 H.
      forwards*: principle_if H13.
      rewrite H3 in *. inverts H1.
    +
      forwards*: principle_if H11.
      rewrite H3 in *. inverts H1.
  -
    inverts Typ.
    *
    lets H0':H0.
    inverts* H0.
    forwards*: Tred_blame_soundness H0'.
    *
    inverts H2.
    --
    lets H0':H0.
    inverts* H0.
    forwards*: Tred_blame_soundness H0'.
    apply multi_blame_cast; eauto.
Qed.

Theorem soundness: forall e t A dir l b ,
  typing nil e dir A t->
  e ->** e_blame l b ->
  t ->* t_blame l b .
Proof.
  introv typ red. gen dir A t.
  inductions red;intros.
  -
  forwards*: soundness_mul_two H.
  inverts H0. inverts H1.
  forwards*: IHred H2.
  -
  forwards*: Soundness_blame_two typ H.
Qed.

Lemma tTypedReduce_completeness: forall v t B A l b ,
  btyping nil t B v ->
  valueb t ->
  bstep (trm_cast t l b B A) (t_blame l b) ->
  TypedReduce v l b A  (e_blame l b).
Proof.
  introv typ val red.
  forwards* h1: valueb_value2 val.
  inductions red; try solve[inverts* typ].
  -
    destruct E; unfold fillb; inverts x;
    try forwards*: bstep_not_value red.
  -
    inverts* typ; inverts h1.
    forwards* h2: btyping_typing H10.
    forwards*: principle_inf h2.
    rewrite <- H3 in *.
    eapply TReduce_blame;eauto.
    unfold not;intros nt.
    inverts H0. inverts* H.
    rewrite <- H4 in nt. inverts nt.
    inverts* H.
    rewrite <- H4 in nt. inverts nt.
Qed.

Theorem typing_elaborate_completeness_gen_blame: forall e t A n l b,
  size_exp e + size_term t < n ->
  btyping nil t A e ->
  bstep t (t_blame l b) ->
  steps e (e_blame l b).
Proof.
  introv sz Typ Red. gen e t A.
  induction n; intros; try omega.
  lets Red': Red.
  inductions Red; intros.
  - clear IHRed.
     destruct E; unfold fillb in *; simpl in *.
    +
    forwards h1: btyping_typing Typ.
    forwards* lc: Typing_regular_1 h1.
    inverts Typ; simpl in *.
    inverts h1; simpl in *.
    forwards* h2: IHn Red H3. simpl in *; omega.
    inverts lc.
    apply multi_bblame_appv2.
    auto. apply h2.
    +
    inverts Typ. inverts H.
    forwards* h1: valueb_value2 H3.
    forwards* h2: IHn Red H6. simpl in *; omega.
    apply multi_bblame_appv.
    auto. apply h2.
    +
     forwards* lc: btyping_regular_3 Typ.
     inverts Typ; simpl in *.
     inverts lc.
     forwards* h1: IHn Red H8. simpl in *; omega.
     apply multi_bblame_anno.
     apply h1.
  -
    inverts Typ.
    forwards* h1: valueb_value2 H11.
    forwards* h2: tTypedReduce_completeness H11 Red'.
    forwards* h3: value_decidable (e_anno e0 l b A0).
    inverts h3.
    +
    forwards* h4: value_tred_keep2 h2. inverts h4.
    +
    apply step_b.
    apply Step_annov; eauto.
Qed.

Theorem ttyping_completeness_blame: forall e t A n n1 l b,
  Deterministic_blame_Calculus ->
  n < n1 ->
  btyping nil t A e ->
  bbsteps t (t_blame l b) n ->
  steps e (e_blame l b).
Proof.
  introv dd sz typ red. gen t l b A e n.
  inductions n1; intros; try solve[omega].
  inverts* red.
  -
  forwards*: typing_elaborate_completeness_gen H2.
  inverts* H.
  +
  lets(ee1 &ee2&nn2& rred1&rred2&ttyp1&ssz): H0.
  destruct(nn2).
  inverts* rred1.
  *
  forwards* h1: IHn1 H4.
  omega.
  *
  assert(n =0).
  omega.
  rewrite H in *.
  inverts* rred1.
  inverts* H7.
  assert(bbsteps ee2 (t_blame l b) (n0-1)).
  inverts H4.
  forwards* h1: dd H6 H7. inverts h1.
  simpl;eauto.
  assert(n2-0 = n2). omega.
  rewrite H1;eauto.
  forwards* h2: dd H6 H8.
  inverts* h2.
  forwards*: IHn1 H1.
  omega.
  +
  inverts* H0. inverts* H. inverts* H0.
  inverts* H4.
  forwards* h2: dd H H6.
  inverts* h2.
  forwards* h2: dd H H7.
  inverts* h2.
  -
  forwards*:  typing_elaborate_completeness_gen_blame H3.
Qed.

(* complete 2 *)

Lemma Tred_completeness_blame: forall v t B A l b ,
  ttyping nil v (Chk2 l b B) A t ->
  valueb t ->
  bstep (trm_cast t l b B A) (t_blame l b) ->
  TypedReduce v l b A (e_blame l b).
Proof.
  introv typ val red.
  forwards*: valueb_value val.
  inductions red; try solve[inverts* H].
  -
    destruct E; unfold fillb; inverts x;
    try forwards*: bstep_not_value red.
  -
    inverts typ; try solve[inverts H0].
    inverts H9.
    +
    inverts H3.
    inverts* H11; try solve[forwards*: abs_nlam].
    forwards*: principle_if2 H10.
    rewrite <- H3 in *; eauto.
    eapply TReduce_blame; eauto.
    unfold not; intros nt.
    inverts H0. inverts H.
    rewrite <- H4 in *.
    exfalso; apply H1; auto.
    rewrite <- H4 in *.
    inverts nt.
    inverts nt.
    rewrite <- H5 in *.
    inverts H.
    exfalso; apply H1; auto.
    rewrite <- H5 in *.
    inverts H.
    +
    eapply TReduce_blame; eauto; simpl.
    unfold not; intros nt.
    inverts nt.
    inverts H0.
    inverts H.
    inverts H4; try solve[forwards*: abs_nlam].
    exfalso; apply H1; auto.
    inverts* H0.
Qed.

Lemma completeness_blame_two2: forall e t dir p b A n,
  size_exp e + size_term t < n ->
  ttyping nil e dir A t->
  bstep t (t_blame p b) ->
  steps e (e_blame p b).
Proof.
  introv sz Typ J. gen t p b A dir e.
  induction n; intros;try solve[omega].
  inductions J; intros.
  - destruct E; unfold fill in *.
  + inverts Typ; simpl in *.
    * forwards: IHn J H6. simpl in *; omega.
    apply multi_bblame_app2; eauto.
    forwards*: ttyping_regular_1 H7.
    inverts* H1.
    *
    forwards: ttyping_regular_1 H6.
    forwards: ttyping_regular_1 H7.
    destruct(value_decidable e0). auto.
    --
    lets red: J. inverts red.
    destruct E; unfold fillb in *; inverts H3.
    forwards: value_valueb H6; auto.
    forwards: bstep_not_value H9. eauto.
    inverts H4.
    forwards: Tred_completeness_blame J ; auto.
    destruct(lambda_decidable e0); eauto.
    inverts H2; try solve[inverts H6;
    exfalso; apply H3; eauto].
    inverts H2; inverts H6;
    try solve[inverts H3;simpl in *;
    exfalso; apply H15; auto].
    inverts H1.
    eapply stars_transb.
    apply stars_one.
    apply Step_betad; eauto.
    apply multi_bblame_app2; auto.
    apply step_b.
    eapply Step_annov; eauto.
    unfold not;intros nt;inverts nt.
    inverts H16.
    inverts H10.
    inverts H17; try solve[forwards: abs_nlam H19;inverts H2].
    exfalso; apply H13; auto.
    --
    assert(not(valueb t1)).
    unfold not;intros nt.
    forwards*: valueb_value H6.
    lets red: J. inverts red;
    try solve[exfalso; apply H3; eauto].
    destruct E; unfold fillb in *; inverts H4.
    forwards: IHn H10 H6. omega.
    inverts H1.
    apply multi_bblame_app2; eauto.
    *
    inverts H0. inverts H10.
    *
    inverts H0; try solve[inverts H3;inverts H12 ].
    --
    forwards: IHn J H7. simpl in *; omega.
    apply multi_bblame_app2; eauto.
    forwards*: ttyping_regular_1 H9. inverts* H3.
    --
    forwards: ttyping_regular_1 H9.
    forwards: ttyping_regular_1 H7.
    destruct(value_decidable e0). auto.
    ---
    lets red: J. inverts red.
    destruct E; unfold fillb in *; inverts H5.
    forwards: value_valueb H7; auto.
    forwards: bstep_not_value H11. eauto.
    inverts H6.
    forwards: Tred_completeness_blame J ; auto.
    destruct(lambda_decidable e0); eauto.
    inverts H4; try solve[inverts H7;
    exfalso; apply H5; eauto].
    inverts H4; inverts H5;
    try solve[inverts H3;simpl in *;
    exfalso; apply H15; auto].
    inverts H0.
    eapply stars_transb.
    apply stars_one.
    apply Step_betad; eauto.
    apply multi_bblame_app2; auto.
    apply step_b.
    eapply Step_annov; eauto.
    unfold not;intros nt;inverts nt.
    inverts H18.
    ---
    assert(not(valueb t1)).
    unfold not;intros nt.
    forwards*: valueb_value H7.
    lets red: J. inverts red;
    try solve[exfalso; apply H5; eauto].
    destruct E; unfold fillb in *; inverts H6.
    forwards: IHn H12 H7. simpl in *;omega.
    inverts H0.
    apply multi_bblame_app2; eauto.
    --
    forwards:IHn J H5. simpl in * ; omega.
    forwards lc1: ttyping_regular_1 H8.
    apply multi_bblame_appv2; auto.
    *
    forwards:IHn J H2. simpl in * ; omega.
    forwards lc1: ttyping_regular_1 H7.
    apply multi_bblame_appv2; auto.
  +
    forwards: ttyping_regular_3 Typ. simpl in *. inverts H0.
    inverts Typ; simpl in *; try solve[forwards: bstep_not_value J].
    *
    inverts H9.
    ++
    forwards: ttyping_regular_1 H11.
    destruct(value_decidable e2); auto.
    --
      forwards: value_valueb H11; auto.
      assert(l0 = p).
      inverts* J;
      destruct E; unfold fillb in ; inverts H6;
      forwards*: bstep_not_value H13.
      assert(b0 = b).
      inverts* J;
      destruct E; unfold fillb in ; inverts H7;
      forwards: bstep_not_value H14; auto.
      inverts H7.
      subst.
      forwards: Tred_completeness_blame H11; auto.
      inverts H.
      forwards: valueb_value H8; auto.
      forwards: principle_if2 H8; auto.
      eapply step_b.
      eapply Step_betap; auto.
      apply H7. apply H6.
    --
      assert(not(valueb t0)).
      unfold not; intros nt.
      forwards: valueb_value H11; auto.
      inverts H.
      forwards: valueb_value H8; auto.
      lets red: J.
      inverts J.
      destruct E; unfold fillb in *; inverts H6.
      forwards: IHn H14 H11. simpl in *; omega.
      forwards: principle_if2 H8. auto.
      eapply multi_bblame_app; auto.
      apply H9.
      forwards: Tred_completeness_blame H11; auto.
      forwards: valueb_value H11; auto.
      forwards: principle_if2 H8; auto.
      eapply step_b.
      eapply Step_betap; auto.
      apply H10. apply H6.
    ++
    forwards: ttyping_regular_1 H11.
    forwards: value_valueb H11; auto.
    forwards: bstep_not_value J; auto.
    inverts H5.
    *
    inverts H. inverts H1.
    *
    inverts H0. inverts H12.
    *
    inverts H0.
    --
    inverts H11.
    ++
    forwards: ttyping_regular_1 H13.
    destruct(value_decidable e2); auto.
    ---
      forwards: value_valueb H13; auto.
      assert(l1 = p).
      inverts* J;
      try solve[
      destruct E; unfold fillb in ; inverts H8;
      forwards: bstep_not_value H15;auto;inverts H8].
      assert(b1 = b).
      inverts* J;
      try solve[
      destruct E; unfold fillb in ; inverts H10;
      forwards: bstep_not_value H16; auto;inverts H10].
      inverts H8. inverts H10.
      forwards: Tred_completeness_blame H13; auto.
      inverts H.
      forwards: valueb_value H9; auto.
      forwards: principle_if2 H9; auto.
      eapply step_b.
      eapply Step_betap; auto.
      apply H10. apply H8.
    ---
      assert(not(valueb t0)).
      unfold not; intros nt.
      forwards: valueb_value H13; auto.
      inverts H.
      forwards: valueb_value H9; auto.
      lets red: J.
      inverts J.
      destruct E; unfold fillb in *; inverts H8.
      forwards: IHn H16 H13. simpl in *; omega.
      forwards: principle_if2 H9. auto.
      eapply multi_bblame_app; auto.
      apply H11.
      forwards: Tred_completeness_blame H13; auto.
      forwards: valueb_value H13; auto.
      forwards: principle_if2 H9; auto.
      eapply step_b.
      eapply Step_betap; auto.
      apply H12. apply H8.
    ++
    forwards: ttyping_regular_1 H13.
    forwards: value_valueb H13;auto.
    forwards: bstep_not_value J.
    auto.
    inverts H7.
    --
    inverts H. inverts H5.
    --
    inverts H5. inverts H14.
    --
    forwards:IHn J H10. simpl in * ; omega.
    inverts H.
    forwards: valueb_value H7. auto.
    apply multi_bblame_appv; auto.
    *
    forwards:IHn J H9. simpl in * ; omega.
    inverts H.
    forwards: valueb_value H2. auto.
    apply multi_bblame_appv; auto.
  +
    simpl in *. forwards: ttyping_regular_3 Typ. inverts H0.
    inverts Typ; simpl in *; try solve[inverts J];
    try solve[forwards: bstep_not_value J; auto;inverts H0].
    *
    forwards: IHn J H7. simpl in *; omega.
    apply multi_bblame_anno; eauto.
    *
    inverts H0; try solve[forwards: bstep_not_value J;auto;inverts H0].
    inverts H11.
    *
    inverts H0; try solve[forwards: bstep_not_value J].
    forwards: IHJ H10; auto. simpl in *; omega.
    apply multi_bblame_anno; eauto.
    inverts H4; try solve[forwards: bstep_not_value J;auto;inverts H0].
    inverts H13.
  -
   inverts Typ.
   +
   forwards: Tred_completeness_blame H9; auto.
   forwards: ttyping_regular_1 H9.
   apply step_b.
   destruct(value_decidable (e_anno e0 p b B)); eauto.
   forwards: value_tred_keep2 H3;auto. inverts H6.
   apply Step_annov; eauto.
   forwards: valueb_value H9;auto.
   +
   inverts H3; inverts H13.
   +
   inverts H3.
   *
   forwards: Tred_completeness_blame H12; auto.
   forwards: ttyping_regular_1 H12.
   apply step_b.
   destruct(value_decidable (e_anno e0 p b B)); eauto.
   forwards: value_tred_keep2 H7.
   apply H3.
   inverts H8.
   apply Step_annov; eauto.
   forwards: valueb_value H12;auto.
   *
   inverts H6. inverts H11.
Qed.

Theorem typing_elaborate_completeness_blame2: forall e t A n n1 l b dir,
  Deterministic_blame_Calculus ->
  n < n1 ->
  ttyping nil e dir A t->
  bbsteps t (t_blame l b) n ->
  steps e (e_blame l b).
Proof.
  introv dd sz typ red. gen t l b dir A e n.
  inductions n1; intros; try solve[omega].
  inverts* red.
  -
  forwards*:  typing_elaborate_completeness_dir H2.
  inverts* H.
  +
  lets(ee1 &ee2&nn2& rred1&rred2&ttyp1&ssz): H0.
  destruct(nn2).
  inverts* rred1.
  *
  forwards* h1: IHn1 H4.
  omega.
  *
  assert(n =0).
  omega.
  rewrite H in *.
  inverts* rred1.
  inverts* H7.
  assert(bbsteps ee2 (t_blame l b) (n0-1)).
  inverts H4.
  forwards* h1: dd H6 H7. inverts h1.
  simpl;eauto.
  assert(n2-0 = n2). omega.
  rewrite H1;eauto.
  forwards* h2: dd H6 H8.
  inverts* h2.
  forwards*: IHn1 H1.
  omega.
  +
  inverts* H0. inverts* H. inverts* H0.
  inverts* H4.
  forwards* h2: dd H H6.
  inverts* h2.
  forwards* h2: dd H H7.
  inverts* h2.
  -
  forwards*:  completeness_blame_two2 H3.
Qed.

(* sound2 *)

Lemma Tred_blame_soundness2: forall v t p b A,
  ttyping nil (e_anno v p b A) Inf2 A t->
  value v ->
  TypedReduce v p b A (e_blame p b) ->
  t ->* (t_blame p b) .
Proof.
  introv Typ val Red.
  inductions Red; intros.
  inverts Typ. inverts H7.
  inverts H6; simpl in *.
  -
    inverts H10; try solve[forwards*: abs_nlam].
    inverts val.
    forwards*: principle_if2 H6.
    forwards*: value_valueb H6.
    rewrite H0 in *.
    inverts H2.
    +
    destruct A.
    *
    rewrite <- TEMP in *.
    exfalso; apply H; auto.
    *
    destruct(eq_type A1). destruct(eq_type A2).
    subst.
    --
    apply bstep_b.
    eapply bStep_vanyp; auto.
    unfold not;intros nt;inverts nt.
    --
    eapply star_transb.
    eapply star_one.
    eapply bStep_dyna;auto.
    unfold not;intros nt;inverts nt.
    unfold not;intros nt;inverts nt.
    exfalso;apply H2; auto.
    eapply bstep_b.
    rewrite fillb_cast.
    eapply blame_stepb;eauto.
    eapply bStep_vanyp; auto.
    unfold not;intros nt;inverts nt.
    --
    eapply star_transb.
    eapply star_one.
    eapply bStep_dyna;auto.
    unfold not;intros nt;inverts nt.
    unfold not;intros nt;inverts nt.
    exfalso;apply H0; auto.
    eapply bstep_b.
    rewrite fillb_cast.
    eapply blame_stepb;eauto.
    eapply bStep_vanyp; auto.
    unfold not;intros nt;inverts nt.
    *
    rewrite <- TEMP in *.
    exfalso; apply H; auto.
    +
    destruct A.
    *
    apply bstep_b.
    eapply bStep_vanyp; auto.
    unfold not;intros nt;inverts nt.
    *
    rewrite <- TEMP in *.
    exfalso; apply H; auto.
    *
    rewrite <- TEMP in *.
    exfalso; apply H; auto.
  -
    inverts val; simpl in *.
    forwards: value_valueb H10; auto.
    inverts H10; try solve[inverts H17].
    +
    destruct A.
    *
    inverts H0.
    apply bstep_b.
    eapply bStep_vanyp; auto.
    unfold not;intros nt;inverts nt.
    *
    exfalso; apply H; auto.
    *
    exfalso; apply H; auto.
    +
    destruct A.
    *
    inverts H0.
    apply bstep_b.
    eapply bStep_vanyp; auto.
    unfold not;intros nt;inverts nt.
    *
    exfalso; apply H; auto.
    *
    exfalso; apply H; auto.
Qed.

Lemma Soundness_blame_two2: forall e t dir p b A,
  ttyping nil e dir A t->
  step e (e_blame p b) ->
  t ->* (t_blame p b).
Proof.
  introv Typ J. gen A dir t.
  inductions J; intros.
  - destruct E; unfold fill in *.
    + inverts* Typ.
      * forwards*: IHJ H8.
      apply multi_blame_app2; eauto.
      forwards*: ttyping_regular_3 H9.
      *
      forwards*: ttyping_regular_3 H9.
      forwards*: IHJ H8.
      apply multi_blame_app2; eauto.
      apply multi_blame_cast; eauto.
      *
      inverts H0.
      ++
      forwards*: IHJ H10.
      apply multi_blame_app2; eauto.
      forwards*: ttyping_regular_3 H11.
      ++
      forwards*: ttyping_regular_3 H11.
      forwards*: IHJ H10.
      apply multi_blame_app2; eauto.
      apply multi_blame_cast; eauto.
    +
      inverts Typ.
      *
      forwards*: ttyping_regular_1 H9. inverts H0.
      inverts H9; try solve[forwards*: step_not_value J].
      forwards*: IHJ H10.
      apply multi_blame_app; eauto.
      inverts H.
      forwards*: value_valueb H8.
      apply multi_blame_cast; eauto.
      *
      inverts H.
      forwards*: principle_if2 H8.
      rewrite H in *. inverts H2.
      *
      inverts H0.
      --
      forwards*: ttyping_regular_1 H11. inverts H0.
      inverts H11; try solve[forwards*: step_not_value J].
      forwards*: IHJ H12.
      apply multi_blame_app; eauto.
      inverts H.
      forwards*: value_valueb H10.
      apply multi_blame_cast; eauto.
      --
      inverts H.
      forwards*: principle_if2 H10.
      rewrite H in *. inverts H4.
    +
      forwards*: ttyping_regular_1 Typ. inverts H0.
      inverts Typ; try solve[forwards*: step_not_value J].
      forwards*: IHJ H9.
      apply multi_blame_cast; eauto.
      forwards*: ttyping_regular_1 H0. inverts H4.
      inverts H0; try solve[forwards*: step_not_value J].
      forwards*: IHJ H12.
      apply multi_blame_cast; eauto.
    +
      forwards*: ttyping_regular_3 Typ.
      inverts Typ; try solve[forwards*: step_not_value J].
      *
      inverts H1.
      inverts H0.
      forwards*: IHJ H6.
      apply multi_blame_app2; eauto.
      *
      inverts H0.
      forwards*: IHJ H3.
      apply multi_blame_app2; eauto.
    +
      forwards*: ttyping_regular_3 Typ.
      inverts H.
      inverts Typ; try solve[forwards*: step_not_value J].
      *
      inverts H.
      forwards*: value_valueb H6.
      forwards*: IHJ H8.
      apply multi_blame_app; eauto.
      *
      forwards*: value_valueb H3.
      forwards*: IHJ H5.
      apply multi_blame_app; eauto.
  -
   inverts Typ.
   +
    forwards*: principle_if2 H11.
    rewrite H3 in *. inverts H1.
    forwards*: Tred_blame_soundness2 H2.
    apply multi_blame_app; eauto.
    forwards*: value_valueb H11.
   +
      forwards*: principle_if2 H11.
      rewrite H3 in *. inverts H1.
   + inverts H3.
     forwards*: principle_if2 H13.
    rewrite H3 in *. inverts H1.
    forwards*: Tred_blame_soundness2 H2.
    apply multi_blame_app; eauto.
    forwards*: value_valueb H.
    forwards*: principle_if2 H13.
    rewrite H3 in *. inverts H1.
  - inverts Typ.
    *
    lets H0':H0.
    inverts* H0.
    forwards*: Tred_blame_soundness2 H0'.
    *
    lets H0':H0.
    inverts* H0.
    *
    inverts H2.
    --
    lets H0':H0.
    inverts* H0.
    forwards*: Tred_blame_soundness2 H0'.
    --
    lets H0':H0.
    inverts* H0.
Qed.

Theorem soundness2: forall e t A dir l b ,
  ttyping nil e dir A t->
  e ->** e_blame l b ->
  t ->* t_blame l b .
Proof.
  introv typ red. gen dir A t.
  inductions red;intros.
  -
  forwards*: typing_elaborate_soundness_dir2 H.
  inverts H0. inverts H1.
  forwards*: IHred H2.
  -
  forwards*: Soundness_blame_two2 typ H.
Qed.


(** * A constructor for polymorphic types *)

Require Import Omega.
Require Import Coq.Logic.Decidable.
Require Import Coq.Program.Basics.
Require Import Coq.Program.Equality.
Require Import Coq.Setoids.Setoid.
Require Import Coq.Classes.RelationClasses.
Require Import Coq.Classes.Morphisms.
Require Import Coq.Arith.Compare_dec.
Require Import Coq.Arith.Plus.
Require Export InformationOrdering.
Require Import Nontermination.
Require Import LeastFixedPoint.
Require Import BohmTrees.
Open Scope code_scope.

(* ------------------------------------------------------------------------ *)
(** ** Components for Bohm-out moves *)

Section pair.
  Context {Var : Set}.
  Let x := make_var Var 0.
  Let y := make_var Var 1.
  Let f := make_var Var 2.
  Definition pair := Eval compute in close_var (\x,\y,\f, f * x * y).
End pair.
Notation "[ x , y ]" := (pair * x * y)%code : code_scope.
Notation "[ x ]" := (C * I * x)%code : code_scope.

Lemma pair_extensionality (Var : Set) (x y x' y' : Code Var) :
  [x, y] [= [x', y'] <-> x [= x' /\ y [= y'.
Proof.
  unfold pair; beta_simpl; split.
    intro H; split.
      apply (code_le_ap_left _ _ _ K) in H; beta_simpl in H; auto.
    apply (code_le_ap_left _ _ _ (K*I)) in H; beta_simpl in H; auto.
  intros [Hx Hy]; auto.
Qed.

Section raise.
  Context {Var : Set}.

  Definition raise : Code Var := K.
  Definition lower : Code Var := [TOP].

  Definition pull : Code Var := K || K * div.
  Definition push : Code Var := [BOT].
End raise.

Lemma lower_raise (Var : Set) (x : Code Var) : lower * (raise * x) == x.
Proof.
  unfold lower, raise; beta_simpl; reflexivity.
Qed.

Lemma push_pull (Var : Set) (x : Code Var) : push * (pull * x) == x.
Proof.
  unfold push, pull; code_simpl; reflexivity.
Qed.

Lemma lower_pull (Var : Set) (x : Code Var) : lower * (pull * x) == TOP.
Proof.
  unfold lower, pull; code_simpl;
  rewrite code_eq_div; code_simpl; reflexivity.
Qed.

Section exp.
  Context {Var : Set}.
  Let a := make_var Var 0.
  Let b := make_var Var 1.
  Let f := make_var Var 2.
  Definition exp := Eval compute in close_var (\a, \b, \f, b o f o a).
End exp.
Notation "x --> y" := (exp * x * y)%code : code_scope.

Lemma exp_i_i (Var : Set) : I --> I == (I : Code Var).
Proof.
  unfold exp; beta_eta.
Qed.

Section compose.
  Context {Var : Set}.
  Let s := make_var Var 0.
  Let a := make_var Var 1.
  Let a' := make_var Var 2.
  Let b := make_var Var 3.
  Let b' := make_var Var 4.

  Definition compose := Eval compute in close_var
    (\s, s*\a,\a', s*\b,\b', [a o b, b' o a']).

  Definition conjugate := Eval compute in close_var
    (\s, s*\a,\a', s*\b,\b', [a' --> b, a --> b']).
End compose.

Lemma compose_pair_le (Var : Set) (s1 r1 s2 r2 : Code Var) :
  [s1 o s2, r2 o r1] [= compose * ([s1, r1] || [s2, r2]).
Proof.
  unfold compose, pair; beta_reduce.
  rewrite pi_j_left, pi_j_right; reflexivity.
Qed.

Lemma conjugate_pair_le (Var : Set) (s1 r1 s2 r2 : Code Var) :
  [r1 --> s2, s1 --> r2] [= conjugate * ([s1, r1] || [s2, r2]).
Proof.
  unfold conjugate, pair; beta_reduce.
  rewrite pi_j_left, pi_j_right.
  unfold exp; code_simpl; reflexivity.
Qed.

(* ------------------------------------------------------------------------ *)
(** ** A constructive definition of [A] *)

Definition A_step {Var : Set} : Code Var
  := K * ([I, I] || [raise, lower] || [pull, push])
    || (compose || conjugate).

Definition A {Var : Set} : Code Var := Eval compute in Y * A_step.

Lemma A_simpl (Var : Set) : (A : Code Var) == Y * A_step.
Proof.
  (freeze code_eq in compute); auto.
Qed.

Ltac A_simpl := rewrite A_simpl; unfold A_step.

(** We will make much use of the following theorems *)

Theorem A_fixes (Var : Set) (f x : Code Var) :
  (forall s r : Code Var, r o s [= I -> f * s * r * x [= x) ->
  A * f * x [= x.
Proof.
  intro H.
  (* TODO use a join argument: A = Join ys and forall y in ys, y f x [= x *)
Admitted.

Lemma A_exp_top (Var : Set) : A * exp * TOP == (TOP : Code Var).
Proof.
  split; auto.
  A_simpl; unfold exp, pair; rewrite code_eq_y; do 3 rewrite pi_j_left.
  eta_expand as x; beta_simpl; auto.
Qed.

(* ------------------------------------------------------------------------ *)
(** ** Using the Bohm-out method through [A] *)

Lemma A_move_i_i (Var : Set) : [I, I] [= (A : Code Var).
Proof.
  A_simpl;
  rewrite code_eq_y, pi_j_left, beta_k, pi_j_left, pi_j_left;
  reflexivity.
Qed.

Lemma A_move_raise_lower (Var : Set) : [raise, lower] [= (A : Code Var).
Proof.
  A_simpl;
  rewrite code_eq_y, pi_j_left, beta_k, pi_j_left, pi_j_right;
  reflexivity.
Qed.

Lemma A_move_pull_push (Var : Set) : [pull, push] [= (A : Code Var).
Proof.
  A_simpl; rewrite code_eq_y, pi_j_left, beta_k, pi_j_right;
  reflexivity.
Qed.

Lemma A_move_compose (Var : Set) (s1 r1 s2 r2 : Code Var) :
  [s1, r1] [= A -> [s2, r2] [= A -> [s1 o s2, r2 o r1] [= A.
Proof.
  rewrite A_simpl at 3; rewrite code_eq_y; rewrite <- A_simpl.
  unfold A_step; rewrite pi_j_right, pi_j_left.
  intros H1 H2.
  assert ([s1, r1] || [s2, r2] [= A) as H; auto; rewrite <- H.
  apply compose_pair_le.
Qed.

Lemma A_move_conjugate (Var : Set) (s1 r1 s2 r2 : Code Var) :
  [s1, r1] [= A -> [s2, r2] [= A -> [r1 --> s2, s1 --> r2] [= A.
Proof.
  rewrite A_simpl at 3; rewrite code_eq_y; rewrite <- A_simpl.
  unfold A_step; rewrite pi_j_right, pi_j_right.
  intros H1 H2.
  assert ([s1, r1] || [s2, r2] [= A) as H; auto; rewrite <- H.
  apply conjugate_pair_le.
Qed.

Lemma A_move_raise_lower_n (Var : Set) (n : nat) :
  [raise^n, lower^n] [= (A : Code Var).
Proof.
  induction n; simpl.
  - apply A_move_i_i.
  - rewrite power_commute_1'; apply A_move_compose; auto.
    apply A_move_raise_lower.
Qed.

Lemma A_move_pull_push_n (Var : Set) (n : nat) :
  [pull^n, push^n] [= (A : Code Var).
Proof.
  induction n; simpl.
  - apply A_move_i_i.
  - rewrite power_commute_1'; apply A_move_compose; auto.
    apply A_move_pull_push.
Qed.

Hint Resolve
  A_move_i_i A_move_raise_lower A_move_pull_push
  A_move_compose A_move_conjugate
  A_move_raise_lower_n A_move_pull_push_n
  : A_moves.

Lemma lower_top (n : nat) : lower^n * TOP == (TOP : ClosedCode).
Proof.
  induction n; simpl; code_simpl; auto.
  rewrite IHn; unfold lower; code_simpl; auto.
Qed.

Lemma push_top (n : nat) : push^n * TOP == (TOP : ClosedCode).
Proof.
  induction n; simpl; code_simpl; auto.
  rewrite IHn; unfold push; code_simpl; auto.
Qed.

Lemma lower_k (n : nat) (x : ClosedCode) : lower^n * (K^n * x) == x.
Proof.
  revert x; induction n; intro x; simpl; code_simpl; auto.
  setoid_rewrite power_commute_1 at 2.
  rewrite IHn; unfold lower; beta_simpl; reflexivity.
Qed.

Lemma push_k (n : nat) (x : ClosedCode) : push^n * (K^n * x) == x.
Proof.
  revert x; induction n; intro x; simpl; code_simpl; auto.
  setoid_rewrite power_commute_1 at 2.
  rewrite IHn; unfold push; beta_simpl; reflexivity.
Qed.

Lemma raise_c_i_bot (n : nat) (x : ClosedCode) :
  [BOT]^n * (raise^n * x) == x.
Proof.
  revert x; induction n; intro x; simpl; code_simpl; auto.
  rewrite power_commute_1, IHn; unfold raise; beta_simpl; reflexivity.
Qed.

Lemma pull_c_i_bot (n : nat) (x : ClosedCode) :
  [BOT]^n * (pull^n * x) == x.
Proof.
  revert x; induction n; intro x; simpl; code_simpl; auto.
  rewrite power_commute_1, IHn; unfold pull; code_simpl; reflexivity.
Qed.

Ltac bohm_out :=
  split; code_simpl; auto with A_moves;
  eta_expand; code_simpl.

Lemma bohm_out_repair (b : nat) :
  exists s r : ClosedCode, [s, r] [= A /\ I [= r o K ^ b o [BOT] ^ b o s.
Proof.
  exists (raise^b), (lower^b); bohm_out.
  rewrite raise_c_i_bot, lower_k; reflexivity.
Qed.

Lemma bohm_out_too_many_args (k d : nat) :
  exists s r : ClosedCode, [s, r] [= A /\
  TOP [= r o K ^ k o [BOT] ^ (1 + k + d) o s.
Proof.
  exists (raise^(1+d+k) o pull), (push o lower^(1+d+k)); bohm_out.
  replace (1 + k + d) with (1 + d + k) by omega.
  rewrite power_add, raise_c_i_bot, lower_k.
  replace (1 + d) with (d + 1) by omega.
  rewrite power_add; code_simpl.
  rewrite lower_pull, lower_top.
  unfold push; code_simpl; auto.
Qed.

Lemma bohm_out_too_few_args (b d : nat) :
  exists s r : ClosedCode, [s, r] [= A /\
  TOP [= r o K ^ (1 + d + b) o [BOT] ^ b o s.
Proof.
  exists (pull^(1+d+b) o raise), (lower o push^(1+d+b)); bohm_out.
  rewrite push_k; code_simpl.
  replace (1 + d + b) with (b + (1 + d)) by omega.
  rewrite power_add; code_simpl.
  rewrite pull_c_i_bot, power_add; simpl; beta_simpl.
  rewrite lower_pull; reflexivity.
Qed.

Lemma bohm_out_wrong_head (h k b : nat) :
  exists s r : ClosedCode, [s, r] [= A /\
  TOP [= r o (K ^ (1 + h) * K ^ k o [BOT] ^ b) o s.
Proof.
  exists (raise^(k+1+h)), (lower^(k+1+h)); bohm_out.
  setoid_rewrite power_add at 1; simpl; code_simpl.
  rewrite lower_k.
  setoid_rewrite power_add; simpl; code_simpl.
  unfold lower at 2; code_simpl.
  rewrite lower_k.
  apply push_top.
Qed.

(* ------------------------------------------------------------------------ *)
(** ** Construction of Bohm tree witnesses *)

Lemma lt_add (p q : nat) : p <= q -> exists r, q = p + r.
Proof.
  intro H; induction H; eauto.
  destruct IHle as [r IH].
  exists (Succ r); rewrite IH; auto.
Qed.

Lemma nle_bot_witness (x : ClosedCode) :
  ~x [= BOT -> exists h k b, K ^ h * K ^ k o [BOT] ^ b [= x.
Proof.
  intro H; apply conv_nle_bot in H.
  rewrite conv_closed in H; destruct H as [y [xy yt]].
  apply weaken_probe in xy; apply weaken_pi in yt.
  dependent induction yt; eauto.
  - admit.
  - admit.
Qed.

(** This follows %\cite{obermeyer2009equational}% pp. 48 Lemma 3.6.11. *)

Theorem A_repairs_pair (i : ClosedCode) :
  ~ i [= BOT -> exists s r, [s, r] [= A /\ I [= r o i o s.
Proof.
  intro H; apply nle_bot_witness in H; destruct H as [h [k [b H]]].
  setoid_rewrite <- H; clear H i.
  destruct h.
  - (* case: correct head variable *)
    simpl; setoid_rewrite beta_i; setoid_rewrite code_eq_b_assoc.
    set (kb := lt_eq_lt_dec k b); destruct kb as [[Hlt | Heq] | Hgt].
    + (* case: too many arguments *)
      apply lt_add in Hlt; destruct Hlt as [d Ed]; subst.
      replace (Datatypes.S k) with (1 + k) by omega.
      setoid_rewrite (@code_le_top _ I) at 1.
      apply bohm_out_too_many_args.
    + (* case: correct number of arguments *)
      subst.
      apply bohm_out_repair.
    + (* case: too few arguments *)
      apply lt_add in Hgt; destruct Hgt as [d Ed]; subst.
      replace (Datatypes.S b + d) with (1 + d + b) by omega.
      setoid_rewrite (@code_le_top _ I) at 1.
      eapply bohm_out_too_few_args.
  - (* case: incorrect head variable *)
    replace (Datatypes.S h) with (1 + h) by omega.
    setoid_rewrite (@code_le_top _ I) at 1.
    apply bohm_out_wrong_head.
Qed.

Corollary A_repairs (i : ClosedCode) : ~ i [= BOT -> I [= A * exp * i.
Proof.
  intro H; apply A_repairs_pair in H; destruct H as [s [r [Ha Hi]]].
  rewrite <- Ha; unfold pair, exp; code_simpl.
  assumption.
Qed.

(* TODO state and prove a [nle_i_witness] lemma
Inductive Increasing : ClosedCode -> Prop :=
  | Increasing_head (h k b : nat) :
      Increasing (K ^ (1 + h) * K ^ k o [BOT] ^ b)
  | Increasing_arg : ???
.

Lemma nle_i_witness (x : ClosedCode) : ~x [= I -> ???.
*)

Theorem A_raises_pair (i : ClosedCode) :
  ~ i [= I -> exists s r, [s, r] [= A /\ TOP [= r o i o s.
Proof.
  admit.
Qed.

Corollary A_raises (i : ClosedCode) : ~ i [= I -> TOP [= A * exp * i.
Proof.
  intro H; apply A_raises_pair in H; destruct H as [s [r [Ha Hi]]].
  rewrite <- Ha; unfold pair, exp; code_simpl.
  assumption.
Qed.

(* TODO the following two theorems need stronger induction hypotheses,
   of higher type *)

Theorem A_repairs' (i : ClosedCode) : ~ i [= BOT -> I [= A * exp * i.
Proof.
  repeat rewrite <- decompile_le.
  do 2 rewrite decompile_app; freeze A in freeze exp in simpl.
  set (i' := decompile i); subst.
  intro H; apply nle_normal_witness in H; destruct H as [n [Hn [ni nb]]].
  rewrite <- ni; clear i i' ni; revert nb.
  induction Hn; intro Hnle.
  - admit. (* TODO deal with TOP *)
  - assert ((BOT [= (BOT : Term Var))%term); [reflexivity | contradiction].
  - rewrite term_le_join in Hnle.
    apply not_and in Hnle; auto.
    destruct Hnle as [Hx | Hy];
    [rewrite <- term_le_join_left | rewrite <- term_le_join_right]; auto.
  - admit.  (* TODO use [pconv] instead of [conv] *)
  (* the last three cases require shifting down and up type. *)
  - admit.  (* TODO prove a lemma about [inert] terms *)
  - admit.
Qed.

Theorem A_raises' (i : ClosedCode) : ~ i [= I -> TOP [= A * exp * i.
Proof.
  repeat rewrite <- decompile_le.
  do 2 rewrite decompile_app; freeze A in freeze exp in simpl.
  set (i' := decompile i); subst.
  intro H; apply nle_normal_witness in H; destruct H as [n [Hn [ni nb]]].
  rewrite <- ni; clear i i' ni; revert nb.
  induction Hn; intro Hnle.
  - admit. (* TODO deal with TOP *)
  - assert ((BOT [= (DeBruijn.I : Term Var))%term);
      [term_to_code | contradiction].
  - rewrite term_le_join in Hnle.
    apply not_and in Hnle; auto.
    destruct Hnle as [Hx | Hy];
    [rewrite <- term_le_join_left | rewrite <- term_le_join_right]; auto.
  - admit.  (* TODO use [pconv] instead of [conv] *)
  (* the last three cases require shifting down and up type. *)
  - admit.  (* TODO prove a lemma about [inert] terms *)
  - admit.
Qed.

(** To generalize to probability,
    we need two parametrized relations [code_ple] and [code_pnle] meaning
    that at least [p] of the time, [code_le] or [~ code_le] holds.
    Note that [code_pnle] is stronger than
    "it is false that [code_le] holds at least p of the time".
    *)

Definition code_ple (p : dyadic) {Var : Set} (x y : Code Var) :=
  x [= dyadic_sub x y p.

(* FIXME Is this right? *)
Definition code_pnle (p : dyadic) {Var : Set} (x y : Code Var) :=
  ~ x || y [= dyadic_sub x y p.

Theorem A_repairs_prob (i : ClosedCode) (p : dyadic) :
  code_pnle p i BOT -> code_ple p I (A * exp * i).
Proof.
  admit.
Qed.

Theorem A_raises_prob (i : ClosedCode) (p : dyadic) :
  ~ i [= (dyadic_sub BOT I p) -> dyadic_sub BOT TOP p [= A * exp * i.
Proof.
  admit.
Qed.

Notation "\\ x , y ; z" := (A * \x, \y, z)%code : code_scope.

Section A_example.
  Variable Var : Set.
  Let a := make_var Var 0.
  Let a' := make_var Var 1.
  Let A_example : Code Var := close_var (\\a,a'; a --> a').
End A_example.


Require Import UFO.Lang.Syntax.
Require Import TLC.LibList.
Local Open Scope list_scope.

Set Implicit Arguments.

Implicit Types EP EV LV V L : Set.

(** An equivalence relation up to renaming lifetime identifiers *)

Section section_sim.

Context (Xs₁ Xs₂ : list var).

Definition var_sim X₁ X₂ : Prop :=
∃ n, Nth n Xs₁ X₁ ∧ Nth n Xs₂ X₂.

Inductive lid_sim L : lid L → lid L → Prop :=
| lid_f_sim : ∀ X₁ X₂, var_sim X₁ X₂ → lid_sim (lid_f X₁) (lid_f X₂)
| lid_b_sim : ∀ I, lid_sim (lid_b I) (lid_b I)
.

Inductive lbl_sim LV L : lbl LV L → lbl LV L → Prop :=
| lbl_var_sim : ∀ β, lbl_sim (lbl_var β) (lbl_var β)
| lbl_id_sim : ∀ ι₁ ι₂, lid_sim ι₁ ι₂ → lbl_sim (lbl_id ι₁) (lbl_id ι₂)
.

Inductive ef_sim EP EV LV L : ef EP EV LV L → ef EP EV LV L → Prop :=
| ef_par_sim : ∀ α, ef_sim (ef_par α) (ef_par α)
| ef_var_sim : ∀ α, ef_sim (ef_var α) (ef_var α)
| ef_lbl_sim : ∀ E₁ E₂, lbl_sim E₁ E₂ → ef_sim (ef_lbl E₁) (ef_lbl E₂)
.

Inductive eff_sim EP EV LV L : eff EP EV LV L → eff EP EV LV L → Prop :=
| eff_nil_sim : eff_sim [] []
| eff_cons_sim :
  ∀ e₁ E₁ e₂ E₂, ef_sim e₁ e₂ → eff_sim E₁ E₂ →
  eff_sim (e₁ :: E₁) (e₂ :: E₂)
.

Inductive it_sim EP EV LV L : ∀ κ, it EP EV LV L κ → it EP EV LV L κ → Prop :=
| it_name_sim : ∀ F, it_sim (it_name F) (it_name F)
| it_inst_sim : ∀ κ N₁ N₂ E₁ E₂, it_sim N₁ N₂ → eff_sim E₁ E₂ → it_sim (κ := κ) (it_inst N₁ E₁) (it_inst N₂ E₂)
.

Inductive
ms_sim EP EV LV L : ms EP EV LV L → ms EP EV LV L → Prop :=
| ms_ev_sim :
  ∀ σ₁ σ₂, @ms_sim _ _ _ _ σ₁ σ₂ → ms_sim (ms_ev σ₁) (ms_ev σ₂)
| ms_lv_sim :
  ∀ σ₁ σ₂, @ms_sim _ _ _ _ σ₁ σ₂ → ms_sim (ms_lv σ₁) (ms_lv σ₂)
| ms_tm_sim :
  ∀ T₁ σ₁ T₂ σ₂, ty_sim T₁ T₂ → ms_sim σ₁ σ₂ → ms_sim (ms_tm T₁ σ₁) (ms_tm T₂ σ₂)
| ms_res_sim :
  ∀ T₁ E₁ T₂ E₂, ty_sim T₁ T₂ → eff_sim E₁ E₂ → ms_sim (ms_res T₁ E₁) (ms_res T₂ E₂)
with
ty_sim EP EV LV L : ty EP EV LV L → ty EP EV LV L → Prop :=
| ty_unit_sim : ty_sim 𝟙 𝟙
| ty_it_sim : ∀ N₁ N₂ ℓ₁ ℓ₂, it_sim N₁ N₂ → lbl_sim ℓ₁ ℓ₂ → ty_sim (ty_it N₁ ℓ₁) (ty_it N₂ ℓ₂)
| ty_ms_sim :
  ∀ σ₁ E₁ σ₂ E₂, ms_sim σ₁ σ₂ → lbl_sim E₁ E₂ → ty_sim (ty_ms σ₁ E₁) (ty_ms σ₂ E₂)
| ty_cont_sim :
  ∀ TA₁ TA₂ EA₁ EA₂ TB₁ TB₂ EB₁ EB₂,
  ty_sim TA₁ TA₂ → eff_sim EA₁ EA₂ → ty_sim TB₁ TB₂ → eff_sim EB₁ EB₂ →
  ty_sim (ty_cont TA₁ EA₁ TB₁ EB₁) (ty_cont TA₂ EA₂ TB₂ EB₂)
.

Inductive
md_sim EV LV V L : md EV LV V L → md EV LV V L → Prop :=
| md_ev_sim : ∀ m₁ m₂, @md_sim _ _ _ _ m₁ m₂ → md_sim (md_ev m₁) (md_ev m₂)
| md_lv_sim : ∀ m₁ m₂, @md_sim _ _ _ _ m₁ m₂ → md_sim (md_lv m₁) (md_lv m₂)
| md_tm_sim : ∀ m₁ m₂, @md_sim _ _ _ _ m₁ m₂ → md_sim (md_tm m₁) (md_tm m₂)
| md_res_sim : ∀ t₁ t₂, @tm_sim _ _ _ _ t₁ t₂ → md_sim (md_res t₁) (md_res t₂)
with
ktx_sim EV LV V L : ktx EV LV V L → ktx EV LV V L → Prop :=
| ktx_hole_sim : ktx_sim ktx_hole ktx_hole
| ktx_op_sim :
  ∀ K₁ K₂, ktx_sim K₁ K₂ → ktx_sim (ktx_op K₁) (ktx_op K₂)
| ktx_up_sim :
  ∀ K₁ K₂, ktx_sim K₁ K₂ → ktx_sim (ktx_up K₁) (ktx_up K₂)
| ktx_down_sim :
  ∀ K₁ K₂ X₁ X₂, ktx_sim K₁ K₂ → var_sim X₁ X₂ → ktx_sim (ktx_down K₁ X₁) (ktx_down K₂ X₂)
| ktx_let_sim :
  ∀ K₁ K₂ t₁ t₂,
  ktx_sim K₁ K₂ → @tm_sim _ _ _ _ t₁ t₂ →
  ktx_sim (ktx_let K₁ t₁) (ktx_let K₂ t₂)
| ktx_throw_sim :
  ∀ K₁ K₂ t₁ t₂,
  ktx_sim K₁ K₂ → tm_sim t₁ t₂ →
  ktx_sim (ktx_throw K₁ t₁) (ktx_throw K₂ t₂)
| ktx_app_eff_sim :
  ∀ K₁ K₂ E₁ E₂,
  ktx_sim K₁ K₂ → eff_sim E₁ E₂ →
  ktx_sim (ktx_app_eff K₁ E₁) (ktx_app_eff K₂ E₂)
| ktx_app_lbl_sim :
  ∀ K₁ K₂ E₁ E₂,
  ktx_sim K₁ K₂ → lbl_sim E₁ E₂ →
  ktx_sim (ktx_app_lbl K₁ E₁) (ktx_app_lbl K₂ E₂)
| ktx_app_tm1_sim :
  ∀ K₁ K₂ t₁ t₂,
  ktx_sim K₁ K₂ → tm_sim t₁ t₂ →
  ktx_sim (ktx_app_tm1 K₁ t₁) (ktx_app_tm1 K₂ t₂)
| ktx_app_tm2_sim :
  ∀ K₁ K₂ v₁ v₂,
  ktx_sim K₁ K₂ → val_sim v₁ v₂ →
  ktx_sim (ktx_app_tm2 K₁ v₁) (ktx_app_tm2 K₂ v₂)
with
val_sim EV LV V L : val EV LV V L → val EV LV V L → Prop :=
| val_unit_sim : val_sim val_unit val_unit
| val_var_sim : ∀ x, val_sim (val_var x) (val_var x)
| val_cont_sim : ∀ K₁ K₂, ktx_sim K₁ K₂ → val_sim (val_cont K₁) (val_cont K₂)
| val_md_sim :
  ∀ m₁ ι₁ m₂ ι₂,
  md_sim m₁ m₂ → lid_sim ι₁ ι₂ →
  val_sim (val_md m₁ ι₁) (val_md m₂ ι₂)
| val_fix_sim :
  ∀ m₁ ι₁ m₂ ι₂,
  md_sim (V := inc V) m₁ m₂ → lid_sim ι₁ ι₂ →
  val_sim (val_fix m₁ ι₁) (val_fix m₂ ι₂)
with
tm_sim EV LV V L : tm EV LV V L → tm EV LV V L → Prop :=
| tm_val_sim : ∀ v₁ v₂, val_sim v₁ v₂ → tm_sim (tm_val v₁) (tm_val v₂)
| tm_op_sim : ∀ t₁ t₂, tm_sim t₁ t₂ → tm_sim (tm_op t₁) (tm_op t₂)
| tm_up_sim : ∀ t₁ t₂, tm_sim t₁ t₂ → tm_sim (tm_up t₁) (tm_up t₂)
| tm_Down_sim :
  ∀ t₁ t₂, @tm_sim _ _ _ _ t₁ t₂ → tm_sim (⬇ t₁) (⬇ t₂)
| tm_down_sim :
  ∀ X₁ t₁ X₂ t₂, var_sim X₁ X₂ → tm_sim t₁ t₂ → tm_sim (⇩ X₁ t₁) (⇩ X₂ t₂)
| tm_let_sim :
  ∀ t₁ s₁ t₂ s₂,
  tm_sim t₁ t₂ → @tm_sim _ _ _ _ s₁ s₂ →
  tm_sim (tm_let t₁ s₁) (tm_let t₂ s₂)
| tm_throw_sim :
  ∀ t₁ s₁ t₂ s₂,
  tm_sim t₁ t₂ → tm_sim s₁ s₂ →
  tm_sim (tm_throw t₁ s₁) (tm_throw t₂ s₂)
| tm_app_eff_sim :
  ∀ t₁ E₁ t₂ E₂,
  tm_sim t₁ t₂ → eff_sim E₁ E₂ →
  tm_sim (tm_app_eff t₁ E₁) (tm_app_eff t₂ E₂)
| tm_app_lbl_sim :
  ∀ t₁ E₁ t₂ E₂,
  tm_sim t₁ t₂ → lbl_sim E₁ E₂ →
  tm_sim (tm_app_lbl t₁ E₁) (tm_app_lbl t₂ E₂)
| tm_app_tm_sim :
  ∀ t₁ s₁ t₂ s₂,
  tm_sim t₁ t₂ → tm_sim s₁ s₂ →
  tm_sim (tm_app_tm t₁ s₁) (tm_app_tm t₂ s₂)
.

Definition xEnv_sim EV LV V (Γ₁ Γ₂ : V → ty ∅ EV LV ∅) : Prop :=
∀ x, ty_sim (Γ₁ x) (Γ₂ x).

End section_sim.

Fixpoint XEnv_sim_aux (Xs₁ Xs₂ : list var) EV LV (Ξ₁ Ξ₂ : XEnv EV LV) : Prop :=
match Ξ₁, Ξ₂ with
| [], [] => True
| (X₁, (T₁, E₁)) :: Ξ₁, (X₂, (T₂, E₂)) :: Ξ₂ =>
  ty_sim Xs₁ Xs₂ T₁ T₂ ∧ eff_sim Xs₁ Xs₂ E₁ E₂ ∧
  XEnv_sim_aux (X₁ :: Xs₁) (X₂ :: Xs₂) Ξ₁ Ξ₂
| _, _ => False
end.

Definition XEnv_sim EV LV (Ξ₁ Ξ₂ : XEnv EV LV) : Prop :=
XEnv_sim_aux [] [] Ξ₁ Ξ₂.


Load LFindLoad.
Load LFindLoad.
From adtind Require Import goal35.

From lfind Require Import LFind.
Lemma lfind_state  (y:natural):@eq natural (plus Zero y) (plus y Zero).
Admitted.
From QuickChick Require Import QuickChick.
QCInclude "/home/yousef/lemmafinder/benchmark/_lfind_clam_lf_goal35_plus_commut_61_plus_zero/".
QCInclude ".".
Extract Constant defNumTests => "50".
Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Open Scope string_scope.

Parameter print : natural -> string -> natural.
Extract Constant print => "Extract.print".
Definition collect_data  (y:natural) :=
 let lfind_var := "y:" ++ "(" ++ show y ++ ")"
 in let lfind_v := print y lfind_var
 in lfind_state lfind_v .
QuickChick collect_data.
Success.


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

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma lfind_hyp_test : (@eq natural (plus (mult (Zero) (Zero)) (Zero)) (mult (Zero) (Succ (Zero)))).
Admitted.
QuickChick lfind_hyp_test.


Require Import Crypto.Specific.Framework.SynthesisFramework.
Require Import Crypto.Specific.solinas64_2e224m2e96p1_5limbs.CurveParameters.

Module P <: PrePackage.
  Definition package : Tag.Context.
  Proof. make_Synthesis_package curve extra_prove_mul_eq extra_prove_square_eq. Defined.
End P.

Module Export S := PackageSynthesis P.


From Equations Require Import Equations.
Require Import List.
(* This type is from VST:
 * https://github.com/PrincetonUniversity/VST/blob/v2.1/floyd/compact_prod_sum.v#L13 *)
Fixpoint compact_sum (T: list Type): Type :=
  match T with
  | nil => unit
  | t :: nil => t
  | t :: T0 => (t + compact_sum T0)%type
end.

(* The rest is a nonsensical, just to give a minimalistic reproducible example *)
Inductive foo :=
| Sum : (foo * list foo) -> foo.

Equations foo_type (t : foo) : Type :=
  foo_type (Sum u) :=
    (foo_type (fst u))
    * (compact_sum (List.map foo_type (snd u))).

(* Moving val into the return type, rather than having it as an argument
   might be unnecessary if
   https://github.com/mattam82/Coq-Equations/issues/73 was fixed *)
Equations do_foo (f : foo) : forall (val : foo_type f), nat := {
  do_foo (Sum s) := fun val =>
    (do_foo (fst s) (fst val)) + (do_sum (snd s) (snd val)) }

  where
    do_sum (fs : list foo) :
      forall val : compact_sum (List.map foo_type fs), nat
      by struct fs := {
    do_sum nil := fun val => 0;
    (* Attempting to work around https://github.com/mattam82/Coq-Equations/issues/78 *)
    do_sum (cons hd tl) with (fun val => do_sum tl val) => {
      do_sum (cons var nil) _ :=
        fun val => do_foo var val;
      do_sum (cons hd tl) do_foo_tl := fun val =>
        match val with
        | inl vh => do_foo hd vh
        | inr vstl => do_foo_tl vstl
        end }}.


Require Import Crypto.Specific.Framework.SynthesisFramework.
Require Import Crypto.Specific.solinas64_2e450m2e225m1_8limbs.CurveParameters.

Module P <: PrePackage.
  Definition package : Tag.Context.
  Proof. make_Synthesis_package curve extra_prove_mul_eq extra_prove_square_eq. Defined.
End P.

Module Export S := PackageSynthesis P.


Require Import Crypto.Specific.Framework.SynthesisFramework.
Require Import Crypto.Specific.solinas32_2e216m2e108m1_8limbs.CurveParameters.

Module P <: PrePackage.
  Definition package : Tag.Context.
  Proof. make_Synthesis_package curve extra_prove_mul_eq extra_prove_square_eq. Defined.
End P.

Module Export S := PackageSynthesis P.


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

 This defines the dynamic semantics of statements and expressions, pg. 58, 59.

*)

Set Implicit Arguments.
Require Export LanguageModuleDef.
(* Import the types langauge to make this more readable. *)
Require Export DynamicSemanticsTypeSubstitution.
Require Export DynamicSemanticsHeapObjects.

Inductive S : Heap -> St -> Heap -> St -> Prop :=

 | S_let_3_1 : forall (x : EV.T) (v : E) (h : Heap) (s: St),
                 Value v ->
                 H.map h x = None ->
                 S h (letx x v s) (H.ctxt x v h) s

 | S_seq_3_2 : forall (v : E) (h : Heap) (s: St),
                  Value v ->
                  S h (seq (e_s v) s) h s

 | S_return_3_3: forall (v : E) (h : Heap) (s: St),
                    Value v ->
                    S h (seq (retn v) s) h (retn v)

 | S_if0_3_4: forall (h : Heap) (s1 s2: St),
                 S h (if_s (i_e (i_i 0)) s1 s2)
                   h s1

 | S_if_ne_0_3_5: forall (h : Heap) (z : Z) (s1 s2: St),
                     z <> Z0 ->
                     S h (if_s (i_e (i_i z)) s1 s2)
                       h s2

 | S_while_3_6: forall (h : Heap) (e : E) (s : St),
                     S h (while e s)
                       h (if_s e (seq s (while e s)) (e_s (i_e (i_i 0))))

| S_open_3_7:  forall (tau tau' : Tau) (v : E) (p : Phi) (k : Kappa) (alpha : TV.T) (x x': EV.T) (h : Heap) (s : St),
                  Value v ->
                  S h (open (pack tau' v (etype p alpha k tau)) alpha x s)
                    h (letx x' v (subst_St s tau alpha))

| S_openstar_3_8: forall (tau tau' : Tau) (v v' : E) (q : Phi) (k : Kappa) (alpha : TV.T) (x x': EV.T) (h : Heap) (s : St) (p : Pth.Path),
                    Value v ->
                    x <> x' ->
                    get v' p (pack tau' v (etype q alpha k tau)) ->
                    (* S is part of the context not the heap, overloading ; in DS3.8 *)
                    (* x' is right, openstar uses *x' but I am eliding it in the syntax. *)
                    H.map h x = Some v' ->
                    S h (openstar (p_e x p) alpha x' s)
                      h (letx x'  (amp (p_e x (p ++ [Pth.u_pe])))
                                     (subst_St s tau alpha))

| S_exp_3_9_1: forall (h h' : Heap) (e e' : E),
                   R h (e_s e) h' (e_s e') ->
                   S h (e_s e) h' (e_s e')

| S_ret_3_9_2: forall (h h' : Heap) (e e' : E),
                   R h (e_s e) h' (e_s e') ->
                   S h (retn e) h' (retn e')

| S_if_3_9_3: forall (h h' : Heap) (e e' : E) (s1 s2 : St),
                   R h (e_s e) h' (e_s e') ->
                   S h (if_s e s1 s2) h' (if_s e' s1 s2)

| S_letx_3_9_4: forall (h h' : Heap) (e e' : E) (s : St) (x : EV.T),
                   R h (e_s e) h' (e_s e') ->
                   S h (letx x e s) h' (letx x e' s)

| S_open_3_9_5: forall (h h' : Heap) (e e' : E) (x : EV.T) (alpha : TV.T) (s : St),
                   R h (e_s e) h' (e_s e') ->
                   S h  (open e  alpha x s)
                        h' (open e' alpha x s)

| S_seq_3_10:  forall (h h' : Heap) (s s' s2: St),
                    S h s h' s' ->
                    S h  (seq s  s2) h' (seq s' s2)

| S_openstar_3_11: forall (h h' : Heap) (e e' : E) (x : EV.T) (alpha : TV.T) (s : St),
                        L h  (e_s e) h' (e_s e') ->
                        S h  (openstar e  alpha x s)
                          h' (openstar e' alpha x s)

with R : Heap -> St -> Heap -> St -> Prop :=
 | R_get_3_1 : forall (h  : Heap) (x : EV.T) (p : Pth.Path) (v v' : E),
                    H.map h x = Some v' ->
                    get v' p v ->
                    Value v ->
                    Value v' ->
                    R h (e_s (p_e x p))
                      h (e_s v)

 | R_assign_3_2:
     forall (h' h : Heap) (v v' v'' : E) (x : EV.T) (p : Pth.Path),
       H.map h x = Some v' ->
       set v' p v v'' ->
       H.add h x v'' = h' ->
       Value v   ->
       Value v'  ->
       Value v'' ->
       R h  (e_s (assign (p_e x p) v))
         h' (e_s v)

 | R_initial_assign_3_2:
     forall (h' h : Heap) (v : E) (x : EV.T),
       H.map h x = None ->
       H.add h x v = h' ->
       Value v   ->
       R h  (e_s (assign (p_e x []) v))
         h' (e_s v)

 | R_star_amp_3_3:
                 forall (h : Heap) (x : EV.T) (p : Pth.Path),
                   R h (e_s (star (amp (p_e x p))))
                     h (e_s (p_e x p))

 (* Split on 0 or 1. *)
 | R_dot_3_4_0:  forall (h : Heap) (v0 v1 : E),
                    R h (e_s (dot (cpair v0 v1) Pth.zero_pe))
                      h (e_s v0)

 | R_dot_3_4_1:  forall (h : Heap) (v0 v1 : E),
                    R h (e_s (dot (cpair v0 v1) Pth.one_pe))
                      h (e_s v1)

 | R_appl_3_5:   forall (h : Heap) (x : EV.T) (tau tau' : Tau) (v : E) (s : St),
                    Value v ->
                    R h (e_s (appl (f_e (dfun tau x tau' s)) v))
                      h (e_s (call (letx x v s)))

 | R_call_3_6:    forall (h : Heap) (v : E),
                    Value v ->
                    R h (e_s (call (retn v)))
                      h (e_s v)

 | R_inst_3_7:  forall (h : Heap) (alpha : TV.T) (k : Kappa) (f : F) (tau : Tau),
                  R h (e_s (inst (f_e (ufun alpha k f)) tau))
                    h (e_s (f_e (subst_F f tau alpha)))

 | R_call_3_8:  forall (h h': Heap) (s s': St),
                  S h s h' s' ->
                  R h (e_s (call s)) h' (e_s (call s'))

 | R_amp_3_9_1: forall (h h' : Heap) (e e' : E),
                   L h (e_s e)       h' (e_s e') ->
                   R h (e_s (amp e)) h' (e_s (amp e'))

 | R_assign_3_9_2: forall (h h' : Heap) (e e' e2: E),
                   L h (e_s e)             h' (e_s e') ->
                   R h (e_s (assign e e2)) h' (e_s (assign e' e2))

 | R_star_3_10_1: forall (h h' : Heap) (e e' : E),
                    R h (e_s e)        h' (e_s e') ->
                    R h (e_s (star e)) h' (e_s (star e'))

 | R_dot_3_10_2: forall (h h' : Heap) (e e' : E) (ipe : Pth.IPE),
                    R h (e_s e) h' (e_s e') ->
                    R h  (e_s (dot e  ipe))
                      h' (e_s (dot e' ipe))

 | R_assign_3_10_3: forall (h h' : Heap) (e e' : E) (x : EV.T) (p : Pth.Path),
                    R h (e_s e) h' (e_s e') ->
                    R h  (e_s (assign (p_e x p) e))
                      h' (e_s (assign (p_e x p) e'))

 | R_inst_3_10_4:  forall (h h' : Heap) (e e' : E) (tau : Tau),
                 R h (e_s e) h' (e_s e') ->
                 R h  (e_s (inst e tau))
                   h' (e_s (inst e' tau))

 | R_pack_3_10_5:  forall (h h' : Heap) (e e' : E) (tau tau' : Tau) (p : Phi) (k : Kappa) (alpha : TV.T),
                    R h (e_s e)        h' (e_s e') ->
                    R h  (e_s (pack tau' e  (etype p alpha k tau)))
                      h' (e_s (pack tau' e' (etype p alpha k tau)))

 | R_cpair_3_10_6:  forall (h h' : Heap) (e e' e2 : E),
                    R h (e_s e) h' (e_s e') ->
                    R h  (e_s (cpair e e2))
                      h' (e_s (cpair e' e2))

 | R_cpair_3_10_7:  forall (h h' : Heap) (e e' v : E),
                    Value v ->
                    R h (e_s e) h' (e_s e') ->
                    R h  (e_s (cpair v e))
                      h' (e_s (cpair v e'))

 | R_cpair_3_10_8:  forall (h h' : Heap) (e e' e2 : E),
                    R h (e_s e) h' (e_s e') ->
                    R h  (e_s (cpair e e2))
                      h' (e_s (cpair e' e2))

 | R_appl_3_10_9:  forall (h h' : Heap) (e e' e2 : E),
                    R h  (e_s e) h' (e_s e') ->
                    R h  (e_s (appl e e2))
                      h' (e_s (appl e' e2))

 | R_appl_3_10_10: forall (h h' : Heap) (v e e': E),
                     Value v ->
                     R h  (e_s e) h' (e_s e') ->
                     R h  (e_s (appl v e))
                       h' (e_s (appl v e'))

with L : Heap -> St -> Heap -> St -> Prop :=

 | L_xpi_3_1: forall (h : Heap) (x : EV.T) (p : Pth.Path) (ipe : Pth.IPE),
                L h (e_s (dot (p_e x p) ipe))
                  h (e_s (p_e x (p ++ [Pth.i_pe ipe])))

 | L_staramp_3_2: forall (h : Heap) (x : EV.T) (p : Pth.Path),
                    L h (e_s (star (amp (p_e x p))))
                      h (e_s (p_e x p))

 | L_star_3_3: forall (h h' : Heap) (e e': E),
                 R h (e_s e)        h' (e_s e') ->
                 L h (e_s (star e)) h' (e_s (star e'))

 | L_ei_3_4: forall (h h' : Heap) (e e': E) (ipe : Pth.IPE),
               L h (e_s e)                h' (e_s e') ->
               L h (e_s (dot e ipe))  h' (e_s (dot e' ipe)).

Scheme R_ind_mutual := Induction for R Sort Prop
with   S_ind_mutual := Induction for S Sort Prop
with   L_ind_mutual := Induction for L Sort Prop.
Combined Scheme SLR_ind_mutual
         from S_ind_mutual, L_ind_mutual, R_ind_mutual.

(* Transitive, reflexive closure of S. *)

Inductive multi (R : Heap -> St -> Heap -> St -> Prop)
              : Heap -> St -> Heap -> St -> Prop :=
  | multi_refl  : forall (h h' : Heap) (s s' : St),
                    multi R h s h' s'
  | multi_step : forall (h h' h'': Heap) (s s' s'' : St),
                    R h s h' s' ->
                    multi R h' s' h'' s'' ->
                    multi R h s h'' s''.

Definition Sstar := (multi S).


Require Import TestSuite.admit.
Require Coq.Lists.List.
Require Coq.Sets.Ensembles.
Import Coq.Sets.Ensembles.
Global Set Implicit Arguments.
Delimit Scope comp_scope with comp.
Inductive Comp : Type -> Type :=
| Return : forall A, A -> Comp A
| Bind : forall A B, Comp A -> (A -> Comp B) -> Comp B
| Pick : forall A, Ensemble A -> Comp A.
Notation ret := Return.
Notation "x <- y ; z" := (Bind y%comp (fun x => z%comp))
                           (at level 81, right associativity,
                            format "'[v' x  <-  y ; '/' z ']'") : comp_scope.
Axiom refine : forall {A} (old : Comp A) (new : Comp A), Prop.
Open Scope comp.
Axiom elements : forall {A} (ls : list A), Ensemble A.
Axiom to_list : forall {A} (S : Ensemble A), Comp (list A).
Axiom finite_set_handle_cardinal : refine (ret 0) (ret 0).
Definition sumUniqueSpec (ls : list nat) : Comp nat.
  exact (ls' <- to_list (elements ls);
         List.fold_right (fun a b' => Bind b' ((fun a b => ret (a + b)) a)) (ret 0) ls').
Defined.
Axiom admit : forall {T}, T.
Definition sumUniqueImpl (ls : list nat)
: { c : _ | refine (sumUniqueSpec ls) (ret c) }%type.
Proof.
  eexists.
  match goal with
    | [ |- refine ?a ?b ] => let a' := eval hnf in a in change (refine a' b)
  end.
  try setoid_rewrite (@finite_set_handle_cardinal).
Abort.


Require Import ReflParam.common.
Require Import ReflParam.templateCoqMisc.
Require Import String.
Require Import List.
Require Import Template.Ast.
Require Import SquiggleEq.terms.
Require Import ReflParam.paramDirect ReflParam.indType.
Require Import SquiggleEq.substitution.
Require Import ReflParam.PiTypeR.
Import ListNotations.
Open Scope string_scope.

Inductive multInd2 (A I : Set) (B: I-> Set) (f: A-> I) (g: forall i, B i)
  : forall (i:I) (b:B i), Set  :=
mlind2 : forall a
(dd:forall (aa:A), multInd2 A I B f g (f aa) (g (f aa))),
multInd2 A I B f g (f a) (g (f a))

|mlind2d : forall aaaa
(ddd:forall (aaa:A), multInd2 A I B f g (f aaa) (g (f aaa))),
multInd2 A I B f g (f aaaa) (g (f aaaa)).

Inductive multInd (A I : Set) (B: I-> Set) (f: A-> I) (g: forall i, B i)
  : forall (i:I) (b:B i), Set  :=
mlind : forall a
(dd:forall (aa:A), multInd A I B f g (f a) (g (f a))),
multInd A I B f g (f a) (g (f a)).

Require Import SquiggleEq.UsefulTypes.

Run TemplateProgram (genParamIndAll [] "Top.multIndices4.multInd").

Check Top_multIndices4_multInd_pmtcty_RR0_constr_0_inv.
(*
Top_multIndices4_multInd_pmtcty_RR0_constr_0_inv
     : forall (A A₂ : Set) (A_R : A -> A₂ -> Prop) (I I₂ : Set)
         (I_R : I -> I₂ -> Prop) (B : I -> Set) (B₂ : I₂ -> Set)
         (B_R : forall (H : I) (H0 : I₂), I_R H H0 -> B H -> B₂ H0 -> Prop)
         (f : A -> I) (f₂ : A₂ -> I₂)
         (f_R : forall (H : A) (H0 : A₂), A_R H H0 -> I_R (f H) (f₂ H0))
         (g : forall i : I, B i) (g₂ : forall i₂ : I₂, B₂ i₂)
         (g_R : forall (i : I) (i₂ : I₂) (i_R : I_R i i₂), B_R i i₂ i_R (g i) (g₂ i₂))
         (a : A) (a₂ : A₂) (dd : A -> multInd A I B f g (f a) (g (f a)))
         (dd₂ : A₂ -> multInd A₂ I₂ B₂ f₂ g₂ (f₂ a₂) (g₂ (f₂ a₂)))
         (i_R : I_R (f a) (f₂ a₂)) (b_R : B_R (f a) (f₂ a₂) i_R (g (f a)) (g₂ (f₂ a₂)))
         (sigt_R : {a_R : A_R a a₂ &
                   {_
                   : forall (aa : A) (aa₂ : A₂),
                     A_R aa aa₂ ->
                     Top_multIndices4_multInd_pmtcty_RR0 A A₂ A_R I I₂ I_R B B₂ B_R f f₂ f_R
                       g g₂ g_R (f a) (f₂ a₂) (f_R a a₂ a_R) (g (f a))
                       (g₂ (f₂ a₂)) (g_R (f a) (f₂ a₂) (f_R a a₂ a_R))
                       (dd aa) (dd₂ aa₂) &
                   Top_multIndices4_multInd_pmtcty_RR0_indices A A₂ A_R I I₂ I_R B B₂ B_R f
                     f₂ f_R g g₂ g_R (f a) (f₂ a₂) (f_R a a₂ a_R)
                     (g (f a)) (g₂ (f₂ a₂)) (g_R (f a) (f₂ a₂) (f_R a a₂ a_R)) i_R b_R}})
         (retTyp_R : forall (i_R0 : I_R (f a) (f₂ a₂))
                       (b_R0 : B_R (f a) (f₂ a₂) i_R0 (g (f a)) (g₂ (f₂ a₂))),
                     {a_R : A_R a a₂ &
                     {_
                     : forall (aa : A) (aa₂ : A₂),
                       A_R aa aa₂ ->
                       Top_multIndices4_multInd_pmtcty_RR0 A A₂ A_R I I₂ I_R B B₂ B_R f f₂
                         f_R g g₂ g_R (f a) (f₂ a₂) (f_R a a₂ a_R)
                         (g (f a)) (g₂ (f₂ a₂)) (g_R (f a) (f₂ a₂) (f_R a a₂ a_R))
                         (dd aa) (dd₂ aa₂) &
                     Top_multIndices4_multInd_pmtcty_RR0_indices A A₂ A_R I I₂ I_R B B₂ B_R
                       f f₂ f_R g g₂ g_R (f a) (f₂ a₂) (f_R a a₂ a_R)
                       (g (f a)) (g₂ (f₂ a₂)) (g_R (f a) (f₂ a₂) (f_R a a₂ a_R)) i_R0 b_R0}} ->
                     Trecord.IndicesInvUniv),
       (forall (a_R : A_R a a₂)
          (dd_R : forall (aa : A) (aa₂ : A₂),
                  A_R aa aa₂ ->
                  Top_multIndices4_multInd_pmtcty_RR0 A A₂ A_R I I₂ I_R B B₂ B_R f f₂ f_R g
                    g₂ g_R (f a) (f₂ a₂) (f_R a a₂ a_R) (g (f a))
                    (g₂ (f₂ a₂)) (g_R (f a) (f₂ a₂) (f_R a a₂ a_R))
                    (dd aa) (dd₂ aa₂)),
        retTyp_R (f_R a a₂ a_R) (g_R (f a) (f₂ a₂) (f_R a a₂ a_R))
          (existT
             (fun a_R0 : A_R a a₂ =>
              {_
              : forall (aa : A) (aa₂ : A₂),
                A_R aa aa₂ ->
                Top_multIndices4_multInd_pmtcty_RR0 A A₂ A_R I I₂ I_R B B₂ B_R f f₂ f_R g g₂
                  g_R (f a) (f₂ a₂) (f_R a a₂ a_R0) (g (f a)) (g₂ (f₂ a₂))
                  (g_R (f a) (f₂ a₂) (f_R a a₂ a_R0)) (dd aa) (dd₂ aa₂) &
              Top_multIndices4_multInd_pmtcty_RR0_indices A A₂ A_R I I₂ I_R B B₂ B_R f f₂
                f_R g g₂ g_R (f a) (f₂ a₂) (f_R a a₂ a_R0) (g (f a))
                (g₂ (f₂ a₂)) (g_R (f a) (f₂ a₂) (f_R a a₂ a_R0))
                (f_R a a₂ a_R) (g_R (f a) (f₂ a₂) (f_R a a₂ a_R))}) a_R
             (existT
                (fun
                   _ : forall (aa : A) (aa₂ : A₂),
                       A_R aa aa₂ ->
                       Top_multIndices4_multInd_pmtcty_RR0 A A₂ A_R I I₂ I_R B B₂ B_R f f₂
                         f_R g g₂ g_R (f a) (f₂ a₂) (f_R a a₂ a_R)
                         (g (f a)) (g₂ (f₂ a₂)) (g_R (f a) (f₂ a₂) (f_R a a₂ a_R))
                         (dd aa) (dd₂ aa₂) =>
                 Top_multIndices4_multInd_pmtcty_RR0_indices A A₂ A_R I I₂ I_R B B₂ B_R f f₂
                   f_R g g₂ g_R (f a) (f₂ a₂) (f_R a a₂ a_R) (g (f a))
                   (g₂ (f₂ a₂)) (g_R (f a) (f₂ a₂) (f_R a a₂ a_R))
                   (f_R a a₂ a_R) (g_R (f a) (f₂ a₂) (f_R a a₂ a_R))) dd_R
                (Top_multIndices4_multInd_pmtcty_RR0_indicesc A A₂ A_R I I₂ I_R B B₂ B_R f
                   f₂ f_R g g₂ g_R (f a) (f₂ a₂) (f_R a a₂ a_R)
                   (g (f a)) (g₂ (f₂ a₂)) (g_R (f a) (f₂ a₂) (f_R a a₂ a_R)))))) ->
       retTyp_R i_R b_R sigt_R
*)

Run TemplateProgram (genParamIndAll [] "Top.multIndices4.multInd2").
Require Import ReflParam.Trecord.

Run TemplateProgram (mkIndEnv "indTransEnv" ["Top.multIndices4.multInd";
"Top.multIndices4.multInd2"]).
Run TemplateProgram (genWrappers indTransEnv).


Require Export Coq.Vectors.Vector.
Require Import Coq.Vectors.Fin.
(* Coding of the element of particular ordinal with two natural numbers.
(n+1) - total, m - number.  $m \in (n+1)$ *)
Print t.
Compute t 0.
Fixpoint code (n m:nat): t (S n).
Proof.
destruct n.
+ exact (F1).
+ destruct m.
  - exact (F1).
  - refine (FS _).
    exact (code n m).
Defined.
(* The same, last elements:
Compute code 2 3.
Compute code 2 2.*)

Section sec0.
Parameter SetFVars : Set.
Parameter SetBVars : Set.
Parameter Constants : Set.
Parameter FuncSymb : Set.
Parameter PredSymb : Set.
Parameter valfs : FuncSymb -> nat.
Parameter valpr : PredSymb -> nat.

(*
Hypothesis PVarseq_dec:forall x y:PropVars,{x=y}+{not(x=y)}.
Hypothesis FVarseq_dec:forall x y:SetFVars,{x=y}+{not(x=y)}.
Hypothesis BVarseq_dec:forall x y:SetBVars,{x=y}+{not(x=y)}.
*)

Inductive Term:Set:=
| CC  :> Constants -> Term
| FVC :> SetFVars  -> Term
| FSC (f:FuncSymb) :  (t (valfs f)-> Term) -> Term.

(* OK
Reserved Notation " x 'NotIn' a "  (at level 70, a at level 9, no associativity).
Inductive qw : Type
:= | tqt (x:Prop)(a:Prop): x NotIn a -> qw
where " x 'NotIn' a " := (x=a).
*)

Reserved Notation " x 'NotIn' a "  (at level 70, a at level 9, no associativity).
(*Inductive qw : Type
:= | tqt (x:Prop)(a:Prop): x NotIn a -> qw
where " x 'NotIn' a " := (x=a).
NotIn (x:SetFVars)(A:PropF) := True.*)

Check prod.

Inductive it:Set:=
|co1 :it
|co2 :it.

Fixpoint ni0 (x:SetFVars) (a:it) : Prop.
destruct a.
exact False.
exact True.
Defined.
Print ni0.

(*Incorrect Formulas*)
Inductive Fo:Set:=
|Atom (p:PredSymb): (t (valpr p)-> Term) -> Fo
|Bot :Fo
|Conj:Fo->Fo->Fo
|Disj:Fo->Fo->Fo
|Impl:Fo->Fo->Fo
|Fora(a:SetFVars)(x:SetBVars)(f:Fo): Fo (*x NotIn a  ->*)
|Exis(a:SetFVars)(x:SetBVars)(f:Fo): Fo.
Definition con :=
fix con (x : SetBVars) (a:Fo) {struct a}:Prop:=
  match a with
  | Atom p H => False
  | Bot => False
  | Conj u v =>  (con x u)\/(con x v)
  | Disj u v =>  (con x u)\/(con x v)
  | Impl u v =>  (con x u)\/(con x v)
  | Fora _ q v =>  (x=q)\/(con x v)
  | Exis _ q v =>  (x=q)\/(con x v)
  end.

Definition ni :=
fix ni (x : SetBVars) (a:Fo) {struct a}:Prop:=
  match a with
  | Atom p H => True
  | Bot => True
  | Conj u v =>  (ni x u)/\(ni x v)
  | Disj u v =>  (ni x u)/\(ni x v)
  | Impl u v =>  (ni x u)/\(ni x v)
  | Fora _ q v => not(x=q)/\(ni x v)
  | Exis _ q v => not(x=q)/\(ni x v)
  end.

Definition cor :=
fix cor (a:Fo) {struct a}:Prop:=
  match a with
  | Atom p H   => True
  | Bot        => True
  | Conj u v   => (cor u)/\(cor v)
  | Disj u v   => (cor u)/\(cor v)
  | Impl u v   => (cor u)/\(cor v)
  | Fora _ q v => (ni q v)/\(cor v)
  | Exis _ q v => (ni q v)/\(cor v)
  end.

Inductive Fmls :=
| cr (f:Fo) (H:cor f): Fmls.

Section sec1.
Context (a:SetFVars).
Context (x y:SetBVars).
Context (A:PredSymb).
Context (h1: (valpr A = 0)).
Notation "x '@' y " := (@cons _ x _ y) (at level 80, right associativity).

Check Vector.t.
Check 1 @ 0 @ nil _. (*vector of numerals, just an example of notation*)
Theorem hj :Fin.t 0 -> Term.
Proof.
intro f.
inversion f.
Show Proof.
Defined.
Theorem hj2: Fin.t (valpr A) -> Term.
Proof.
rewrite -> h1 .
exact hj.
Defined.

Definition example:= Fora a x (Fora a y (Atom A hj2)).
Compute example.

Definition ex0 := Fora a x
         (Fora a y
            (Atom A
               match
                 match h1 in (_ = x) return (x = valpr A) with
                 | eq_refl => eq_refl
                 end in (_ = x) return (t x -> Term)
               with
               | eq_refl =>
                   fun x : t 0 =>
                   match x in (t x0) return (x0 = 0 -> Term) with
                   | @F1 n =>
                       fun x0 : S n = 0 =>
                       match
                         match
                           x0 in (_ = x1)
                           return
                             match x1 with
                             | 0 => False
                             | S _ => True
                             end
                         with
                         | eq_refl => I
                         end return Term
                       with
                       end
                   | @FS n x0 =>
                       fun x1 : S n = 0 =>
                       match
                         match
                           x1 in (_ = x2)
                           return
                             match x2 with
                             | 0 => False
                             | S _ => True
                             end
                         with
                         | eq_refl => I
                         end return (t n -> Term)
                       with
                       end x0
                   end eq_refl
               end))
     : Fo.

Fixpoint cor (f:Fo):Prop.

Inductive cfo:=
|c1: ->cfo
Check (sig fun x=>ni).
Definition Fmls := sig

where " x 'NotIn' a " :=
(let fix ni  (x : SetFVars) (a:PropF) {struct a}:Prop:=
  match a with
  | _ =>  False
  end in (ni x a)).

((fix ni0 (x : SetFVars) (a : it) {struct a} : Prop :=
  match a with
  | co1 => False
  | co2 => True
  end) x co1).

((fix ni (x:SetFVars) (a:PropF) {struct a}:Type:=
  match a with
  | _ =>  False
  end :Type ) x a).

 := (prod (x=x) (a=a)).

where NotIn (x:SetFVars)(A:PropF) := True.

where Definition NotIn (x:SetFVars)(A:PropF) := True.

with NotIn (x:SetFVars)(A:PropF) :=
| yyyy : forall (x:SetFVars)(A:PropF), NotIn .

(*with Sub:PropF->Term->SetFVars->PropF:=
| q.*)

(*|Forall:SetFVars->PropF->PropF
|Subst:PropF->Term->SetFVars->PropF*m
with q :=
|true
with w :=
|tqrue
.

Check Vector.t.

Section sec1.
Context (x y:SetVars).
Context (A:PropVars).

Check (Impl (Forall x A) (Subst A y x)).

Definition Normalize : PropF -> PropF.
intro p.
destruct p.

Check Forall x (Impl A).

Fixpoint substi (v:SetVars) (x:PropF) :PropF.
destruct x.
destruct (SVarseq_dec v p).

(*
Fixpoint eqvi (a b: PropF): Set. (* Prop.*)
destruct a, b.
exact (p=p0). (* Varseq_dec p p0 *).
*)

Notation "# P" := (Var P) (at level 1) : My_scope.
Notation "A \u2228 B" := (Disj A B) (at level 15, right associativity):My_scope.
Notation "A \u2227 B" := (Conj A B) (at level 15, right associativity):My_scope.
Notation "A * B":= (Impl A B)
(
at         level
16,
right         associativity
)
:
My
scope