From CoreErlang.BigStep Require Import Tactics.
From CoreErlang.BigStep Require Export BigStep.

From Coq Require Arith.PeanoNat.

(** Helper lemmas for determinism *)

Import ListNotations.

Ltac empty_list_in_hypo :=
match goal with
| [H : 0 = length _ |- _ ] => apply eq_sym, length_zero_iff_nil in H
| [H : length _ = 0 |- _ ] => apply length_zero_iff_nil in H
| _ => idtac
end.

Ltac single_unfold_list :=
match goal with
| [ Hyp : Datatypes.length ?l = 0 |- _] => apply length_zero_iff_nil in Hyp; subst
| [ Hyp : 0 = Datatypes.length ?l |- _] => apply eq_sym, length_zero_iff_nil in Hyp; subst
| [ Hyp : Datatypes.length ?l = S ?n |- _] => symmetry in Hyp; single_unfold_list
| [ Hyp : S ?n = Datatypes.length ?l |- _] =>
   pose (element_exist _ _ Hyp);
   match goal with
   | [H' : exists x l', _ = x::l' |- _] =>
     inversion H';
     match goal with
     | [H'' : exists l', _ = ?x::l' |- _] => inversion H''; subst; simpl in Hyp; inversion Hyp
     end
   end
end
.

(** Value lists are equal ased on the determinism hypotheses *)
Lemma explist_equality {env : Environment} {modules : list ErlModule} {own_module : string} {exps : list Expression} {eff1 : SideEffectList} :
forall vals vals0 : list Value, forall eff eff4 : list SideEffectList,
forall id ids ids0,
(forall i : nat,
     i < Datatypes.length exps ->
     forall (v2 : ValueSequence + Exception) (eff'' : SideEffectList) (id'' : nat),
     | env, modules, own_module, nth_def ids id 0 i, nth i exps ErrorExp, nth_def eff eff1 [] i |
     -e>
     | id'', v2, eff'' | ->
     inl [nth i vals ErrorValue] = v2 /\ nth_def eff eff1 [] (S i) = eff'' /\ nth_def ids id 0 (S i) = id'')
->
(forall i : nat,
     i < Datatypes.length exps ->
     | env, modules, own_module, nth_def ids0 id 0 i, nth i exps ErrorExp, nth_def eff4 eff1 [] i |
     -e>
     | nth_def ids0 id 0 (S i), inl [nth i vals0 ErrorValue], nth_def eff4 eff1 [] (S i) |)
->
Datatypes.length exps = Datatypes.length vals0
->
Datatypes.length exps = Datatypes.length eff4
->
Datatypes.length exps = Datatypes.length vals
->
Datatypes.length exps = Datatypes.length eff
->
length exps = length ids
->
length exps = length ids0
->
eff = eff4 /\ vals = vals0 /\ ids = ids0.
Proof.
  generalize dependent eff1. induction exps.
  * intros. simpl in H3, H2, H4, H5, H6, H1.
    repeat empty_list_in_hypo.
    subst. auto.
  * intros. inversion H3. inversion H2. inversion H4. inversion H5. inversion H6. inversion H1.

  (* first elements are the same *)
    single_unfold_list. single_unfold_list.
    single_unfold_list. single_unfold_list.
    single_unfold_list. single_unfold_list.
    pose (P1 := H0 0 list_length).
    pose (P2 := H 0 list_length _ _ _ P1).
    inversion P2. inversion H24. destruct H26.
    simpl in H26, H27.
    subst.
  (* remaining lists are the same *)
    assert (
      (forall i : nat,
      i < Datatypes.length exps ->
      forall (v2 : ValueSequence + Exception) (eff'' : SideEffectList) (id'' : nat),
      | env, modules, own_module, nth_def x4 x1 0 i, nth i exps ErrorExp, nth_def x6 x7 [] i | -e> | id'', v2, eff'' | ->
      inl [nth i x10 ErrorValue] = v2 /\ nth_def x6 x7 [] (S i) = eff'' /\ nth_def x4 x1 0 (S i) = id'')
    ).
    {
      intros. assert (S i < Datatypes.length (a::exps)). { simpl. lia. }
      pose (P4 := H (S i) H28 v2 eff'' id''). simpl nth in P4. exact (P4 H27).
    }
    assert (
     (forall i : nat,
    i < Datatypes.length exps ->
    | env, modules, own_module, nth_def x2 x1 0 i, nth i exps ErrorExp, nth_def x8 x7 [] i | -e>
    | nth_def x2 x1 0 (S i), inl [nth i x0 ErrorValue],
    nth_def x8 x7 [] (S i) |)
    ).
    {
      intros. assert (S i < Datatypes.length (a :: exps)). { simpl. lia. }
      pose (P4 := H0 (S i) H28). simpl nth in P4. assumption.
    }
    (* simpl list lengths *)
    inversion H10. inversion H11. inversion H12. inversion H13. inversion H9.
    inversion H8.
    pose (IH := IHexps _ _ _ _ _ _ _ _ H26 H27 H32 H33 H34 H29 H30 H31).
    destruct IH. destruct H35. subst. auto.
Qed.
(*
Lemma singleexplist_equality {env : Environment} {exps : list SingleExpression} {eff1 : SideEffectList} :
forall vals vals0 : list Value, forall eff eff4 : list SideEffectList,
forall id ids ids0,
(forall i : nat,
     i < Datatypes.length exps ->
     forall (v2 : ValueSequence + Exception) (eff'' : SideEffectList) (id'' : nat),
     | env, nth_def ids id 0 i, nth i exps ErrorExp, nth_def eff eff1 [] i |
     -s>
     | id'', v2, eff'' | ->
     inl [nth i vals ErrorValue] = v2 /\ nth_def eff eff1 [] (S i) = eff'' /\ nth_def ids id 0 (S i) = id'')
->
(forall i : nat,
     i < Datatypes.length exps ->
     | env, nth_def ids0 id 0 i, nth i exps ErrorExp, nth_def eff4 eff1 [] i |
     -s>
     | nth_def ids0 id 0 (S i), inl [nth i vals0 ErrorValue], nth_def eff4 eff1 [] (S i) |)
->
Datatypes.length exps = Datatypes.length vals0
->
Datatypes.length exps = Datatypes.length eff4
->
Datatypes.length exps = Datatypes.length vals
->
Datatypes.length exps = Datatypes.length eff
->
length exps = length ids
->
length exps = length ids0
->
eff = eff4 /\ vals = vals0 /\ ids = ids0.
Proof.
  generalize dependent eff1. induction exps.
  * intros. simpl in H3, H2, H4, H5, H6, H1.
    repeat empty_list_in_hypo.
    subst. auto.
  * intros. inversion H3. inversion H2. inversion H4. inversion H5. inversion H6. inversion H1.

  (* first elements are the same *)
    single_unfold_list. single_unfold_list.
    single_unfold_list. single_unfold_list.
    single_unfold_list. single_unfold_list.
    pose (P1 := H0 0 list_length).
    pose (P2 := H 0 list_length _ _ _ P1).
    inversion P2. inversion H24. destruct H26.
    simpl in H26, H27.
    subst.
  (* remaining lists are the same *)
    assert (
      (forall i : nat,
      i < Datatypes.length exps ->
      forall (v2 : ValueSequence + Exception) (eff'' : SideEffectList) (id'' : nat),
      | env, nth_def x4 x1 0 i, nth i exps ErrorExp, nth_def x6 x7 [] i | -s> | id'', v2, eff'' | ->
      inl [nth i x10 ErrorValue] = v2 /\ nth_def x6 x7 [] (S i) = eff'' /\ nth_def x4 x1 0 (S i) = id'')
    ).
    {
      intros. assert (S i < Datatypes.length (a::exps)). { simpl. lia. }
      pose (P4 := H (S i) H28 v2 eff'' id''). simpl nth in P4. exact (P4 H27).
    }
    assert (
     (forall i : nat,
    i < Datatypes.length exps ->
    | env, nth_def x2 x1 0 i, nth i exps ErrorExp, nth_def x8 x7 [] i | -s>
    | nth_def x2 x1 0 (S i), inl [nth i x0 ErrorValue],
    nth_def x8 x7 [] (S i) |)
    ).
    {
      intros. assert (S i < Datatypes.length (a :: exps)). { simpl. lia. }
      pose (P4 := H0 (S i) H28). simpl nth in P4. assumption.
    }
    (* simpl list lengths *)
    inversion H10. inversion H11. inversion H12. inversion H13. inversion H9.
    inversion H8.
    pose (IH := IHexps _ _ _ _ _ _ _ _ H26 H27 H32 H33 H34 H29 H30 H31).
    destruct IH. destruct H35. subst. auto.
Qed. *)

(** Based on determinism hypotheses, the same clause was chosen in case evaluation *)
Lemma index_case_equality {env : Environment} {modules : list ErlModule} {own_module : string} {clauses : list (list Pattern * Expression * Expression)} {vals : list Value} (i i0 : nat)
    (guard guard0 exp exp0 : Expression) (bindings bindings0 : list (Var * Value))
    (eff1 : SideEffectList) (id' : nat) :
  (forall j : nat,
     j < i ->
     forall (gg ee : Expression) (bb : list (Var * Value)),
     match_clause vals clauses j = Some (gg, ee, bb) ->
     forall (v2 : ValueSequence + Exception) (eff'' : SideEffectList) (id'' : nat),
     | add_bindings bb env, modules, own_module, id', gg, eff1 | -e> | id'', v2, eff'' | ->
     inl [ffalse] = v2 /\ eff1 = eff'' /\ id' = id'')
  ->
  (forall j : nat,
      j < i0 ->
      forall (gg ee : Expression) (bb : list (Var * Value)),
      match_clause vals clauses j = Some (gg, ee, bb) ->
      | add_bindings bb env, modules, own_module, id', gg, eff1 | -e> | id', inl [ffalse], eff1 |)
  ->
  match_clause vals clauses i = Some (guard, exp, bindings)
  ->
  match_clause vals clauses i0 = Some (guard0, exp0, bindings0)
  ->
  | add_bindings bindings0 env, modules, own_module, id', guard0, eff1 | -e> | id', inl [ttrue], eff1 |
  ->
  | add_bindings bindings env, modules, own_module, id', guard, eff1 | -e> | id', inl [ttrue], eff1 |
  ->
  (forall (v2 : ValueSequence + Exception) (eff'' : SideEffectList) (id'' : nat),
         | add_bindings bindings env, modules, own_module, id', guard, eff1 | -e> | id'', v2, eff'' | ->
         inl [ttrue] = v2 /\ eff1 = eff'' /\ id' = id'')
->
  i = i0.
Proof.
  intros. pose (D := Nat.lt_decidable i i0). destruct D.
  * pose (P1 := H0 i H6 guard exp bindings H1). pose (P2 := H5 (inl [ffalse]) _ _ P1).
    inversion P2. inversion H7.
  * apply Compare_dec.not_lt in H6. apply (nat_ge_or) in H6. inversion H6.
    - assumption.
    - pose (P3 := H i0 H7 guard0 exp0 bindings0 H2 (inl [ttrue]) _ _ H3). inversion P3. inversion H8.
Qed.

(** Based on determinism, until the i-th element, the side effects are equal *)
Lemma explist_prefix_eq {env : Environment} {modules : list ErlModule} {own_module : string} {eff : list SideEffectList} :
forall (eff' : list SideEffectList) (exps : list Expression) (vals vals' : list Value)
   (eff1 : SideEffectList) (ids ids' : list nat) (id id'' : nat) ex eff3,
length exps = length vals ->
Datatypes.length exps = Datatypes.length eff
->
Datatypes.length eff' = Datatypes.length vals'
->
Datatypes.length vals' < Datatypes.length exps
->
length exps = length ids
->
length ids' = length vals'
->
(forall i : nat,
     i < Datatypes.length exps ->
     forall (v2 : ValueSequence + Exception) (eff'' : SideEffectList) (id'' : nat),
     | env, modules, own_module, nth_def ids id 0 i, nth i exps ErrorExp, nth_def eff eff1 [] i | -e> | id'', v2, eff'' | ->
     inl [nth i vals ErrorValue] = v2 /\ nth_def eff eff1 [] (S i) = eff'' /\ nth_def ids id 0 (S i) = id'')
->
(forall j : nat,
     j < Datatypes.length vals' ->
     | env, modules, own_module, nth_def ids' id 0 j, nth j exps ErrorExp, nth_def eff' eff1 [] j | -e>
     | nth_def ids' id 0 (S j), inl [nth j vals' ErrorValue],
     nth_def eff' eff1 [] (S j) |)
->
| env, modules, own_module, last ids' id, nth (Datatypes.length vals') exps ErrorExp,
      last eff' eff1 | -e> | id'', inr ex,
      eff3 |
->
False.
Proof.
  induction eff.
  * intros. inversion H0. rewrite H9 in H2. inversion H2.
  * intros. destruct eff'.
    - inversion H1. simpl in H1. apply eq_sym, length_zero_iff_nil in H1. subst.
      simpl in H4.
      apply length_zero_iff_nil in H4. subst. simpl in H0. rewrite H0 in H5.
      pose (P := H5 0 (Nat.lt_0_succ _) _ _ _ H7). destruct P. inversion H1.
    - inversion H1. simpl.
    (* first elements *)
      inversion H0.
      assert (0 < length exps). { lia. }
      assert (0 < length vals'). { lia. }
      assert (0 < length ids'). { lia. }
      simpl in H0, H1.
      (* single_unfold_list H1. *)
      assert (Datatypes.length exps = S (Datatypes.length eff)) as Helper. { auto. }
      assert (Datatypes.length ids' = Datatypes.length vals') as Helper2. { auto. }
      assert (Datatypes.length exps = Datatypes.length ids) as Helper3. { auto. }
      pose (EE1 := element_exist _ _ (eq_sym H10)).
      pose (EE2 := element_exist _ _ H1).
      rewrite H in H0.
      pose (EE3 := element_exist _ _ (eq_sym H0)).
      rewrite <- H1 in H4. rewrite H10 in H3.
      pose (EE4 := element_exist _ _ H3).
      pose (EE5 := element_exist _ _ (eq_sym H4)).
      inversion EE1 as [e]. inversion EE2 as [v]. inversion EE3 as [v'].
      inversion EE4 as [id0']. inversion EE5 as [id0''].
      inversion H13. inversion H14. inversion H15. inversion H16. inversion H17. subst.
      pose (P0 := H6 0 H11).
      pose (P1 := H5 0 H8 (inl [v]) (s)).
      pose (P2 := P1 _ P0). destruct P2. destruct H18, H19. simpl in H18, H19. subst.
    (* other elements *)
      inversion H1.
      eapply IHeff with (exps := x) (vals := x1) (vals' := x0) (eff1 := s)
                      (ids := x2) (ids' := x3) (id := id0'') (eff' := eff'); auto.
        + intuition.
        + intros. assert (S i < Datatypes.length (e :: x)). { simpl. lia. }
          pose (A := H5 (S i) H21 v2 eff''). simpl in A, H20.
          pose (B := A _ H20). assumption.
        + intros. assert (S j < Datatypes.length (v :: x0)). { lia. }
          pose (A := H6 (S j) H20). exact A.
        + rewrite <- last_element_equal, <- last_element_equal in H7. exact H7.
Qed.

(*
Lemma singleexplist_prefix_eq {env : Environment} {eff : list SideEffectList} :
forall (eff' : list SideEffectList) (exps : list SingleExpression) (vals vals' : list Value)
   (eff1 : SideEffectList) (ids ids' : list nat) (id id'' : nat) ex eff3,
length exps = length vals ->
Datatypes.length exps = Datatypes.length eff
->
Datatypes.length eff' = Datatypes.length vals'
->
Datatypes.length vals' < Datatypes.length exps
->
length exps = length ids
->
length ids' = length vals'
->
(forall i : nat,
     i < Datatypes.length exps ->
     forall (v2 : ValueSequence + Exception) (eff'' : SideEffectList) (id'' : nat),
     | env, nth_def ids id 0 i, nth i exps ErrorExp, nth_def eff eff1 [] i | -s> | id'', v2, eff'' | ->
     inl [nth i vals ErrorValue] = v2 /\ nth_def eff eff1 [] (S i) = eff'' /\ nth_def ids id 0 (S i) = id'')
->
(forall j : nat,
     j < Datatypes.length vals' ->
     | env, nth_def ids' id 0 j, nth j exps ErrorExp, nth_def eff' eff1 [] j | -s>
     | nth_def ids' id 0 (S j), inl [nth j vals' ErrorValue],
     nth_def eff' eff1 [] (S j) |)
->
| env, last ids' id, nth (Datatypes.length vals') exps ErrorExp,
      last eff' eff1 | -s> | id'', inr ex,
      eff3 |
->
False.
Proof.
  induction eff.
  * intros. inversion H0. rewrite H9 in H2. inversion H2.
  * intros. destruct eff'.
    - inversion H1. simpl in H1. apply eq_sym, length_zero_iff_nil in H1. subst.
      simpl in H4.
      apply length_zero_iff_nil in H4. subst. simpl in H0. rewrite H0 in H5.
      pose (P := H5 0 (Nat.lt_0_succ _) _ _ _ H7). destruct P. inversion H1.
    - inversion H1. simpl.
    (* first elements *)
      inversion H0.
      assert (0 < length exps). { lia. }
      assert (0 < length vals'). { lia. }
      assert (0 < length ids'). { lia. }
      simpl in H0, H1.
      (* single_unfold_list H1. *)
      assert (Datatypes.length exps = S (Datatypes.length eff)) as Helper. { auto. }
      assert (Datatypes.length ids' = Datatypes.length vals') as Helper2. { auto. }
      assert (Datatypes.length exps = Datatypes.length ids) as Helper3. { auto. }
      pose (EE1 := element_exist _ _ (eq_sym H10)).
      pose (EE2 := element_exist _ _ H1).
      rewrite H in H0.
      pose (EE3 := element_exist _ _ (eq_sym H0)).
      rewrite <- H1 in H4. rewrite H10 in H3.
      pose (EE4 := element_exist _ _ H3).
      pose (EE5 := element_exist _ _ (eq_sym H4)).
      inversion EE1 as [e]. inversion EE2 as [v]. inversion EE3 as [v'].
      inversion EE4 as [id0']. inversion EE5 as [id0''].
      inversion H13. inversion H14. inversion H15. inversion H16. inversion H17. subst.
      pose (P0 := H6 0 H11).
      pose (P1 := H5 0 H8 (inl [v]) (s)).
      pose (P2 := P1 _ P0). destruct P2. destruct H18, H19. simpl in H18, H19. subst.
    (* other elements *)
      inversion H1.
      eapply IHeff with (exps := x) (vals := x1) (vals' := x0) (eff1 := s)
                      (ids := x2) (ids' := x3) (id := id0'') (eff' := eff'); auto.
        + intuition.
        + intros. assert (S i < Datatypes.length (e :: x)). { simpl. lia. }
          pose (A := H5 (S i) H21 v2 eff''). simpl in A, H20.
          pose (B := A _ H20). assumption.
        + intros. assert (S j < Datatypes.length (v :: x0)). { lia. }
          pose (A := H6 (S j) H20). exact A.
        + rewrite <- last_element_equal, <- last_element_equal in H7. exact H7.
Qed.
 *)
(** First i elements are equal, but with changed hypotheses *)
Lemma explist_prefix_eq_rev {env : Environment} {modules : list ErlModule} {own_module : string} {eff : list SideEffectList} :
   forall (eff' : list SideEffectList) (exps : list Expression) (vals vals' : list Value)
          (eff1 : SideEffectList) (ids ids' : list nat) (id : nat) (eff2 : SideEffectList)
          (id' : nat) (ex : Exception),
(forall j : nat,
     j < Datatypes.length vals ->
     forall (v2 : ValueSequence + Exception) (eff'' : SideEffectList) (id'' : nat),
     | env, modules, own_module, nth_def ids id 0 j, nth j exps ErrorExp, nth_def eff eff1 [] j | -e> | id'', v2, eff'' | ->
     inl [nth j vals ErrorValue] = v2 /\ nth_def eff eff1 [] (S j) = eff'' /\ nth_def ids id 0 (S j) = id'')
->
(forall i : nat,
     i < Datatypes.length exps ->
     | env, modules, own_module, nth_def ids' id 0 i, nth i exps ErrorExp, nth_def eff' eff1 [] i | -e>
     | nth_def ids' id 0 (S i), inl [nth i vals' ErrorValue],
     nth_def eff' eff1 [] (S i) |) ->
(forall (v2 : ValueSequence + Exception) (eff'' : SideEffectList) (id'' : nat),
        | env, modules, own_module, last ids id, nth (Datatypes.length vals) exps ErrorExp,
        last eff eff1 | -e> | id'', v2, eff'' | ->
        inr ex = v2 /\ eff2 = eff'' /\ id' = id'')
->
Datatypes.length vals < Datatypes.length exps ->
Datatypes.length eff = Datatypes.length vals ->
Datatypes.length exps = Datatypes.length vals' ->
Datatypes.length exps = Datatypes.length eff' ->
length exps = length ids' ->
length ids = length vals
->
False.
Proof.
  induction eff.
  * intros. apply eq_sym, length_zero_iff_nil in H3. subst.
    apply length_zero_iff_nil in H7. subst.
    pose (P := H0 0 H2).
    pose (P2 := H1 _ _ _ P). inversion P2. congruence.
  * intros. destruct eff'.
    - inversion H5. rewrite H5 in H2. inversion H2.
    - inversion H3. inversion H5.
    (* first elements *)
      assert (0 < length exps). { lia. } assert (0 < length vals). { lia. }
      assert (S (Datatypes.length eff') = Datatypes.length exps). { auto. }
      assert (Datatypes.length exps = Datatypes.length vals') as LENGTH. { auto. }
      assert (S (Datatypes.length eff) = Datatypes.length vals) as Helper1. { auto. }
      assert (Datatypes.length exps = Datatypes.length ids') as Helper2. { auto. }
      (* single_unfold_list H9. *)
      pose (EE1 := element_exist (length eff') exps (eq_sym H5)).
      pose (EE2 := element_exist (length eff) vals H9).
      rewrite H5 in H4, H6. rewrite <- H9 in H7.
      pose (EE3 := element_exist (length eff') vals' H4).
      pose (EE4 := element_exist _ _ (eq_sym H7)).
      pose (EE5 := element_exist _ _ H6).

      inversion EE1 as [e]. inversion EE2 as [v]. inversion EE3 as [v'].
      inversion EE4 as [id0']. inversion EE5 as [id0''].
      inversion H13. inversion H14. inversion H15. inversion H16. inversion H17. subst.
      pose (P0 := H0 0 H8).
      pose (P1 := H 0 H11 (inl [v']) s).
      pose (P2 := P1 _ P0). destruct P2. destruct H19. inversion H18. simpl in H19, H20. subst.
    (* other elements *)
      inversion H3.
      apply IHeff with (exps := x) (vals := x0) (eff1 := s) (vals' := x1)
                  (ids := x2) (ids' := x3) (id := id0'') (ex := ex) (eff' := eff')
                  (eff2 := eff2) (id' := id'); auto.
        + intros. assert (S j < Datatypes.length (v' :: x0)). { simpl. lia. }
          pose (A := H (S j) H22 v2 eff'').
          pose (B := A _ H21). assumption.
        + intros. assert (S i < Datatypes.length (e :: x)). { simpl. lia. }
          pose (A := H0 (S i) H21). exact A.
        + intros. rewrite <- last_element_equal, <- last_element_equal in H1. apply H1. assumption.
        + intuition.
        + inversion H7. lia.
Qed.
(*

Lemma singleexplist_prefix_eq_rev {env : Environment} {eff : list SideEffectList} :
   forall (eff' : list SideEffectList) (exps : list SingleExpression) (vals vals' : list Value)
          (eff1 : SideEffectList) (ids ids' : list nat) (id : nat) (eff2 : SideEffectList)
          (id' : nat) (ex : Exception),
(forall j : nat,
     j < Datatypes.length vals ->
     forall (v2 : ValueSequence + Exception) (eff'' : SideEffectList) (id'' : nat),
     | env, nth_def ids id 0 j, nth j exps ErrorExp, nth_def eff eff1 [] j | -s> | id'', v2, eff'' | ->
     inl [nth j vals ErrorValue] = v2 /\ nth_def eff eff1 [] (S j) = eff'' /\ nth_def ids id 0 (S j) = id'')
->
(forall i : nat,
     i < Datatypes.length exps ->
     | env, nth_def ids' id 0 i, nth i exps ErrorExp, nth_def eff' eff1 [] i | -s>
     | nth_def ids' id 0 (S i), inl [nth i vals' ErrorValue],
     nth_def eff' eff1 [] (S i) |) ->
(forall (v2 : ValueSequence + Exception) (eff'' : SideEffectList) (id'' : nat),
        | env, last ids id, nth (Datatypes.length vals) exps ErrorExp,
        last eff eff1 | -s> | id'', v2, eff'' | ->
        inr ex = v2 /\ eff2 = eff'' /\ id' = id'')
->
Datatypes.length vals < Datatypes.length exps ->
Datatypes.length eff = Datatypes.length vals ->
Datatypes.length exps = Datatypes.length vals' ->
Datatypes.length exps = Datatypes.length eff' ->
length exps = length ids' ->
length ids = length vals
->
False.
Proof.
  induction eff.
  * intros. apply eq_sym, length_zero_iff_nil in H3. subst.
    apply length_zero_iff_nil in H7. subst.
    pose (P := H0 0 H2).
    pose (P2 := H1 _ _ _ P). inversion P2. congruence.
  * intros. destruct eff'.
    - inversion H5. rewrite H5 in H2. inversion H2.
    - inversion H3. inversion H5.
    (* first elements *)
      assert (0 < length exps). { lia. } assert (0 < length vals). { lia. }
      assert (S (Datatypes.length eff') = Datatypes.length exps). { auto. }
      assert (Datatypes.length exps = Datatypes.length vals') as LENGTH. { auto. }
      assert (S (Datatypes.length eff) = Datatypes.length vals) as Helper1. { auto. }
      assert (Datatypes.length exps = Datatypes.length ids') as Helper2. { auto. }
      (* single_unfold_list H9. *)
      pose (EE1 := element_exist (length eff') exps (eq_sym H5)).
      pose (EE2 := element_exist (length eff) vals H9).
      rewrite H5 in H4, H6. rewrite <- H9 in H7.
      pose (EE3 := element_exist (length eff') vals' H4).
      pose (EE4 := element_exist _ _ (eq_sym H7)).
      pose (EE5 := element_exist _ _ H6).

      inversion EE1 as [e]. inversion EE2 as [v]. inversion EE3 as [v'].
      inversion EE4 as [id0']. inversion EE5 as [id0''].
      inversion H13. inversion H14. inversion H15. inversion H16. inversion H17. subst.
      pose (P0 := H0 0 H8).
      pose (P1 := H 0 H11 (inl [v']) s).
      pose (P2 := P1 _ P0). destruct P2. destruct H19. inversion H18. simpl in H19, H20. subst.
    (* other elements *)
      inversion H3.
      apply IHeff with (exps := x) (vals := x0) (eff1 := s) (vals' := x1)
                  (ids := x2) (ids' := x3) (id := id0'') (ex := ex) (eff' := eff')
                  (eff2 := eff2) (id' := id'); auto.
        + intros. assert (S j < Datatypes.length (v' :: x0)). { simpl. lia. }
          pose (A := H (S j) H22 v2 eff'').
          pose (B := A _ H21). assumption.
        + intros. assert (S i < Datatypes.length (e :: x)). { simpl. lia. }
          pose (A := H0 (S i) H21). exact A.
        + intros. rewrite <- last_element_equal, <- last_element_equal in H1. apply H1. assumption.
        + intuition.
        + inversion H7. lia.
Qed. *)

(** First i element are equal with concatn *)
Lemma con_n_equality {env : Environment} {modules : list ErlModule} {own_module : string} {eff : list SideEffectList} :
  forall (exps : list Expression) (vals vals0 : list Value) eff1 eff6 i i0 ids ids0 id eff3 id' ex,
(forall j : nat,
    j < i ->
    forall (v2 : ValueSequence + Exception) (eff'' : SideEffectList) (id'' : nat),
    | env, modules, own_module, nth_def ids id 0 j, nth j exps ErrorExp, nth_def eff eff1 [] j | -e> | id'', v2, eff'' | ->
    inl [nth j vals ErrorValue] = v2 /\ nth_def eff eff1 [] (S j) = eff'' /\ nth_def ids id 0 (S j) = id'')
->
(forall j : nat,
     j < i0 ->
     | env, modules, own_module, nth_def ids0 id 0 j, nth j exps ErrorExp, nth_def eff6 eff1 [] j | -e>
     | nth_def ids0 id 0 (S j), inl [nth j vals0 ErrorValue],
     nth_def eff6 eff1 [] (S j) |)
->
(forall (v2 : ValueSequence + Exception) (eff'' : SideEffectList) (id'' : nat),
     | env, modules, own_module, last ids id, nth i exps ErrorExp, last eff eff1 | -e> | id'', v2, eff'' | ->
     inr ex = v2 /\ eff3 = eff'' /\ id' = id'')
->
Datatypes.length eff = i ->
i < Datatypes.length exps ->
Datatypes.length vals = i ->
Datatypes.length vals0 = i0 ->
i0 < Datatypes.length exps ->
Datatypes.length eff6 = i0 ->
length ids = i ->
length ids0 = i0 ->
i < i0
->
False.
Proof.
  induction eff.
  * intros. simpl in H1. subst. simpl in H10. pose (P := H0 0 H10).
    simpl in H8, P. apply length_zero_iff_nil in H8. subst.
    pose (P2 := H1 _ _ _ P). inversion P2. congruence.
  * intros. inversion H2. simpl in H2. rewrite <- H2 in H4.
    pose (EE1 := element_exist (length eff) vals (eq_sym H4)).
    inversion EE1 as [v]. inversion H12 as [vs]. destruct eff6.
    - simpl in H7. subst. rewrite <- H7 in H10. inversion H10.
    - subst. simpl. (* simpl_concatn_H IHeff. rewrite concatn_app, concatn_app. simpl_concatn. *)
      simpl in H7. (* single_unfold_list H6. *)
      pose (EE2 := element_exist (length eff6) vals0 H7). inversion EE2.
      inversion H2.
      pose (NE := nat_lt_zero _ _  H3). inversion NE.
      pose (EE3 := element_exist x1 exps (eq_sym H13)). inversion EE3. inversion H14.
      subst.
      pose (EE4 := element_exist _ _ (eq_sym H8)).
      pose (EE5 := element_exist _ _ (eq_sym H9)).
      inversion EE4 as [id0']. inversion EE5 as [id0''].
      inversion H5. inversion H15. subst.
      assert (s = a /\ id0' = id0''). {
        subst.
        assert (0 < Datatypes.length (x :: x0)). {  simpl. lia. }
        pose (P := H0 0 H16).
        assert (0 < S (Datatypes.length eff)). {  simpl. lia. }
        pose (P2 := H 0 H17 (inl [nth 0 (x :: x0) ErrorValue]) (nth_def (s :: eff6) eff1 [] 1) _ P).
        inversion P2.
        destruct H19. auto.
      }
      destruct H16. subst.

      eapply IHeff with (exps := x3) (vals := vs) (vals0 := x0) (eff1 := a)
                        (i0 := length x0) (ids := x4) (ids0 := x5); auto.
      + intros. assert (S j < S (Datatypes.length eff)). { simpl. lia. }
        pose (P := H (S j) H18 v2 eff'' id''). pose (P H17). assumption.
      + intros. assert (S j < Datatypes.length (x :: x0)). { simpl. lia. }
        pose (P := H0 (S j) H17). exact P.
      + intros. apply H1.
        rewrite (last_element_equal _ _ id), (last_element_equal _ _ eff1) in H16.
        exact H16.
      + intuition.
      + intuition.
      + intuition.
      + intuition.
Qed.

(** Value lists are equal until ith value *)
Lemma list_equal_until_i {env : Environment} {modules : list ErlModule} {own_module : string} {eff : list SideEffectList} :
  forall (exps : list Expression) (vals vals0 : list Value) (eff6 : list SideEffectList)
      (eff1 : SideEffectList) (ids ids0 : list nat) (id : nat),
(forall j : nat,
    j < Datatypes.length vals ->
    forall (v2 : ValueSequence + Exception) (eff'' : SideEffectList) (id'' : nat),
    | env, modules, own_module, nth_def ids id 0 j, nth j exps ErrorExp, nth_def eff eff1 [] j | -e> | id'', v2, eff'' | ->
    inl [nth j vals ErrorValue] = v2 /\ nth_def eff eff1 [] (S j) = eff'' /\ nth_def ids id 0 (S j) = id'')
->
(forall j : nat,
     j < Datatypes.length vals0 ->
     | env, modules, own_module, nth_def ids0 id 0 j, nth j exps ErrorExp, nth_def eff6 eff1 [] j | -e>
     | nth_def ids0 id 0 (S j), inl [nth j vals0 ErrorValue],
     nth_def eff6 eff1 [] (S j) |)
->
Datatypes.length vals = Datatypes.length vals0
->
Datatypes.length eff = Datatypes.length vals
->
Datatypes.length eff6 = Datatypes.length vals0
->
Datatypes.length vals0 < Datatypes.length exps
->
length ids = length vals
->
length ids0 = length vals0
->
eff = eff6 /\ vals = vals0 /\ ids = ids0.
Proof.
  induction eff.
  * intros. inversion H2. apply eq_sym, length_zero_iff_nil in H8. subst. simpl in H1.
    apply eq_sym, length_zero_iff_nil in H1. subst. simpl in H3. apply length_zero_iff_nil in H3.
    apply length_zero_iff_nil in H5. apply length_zero_iff_nil in H6. subst. auto.
  * intros. simpl in H2. rewrite <- H2 in H1. rewrite <- H1 in H3. pose (NE := nat_lt_zero _ _ H4). inversion NE.
    (* single_unfold_list H2. *)
    pose (EE1 := element_exist (length eff) vals H2).
    pose (EE2 := element_exist (length eff) vals0 H1).
    pose (EE3 := element_exist (length eff) eff6 (eq_sym H3)).
    pose (EE4 := element_exist x exps (eq_sym H7)).
    inversion EE1 as [v]. inversion EE2 as [v']. inversion EE3 as [fe]. inversion EE4 as [e'].
    inversion H8. inversion H9. inversion H10. inversion H11. subst.
    pose (EE5 := element_exist _ _ (eq_sym H5)).
    pose (EE6 := element_exist _ _ (eq_sym H6)).
    inversion EE5 as [id']. inversion EE6 as [id''].
    inversion H12. inversion H13. subst.
    assert (0 < Datatypes.length (v' :: x1)). { simpl. lia. }
    pose (P := H0 0 H14).
    assert (0 < Datatypes.length (v :: x0)). { simpl. lia. }
    pose (P1 := H 0 H15 (inl [nth 0 (v' :: x1) ErrorValue]) (nth_def (fe :: x2) eff1 [] 1) _ P).
    inversion P1. destruct H17. simpl in H18. inversion H16. simpl in H17. subst.

    assert (eff = x2 /\ x0 = x1 /\ x4 = x5).
    {
      apply IHeff with (exps := x3) (vals := x0) (vals0 := x1) (eff1 := fe) (id := id''); auto.
      + intros. assert (S j < S (Datatypes.length x0)). { simpl. lia. } pose (P2 := H (S j) H19 v2 eff'').
        simpl in P2. pose (P2 _ H18). assumption.
      + intros. assert (S j < Datatypes.length (v' :: x1)). { simpl. lia. }
        pose (P3 := H0 (S j) H18). simpl in P3. assumption.
      + inversion H2. inversion H3. inversion H1. auto.
      + inversion H2. inversion H3. inversion H1. auto.
      + intuition.
    }
    inversion H17. inversion H19. subst. auto.
Qed.

(** Slightly different hypotheses for i first element concatn equality *)
Lemma con_n_equality_rev {env : Environment} {modules : list ErlModule} {own_module : string} {eff : list SideEffectList} :
forall (exps : list Expression) (vals vals0 : list Value) (eff1 : SideEffectList)
   (eff6 : list SideEffectList) (i i0 : nat) (id : nat) (ids ids0 : list nat) id' ex0 eff4,
(forall j : nat,
    j < i ->
    forall (v2 : ValueSequence + Exception) (eff'' : SideEffectList) (id'' : nat),
    | env, modules, own_module, nth_def ids id 0 j, nth j exps ErrorExp, nth_def eff eff1 [] j | -e> | id'', v2, eff'' | ->
    inl [nth j vals ErrorValue] = v2 /\ nth_def eff eff1 [] (S j) = eff'' /\ nth_def ids id 0 (S j) = id'')
->
(forall j : nat,
     j < i0 ->
     | env, modules, own_module, nth_def ids0 id 0 j, nth j exps ErrorExp, nth_def eff6 eff1 [] j | -e>
     | nth_def ids0 id 0 (S j), inl [nth j vals0 ErrorValue],
     nth_def eff6 eff1 [] (S j) |)
->
Datatypes.length eff = i ->
i < Datatypes.length exps ->
Datatypes.length vals = i ->
Datatypes.length vals0 = i0 ->
i0 < Datatypes.length exps ->
Datatypes.length eff6 = i0 ->
length ids = i ->
length ids0 = i0 ->
i > i0 ->
(| env, modules, own_module, last ids0 id, nth i0 exps ErrorExp, last eff6 eff1 | -e> | id',
     inr ex0,eff4 |)
->
False.
Proof.
induction eff.
  * intros. simpl in H1. subst. inversion H9.
  * intros. simpl in H1. rewrite <- H1 in H3.
    pose (EE1 := element_exist (length eff) vals (eq_sym H3)).
    inversion EE1 as [v]. inversion H11 as [vs]. destruct eff6.
    - subst. apply eq_sym, length_zero_iff_nil in H6. subst. apply length_zero_iff_nil in H8.
      subst.
      simpl in H10. pose (P := H 0 (Nat.lt_0_succ _) _ _ _ H10). inversion P. congruence.
    - subst.
      assert (Datatypes.length ids0 = Datatypes.length vals0) as Helper. { auto. }
      pose (EE2 := element_exist (length eff6) vals0 H6). inversion EE2. inversion H1.
      pose (NE := nat_lt_zero _ _ H2). inversion NE.
      pose (EE3 := element_exist x1 exps (eq_sym H12)). inversion EE3.
      inversion H13. subst.
      pose (EE4 := element_exist _ _ (eq_sym H7)).
      pose (EE5 := element_exist _ _ (eq_sym H8)).
      inversion EE4 as [id0']. inversion EE5 as [id0'']. inversion H4. inversion H14. subst.
      assert (s = a /\ id0' = id0''). {
        subst.
        assert (0 < Datatypes.length (x :: x0)). {  simpl. lia. }
        pose (P := H0 0 H15).
        assert (0 < S (Datatypes.length eff)). {  simpl. lia. }
        pose (P1 := H 0 H16 (inl [nth 0 (x :: x0) ErrorValue]) (nth_def (s :: eff6) eff1 [] 1) _ P).
        destruct P1. destruct H18. simpl in H19, H18. auto.
      }
      destruct H15. subst.
      eapply IHeff with (exps := x3) (vals := vs) (vals0 := x0) (eff1 := a)
                       (i0 := length eff6) (i := length eff) (ids := x4) (ids0 := x5); auto.
      + intros. assert (S j < S (Datatypes.length eff)). { simpl. lia. }
        pose (P := H (S j) H17 v2 eff''). simpl in P.
        pose (P1 := P _ H16). assumption.
      + intros. inversion H6. assert (S j < Datatypes.length (x :: x0)). { simpl. lia. }
        pose (P := H0 (S j) H16). assumption.
      + intuition.
      + inversion H6. auto.
      + rewrite <- H6 in H5. simpl in H5. lia.
      + rewrite <- H6 in Helper. auto.
      + simpl in *. rewrite <- H6 in H9. lia.
      + rewrite <- last_element_equal, <- last_element_equal in H10. simpl in H10.
        inversion H6. rewrite H16. exact H10.
Qed.

(** Based on determinsim, using lists with exceptions, these are equal *)
Lemma exception_equality {env : Environment} {modules : list ErlModule} {own_module : string} {exps : list Expression} (vals vals0 : list Value)
   (ex : Exception) (eff1 : SideEffectList) (eff eff6 : list SideEffectList) (i i0 : nat)
   (eff3 : SideEffectList) (ex0 : Exception) (eff4 : SideEffectList) (ids ids0 : list nat)
   (id id' id'' : nat) :
(forall j : nat,
     j < i ->
     forall (v2 : ValueSequence + Exception) (eff'' : SideEffectList) (id'' : nat),
     | env, modules, own_module, nth_def ids id 0 j, nth j exps ErrorExp, nth_def eff eff1 [] j | -e> | id'', v2, eff'' | ->
     inl [nth j vals ErrorValue] = v2 /\ nth_def eff eff1 [] (S j) = eff'' /\ nth_def ids id 0 (S j) = id'')
->
| env, modules, own_module, last ids0 id, nth i0 exps ErrorExp, last eff6 eff1 | -e>
| id'', inr ex0, eff4 |
->
(forall (v2 : ValueSequence + Exception) (eff'' : SideEffectList) (id'' : nat),
        | env, modules, own_module, last ids id, nth i exps ErrorExp, last eff eff1 | -e>
        | id'', v2, eff'' | -> inr ex = v2 /\ eff3 = eff'' /\ id' = id'')
->
(forall j : nat,
      j < i0 ->
      | env, modules, own_module, nth_def ids0 id 0 j, nth j exps ErrorExp, nth_def eff6 eff1 [] j | -e>
      | nth_def ids0 id 0 (S j), inl [nth j vals0 ErrorValue],
      nth_def eff6 eff1 [] (S j) |)
->
Datatypes.length vals = i ->
 i < Datatypes.length exps ->
 Datatypes.length eff = i ->
 Datatypes.length vals0 = i0 ->
 i0 < Datatypes.length exps ->
 Datatypes.length eff6 = i0 ->
 length ids = i ->
 length ids0 = i0
->
i = i0 /\ eff = eff6 /\ vals = vals0 /\ ids = ids0.
Proof.
  intros. destruct (Compare_dec.le_gt_dec i i0).
  * case_eq (Lt.le_lt_or_eq i i0 l).
    - intros.
      pose (P1 := con_n_equality exps vals vals0 eff1 eff6 i i0 ids ids0 id _ _ _
                 H H2 H1 H5 H4 H3 H6 H7 H8 H9 H10 l0). inversion P1.
    - intros. subst. pose (list_equal_until_i exps vals vals0 eff6 eff1 _ _ _
                            H H2 e H5 H8 H7 H9 H10). auto.
  * pose (P := con_n_equality_rev exps vals vals0 eff1 eff6 i i0 id ids ids0 _ _ _
               H H2 H5 H4 H3 H6 H7 H8 H9 H10 g H0). inversion P.
Qed.
(*
Lemma con_n_equality_single {env : Environment} {eff : list SideEffectList} :
  forall (exps : list SingleExpression) (vals vals0 : list Value) eff1 eff6 i i0 ids ids0 id eff3 id' ex,
(forall j : nat,
    j < i ->
    forall (v2 : ValueSequence + Exception) (eff'' : SideEffectList) (id'' : nat),
    | env, nth_def ids id 0 j, nth j exps ErrorExp, nth_def eff eff1 [] j | -s> | id'', v2, eff'' | ->
    inl [nth j vals ErrorValue] = v2 /\ nth_def eff eff1 [] (S j) = eff'' /\ nth_def ids id 0 (S j) = id'')
->
(forall j : nat,
     j < i0 ->
     | env, nth_def ids0 id 0 j, nth j exps ErrorExp, nth_def eff6 eff1 [] j | -s>
     | nth_def ids0 id 0 (S j), inl [nth j vals0 ErrorValue],
     nth_def eff6 eff1 [] (S j) |)
->
(forall (v2 : ValueSequence + Exception) (eff'' : SideEffectList) (id'' : nat),
     | env, last ids id, nth i exps ErrorExp, last eff eff1 | -s> | id'', v2, eff'' | ->
     inr ex = v2 /\ eff3 = eff'' /\ id' = id'')
->
Datatypes.length eff = i ->
i < Datatypes.length exps ->
Datatypes.length vals = i ->
Datatypes.length vals0 = i0 ->
i0 < Datatypes.length exps ->
Datatypes.length eff6 = i0 ->
length ids = i ->
length ids0 = i0 ->
i < i0
->
False.
Proof.
  induction eff.
  * intros. simpl in H1. subst. simpl in H10. pose (P := H0 0 H10).
    simpl in H8, P. apply length_zero_iff_nil in H8. subst.
    pose (P2 := H1 _ _ _ P). inversion P2. congruence.
  * intros. inversion H2. simpl in H2. rewrite <- H2 in H4.
    pose (EE1 := element_exist (length eff) vals (eq_sym H4)).
    inversion EE1 as [v]. inversion H12 as [vs]. destruct eff6.
    - simpl in H7. subst. rewrite <- H7 in H10. inversion H10.
    - subst. simpl. (* simpl_concatn_H IHeff. rewrite concatn_app, concatn_app. simpl_concatn. *)
      simpl in H7. (* single_unfold_list H6. *)
      pose (EE2 := element_exist (length eff6) vals0 H7). inversion EE2.
      inversion H2.
      pose (NE := nat_lt_zero _ _  H3). inversion NE.
      pose (EE3 := element_exist x1 exps (eq_sym H13)). inversion EE3. inversion H14.
      subst.
      pose (EE4 := element_exist _ _ (eq_sym H8)).
      pose (EE5 := element_exist _ _ (eq_sym H9)).
      inversion EE4 as [id0']. inversion EE5 as [id0''].
      inversion H5. inversion H15. subst.
      assert (s = a /\ id0' = id0''). {
        subst.
        assert (0 < Datatypes.length (x :: x0)). {  simpl. lia. }
        pose (P := H0 0 H16).
        assert (0 < S (Datatypes.length eff)). {  simpl. lia. }
        pose (P2 := H 0 H17 (inl [nth 0 (x :: x0) ErrorValue]) (nth_def (s :: eff6) eff1 [] 1) _ P).
        inversion P2.
        destruct H19. auto.
      }
      destruct H16. subst.

      eapply IHeff with (exps := x3) (vals := vs) (vals0 := x0) (eff1 := a)
                        (i0 := length x0) (ids := x4) (ids0 := x5); auto.
      + intros. assert (S j < S (Datatypes.length eff)). { simpl. lia. }
        pose (P := H (S j) H18 v2 eff'' id''). pose (P H17). assumption.
      + intros. assert (S j < Datatypes.length (x :: x0)). { simpl. lia. }
        pose (P := H0 (S j) H17). exact P.
      + intros. apply H1.
        rewrite (last_element_equal _ _ id), (last_element_equal _ _ eff1) in H16.
        exact H16.
      + intuition.
      + intuition.
      + intuition.
      + intuition.
Qed.

(** Value lists are equal until ith value *)
Lemma list_equal_until_i_single {env : Environment} {eff : list SideEffectList} :
  forall (exps : list SingleExpression) (vals vals0 : list Value) (eff6 : list SideEffectList)
      (eff1 : SideEffectList) (ids ids0 : list nat) (id : nat),
(forall j : nat,
    j < Datatypes.length vals ->
    forall (v2 : ValueSequence + Exception) (eff'' : SideEffectList) (id'' : nat),
    | env, nth_def ids id 0 j, nth j exps ErrorExp, nth_def eff eff1 [] j | -s> | id'', v2, eff'' | ->
    inl [nth j vals ErrorValue] = v2 /\ nth_def eff eff1 [] (S j) = eff'' /\ nth_def ids id 0 (S j) = id'')
->
(forall j : nat,
     j < Datatypes.length vals0 ->
     | env, nth_def ids0 id 0 j, nth j exps ErrorExp, nth_def eff6 eff1 [] j | -s>
     | nth_def ids0 id 0 (S j), inl [nth j vals0 ErrorValue],
     nth_def eff6 eff1 [] (S j) |)
->
Datatypes.length vals = Datatypes.length vals0
->
Datatypes.length eff = Datatypes.length vals
->
Datatypes.length eff6 = Datatypes.length vals0
->
Datatypes.length vals0 < Datatypes.length exps
->
length ids = length vals
->
length ids0 = length vals0
->
eff = eff6 /\ vals = vals0 /\ ids = ids0.
Proof.
  induction eff.
  * intros. inversion H2. apply eq_sym, length_zero_iff_nil in H8. subst. simpl in H1.
    apply eq_sym, length_zero_iff_nil in H1. subst. simpl in H3. apply length_zero_iff_nil in H3.
    apply length_zero_iff_nil in H5. apply length_zero_iff_nil in H6. subst. auto.
  * intros. simpl in H2. rewrite <- H2 in H1. rewrite <- H1 in H3. pose (NE := nat_lt_zero _ _ H4). inversion NE.
    (* single_unfold_list H2. *)
    pose (EE1 := element_exist (length eff) vals H2).
    pose (EE2 := element_exist (length eff) vals0 H1).
    pose (EE3 := element_exist (length eff) eff6 (eq_sym H3)).
    pose (EE4 := element_exist x exps (eq_sym H7)).
    inversion EE1 as [v]. inversion EE2 as [v']. inversion EE3 as [fe]. inversion EE4 as [e'].
    inversion H8. inversion H9. inversion H10. inversion H11. subst.
    pose (EE5 := element_exist _ _ (eq_sym H5)).
    pose (EE6 := element_exist _ _ (eq_sym H6)).
    inversion EE5 as [id']. inversion EE6 as [id''].
    inversion H12. inversion H13. subst.
    assert (0 < Datatypes.length (v' :: x1)). { simpl. lia. }
    pose (P := H0 0 H14).
    assert (0 < Datatypes.length (v :: x0)). { simpl. lia. }
    pose (P1 := H 0 H15 (inl [nth 0 (v' :: x1) ErrorValue]) (nth_def (fe :: x2) eff1 [] 1) _ P).
    inversion P1. destruct H17. simpl in H18. inversion H16. simpl in H17. subst.

    assert (eff = x2 /\ x0 = x1 /\ x4 = x5).
    {
      apply IHeff with (exps := x3) (vals := x0) (vals0 := x1) (eff1 := fe) (id := id''); auto.
      + intros. assert (S j < S (Datatypes.length x0)). { simpl. lia. } pose (P2 := H (S j) H19 v2 eff'').
        simpl in P2. pose (P2 _ H18). assumption.
      + intros. assert (S j < Datatypes.length (v' :: x1)). { simpl. lia. }
        pose (P3 := H0 (S j) H18). simpl in P3. assumption.
      + inversion H2. inversion H3. inversion H1. auto.
      + inversion H2. inversion H3. inversion H1. auto.
      + intuition.
    }
    inversion H17. inversion H19. subst. auto.
Qed.

(** Slightly different hypotheses for i first element concatn equality *)
Lemma con_n_equality_rev_single {env : Environment} {eff : list SideEffectList} :
forall (exps : list SingleExpression) (vals vals0 : list Value) (eff1 : SideEffectList)
   (eff6 : list SideEffectList) (i i0 : nat) (id : nat) (ids ids0 : list nat) id' ex0 eff4,
(forall j : nat,
    j < i ->
    forall (v2 : ValueSequence + Exception) (eff'' : SideEffectList) (id'' : nat),
    | env, nth_def ids id 0 j, nth j exps ErrorExp, nth_def eff eff1 [] j | -s> | id'', v2, eff'' | ->
    inl [nth j vals ErrorValue] = v2 /\ nth_def eff eff1 [] (S j) = eff'' /\ nth_def ids id 0 (S j) = id'')
->
(forall j : nat,
     j < i0 ->
     | env, nth_def ids0 id 0 j, nth j exps ErrorExp, nth_def eff6 eff1 [] j | -s>
     | nth_def ids0 id 0 (S j), inl [nth j vals0 ErrorValue],
     nth_def eff6 eff1 [] (S j) |)
->
Datatypes.length eff = i ->
i < Datatypes.length exps ->
Datatypes.length vals = i ->
Datatypes.length vals0 = i0 ->
i0 < Datatypes.length exps ->
Datatypes.length eff6 = i0 ->
length ids = i ->
length ids0 = i0 ->
i > i0 ->
(| env, last ids0 id, nth i0 exps ErrorExp, last eff6 eff1 | -s> | id',
     inr ex0,eff4 |)
->
False.
Proof.
induction eff.
  * intros. simpl in H1. subst. inversion H9.
  * intros. simpl in H1. rewrite <- H1 in H3.
    pose (EE1 := element_exist (length eff) vals (eq_sym H3)).
    inversion EE1 as [v]. inversion H11 as [vs]. destruct eff6.
    - subst. apply eq_sym, length_zero_iff_nil in H6. subst. apply length_zero_iff_nil in H8.
      subst.
      simpl in H10. pose (P := H 0 (Nat.lt_0_succ _) _ _ _ H10). inversion P. congruence.
    - subst.
      assert (Datatypes.length ids0 = Datatypes.length vals0) as Helper. { auto. }
      pose (EE2 := element_exist (length eff6) vals0 H6). inversion EE2. inversion H1.
      pose (NE := nat_lt_zero _ _ H2). inversion NE.
      pose (EE3 := element_exist x1 exps (eq_sym H12)). inversion EE3.
      inversion H13. subst.
      pose (EE4 := element_exist _ _ (eq_sym H7)).
      pose (EE5 := element_exist _ _ (eq_sym H8)).
      inversion EE4 as [id0']. inversion EE5 as [id0'']. inversion H4. inversion H14. subst.
      assert (s = a /\ id0' = id0''). {
        subst.
        assert (0 < Datatypes.length (x :: x0)). {  simpl. lia. }
        pose (P := H0 0 H15).
        assert (0 < S (Datatypes.length eff)). {  simpl. lia. }
        pose (P1 := H 0 H16 (inl [nth 0 (x :: x0) ErrorValue]) (nth_def (s :: eff6) eff1 [] 1) _ P).
        destruct P1. destruct H18. simpl in H19, H18. auto.
      }
      destruct H15. subst.
      eapply IHeff with (exps := x3) (vals := vs) (vals0 := x0) (eff1 := a)
                       (i0 := length eff6) (i := length eff) (ids := x4) (ids0 := x5); auto.
      + intros. assert (S j < S (Datatypes.length eff)). { simpl. lia. }
        pose (P := H (S j) H17 v2 eff''). simpl in P.
        pose (P1 := P _ H16). assumption.
      + intros. inversion H6. assert (S j < Datatypes.length (x :: x0)). { simpl. lia. }
        pose (P := H0 (S j) H16). assumption.
      + intuition.
      + inversion H6. auto.
      + rewrite <- H6 in H5. simpl in H5. lia.
      + rewrite <- H6 in Helper. auto.
      + simpl in *. rewrite <- H6 in H9. lia.
      + rewrite <- last_element_equal, <- last_element_equal in H10. simpl in H10.
        inversion H6. rewrite H16. exact H10.
Qed.

(** Based on determinsim, using lists with exceptions, these are equal *)
Lemma exception_equality_single {env : Environment} {exps : list SingleExpression} (vals vals0 : list Value)
   (ex : Exception) (eff1 : SideEffectList) (eff eff6 : list SideEffectList) (i i0 : nat)
   (eff3 : SideEffectList) (ex0 : Exception) (eff4 : SideEffectList) (ids ids0 : list nat)
   (id id' id'' : nat) :
(forall j : nat,
     j < i ->
     forall (v2 : ValueSequence + Exception) (eff'' : SideEffectList) (id'' : nat),
     | env, nth_def ids id 0 j, nth j exps ErrorExp, nth_def eff eff1 [] j | -s> | id'', v2, eff'' | ->
     inl [nth j vals ErrorValue] = v2 /\ nth_def eff eff1 [] (S j) = eff'' /\ nth_def ids id 0 (S j) = id'')
->
| env, last ids0 id, nth i0 exps ErrorExp, last eff6 eff1 | -s>
| id'', inr ex0, eff4 |
->
(forall (v2 : ValueSequence + Exception) (eff'' : SideEffectList) (id'' : nat),
        | env, last ids id, nth i exps ErrorExp, last eff eff1 | -s>
        | id'', v2, eff'' | -> inr ex = v2 /\ eff3 = eff'' /\ id' = id'')
->
(forall j : nat,
      j < i0 ->
      | env, nth_def ids0 id 0 j, nth j exps ErrorExp, nth_def eff6 eff1 [] j | -s>
      | nth_def ids0 id 0 (S j), inl [nth j vals0 ErrorValue],
      nth_def eff6 eff1 [] (S j) |)
->
Datatypes.length vals = i ->
 i < Datatypes.length exps ->
 Datatypes.length eff = i ->
 Datatypes.length vals0 = i0 ->
 i0 < Datatypes.length exps ->
 Datatypes.length eff6 = i0 ->
 length ids = i ->
 length ids0 = i0
->
i = i0 /\ eff = eff6 /\ vals = vals0 /\ ids = ids0.
Proof.
  intros. destruct (Compare_dec.le_gt_dec i i0).
  * case_eq (Lt.le_lt_or_eq i i0 l).
    - intros.
      pose (P1 := con_n_equality_single exps vals vals0 eff1 eff6 i i0 ids ids0 id _ _ _
                 H H2 H1 H5 H4 H3 H6 H7 H8 H9 H10 l0). inversion P1.
    - intros. subst. pose (list_equal_until_i_single exps vals vals0 eff6 eff1 _ _ _
                            H H2 e H5 H8 H7 H9 H10). auto.
  * pose (P := con_n_equality_rev_single exps vals vals0 eff1 eff6 i i0 id ids ids0 _ _ _
               H H2 H5 H4 H3 H6 H7 H8 H9 H10 g H0). inversion P.
Qed. *)


Coq < Section Basics001.

Coq < Require Import Classical.

Coq < Definition admit {T: Type} : T.
1 subgoal

  T : Type
  ============================
   T

admit < Inductive day : Type :=
  | monday : day
  | tuesday : day
  | wednesday : day
  | thursday : day
  | friday : day
  | saturday : day
  | sunday : day.admit < admit < admit < admit < admit < admit < admit <
day is defined
day_rect is defined
day_ind is defined
day_rec is defined

admit < Definition next_weekday (d:day) : day :=
  match d with
  | monday    => tuesday
  | tuesday   => wednesday
  | wednesday => thursday
  | thursday  => friday
  | friday    => monday
  | saturday  => monday
  | sunday    => monday
  end.admit < admit < admit < admit < admit < admit < admit < admit < admit <
next_weekday is defined

admit < Compute (next_weekday friday).
     = monday
     : day

admit < Compute (next_weekday (next_weekday saturday)).
     = tuesday
     : day


Unset Strict Universe Declaration.
Require Import TestSuite.admit.
(* File reduced by coq-bug-finder from original input, then from 9113 lines to 279 lines *)
(* coqc version trunk (October 2014) compiled on Oct 19 2014 18:56:9 with OCaml 3.12.1
   coqtop version trunk (October 2014) *)

Notation Type0 := Set.

Notation idmap := (fun x => x).

Notation "( x ; y )" := (existT _ x y) : fibration_scope.
Open Scope fibration_scope.

Notation pr1 := projT1.

Notation "x .1" := (pr1 x) (at level 3, format "x '.1'") : fibration_scope.

Definition compose {A B C : Type} (g : B -> C) (f : A -> B) :=
  fun x => g (f x).

Notation "g 'o' f" := (compose g f) (at level 40, left associativity) : function_scope.
Open Scope function_scope.

Inductive paths {A : Type} (a : A) : A -> Type :=
  idpath : paths a a.

Arguments idpath {A a} , [A] a.

Notation "x = y :> A" := (@paths A x y) : type_scope.
Notation "x = y" := (x = y :>_) : type_scope.
Definition inverse {A : Type} {x y : A} (p : x = y) : y = x.
admit.
Defined.

Definition concat {A : Type} {x y z : A} (p : x = y) (q : y = z) : x = z :=
  match p, q with idpath, idpath => idpath end.

Notation "1" := idpath : path_scope.

Notation "p @ q" := (concat p q) (at level 20) : path_scope.

Notation "p ^" := (inverse p) (at level 3, format "p '^'") : path_scope.

Notation "p @' q" := (concat p q) (at level 21, left associativity,
  format "'[v' p '/' '@''  q ']'") : long_path_scope.
Definition transport {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x) : P y.
exact (match p with idpath => u end).
Defined.

Notation "p # x" := (transport _ p x) (right associativity, at level 65, only parsing) : path_scope.
Definition ap {A B:Type} (f:A -> B) {x y:A} (p:x = y) : f x = f y.
exact (match p with idpath => idpath end).
Defined.

Definition pointwise_paths {A} {P:A->Type} (f g:forall x:A, P x)
  := forall x:A, f x = g x.

Notation "f == g" := (pointwise_paths f g) (at level 70, no associativity) : type_scope.

Definition Sect {A B : Type} (s : A -> B) (r : B -> A) :=
  forall x : A, r (s x) = x.

Class IsEquiv {A B : Type} (f : A -> B) := BuildIsEquiv {
  equiv_inv : B -> A ;
  eisretr : Sect equiv_inv f;
  eissect : Sect f equiv_inv;
  eisadj : forall x : A, eisretr (f x) = ap f (eissect x)
}.

Arguments eisretr {A B} f {_} _.

Record Equiv A B := BuildEquiv {
  equiv_fun : A -> B ;
  equiv_isequiv : IsEquiv equiv_fun
}.

Coercion equiv_fun : Equiv >-> Funclass.

Global Existing Instance equiv_isequiv.

Notation "A <~> B" := (Equiv A B) (at level 85) : equiv_scope.

Notation "f ^-1" := (@equiv_inv _ _ f _) (at level 3, format "f '^-1'") : equiv_scope.

Class Contr_internal (A : Type) := BuildContr {
  center : A ;
  contr : (forall y : A, center = y)
}.

Inductive trunc_index : Type :=
| minus_two : trunc_index
| trunc_S : trunc_index -> trunc_index.

Notation "n .+1" := (trunc_S n) (at level 2, left associativity, format "n .+1") : trunc_scope.
Local Open Scope trunc_scope.
Notation "-2" := minus_two (at level 0) : trunc_scope.
Notation "-1" := (-2.+1) (at level 0) : trunc_scope.

Fixpoint IsTrunc_internal (n : trunc_index) (A : Type) : Type :=
  match n with
    | -2 => Contr_internal A
    | n'.+1 => forall (x y : A), IsTrunc_internal n' (x = y)
  end.

Class IsTrunc (n : trunc_index) (A : Type) : Type :=
  Trunc_is_trunc : IsTrunc_internal n A.
Notation IsHProp := (IsTrunc -1).

Monomorphic Axiom dummy_funext_type : Type0.
Monomorphic Class Funext := { dummy_funext_value : dummy_funext_type }.

Local Open Scope path_scope.

Definition concat_p1 {A : Type} {x y : A} (p : x = y) :
  p @ 1 = p
  :=
  match p with idpath => 1 end.

Definition concat_1p {A : Type} {x y : A} (p : x = y) :
  1 @ p = p
  :=
  match p with idpath => 1 end.

Definition concat_p_pp {A : Type} {x y z t : A} (p : x = y) (q : y = z) (r : z = t) :
  p @ (q @ r) = (p @ q) @ r :=
  match r with idpath =>
    match q with idpath =>
      match p with idpath => 1
      end end end.

Definition concat_pp_p {A : Type} {x y z t : A} (p : x = y) (q : y = z) (r : z = t) :
  (p @ q) @ r = p @ (q @ r) :=
  match r with idpath =>
    match q with idpath =>
      match p with idpath => 1
      end end end.

Definition moveL_Mp {A : Type} {x y z : A} (p : x = z) (q : y = z) (r : y = x) :
  r^ @ q = p -> q = r @ p.
admit.
Defined.

Ltac with_rassoc tac :=
  repeat rewrite concat_pp_p;
  tac;

  repeat rewrite concat_p_pp.

Ltac rewrite_moveL_Mp_p := with_rassoc ltac:(apply moveL_Mp).

Definition ap_p_pp {A B : Type} (f : A -> B) {w : B} {x y z : A}
  (r : w = f x) (p : x = y) (q : y = z) :
  r @ (ap f (p @ q)) = (r @ ap f p) @ (ap f q).
admit.
Defined.

Definition ap_compose {A B C : Type} (f : A -> B) (g : B -> C) {x y : A} (p : x = y) :
  ap (g o f) p = ap g (ap f p)
  :=
  match p with idpath => 1 end.

Definition concat_Ap {A B : Type} {f g : A -> B} (p : forall x, f x = g x) {x y : A} (q : x = y) :
  (ap f q) @ (p y) = (p x) @ (ap g q)
  :=
  match q with
    | idpath => concat_1p _ @ ((concat_p1 _) ^)
  end.

Definition transportD2 {A : Type} (B C : A -> Type) (D : forall a:A, B a -> C a -> Type)
  {x1 x2 : A} (p : x1 = x2) (y : B x1) (z : C x1) (w : D x1 y z)
  : D x2 (p # y) (p # z)
  :=
  match p with idpath => w end.
Local Open Scope equiv_scope.

Definition transport_arrow_toconst {A : Type} {B : A -> Type} {C : Type}
  {x1 x2 : A} (p : x1 = x2) (f : B x1 -> C) (y : B x2)
  : (transport (fun x => B x -> C) p f) y  =  f (p^ # y).
admit.
Defined.

Definition transport_arrow_fromconst {A B : Type} {C : A -> Type}
  {x1 x2 : A} (p : x1 = x2) (f : B -> C x1) (y : B)
  : (transport (fun x => B -> C x) p f) y  =  p # (f y).
admit.
Defined.

Definition ap_transport_arrow_toconst {A : Type} {B : A -> Type} {C : Type}
  {x1 x2 : A} (p : x1 = x2) (f : B x1 -> C) {y1 y2 : B x2} (q : y1 = y2)
  : ap (transport (fun x => B x -> C) p f) q
    @ transport_arrow_toconst p f y2
    = transport_arrow_toconst p f y1
    @ ap (fun y => f (p^ # y)) q.
admit.
Defined.

Class Univalence.
Definition path_universe {A B : Type} (f : A -> B) {feq : IsEquiv f} : (A = B).
admit.
Defined.
Definition transport_path_universe
           {A B : Type} (f : A -> B) {feq : IsEquiv f} (z : A)
  : transport (fun X:Type => X) (path_universe f) z = f z.
admit.
Defined.
Definition transport_path_universe_V `{Funext}
           {A B : Type} (f : A -> B) {feq : IsEquiv f} (z : B)
  : transport (fun X:Type => X) (path_universe f)^ z = f^-1 z.
admit.
Defined.

Ltac simpl_do_clear tac term :=
  let H := fresh in
  assert (H := term);
    simpl in H |- *;
    tac H;
    clear H.

Tactic Notation "simpl" "rewrite"      constr(term) := simpl_do_clear ltac:(fun H => rewrite    H) term.

Global Instance Univalence_implies_Funext `{Univalence} : Funext.
Admitted.

Section Factorization.

  Context {class1 class2 : forall (X Y : Type@{i}), (X -> Y) -> Type@{i}}
          `{forall (X Y : Type@{i}) (g:X->Y), IsHProp (class1 _ _ g)}
          `{forall (X Y : Type@{i}) (g:X->Y), IsHProp (class2 _ _ g)}
          {A B : Type@{i}} {f : A -> B}.

  Record Factorization :=
    { intermediate : Type ;
      factor1 : A -> intermediate ;
      factor2 : intermediate -> B ;
      fact_factors : factor2 o factor1 == f ;
      inclass1 : class1 _ _ factor1 ;
      inclass2 : class2 _ _ factor2
    }.

  Record PathFactorization {fact fact' : Factorization} :=
    { path_intermediate : intermediate fact <~> intermediate fact' ;
      path_factor1 : path_intermediate o factor1 fact == factor1 fact' ;
      path_factor2 : factor2 fact == factor2 fact' o path_intermediate ;
      path_fact_factors : forall a, path_factor2 (factor1 fact a)
                          @ ap (factor2 fact') (path_factor1 a)
                          @ fact_factors fact' a
                          = fact_factors fact a
    }.
    Context `{Univalence} {fact fact' : Factorization}
            (pf : @PathFactorization fact fact').

    Let II := path_intermediate pf.
    Let ff1 := path_factor1 pf.
    Let ff2 := path_factor2 pf.
Local Definition II' : intermediate fact = intermediate fact'.
admit.
Defined.

    Local Definition fff' (a : A)
    : (transportD2 (fun X => A -> X) (fun X => X -> B)
                   (fun X g h => {_ : forall a : A, h (g a) = f a &
                                  {_ : class1 A X g & class2 X B h}})
                   II' (factor1 fact) (factor2 fact)
                   (fact_factors fact; (inclass1 fact; inclass2 fact))).1 a =
      ap (transport (fun X => X -> B) II' (factor2 fact))
        (transport_arrow_fromconst II' (factor1 fact) a
          @ transport_path_universe II (factor1 fact a)
          @ ff1 a)
        @ transport_arrow_toconst II' (factor2 fact) (factor1 fact' a)
        @ ap (factor2 fact) (transport_path_universe_V II (factor1 fact' a))
        @ ff2 (II^-1 (factor1 fact' a))
        @ ap (factor2 fact') (eisretr II (factor1 fact' a))
        @ fact_factors fact' a.
    Proof.

      Open Scope long_path_scope.

      rewrite (ap_transport_arrow_toconst (B := idmap) (C := B)).

      simpl rewrite (@ap_compose _ _ _ (transport idmap (path_universe II)^)
                                 (factor2 fact)).
      rewrite <- ap_p_pp; rewrite_moveL_Mp_p.
      Set Debug Tactic Unification.
      Fail rewrite (concat_Ap ff2).


(* This file is generated by Why3's Coq 8.4 driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.
Require int.Int.
Require int.Abs.
Require int.EuclideanDivision.
Require int.ComputerDivision.
Require number.Parity.
Require number.Divisibility.
Require number.Prime.
Require map.Map.

(* Why3 assumption *)
Definition unit := unit.

Axiom qtmark : Type.
Parameter qtmark_WhyType : WhyType qtmark.
Existing Instance qtmark_WhyType.

(* Why3 assumption *)
Definition lt_nat (x:Z) (y:Z): Prop := (0%Z <= y)%Z /\ (x < y)%Z.

(* Why3 assumption *)
Inductive lex : (Z* Z)%type -> (Z* Z)%type -> Prop :=
  | Lex_1 : forall (x1:Z) (x2:Z) (y1:Z) (y2:Z), (lt_nat x1 x2) -> (lex (x1,
      y1) (x2, y2))
  | Lex_2 : forall (x:Z) (y1:Z) (y2:Z), (lt_nat y1 y2) -> (lex (x, y1) (x,
      y2)).

(* Why3 assumption *)
Inductive ref (a:Type) {a_WT:WhyType a} :=
  | mk_ref : a -> ref a.
Axiom ref_WhyType : forall (a:Type) {a_WT:WhyType a}, WhyType (ref a).
Existing Instance ref_WhyType.
Implicit Arguments mk_ref [[a] [a_WT]].

(* Why3 assumption *)
Definition contents {a:Type} {a_WT:WhyType a} (v:(@ref a a_WT)): a :=
  match v with
  | (mk_ref x) => x
  end.

(* Why3 assumption *)
Inductive array
  (a:Type) {a_WT:WhyType a} :=
  | mk_array : Z -> (@map.Map.map Z _ a a_WT) -> array a.
Axiom array_WhyType : forall (a:Type) {a_WT:WhyType a}, WhyType (array a).
Existing Instance array_WhyType.
Implicit Arguments mk_array [[a] [a_WT]].

(* Why3 assumption *)
Definition elts {a:Type} {a_WT:WhyType a} (v:(@array a a_WT)): (@map.Map.map
  Z _ a a_WT) := match v with
  | (mk_array x x1) => x1
  end.

(* Why3 assumption *)
Definition length {a:Type} {a_WT:WhyType a} (v:(@array a a_WT)): Z :=
  match v with
  | (mk_array x x1) => x
  end.

(* Why3 assumption *)
Definition get {a:Type} {a_WT:WhyType a} (a1:(@array a a_WT)) (i:Z): a :=
  (map.Map.get (elts a1) i).

(* Why3 assumption *)
Definition set {a:Type} {a_WT:WhyType a} (a1:(@array a a_WT)) (i:Z)
  (v:a): (@array a a_WT) := (mk_array (length a1) (map.Map.set (elts a1) i
  v)).

(* Why3 assumption *)
Definition make {a:Type} {a_WT:WhyType a} (n:Z) (v:a): (@array a a_WT) :=
  (mk_array n (map.Map.const v: (@map.Map.map Z _ a a_WT))).

(* Why3 assumption *)
Definition no_prime_in (l:Z) (u:Z): Prop := forall (x:Z), ((l < x)%Z /\
  (x < u)%Z) -> ~ (number.Prime.prime x).

(* Why3 assumption *)
Definition first_primes (p:(@array Z _)) (u:Z): Prop := ((get p
  0%Z) = 2%Z) /\ ((forall (i:Z) (j:Z), ((0%Z <= i)%Z /\ ((i < j)%Z /\
  (j < u)%Z)) -> ((get p i) < (get p j))%Z) /\ ((forall (i:Z),
  ((0%Z <= i)%Z /\ (i < u)%Z) -> (number.Prime.prime (get p i))) /\
  forall (i:Z), ((0%Z <= i)%Z /\ (i < (u - 1%Z)%Z)%Z) -> (no_prime_in (get p
  i) (get p (i + 1%Z)%Z)))).

Axiom exists_prime : forall (p:(@array Z _)) (u:Z), (1%Z <= u)%Z ->
  ((first_primes p u) -> forall (d:Z), ((2%Z <= d)%Z /\ (d <= (get p
  (u - 1%Z)%Z))%Z) -> ((number.Prime.prime d) -> exists i:Z, ((0%Z <= i)%Z /\
  (i < u)%Z) /\ (d = (get p i)))).

Axiom Bertrand_postulate : forall (p:Z), (number.Prime.prime p) ->
  ~ (no_prime_in p (2%Z * p)%Z).

Lemma Zle_sqrt: forall x y, (0 <= x -> 0 <= y -> x*x < y*y -> x<y)%Z.
intros x y Hx Hy H.
apply Znot_ge_lt.
intros H'.
apply (Zlt_not_le _ _ H).
apply Zge_le in H'.
now apply Zmult_le_compat.
Qed.

Import Zquot.

(* Why3 goal *)
Theorem WP_parameter_prime_numbers : forall (m:Z), (2%Z <= m)%Z ->
  ((0%Z <= m)%Z -> ((0%Z <= m)%Z -> (((0%Z <= 0%Z)%Z /\ (0%Z < m)%Z) ->
  forall (p:(@map.Map.map Z _ Z _)), ((0%Z <= m)%Z /\
  (p = (map.Map.set (map.Map.const 0%Z: (@map.Map.map Z _ Z _)) 0%Z 2%Z))) ->
  (((0%Z <= 1%Z)%Z /\ (1%Z < m)%Z) -> forall (p1:(@map.Map.map Z _ Z _)),
  ((0%Z <= m)%Z /\ (p1 = (map.Map.set p 1%Z 3%Z))) -> let o := (m - 1%Z)%Z in
  ((2%Z <= o)%Z -> forall (n:Z) (p2:(@map.Map.map Z _ Z _)), forall (j:Z),
  ((2%Z <= j)%Z /\ (j <= o)%Z) -> (((first_primes (mk_array m p2) j) /\
  ((((map.Map.get p2 (j - 1%Z)%Z) < n)%Z /\ (n < (2%Z * (map.Map.get p2
  (j - 1%Z)%Z))%Z)%Z) /\ ((number.Parity.odd n) /\ (no_prime_in
  (map.Map.get p2 (j - 1%Z)%Z) n)))) -> forall (k:Z), forall (n1:Z)
  (p3:(@map.Map.map Z _ Z _)), ((0%Z <= m)%Z /\ (((1%Z <= k)%Z /\
  (k < j)%Z) /\ ((first_primes (mk_array m p3) j) /\ ((((map.Map.get p3
  (j - 1%Z)%Z) < n1)%Z /\ (n1 < (2%Z * (map.Map.get p3 (j - 1%Z)%Z))%Z)%Z) /\
  ((number.Parity.odd n1) /\ ((no_prime_in (map.Map.get p3 (j - 1%Z)%Z)
  n1) /\ forall (i:Z), ((0%Z <= i)%Z /\ (i < k)%Z) ->
  ~ (number.Divisibility.divides (map.Map.get p3 i) n1))))))) ->
  (((0%Z <= k)%Z /\ (k < m)%Z) ->
  ((~ ((ZArith.BinInt.Z.rem n1 (map.Map.get p3 k)) = 0%Z)) ->
  (((0%Z <= k)%Z /\ (k < m)%Z) -> (((0%Z <= k)%Z /\ (k < m)%Z) ->
  ((~ ((map.Map.get p3 k) < (ZArith.BinInt.Z.quot n1 (map.Map.get p3
  k)))%Z) -> (number.Prime.prime n1)))))))))))).
(* Why3 intros m h1 h2 h3 (h4,h5) p (h6,h7) (h8,h9) p1 (h10,h11) o h12 n p2 j
        (h13,h14) (h15,((h16,h17),(h18,h19))) k n1 p3
        (h20,((h21,h22),(h23,((h24,h25),(h26,(h27,h28)))))) (h29,h30) h31
        (h32,h33) (h34,h35) h36. *)
intros m h1 h2 h3 (h4,h5) p (h6,h7) (h8,h9) p1 (h10,h11) o h12 n p2 j
        (h13,h14) (h15,((h16,h17),(h18,h19))) k n1 p3
        (h20,((h21,h22),(h23,((h24,h25),(h26,(h27,h28)))))) (h29,h30) h31
        (h32,h33) (h34,h35) h36.
intuition.
red in h23. destruct h23 as (p0, (sorted, (only_primes, all_primes))).
assert (H2: (2 < Map.get p3 k)%Z).
rewrite <- p0. apply sorted; omega.
apply Prime.small_divisors; auto.
omega.
intros.
generalize (Z_quot_rem_eq n1 (Map.get p3 k)). intro div.
assert (ne1: (0 <= n1 /\ Map.get p3 k <> 0)%Z) by omega.
assert (mod1: (0 <= Z.rem n1 (Map.get p3 k))%Z).
destruct (not_Zeq_inf _ _ (proj2 ne1)) as [Zm|Zm].
now apply Zrem_lt_pos_neg.
now apply Zrem_lt_pos_pos.
assert (mod2: (Z.rem n1 (Map.get p3 k) < Map.get p3 k)%Z).
apply Zrem_lt_pos_pos ; omega.
assert (d <= Map.get p3 k)%Z.
assert (d < Map.get p3 k+1)%Z. 2: omega.
apply Zle_sqrt; try omega.
assert (2 < Map.get p3 k)%Z.
rewrite <- p0. apply sorted; omega.
apply Zle_lt_trans with n1; try omega.
assert (Map.get p3 k * (Z.quot n1 (Map.get p3 k)) <= Map.get p3 k * Map.get p3 k)%Z.
apply Zmult_le_compat_l; try omega.
replace ((Map.get p3 k + 1) * (Map.get p3 k + 1))%Z with (Map.get p3 k * Map.get p3 k + 2 * Map.get p3 k + 1)%Z by ring.
omega.
destruct (exists_prime (mk_array m p3) (k+1))%Z with (d := d) as (i, (hi1, hi2)); auto.
omega.
red; split; intros.
auto.
split; intros.
apply sorted; omega.
split; intros.
apply only_primes; omega.
apply all_primes; omega.
unfold get; simpl.
replace (k+1-1)%Z with k by omega.
auto.
unfold get in hi2; simpl in hi2. subst d.
assert (case: (i < k \/i = k)%Z) by omega. destruct case.
red; intro. apply h28 with i; try omega.
auto.
subst i.
intro. apply h31.
apply Divisibility.divides_mod_computer; auto; omega.
Qed.


From Equations Require Import Equations.

Require Import Coq.Lists.List.
Import ListNotations.

Require Export SystemFR.TypeSugar.

Opaque T_reducible.
Opaque reducible_values.

Definition T_equivalent_at A t1 t2: tree :=
  T_type_refine
    T_unit
      (T_intersection
        (T_forall
           (T_arrow A T_bool)
           (T_equiv (app (lvar 0 term_var) t1) (app (lvar 0 term_var) t2))
        )
        (T_intersection (T_reducible t1 A) (T_reducible t2 A))
      ).

Lemma subst_equivalent_at:
  forall A t1 t2 l tag,
    psubstitute (T_equivalent_at A t1 t2) l tag =
    T_equivalent_at (psubstitute A l tag) (psubstitute t1 l tag) (psubstitute t2 l tag).
Proof.
  unfold T_equivalent_at;
    repeat step.
Qed.

Definition equivalent_at ρ A t1 t2: Prop :=
  [ ρ ⊨ t1 : A ] /\
  [ ρ ⊨ t2 : A ] /\
  forall f,
    is_erased_term f ->
    wf f 0 ->
    pfv f term_var = nil ->
    [ ρ ⊨ f : T_arrow A T_bool ]v ->
    [ app f t1 ≡ app f t2 ].

Notation "[ ρ ⊨ t1 ≡ t2 : A ]" := (equivalent_at ρ A t1 t2)
  (at level 60, ρ at level 60, t1 at level 60, t2 at level 60).
Notation "[ t1 ≡ t2 : A ]" := ([ nil ⊨ t1 ≡ t2 : A ])
  (at level 60, t1 at level 60, t2 at level 60).

Lemma equivalent_at_prop_type:
  forall ρ A t1 t2,
    is_erased_type A ->
    is_erased_term t1 ->
    is_erased_term t2 ->
    wf A 0 ->
    wf t1 0 ->
    wf t2 0 ->
    twf A 0 ->
    [ ρ ⊨ t1 ≡ t2 : A ] ->
    [ ρ ⊨ uu : T_equivalent_at A t1 t2 ]v.
Proof.
  unfold equivalent_at, T_equivalent_at;
    repeat step || simp_red_top_level_goal ||
           (rewrite open_none in * by t_closer);
    t_closer;
    eauto using is_erased_type_T_reducible.

  exists uu;
    repeat step || simp_red_goal || apply reducible_values_prop_type ||
           (rewrite open_T_reducible in * by auto) ||
           (rewrite open_none in * by t_closer);
    t_closer.
Qed.

Lemma equivalent_at_type_prop:
  forall ρ A t1 t2 p,
    is_erased_type A ->
    is_erased_term t1 ->
    is_erased_term t2 ->
    wf A 0 ->
    wf t1 0 ->
    wf t2 0 ->
    pfv A term_var = nil ->
    pfv t1 term_var = nil ->
    pfv t2 term_var = nil ->
    twf A 0 ->
    valid_interpretation ρ ->
    [ ρ ⊨ p : T_equivalent_at A t1 t2 ]v ->
    [ ρ ⊨ t1 ≡ t2 : A ].
Proof.
  unfold equivalent_at, T_equivalent_at;
    repeat step || simp reducible_values in H10 || list_utils ||
         apply_anywhere reducible_values_type_prop ||
         (rewrite open_T_reducible in * by auto) ||
         (rewrite open_none in * by t_closer) ||
         (rewrite topen_none in * by t_closer);
    t_closer.

  unshelve epose proof (H25 _ _ _ _ H14) as HH;
    repeat step.

  simp reducible_values in HH;
    repeat step || (rewrite open_none in * by t_closer).
Qed.

Lemma equivalent_at_type_prop2:
  forall ρ A t1 t2 p,
    is_erased_type A ->
    is_erased_term t1 ->
    is_erased_term t2 ->
    wf A 0 ->
    wf t1 0 ->
    wf t2 0 ->
    pfv A term_var = nil ->
    pfv t1 term_var = nil ->
    pfv t2 term_var = nil ->
    twf A 0 ->
    valid_interpretation ρ ->
    [ ρ ⊨ p : T_equivalent_at A t1 t2 ] ->
    [ ρ ⊨ t1 ≡ t2 : A ].
Proof.
  unfold reduces_to;
    repeat step;
    eauto using equivalent_at_type_prop.
Qed.


(* * Heap Lookup *)

From Undecidability Require Import TM.Code.ProgrammingTools LM_heap_def.
From Undecidability.TM.L Require Import Alphabets.
From Undecidability Require Import TM.Code.ListTM TM.Code.CasePair TM.Code.CaseSum TM.Code.CaseNat Hoare.Hoare.

Set Default Proof Using "Type".
Local Arguments plus : simpl never.
Local Arguments mult : simpl never.

Section Lookup.

  (* There is no need to save [n]. [H] must be saved. We use the [Nth'] machine, because we don't want to introduce an additional [sigOption sigHEnt] to the alphabet. [Nth'] also doesn't save [a] (which is the parameter of [Nth'] here, not [n]). [Lookup] will overwrite and reset the variables [a] and [n], but save [H] (which is saved by [Nth']). *)

(* We could define [Lookup] over the alphabet [sigHeap], however, in the step machine, we want to read [a] and [n] from a different closure alphabet (sigList sigHClos). [a] is read from an address of a closure and [n] from a variable of this closure, and the output closure will also be copied to this alphabet. *)

  Variable sigLookup : finType.

  Variable retr_clos_lookup : Retract sigHClos sigLookup.
  Variable retr_heap_lookup : Retract sigHeap sigLookup.

  (*
There are (more than) three possible ways how to encode [nat] on the [Heap] alphabet [sigLookup]:

- 1: as a heap address of a closure on the stack alphabet
- 2: as a variable of a command inside a closure of the closure input alphabet
- 3: as a "next" address of an heap entry

[a] is stored in the second way and [n] in the third way.
*)

  (* No 1 *)
  Definition retr_nat_clos_ad : Retract sigNat sigHClos :=
    Retract_sigPair_X _ _.
  Definition retr_nat_lookup_clos_ad : Retract sigNat sigLookup :=
    ComposeRetract retr_clos_lookup retr_nat_clos_ad.

  (* No 2 *)
  Definition retr_nat_clos_var : Retract sigNat sigHClos :=
    Retract_sigPair_Y _ _.
  Definition retr_nat_lookup_clos_var : Retract sigNat sigLookup :=
    ComposeRetract retr_clos_lookup retr_nat_clos_var.

  (* No 3 *)
  Definition retr_nat_heap_entry : Retract sigNat sigHeap :=
    Retract_sigList_X (Retract_sigOption_X (Retract_sigPair_Y _ (Retract_id _))).
  Local Definition retr_nat_lookup_entry : Retract sigNat sigLookup :=
    ComposeRetract retr_heap_lookup retr_nat_heap_entry.

  (* Encoding of a closure on the heap alphabet *)
  Definition retr_clos_heap : Retract sigHClos sigHeap := _.
  Definition retr_clos_lookup_heap : Retract sigHClos sigLookup := ComposeRetract retr_heap_lookup retr_clos_heap.

  Definition retr_hent_heap : Retract sigHEntr sigHeap := _.
  Local Definition retr_hent_lookup : Retract sigHEntr sigLookup := ComposeRetract retr_heap_lookup retr_hent_heap.

  Definition retr_hent'_heap : Retract sigHEntr' sigHeap := _.
  Local Definition retr_hent'_lookup : Retract sigHEntr' sigLookup := ComposeRetract retr_heap_lookup retr_hent'_heap.

  (*
  Tapes:
  t0: H
  t1: a
  t2: n
  t3: out
  t4: internal tape
  *)

  Definition Lookup_Step : pTM sigLookup^+ (option bool) 5 :=
    If (Nth' retr_heap_lookup retr_nat_lookup_clos_ad @ [|Fin0; Fin1; Fin4; Fin3|])
       (If (CaseOption sigHEntr'_fin ⇑ retr_hent_lookup @ [|Fin4|])
           (CasePair sigHClos_fin sigHAdd_fin ⇑ retr_hent'_lookup @ [|Fin4; Fin3|];;
            If (CaseNat ⇑ retr_nat_lookup_clos_var @ [|Fin2|])
               (Return (CopyValue _ @ [|Fin4; Fin1|];; (* n = S n' *)
                        Translate retr_nat_lookup_entry retr_nat_lookup_clos_ad @ [|Fin1|];;
                        Reset _ @ [|Fin4|];;
                        Reset _ @ [|Fin3 |])
                       None) (* continue *)
               (Return (Reset _ @ [|Fin4|];; (* n = 0 *)
                        Reset _ @ [|Fin2|];;
                        Translate retr_clos_lookup_heap retr_clos_lookup @ [|Fin3|])
                       (Some true))) (* return true *)
           (Return Nop (Some false))) (* return false *)
       (Return Nop (Some false)) (* return false *)
  .

  Definition Lookup_Step_size (H : Heap) (a n : nat) : Vector.t (nat->nat) 5 :=
    match nth_error H a with
    | Some (Some (g, b)) =>
      match n with
      | S n' =>
        [|(* 0 *) Nth'_size H a @>Fin0;
          (* 1 *) Nth'_size H a @>Fin1 >> CopyValue_size b;
          (* 2 *) S;
          (* 3 *) Nth'_size H a @>Fin3 >> CasePair_size1 g >> Reset_size g;
          (* 4 *) Nth'_size H a @>Fin2 >> CaseOption_size_Some >> CasePair_size0 g >> Reset_size b|]
      | 0 =>
        [|(* 0 *) Nth'_size H a @>Fin0;
          (* 1 *) Nth'_size H a @>Fin1;
          (* 2 *) Reset_size 0;
          (* 3 *) Nth'_size H a @>Fin3 >> CasePair_size1 g;
          (* 4 *) Nth'_size H a @>Fin2 >> CaseOption_size_Some >> CasePair_size0 g >> Reset_size b|]
      end
    | _ => default (* not specified *)
    end.

  Local Definition Lookup_Step_steps_CaseNat (n: nat) (e': HClos * HAdd) :=
    let (g,b) := (fst e', snd e') in
    match n with
    | S _ => 1 + CopyValue_steps b + 1 + Translate_steps b + 1 + Reset_steps b + Reset_steps g
    | O => 1 + Reset_steps b + 1 + Reset_steps 0 + Translate_steps g
    end.

  Local Definition Lookup_Step_steps_CaseOption (n:nat) (e: HEntr) :=
    match e with
    | Some ((g, b) as e') => 1 + CasePair_steps g + 1 + CaseNat_steps + Lookup_Step_steps_CaseNat n e'
    | None => 0
    end.

  Local Definition Lookup_Step_steps_Nth' H a n :=
    match nth_error H a with
    | Some e => 1 + CaseOption_steps + Lookup_Step_steps_CaseOption n e
    | None => 0
    end.

  Definition Lookup_Step_steps (H: Heap) (a: HAdd) (n: nat) :=
    1 + Nth'_steps H a + Lookup_Step_steps_Nth' H a n.

  Lemma Lookup_Step_SpecT_space H a n ss:
  TripleT
    ≃≃([],withSpace [| ≃(_) H ; ≃(retr_nat_lookup_clos_ad) a;≃(retr_nat_lookup_clos_var) n;Void;Void |] ss)
    (Lookup_Step_steps H a n) Lookup_Step
    (fun yout => ≃≃([yout = match nth_error (A:=HEntr) H a with Some (Some _ ) => match n with 0 => Some true | _ => None end | _ => Some false end]
       ,withSpace
       match nth_error (A:=HEntr) H a with
        Some (Some (g,b) ) =>
        match n with
        | 0 => [| ≃(_) H; Void;Void;≃(retr_clos_lookup) g;Void|]
        | S n' => [| ≃(_) H;≃(retr_nat_lookup_clos_ad) b;≃(retr_nat_lookup_clos_var) n';Void;Void|]
        end
       | _ => SpecVTrue
       end (appSize (Lookup_Step_size H a n) ss))).
  Proof.
    unfold Lookup_Step. remember (Lookup_Step_size H a n) as F eqn:HF.
    eapply If_SpecTReg with (k2:= match nth_error H a with Some (Some (g,b)) => _ | Some _ => _ | None => _ end) (k3:=0).
    now hsteps_cbn.
    2:{ destruct nth_error. hintros [=]. cbn. hsteps_cbn. tspec_ext. }
    {
      unfold Lookup_Step_size in HF.
      cbn. destruct nth_error as [ h | ];hintros [=];[].
      eapply If_SpecTReg  with (k2:= match h with Some (g,b)=> _ |  None => _ end) (k3:=0).
      { hsteps_cbn. cbn. tspec_ext. }
      2:{ cbn. destruct h; hintros [=]. hsteps_cbn. cbn. tspec_ext. }
      2:{ cbn. intros ? ->. destruct h as [[]| ]. 2:reflexivity. shelve. }
      cbn. destruct h as [[g b] | ];hintros [=];[].
      hstep. { hsteps_cbn. cbn. tspec_ext. }
      2:{cbn. unfold CasePair_steps. reflexivity. }
      intros ?. hstep. { hsteps_cbn. cbn. tspec_ext. }
      - cbn. hintros Hn. destruct n. easy.
        hsteps_cbn. cbn.
        { eapply ConsequenceT_pre. refine (Translate_SpecT_size _ _ _ _ [| _|]). 3:tspec_ext. reflexivity. }
        1-3:reflexivity.
        subst F. cbn. tspec_ext.
      - cbn. hintros ->.
        hsteps_cbn. cbn. { eapply ConsequenceT_pre. refine (Translate_SpecT_size _ _ _ _ [| _|]). 3:tspec_ext. reflexivity. }
        1-2:reflexivity.
        subst F. cbn; tspec_ext.
      - cbn. intros b0 Hb. refine (_ : _ <= match n with 0 => _ | _ => _ end).
        destruct b0, n. 1,4:exfalso;clear - Hb;lia. all:reflexivity.
    }
    Unshelve. 5:reflexivity. 2,3:exact 0.
    cbn. intros ? ->. unfold Lookup_Step_steps,Lookup_Step_steps_Nth'. destruct nth_error as [[[[] ]| ]| ]. all:cbn. 2,3:nia. unfold CasePair_steps. destruct n; cbn. all:rewrite !Nat.add_assoc. all:reflexivity.
  Qed.

  Definition Lookup := While Lookup_Step.

  Fixpoint Lookup_size (H : Heap) (a n : nat) {struct n} : Vector.t (nat -> nat) 5 :=
    match nth_error H a with
    | Some (Some (g, b)) =>
      match n with
      | S n' => Lookup_Step_size H a n >>> Lookup_size H b n'
      | 0 => Lookup_Step_size H a n
      end
    | _ => default (* not specified *)
    end.

  Lemma Lookup_size_eq (H : Heap) (a n : nat) :
    Lookup_size H a n =
    match nth_error H a with
    | Some (Some (g, b)) =>
      match n with
      | S n' => Lookup_Step_size H a n >>> Lookup_size H b n'
      | 0 => Lookup_Step_size H a n
      end
    | _ => default (* not specified *)
    end.
  Proof. destruct n; auto. Qed.

  Definition Lookup_Rel : pRel sigLookup^+ bool 5 :=
    fun tin '(yout, tout) =>
      forall (H: Heap) (a n: nat) (s0 s1 s2 s3 s4 : nat),
        let size := Lookup_size H a n in
        tin[@Fin0] ≃(;s0) H ->
        tin[@Fin1] ≃(retr_nat_lookup_clos_ad ; s1) a ->
        tin[@Fin2] ≃(retr_nat_lookup_clos_var; s2) n ->
        isVoid_size tin[@Fin3] s3 -> isVoid_size tin[@Fin4] s4 ->
        match yout with
        | true =>
          exists g,
          lookup H a n = Some g /\
          tout[@Fin0] ≃(;size @>Fin0 s0) H /\ (* [H] is saved *)
          isVoid_size tout[@Fin1] (size @>Fin1 s1) /\ (* [a] is discarded *)
          isVoid_size tout[@Fin2] (size @>Fin2 s2) /\ (* [n] is discarded *)
          tout[@Fin3] ≃(retr_clos_lookup; size @>Fin3 s3) g /\ (* result *)
          isVoid_size tout[@Fin4] (size @>Fin4 s4) (* internal tape *)
        | false =>
          lookup H a n = None (* Tapes are not specified *)
        end.

  Arguments Lookup_Step_size : simpl never.

  Fixpoint Lookup_steps (H : Heap) (a : HAdd) (n : nat) : nat :=
    match nth_error H a with
    | Some (Some (g, b)) =>
      match n with
      | 0 => Lookup_Step_steps H a n
      | S n' => 1 + Lookup_Step_steps H a n + Lookup_steps H b n'
      end
    | _ => Lookup_Step_steps H a n
    end.

  Lemma Lookup_SpecT_space H a n ss:
  TripleT
    ≃≃([],withSpace [| ≃(_) H ; ≃(retr_nat_lookup_clos_ad) a;≃(retr_nat_lookup_clos_var) n;Void;Void |] ss)
    (Lookup_steps H a n) Lookup
    (fun yout => ≃≃([yout = match lookup H a n with Some _ => true | _ => false end]
    , withSpace match lookup H a n with Some g => [| ≃(_) H;Void;Void;≃(retr_clos_lookup) g; Void|] | _ => SpecVTrue end (appSize (Lookup_size H a n) ss))).
  Proof.
    unfold Lookup.
    eapply While_SpecTReg with (PRE := fun '(a,n,ss) => (_,_))(INV := fun '(a,n,ss) y => ([y = match nth_error H a with
    | Some (Some _) => match n with | 0 => Some true | S _ => None end | _ => Some false end],_)) (POST := fun '(a,n,ss) y => (_,_))
       (f__step := fun '(a,n,ss) => Lookup_Step_steps H a n ) (f__loop := fun '(a,n,ss) => _ ) (x:= (a,n,ss));clear a n ss;intros [[a n] ss].
    { eapply ConsequenceT. eapply Lookup_Step_SpecT_space. 2:intros. 1,2:cbn - [appSize SpecVTrue].  1,2:now tspec_ext. reflexivity. }
    all:cbn - [SpecVTrue appSize Lookup_size].
    remember (Lookup_size H a n) as F eqn:HF. remember (Lookup_steps H a n) as F' eqn:HF'. split.
    -destruct n;unfold Lookup_size in HF;unfold Lookup_steps in HF';fold Lookup_size in HF;fold Lookup_steps in HF'.
      +intros ? H'. cbn[lookup Lookup_Step_size]. destruct nth_error as [[[]| ]| ] eqn:Hnth. all:split;[ | subst F';reflexivity].
      all:revert H';intros [= ->]. now rewrite <- HF. 1-2:tspec_ext.
      +intros ? H'. cbn [lookup]. unfold Lookup_Step_steps. destruct nth_error as [[[]| ]| ] eqn:Hnth. easy.
        all:split;[ | subst F';reflexivity]. all:inv H'. all:tspec_ext.
    - destruct (nth_error H a) as [[[g' b]| ]| ] eqn:Hnth. 2-3:easy. destruct n as [ | n]. easy. intros _.
      cbn [lookup]. rewrite Hnth.
      unfold Lookup_size in HF;fold Lookup_size in HF. rewrite Hnth in HF.
      eexists (b,n,_). repeat apply conj.
      + subst F. cbn. tspec_ext.
      + subst F'. cbn. rewrite Hnth. reflexivity.
      +intros. subst F. reflexivity.
  Qed.

  (*legacy *)
  Lemma Lookup_Realise : Lookup ⊨ Lookup_Rel.
  Proof.
    repeat (eapply RealiseIntroAll;intro). eapply Realise_monotone.
    -eapply TripleT_Realise. eapply Lookup_SpecT_space with (ss:=[| _;_;_;_;_|]).
    -cbn.  intros ? [] H **. modpon H.
    {unfold "≃≃",withSpace;cbn. intros i; destruct_fin i;cbn. all:eassumption. }
    repeat destruct _;unfold "≃≃",withSpace in H;cbn in H.
    all:destruct H as [Heq H].
    2,3:discriminate Heq. 2:easy.
    all:specializeFin H. eexists;repeat split; easy.
  Qed.

  Definition Lookup_T : tRel sigLookup^+ 5 :=
    fun tin k =>
      exists (H: Heap) (a n: nat),
        tin[@Fin0] ≃ H /\
        tin[@Fin1] ≃(retr_nat_lookup_clos_ad) a /\
        tin[@Fin2] ≃(retr_nat_lookup_clos_var) n /\
        isVoid tin[@Fin3] /\ isVoid tin[@Fin4] /\
        Lookup_steps H a n <= k.

  Lemma Lookup_Terminates : projT1 Lookup ↓ Lookup_T.
  Proof.
    repeat (eapply TerminatesInIntroEx;intro). eapply TerminatesIn_monotone.
    -eapply TripleT_TerminatesIn. eapply TripleT_RemoveSpace,Lookup_SpecT_space.
    -intros ? k H **. modpon H.
    split. 2:eassumption.
    unfold "≃≃",withSpace;cbn. intros i; destruct_fin i;cbn. all:assumption.
  Qed.

End Lookup.

Arguments Lookup_steps : simpl never.
Arguments Lookup_size : simpl never.


Add LoadPath "coq".
Require Import Ornamental.Ornaments.
Require Import List.
Require Import minimal_records.
Require Import Coq.Bool.Bool.

Set DEVOID search prove equivalence. (* <-- Correctness proofs for search *)
Set DEVOID lift type. (* <-- Prettier types than the ones Coq infers *)
Set Nonrecursive Elimination Schemes. (* <--- Preprocess needs induction principles for records *)
Set DEVOID smart cache.

Module leb.

Lemma leb_implb : forall b1 b2, leb b1 b2 -> implb b1 b2 = true.
Proof.
  apply leb_implb.
Qed.

End leb.

Preprocess Module leb as leb' { opaque Bool.leb_implb }.
Definition leb_implb := leb'.leb_implb.

Definition f (b1 b2 b3 b4 : bool) (H : leb true false) (H0 : leb_implb true false H = leb_implb true false H) := ifb (eqb (negb (andb b1 (orb b2 (xorb b3 b4)))) true) false b4.
Definition g (b1 b2 b3 b4 : bool) (H : leb true false) (H0 : leb_implb true false H = leb_implb true false H)  := ifb (eqb (negb (orb b1 (andb b2 (xorb b3 b4)))) true) false b4.
Definition h (b1 b2 b3 b4 : bool) (H : leb true false) (H0 : leb_implb true false H = leb_implb true false H)  := ifb (eqb (negb (orb (andb b1 b2) (xorb b3 b4))) true) false b4.
Definition i (b1 b2 b3 b4 : bool) (H : leb true false) (H0 : leb_implb true false H = leb_implb true false H)  := ifb (eqb (negb (andb (orb b1 b2) (xorb b3 b4))) true) false b4.

Time Lift Generated'.output Handwritten'.output in f as f'.
Time Lift Generated'.output Handwritten'.output in g as g'.
Time Lift Generated'.output Handwritten'.output in h as h'.
Time Lift Generated'.output Handwritten'.output in i as i'.

Lemma test_f :
  f = f'.
Proof.
  reflexivity.
Qed.

Lemma test_g :
  g = g'.
Proof.
  reflexivity.
Qed.

Lemma test_h :
  h = h'.
Proof.
  reflexivity.
Qed.

Lemma test_i :
  i = i'.
Proof.
  reflexivity.
Qed.


Require Import Logic.lib.Coqlib.
Require Import Logic.lib.SublistT.
Require Import Logic.GeneralLogic.Base.
Require Import Logic.MinimumLogic.Syntax.
Require Import Logic.PropositionalLogic.Syntax.
Require Import Logic.QuantifierLogic.Syntax.
Require Import Logic.MinimumLogic.ProofTheory.Normal.
Require Import Logic.MinimumLogic.ProofTheory.Minimum.
Require Import Logic.MinimumLogic.ProofTheory.RewriteClass.
Require Import Logic.MinimumLogic.ProofTheory.ContextProperty.
Require Import Logic.PropositionalLogic.ProofTheory.Intuitionistic.
Require Import Logic.PropositionalLogic.ProofTheory.RewriteClass.
Require Import Logic.QuantifierLogic.ProofTheory.QuantifierLogic.

Local Open Scope logic_base.
Local Open Scope syntax.
Import PropositionalLanguageNotation.

Lemma allp_K
      (BL: BinderLanguage)
      {nBL: NormalBinderLanguage BL}
      {pBL: PropositionalBinderLanguage BL}
      {qL: QuantifierLanguage BL}
      (BGamma: BindedProofTheory BL)
      {nGamma: forall ts, NormalProofTheory (binded_L ts) (binded_Gamma ts)}
      {mpGamma: forall ts, MinimumPropositionalLogic (binded_L ts) (binded_Gamma ts)}
      {ipGamma: forall ts, IntuitionisticPropositionalLogic (binded_L ts) (binded_Gamma ts)}
      {qGamma: QuantifierLogic BL BGamma}:
  forall (t: type) (ts: list type) (x y: binded_expr (t :: ts)),
    |-- allp (x --> y) --> (allp x --> allp y).
Proof.
  intros.
  rewrite provable_derivable.
  rewrite <- !deduction_theorem.
  eapply deduction_modus_ponens.
  + apply deduction_andp_intros.
    - apply derivable_assum1.
    - apply deduction_weaken1.
      apply derivable_assum1.
  + apply deduction_weaken0.
    eapply allp_gen.
    rewrite lift_andp, !lift_allp.
    rewrite !(allp_elim _ _ _ var_term).
Abort.

Lemma allp_intros
      (BL: BinderLanguage)
      {nL: forall ts, NormalLanguage (binded_L ts)}
      {qL: QuantifierLanguage BL}
      (BGamma: BindedProofTheory BL)
      {nGamma: forall ts, NormalProofTheory (binded_L ts) (binded_Gamma ts)}
      {mpGamma: forall ts, MinimumPropositionalLogic (binded_L ts) (binded_Gamma ts)}
      {qGamma: QuantifierLogic BL BGamma}:
  forall (t: type) (ts: list type) (x: binded_expr ts) (y: binded_expr (t :: ts)),
    |-- allp (lift t x --> y) --> (x --> allp y).
Proof.
  intros.
Abort.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C Aprime Bprime Cprime O X Y L M N : Universe, ((wd_ B O /\ (wd_ A O /\ (wd_ C O /\ (wd_ Bprime O /\ (wd_ Aprime O /\ (wd_ Cprime O /\ (wd_ X Y /\ (wd_ A L /\ (wd_ A M /\ (wd_ L Aprime /\ (wd_ A N /\ (wd_ M L /\ (wd_ L Cprime /\ (wd_ Aprime A /\ (wd_ A B /\ (wd_ Aprime B /\ (wd_ Bprime A /\ (wd_ Bprime B /\ (wd_ Aprime Cprime /\ (wd_ Aprime Bprime /\ (wd_ A Cprime /\ (wd_ B C /\ (wd_ Bprime Cprime /\ (wd_ A C /\ (wd_ Aprime C /\ (wd_ N Bprime /\ (wd_ N O /\ (wd_ N Cprime /\ (wd_ L O /\ (wd_ L Bprime /\ (wd_ C Cprime /\ (wd_ N M /\ (col_ O A Aprime /\ (col_ O B Bprime /\ (col_ O C Cprime /\ (col_ A X Y /\ (col_ L X Y /\ (col_ L Aprime Cprime /\ (col_ M X Y /\ (col_ M O C /\ (col_ N A B /\ col_ N L Bprime))))))))))))))))))))))))))))))))))))))))) -> col_ O Cprime M)).
Proof.
  time tac.
Qed.

End FOFProblem.


Set Warnings "-notation-overridden,-parsing".
From Coq Require Import Strings.String.
Require Import maps.
From Coq Require Import Bool.Bool.
From Coq Require Import Arith.Arith.
From Coq Require Import Arith.EqNat.
From Coq Require Import Arith.PeanoNat. Import Nat.
From Coq Require Import omega.Omega.
Require Import hoare.
Require Import imp.

Definition reduce_to_zero' : com :=
  (WHILE ~(X = 0) DO
    X ::= X - 1
  END)%imp.

Theorem reduce_to_zero_correct' :
  {{fun st => True}}
  reduce_to_zero'
  {{fun st => st X = 0}}.
Proof.
  unfold reduce_to_zero'.
  eapply hoare_consequence_post.
  apply hoare_while.
  -

    eapply hoare_consequence_pre. apply hoare_asgn.
    intros st [HT Hbp]. unfold assn_sub. constructor.
  -
    intros st [Inv GuardFalse].
    unfold bassn in GuardFalse. simpl in GuardFalse.
    rewrite not_true_iff_false in GuardFalse.
    rewrite negb_false_iff in GuardFalse.
    apply eqb_eq in GuardFalse.
    apply GuardFalse. Qed.

Fixpoint parity x :=
  match x with
  | 0 => 0
  | 1 => 1
  | S (S x') => parity x'
  end.

Lemma parity_ge_2 : forall x,
  2 <= x ->
  parity (x - 2) = parity x.
Proof.
  induction x; intro. reflexivity.
  destruct x. inversion H. inversion H1.
  simpl. rewrite <- minus_n_O. reflexivity.
Qed.

Lemma parity_lt_2 : forall x,
  ~ 2 <= x ->
  parity (x) = x.
Proof.
  intros. induction x. reflexivity. destruct x. reflexivity.
    exfalso. apply H. omega.
Qed.

Theorem parity_correct : forall m,
    {{ fun st => st X = m }}
  WHILE 2 <= X DO
    X ::= X - 2
  END
    {{ fun st => st X = parity m }}.
Proof.
  unfold hoare_triple. intros. inversion H; subst. symmetry. apply parity_lt_2.
  unfold not. intros. simpl in H5. induction (st' X). inversion H0. induction n. inversion H0. inversion H2. inversion H5.
Abort.


Require Import VST.floyd.base.
Require Import VST.floyd.assert_lemmas.
Require Import VST.floyd.client_lemmas.
(* Require Import VST.floyd.closed_lemmas. *)

Local Open Scope logic.

Lemma closed_wrt_wand: forall (S : ident -> Prop) (P Q : environ -> mpred),
       closed_wrt_vars S P ->
       closed_wrt_vars S Q -> closed_wrt_vars S (P -* Q).
Proof.
  intros; hnf in *; intros.
  simpl. f_equal; eauto.
Qed.

Lemma closed_wrtl_wand: forall (S : ident -> Prop) (P Q : environ -> mpred),
       closed_wrt_lvars S P ->
       closed_wrt_lvars S Q -> closed_wrt_lvars S (P -* Q).
Proof.
  intros; hnf in *; intros.
  simpl. f_equal; eauto.
Qed.

#[export] Hint Resolve closed_wrt_wand closed_wrtl_wand : closed.


Require Import CSet Le CMap CMapDomain CMapPartialOrder CMapJoinSemiLattice CMapTerminating.

Require Import Plus Util AllInRel CSet OptionPO.
Require Import Val Var Envs IL Annotation Infra.Lattice DecSolve.
Require Import Analysis.Analysis AnalysisForwardSSA ValueOpts.ConstantPropagation.

Require Import CMap WithTop DomainSSA.

Set Implicit Arguments.

Open Scope map_scope.

Definition Dom := Map [var, withTop val].

Lemma wua_poLe_inv (x y : withUnknown val)
  : poLe x y -> x = y.
Proof.
  intros A; inv A.
  - f_equal. eauto.
  - eauto.
Qed.

Smpl Add 100 match goal with
             | [ H : @poLe (withUnknown val) _ ?x ?y  |- _ ] =>
               eapply wua_poLe_inv in H; subst
             end : inv_trivial.

Require Import MapNotations ListUpdateAt Subterm.

Lemma leMap_op_eval e a b
  : poLe a b
    -> poLe (op_eval (domenv a) e) (op_eval (domenv b) e).
Proof.
  revert a b.
  general induction e; simpl; eauto.
  - specialize (IHe _ _ H).
    repeat cases; clear_trivial_eqs;
      eauto using poLe_option_None, poLe_withTopLe_top, poLe_Some_struct.
  - specialize (IHe1 _ _ H).
    specialize (IHe2 _ _ H).
    inv IHe1; inv IHe2; repeat cases;
      simpl in *; clear_trivial_eqs;
        eauto using poLe_option_None, poLe_withTopLe_top, poLe_Some_struct.
Qed.

Hint Resolve leMap_op_eval.

Lemma eqMap_op_eval e a b
  : poEq a b
    -> poEq (op_eval (domenv a) e) (op_eval (domenv b) e).
Proof.
  revert a b.
  general induction e; simpl; eauto.
  - specialize (IHe _ _ H).
    repeat cases; clear_trivial_eqs;
      eauto using poLe_option_None, poLe_withTopLe_top, poLe_Some_struct.
  - specialize (IHe1 _ _ H).
    specialize (IHe2 _ _ H).
    inv IHe1; inv IHe2; repeat cases;
      simpl in *; clear_trivial_eqs;
        eauto using poLe_option_None, poLe_withTopLe_top, poLe_Some_struct.
Qed.

Hint Resolve leMap_op_eval eqMap_op_eval.

Definition DDom (sT:stmt) := { m : Map [var, withTop val] | domain m ⊆ occurVars sT}.

Definition cp_reach (U : ⦃var⦄) (b:bool) (d: VDom U (withTop val)) (e:op) : bool * bool :=
  (if [op_eval (domenv (proj1_sig d)) e = None] then false
     else if [op_eval (domenv (proj1_sig d)) e = Some (wTA val_false)] then
            false else b,
     if [op_eval (domenv (proj1_sig d)) e = None] then false
     else if [op_eval (domenv (proj1_sig d)) e = Some (wTA val_true)] then
            false else b).

Lemma cp_reach_mon (U : ⦃var⦄) (e : op) (a a' : VDom U (withTop val))
  : a ⊑ a' -> forall b b' : bool, b ⊑ b' -> cp_reach b a e ⊑ cp_reach b' a' e.
Proof.
  unfold cp_reach.
  intros.
  intros. pose proof (leMap_op_eval e H); eauto.
  set (X:=op_eval (domenv (proj1_sig a)) e) in *.
  set (Y:=op_eval (domenv (proj1_sig a')) e) in *. clearbody X Y.
  unfold val in *.
  repeat cases; split; simpl fst; simpl snd; eauto; clear_trivial_eqs.
Qed.

Lemma cp_reach_ext (U : ⦃var⦄) (e : op) (a a' : VDom U (withTop val))
  : a ≣ a' -> forall b b' : bool, b ≣ b' -> cp_reach b a e ≣ cp_reach b' a' e.
Proof.
  unfold cp_reach.
  intros.
  intros. pose proof (eqMap_op_eval e H); eauto.
  set (X:=op_eval (domenv (proj1_sig a)) e) in *.
  set (Y:=op_eval (domenv (proj1_sig a')) e) in *. clearbody X Y.
  unfold val in *.
  repeat cases; split; simpl fst; simpl snd; eauto; clear_trivial_eqs.
Qed.

Definition cp_trans (U : ⦃var⦄) (b:bool) (d: VDom U (withTop val)) (e:exp) : ؟ (withTop val) :=
  match e with
  | Operation e => op_eval (domenv (proj1_sig d)) e
  | _ => Some Top
  end.

Lemma cp_trans_mon (U : ⦃var⦄) (e : exp) (a a' : VDom U (withTop val))
  : a ⊑ a' -> forall b b' : bool, b ⊑ b' -> @cp_trans U b a e ⊑ @cp_trans U b' a' e.
Proof.
  intros. destruct e; simpl; eauto.
Qed.

Lemma cp_trans_ext (U : ⦃var⦄) (e : exp) (a a' : VDom U (withTop val))
  : a ≣ a' -> forall b b' : bool, b ≣ b' -> @cp_trans U b a e ≣ @cp_trans U b' a' e.
Proof.
  intros. destruct e; simpl; eauto.
Qed.

Instance withTop_OUB A R `{EqDec A R}
  : @UpperBounded (option (withTop A)) _ :=
  { top := Some Top
  }.
- intros.
  destruct a; eauto using poLe_Some_struct, poLe_withTopLe_top.
Defined.

Instance withTop_UB A R `{EqDec A R}
  : @UpperBounded (withTop A) _ :=
  { top := Top
  }.
- intros.
  eauto using poLe_Some_struct, poLe_withTopLe_top.
Defined.

Definition constant_propagation_analysis :=
  makeForwardAnalysis _ _ _ cp_trans cp_reach cp_trans_mon cp_reach_mon
                      _.

Require Import FiniteFixpointIteration.

Definition constantPropagationAnalysis s ra (RA:RenamedApart.renamedApart s ra) :=
  proj1_sig (safeFixpoint (constant_propagation_analysis RA)).


(** * Evaluation environments *)

From Coq Require Import String.
From Coq Require Import List.
From Coq Require Import PeanoNat.
From Coq Require Import Lia.
From ConCert.Utils Require Import Automation.

Import ListNotations.

Definition env (A : Type) := list (string * A).

(** Lookup by variable name *)
Fixpoint lookup {A} (ρ : env A) (key : string) : option A :=
  match ρ with
  | [] => None
  | (nm, a) :: ρ' =>
    if (eqb nm key)
    then Some a
    else lookup ρ' key
  end.

Fixpoint lookup_with_ind_rec {A}
                             (i : nat)
                             (ρ : env A)
                             (key : string)
                             : option (nat * A) :=
  match ρ with
  | [] => None
  | (nm, a) :: ρ' =>
    if (eqb nm key)
    then Some (i, a)
    else lookup_with_ind_rec (1 + i) ρ' key
  end.

Definition lookup_with_ind {A} (ρ : env A) (key : string) : option (nat * A) :=
  lookup_with_ind_rec 0 ρ key.

(** Lookup by index (similar to [List.nth_error]), but defined by recursion on env *)
Fixpoint lookup_i {A} (ρ : env A) (i : nat) : option A :=
  match ρ with
  | [] => None
  | (nm, a) :: ρ' =>
    if (Nat.eqb i 0)
    then Some a
    else lookup_i ρ' (i - 1)
  end.

(** A value environment lookup: *)
Notation "ρ # '(' k ')'" := (lookup ρ k) (at level 10).
(** A value environment extension: *)
Notation "ρ # [ k ~> v ]" := ((k,v) :: ρ) (at level 50).

Fixpoint remove_by_key {A} (key : string) (ρ : env A) : env A :=
  match ρ with
  | [] => []
  | (nm, a) :: ρ' =>
    if (eqb nm key)
    then remove_by_key key ρ'
    else (nm, a) :: (remove_by_key key ρ')
  end.

Lemma lookup_i_length {A} (ρ : env A) n :
  (n <? length ρ) = true -> {e | lookup_i ρ n = Some e}.
Proof.
  intros H. revert dependent n.
  induction ρ; intros; propify; simpl in *.
  elimtype False. lia.
  destruct a. destruct n.
  + simpl; eauto.
  + simpl.
    assert (n < length ρ) by lia.
    replace (n - 0) with n by lia.
    apply IHρ.
    now propify.
Qed.

Lemma lookup_i_length_false {A} (ρ : env A) n :
  (n <? length ρ) = false -> lookup_i ρ n = None.
Proof.
  intros H. revert dependent n.
  induction ρ; intros; propify; simpl in *; auto.
  destruct a. destruct n.
  + simpl; eauto.
    inversion H.
  + simpl.
    assert (length ρ <= n) by lia.
    replace (n - 0) with n by lia.
    rewrite <- PeanoNat.Nat.ltb_ge in *.
    now apply IHρ.
Qed.


From Equations Require Import Equations.
Require Import Coq.Lists.List.

Require Export SystemFR.ReducibilityOpenEquivalent.
Require Export SystemFR.ErasedTypeRefine.
Require Export SystemFR.ErasedArrow.
Require Export SystemFR.ScalaDepSugar.
Require Export SystemFR.ReducibilitySubtype.
Require Export SystemFR.SubtypeMisc.

Opaque reducible_values.
Opaque makeFresh.

Lemma substitute_type_application:
  forall T1 T2 l tag,
    psubstitute (type_application T1 T2) l tag =
    type_application (psubstitute T1 l tag) (psubstitute T2 l tag).
Proof.
  unfold type_application; steps.
Qed.

Lemma reducible_type_application:
  forall ρ f t A B C,
    valid_interpretation ρ ->
    wf A 0 ->
    wf B 1 ->
    wf C 0 ->
    is_erased_type A ->
    is_erased_type B ->
    is_erased_type C ->
    pfv A term_var = nil ->
    pfv B term_var = nil ->
    pfv C term_var = nil ->
    [ ρ ⊨ f : T_arrow A B ] ->
    [ ρ ⊨ t : C ] ->
    [ ρ ⊨ C <: A ] ->
    [ ρ ⊨ app f t : type_application (T_arrow A B) C ].
Proof.
  unfold type_application; intros.
  apply reducible_type_refine with uu;
    repeat step || list_utils;
    eauto with wf.

  - unshelve epose proof (
      reducible_app ρ A B f t _ _ _ _ _ _
    ) as R;
      repeat step;
      eauto using reducible_values_exprs.

    eapply subtype_reducible; try eassumption;
      eauto using subtype_top.

  - repeat rewrite open_none by t_closer.

    apply reducible_value_expr;
      repeat step || simp_red_top_level_goal;
      t_closer.

    unfold reduces_to in *; steps.

    exists v0; repeat step; t_closer.
    repeat rewrite open_none by t_closer.

    clear H15.

    simp_red; repeat step; t_closer.

    exists v; repeat step; t_closer.
    repeat rewrite open_none by t_closer.

    simp_red; steps.
    apply equivalent_app;
      try solve [ apply equivalent_sym; equivalent_star ].
Qed.

Lemma open_reducible_type_application:
  forall tvars gamma f t A B C,
    wf A 0 ->
    wf B 1 ->
    wf C 0 ->
    is_erased_type A ->
    is_erased_type B ->
    is_erased_type C ->
    subset (fv A) (support gamma) ->
    subset (fv B) (support gamma) ->
    subset (fv C) (support gamma) ->
    [ tvars; gamma ⊨ f : T_arrow A B ] ->
    [ tvars; gamma ⊨ t : C ] ->
    [ tvars; gamma ⊨ C <: A ] ->
    [ tvars; gamma ⊨ app f t : type_application (T_arrow A B) C ].
Proof.
  unfold open_reducible, open_subtype.
  intros.
  unfold substitute; steps.
  apply reducible_type_application;
    repeat step || unfold subtype;
    eauto with wf;
    eauto with erased;
    eauto with fv.
Qed.