Require Import ast.
Require Import environment.
Require Import semantics.
Require Import step_semantics.
Require Import Coq.Strings.String.
Require Import Coq.ZArith.ZArith.
Require Import Coq.Lists.List.
Require Import Coq.Program.Wf.

(*<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>
COMMON
<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>*)

(*<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>
var_env_eq_relevant_vars : checks if a var_env  is included in another regarding a list of variables
<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>*)
Fixpoint var_env_included_relevant_vars (e1 e2: var_env) (rel_vars: list string): bool :=
match e1, e2 with
| nil , _ => true
| _ :: _ , nil => false
| entry1::tail , _ :: _ =>
  match entry1 with
  |VarEntry id _ =>
    match List.existsb ( String.eqb id ) rel_vars with
    |false => var_env_included_relevant_vars tail e2 rel_vars
    |true =>
      match List.existsb (var_entry_eqb entry1 ) e2 with
      |true => var_env_included_relevant_vars tail e2 rel_vars
      |false => false
      end
    end
  end
end.

(*<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>
arr_env_eq_relevant_vars : checks if an arr_env  is included in another regarding a list of variables
<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>*)
Fixpoint arr_env_included_relevant_vars (e1 e2: arr_env) (rel_vars: list string): bool :=
match e1, e2 with
| nil , _ => true
| _ :: _ , nil => false
| entry1::tail , _ :: _ =>
  match entry1 with
  |ArrEntry id _ _ =>
    match List.existsb ( String.eqb id ) rel_vars with
    |false => arr_env_included_relevant_vars tail e2 rel_vars
    |true =>
      match List.existsb (arr_entry_eqb entry1 ) e2 with
      |true => arr_env_included_relevant_vars tail e2 rel_vars
      |false => false
      end
    end
  end
end.

(*<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>
env_eq_relevant_vars : checks if two envs are equal regarding a list of variables
<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>*)
Definition env_eq_relevant_vars (e1 e2: env) (rel_vars: relevant_variables) : bool :=
match e1, e2 with
|Env v1 a1, Env v2 a2 =>
  match rel_vars with
  |Rel_Vars vars arrs =>
    (var_env_included_relevant_vars v1 v2 vars) && (var_env_included_relevant_vars v2 v1 vars)
    && (arr_env_included_relevant_vars a1 a2 arrs) && (arr_env_included_relevant_vars a2 a1 arrs)
  end
end.

Definition states_are_equivalent {A B C: Type} (s1: relevant_state A) (s2: relevant_state B) (memory: C) (lab_eq_u: B->B->bool) (projection_func: A->C->B) (rel_vars: relevant_variables): bool :=
match s1, s2 with
|RState _ lbl e1 _ , RState _ lbl2 e2 r =>andb (env_eq_relevant_vars e1 e2 rel_vars) (lab_eq_u lbl2 (projection_func lbl memory))  (* check here for relevancy*)
end.

Theorem error_neq_noerror : forall (A: Type), forall (s: string), forall (x: A),
Error s <> NoError x
.
Proof.
intros. discriminate.
Qed.

Theorem noerror_eq : forall (A: Type), forall (x y: A),
NoError x = NoError y
->
x = y
.
Proof.
intros.
inversion H.
reflexivity.
Qed.

Inductive equ_ret:=
|Equ_ret (is_eq: bool) (n:nat).

Theorem equret_eq : forall (x y: bool), forall (n m : nat),
Equ_ret x n = Equ_ret y m
->
x = y /\ n=m
.
Proof.
intros.
inversion H.
split.
reflexivity.
reflexivity.
Qed.

Theorem rmstate_eq :
forall A, forall C, forall l1, forall l2, forall e1, forall e2, forall r1, forall r2, forall m1, forall m2,

RMState A C l1 e1 r1 m1 = RMState A C l2 e2 r2 m2
->
l1 = l2
/\
e1 = e2
/\
r1 = r2
/\
m1 = m2
.
Proof.
intros.
inversion H.
repeat split.
Qed.

(*<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>
UNROLLED IS EQUIVALENT TO SOURCE
<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>*)

Definition n_is_equivalent_u {A B C: Type} (source_state: relevant_state A) (unrolled: uprog B) (memory: C) (lab_eq_u: B->B->bool) (projection_func: A->C->B) (rel_vars: relevant_variables) (n: nat): error bool :=
let current_state := SF_B_P_T_Semantics_stmt_step_prefix_nth_U B lab_eq_u rel_vars unrolled n in
match current_state with
| NoError c_state =>
  NoError (states_are_equivalent source_state c_state memory lab_eq_u projection_func rel_vars)
| Error s => Error (String.append "Error while testing equivalence of nth state in unrolled : " s)
end
.

Theorem n_equivalent_u_to_witness :
forall (A B C : Type), forall (unrolled: uprog B), forall (source_state: relevant_state A), forall (rel_vars: relevant_variables), forall (memory: C),
forall (projection_func: A->C->B),
forall (lab_eq_u: B->B->bool), forall (n: nat),

n_is_equivalent_u source_state unrolled memory lab_eq_u projection_func rel_vars n = NoError true

->
(
exists s,
SF_B_P_T_Semantics_stmt_step_prefix_nth_U B lab_eq_u rel_vars unrolled n = NoError s
/\
states_are_equivalent source_state s memory lab_eq_u projection_func rel_vars = true
)
.
Proof.
intros.
unfold n_is_equivalent_u in H.
edestruct (SF_B_P_T_Semantics_stmt_step_prefix_nth_U B lab_eq_u rel_vars unrolled n).
+ apply error_neq_noerror in H. contradiction.
+ exists val.
  split. reflexivity.
  apply noerror_eq in H.
  assumption.
Qed.

Fixpoint search_equivalent_in_unrolled {A B C: Type} (unrolled: uprog B) (source_state: relevant_state A) (memory: C) (lab_eq_u: B->B->bool) (projection_func: A->C->B) (rel_vars: relevant_variables) (curr_depth: nat) (n: nat) : error equ_ret :=
match curr_depth with
| 0 =>
  match n_is_equivalent_u source_state unrolled memory lab_eq_u projection_func rel_vars n with
  |Error s => Error (String.append "Error while looking for equivalent : " s)
  |NoError b => NoError (Equ_ret b n)
  end
| S new_depth =>
  match n_is_equivalent_u source_state unrolled memory lab_eq_u projection_func rel_vars (n + curr_depth) with
    |Error s => Error (String.append "Error while looking for equivalent : " s)
    |NoError true => NoError (Equ_ret true (n+curr_depth))
    |NoError false => search_equivalent_in_unrolled unrolled source_state memory lab_eq_u projection_func rel_vars new_depth n
  end
end.

Theorem search_equivalent_cases_u:
forall (A B C : Type), forall (unrolled: uprog B), forall (source_state: relevant_state A), forall (rel_vars: relevant_variables), forall (memory: C),
forall (projection_func: A->C->B),
forall (lab_eq_u: B->B->bool), forall (n: nat), forall (k:nat),forall (curr_depth : nat),

search_equivalent_in_unrolled unrolled source_state memory lab_eq_u projection_func rel_vars (S curr_depth) n = NoError (Equ_ret true k )
->
search_equivalent_in_unrolled unrolled source_state memory lab_eq_u projection_func rel_vars curr_depth n = NoError (Equ_ret true k )
\/
( n_is_equivalent_u source_state unrolled memory lab_eq_u projection_func rel_vars (n + (S curr_depth)) = NoError true
/\ (n + (S curr_depth) = k)
)
.
Proof.
induction curr_depth.
+ intro.
  unfold search_equivalent_in_unrolled in H.
  destruct (n_is_equivalent_u source_state unrolled memory lab_eq_u projection_func rel_vars (n + 1)) eqn:Hneq in H.
  - apply error_neq_noerror in H. contradiction.
  - destruct val eqn:Hval in H.
    * apply noerror_eq in H. apply equret_eq in H. destruct H.
      rewrite Hval in Hneq. right. split. assumption. assumption.
    * destruct (n_is_equivalent_u source_state unrolled memory lab_eq_u projection_func rel_vars n) eqn:Hneq0 in H.
      (*1*)    apply error_neq_noerror in H. contradiction.
      (*2*)    unfold search_equivalent_in_unrolled.
               destruct (n_is_equivalent_u source_state unrolled memory lab_eq_u projection_func rel_vars n).
               apply error_neq_noerror in Hneq0. contradiction.
               apply noerror_eq in Hneq0. rewrite Hneq0. left ; assumption.
+ intro.
  unfold search_equivalent_in_unrolled in H.
  destruct (n_is_equivalent_u source_state unrolled memory lab_eq_u projection_func rel_vars (n + S (S curr_depth))) eqn:HSSneq in H.
  - apply error_neq_noerror in H ; contradiction.
  - destruct val eqn:Hval in H.
    * right. rewrite Hval in HSSneq. apply noerror_eq in H. apply equret_eq in H. destruct H.
      split ; assumption ; assumption.
    * left.
      unfold search_equivalent_in_unrolled. assumption.
Qed.

Theorem search_equivalent_increasing_u:
forall (A B C : Type), forall (unrolled: uprog B), forall (source_state: relevant_state A), forall (rel_vars: relevant_variables), forall (memory: C),
forall (projection_func: A->C->B),
forall (lab_eq_u: B->B->bool), forall (n: nat), forall (k:nat),forall (curr_depth : nat),

search_equivalent_in_unrolled unrolled source_state memory lab_eq_u projection_func rel_vars curr_depth n = NoError (Equ_ret true k )

->

n <= k
.
Proof.
induction curr_depth.
- intro. unfold search_equivalent_in_unrolled in H.
  destruct (n_is_equivalent_u source_state unrolled memory lab_eq_u projection_func rel_vars n) in H.
  apply error_neq_noerror in H; contradiction.
  destruct val.
  + apply noerror_eq in H. apply equret_eq in H. destruct H. rewrite H0. apply le_n.
  + apply noerror_eq in H. apply equret_eq in H. destruct H. discriminate H.
- intros.
  unfold search_equivalent_in_unrolled in H.
  destruct (n_is_equivalent_u source_state unrolled memory lab_eq_u projection_func rel_vars (n + S curr_depth)) eqn:Hneq in H.
  + apply error_neq_noerror in H ; contradiction.
  + destruct val.
    * apply noerror_eq in H. apply equret_eq in H. destruct H. rewrite <- H0.
      apply Nat.le_add_r.
    * apply IHcurr_depth in H. assumption.
Qed.

Theorem search_equivalent_witness_u:
forall (A B C : Type), forall (unrolled: uprog B), forall (source_state: relevant_state A), forall (rel_vars: relevant_variables), forall (memory: C),
forall (projection_func: A->C->B),
forall (lab_eq_u: B->B->bool), forall (n: nat), forall (k:nat),forall (curr_depth : nat),

search_equivalent_in_unrolled unrolled source_state memory lab_eq_u projection_func rel_vars curr_depth n = NoError (Equ_ret true k )

->

n_is_equivalent_u source_state unrolled memory lab_eq_u projection_func rel_vars k = NoError true
.

Proof.
induction curr_depth.
+ intro.
  unfold search_equivalent_in_unrolled in H.
  destruct (n_is_equivalent_u source_state unrolled memory lab_eq_u projection_func rel_vars n) eqn:Hneq in H.
  - apply error_neq_noerror in H. contradiction.
  - apply noerror_eq in H. apply equret_eq in H.
    destruct H. rewrite H in Hneq. rewrite H0 in Hneq. assumption.
+ intro. apply search_equivalent_cases_u in H. destruct H.
  - apply IHcurr_depth in H. assumption.
  - destruct H. rewrite H0 in H. assumption.
Qed.

Fixpoint step_semantics_eq_prover_u (A B C: Type) (p: prog A) (up: uprog B) (rel_vars: relevant_variables) (start_memory: C) (mem_update: (relevant_state A)->C->C) (projection_func: A->C->B) (lab_eq_s: A->A->bool) (lab_eq_u: B->B->bool) (plength: nat) (max_depth: nat): error equ_ret :=
match plength with
|0 => NoError (Equ_ret true 0)
|S new_plength =>
  match step_semantics_eq_prover_u A B C p up rel_vars start_memory mem_update projection_func lab_eq_s lab_eq_u new_plength max_depth with
  |Error s => Error (String.append "Error while trying to prove unrolled equivalence : " s)
  |NoError (Equ_ret false k) => NoError (Equ_ret false k)
  |NoError (Equ_ret true k) =>
    match SF_B_P_T_Semantics_stmt_step_prefix_nth_mem A C lab_eq_s rel_vars p plength start_memory mem_update with
    |Error s => Error (String.append "Error while stepping in source while trying to prove unrolled equivalence : " s)
    |NoError rmstate =>
      match rmstate with
      |RMState _ _ _ _ false mem => NoError (Equ_ret true k)
      |RMState _ _ l e true mem => search_equivalent_in_unrolled up (RState A l e true) mem lab_eq_u projection_func rel_vars max_depth (S k)
      end
    end
  end
end
.

Theorem prover_0_true_u :
forall (A B C : Type), forall (source: prog A), forall (unrolled: uprog B), forall (rel_vars: relevant_variables), forall (start_memory: C),
forall (mem_update: (relevant_state A)->C->C), forall (projection_func: A->C->B),
forall (lab_eq_s: A->A->bool), forall (lab_eq_u: B->B->bool), forall (max_depth: nat),

step_semantics_eq_prover_u A B C source unrolled rel_vars start_memory mem_update projection_func lab_eq_s lab_eq_u 0 max_depth = NoError (Equ_ret true 0)
.
Proof.
intros. unfold step_semantics_eq_prover_u. reflexivity.
Qed.

Theorem prover_Sn_implies_n_u :
forall (A B C : Type), forall (source: prog A), forall (unrolled: uprog B), forall (rel_vars: relevant_variables), forall (start_memory: C),
forall (mem_update: (relevant_state A)->C->C), forall (projection_func: A->C->B),
forall (lab_eq_s: A->A->bool), forall (lab_eq_u: B->B->bool), forall (max_depth: nat), forall (prefix_length: nat),
forall n,

step_semantics_eq_prover_u A B C source unrolled rel_vars start_memory mem_update projection_func lab_eq_s lab_eq_u (S prefix_length) max_depth= NoError (Equ_ret true n)

->
(exists n',
step_semantics_eq_prover_u A B C source unrolled rel_vars start_memory mem_update projection_func lab_eq_s lab_eq_u prefix_length max_depth = NoError (Equ_ret true n')
)
.
Proof.
induction prefix_length.
+ intros. unfold step_semantics_eq_prover_u. exists 0. split.
+ intros.
  unfold step_semantics_eq_prover_u in H.

  unfold step_semantics_eq_prover_u.
  destruct
  (
   match
        (fix step_semantics_eq_prover_u
           (A B C : Type) (p : prog A) (up : uprog B) (rel_vars : relevant_variables) (start_memory : C) (mem_update : relevant_state A -> C -> C)
           (projection_func : A -> C -> B) (lab_eq_s : A -> A -> bool) (lab_eq_u : B -> B -> bool) (plength max_depth : nat) {struct plength} :
             error equ_ret :=
           match plength with
           | 0 => NoError (Equ_ret true 0)
           | S new_plength =>
               match step_semantics_eq_prover_u A B C p up rel_vars start_memory mem_update projection_func lab_eq_s lab_eq_u new_plength max_depth with
               | Error s => Error ("Error while trying to prove unrolled equivalence : " ++ s)
               | NoError (Equ_ret true k) =>
                   match SF_B_P_T_Semantics_stmt_step_prefix_nth_mem A C lab_eq_s rel_vars p plength start_memory mem_update with
                   | Error s => Error ("Error while stepping in source while trying to prove unrolled equivalence : " ++ s)
                   | NoError (RMState _ _ l e true mem) =>
                       search_equivalent_in_unrolled up (RState A l e true) mem lab_eq_u projection_func rel_vars max_depth (S k)
                   | NoError (RMState _ _ l e false _) => NoError (Equ_ret true k)
                   end
               | NoError (Equ_ret false k) => NoError (Equ_ret false k)
               end
           end) A B C source unrolled rel_vars start_memory mem_update projection_func lab_eq_s lab_eq_u prefix_length max_depth
      with
      | Error s => Error ("Error while trying to prove unrolled equivalence : " ++ s)
      | NoError (Equ_ret true k) =>
          match SF_B_P_T_Semantics_stmt_step_prefix_nth_mem A C lab_eq_s rel_vars source (S prefix_length) start_memory mem_update with
          | Error s => Error ("Error while stepping in source while trying to prove unrolled equivalence : " ++ s)
          | NoError (RMState _ _ l e true mem) =>
              search_equivalent_in_unrolled unrolled (RState A l e true) mem lab_eq_u projection_func rel_vars max_depth (S k)
          | NoError (RMState _ _ l e false _) => NoError (Equ_ret true k)
          end
      | NoError (Equ_ret false k) => NoError (Equ_ret false k)
      end
  ) eqn:Hfix in H.
  - apply error_neq_noerror in H. contradiction.
  - destruct val eqn:Hval in H.
    destruct is_eq.
    * exists n0. rewrite Hval in Hfix. assumption.
    * apply noerror_eq in H. apply equret_eq in H. destruct H. discriminate H.
Qed.

Theorem prover_witness_u :
forall (A B C : Type), forall (source: prog A), forall (unrolled: uprog B), forall (rel_vars: relevant_variables), forall (start_memory: C),
forall (mem_update: (relevant_state A)->C->C), forall (projection_func: A->C->B),
forall (lab_eq_s: A->A->bool), forall (lab_eq_u: B->B->bool), forall (max_depth: nat), forall (prefix_length: nat),
forall n,
forall l, forall e, forall mem,

0 < prefix_length
/\
step_semantics_eq_prover_u A B C source unrolled rel_vars start_memory mem_update projection_func lab_eq_s lab_eq_u prefix_length max_depth = NoError (Equ_ret true n)
/\
(SF_B_P_T_Semantics_stmt_step_prefix_nth_mem A C lab_eq_s rel_vars source prefix_length start_memory mem_update = NoError (RMState _ _ l e true mem))
->

n_is_equivalent_u (RState _ l e true) unrolled mem lab_eq_u projection_func rel_vars n = NoError true

.
Proof.
induction prefix_length.
intros.
- destruct H. apply Nat.nlt_0_r in H. contradiction.
- intros.
  destruct H. destruct H0.
  unfold step_semantics_eq_prover_u in H0.
  destruct ((fix step_semantics_eq_prover_u
          (A B C : Type) (p : prog A) (up : uprog B) (rel_vars : relevant_variables) (start_memory : C)
          (mem_update : relevant_state A -> C -> C) (projection_func : A -> C -> B) (lab_eq_s : A -> A -> bool)
          (lab_eq_u : B -> B -> bool) (plength max_depth : nat) {struct plength} : error equ_ret :=
          match plength with
          | 0 => NoError (Equ_ret true 0)
          | S new_plength =>
              match
                step_semantics_eq_prover_u A B C p up rel_vars start_memory mem_update projection_func lab_eq_s lab_eq_u
                  new_plength max_depth
              with
              | Error s => Error ("Error while trying to prove unrolled equivalence : " ++ s)
              | NoError (Equ_ret true k) =>
                  match
                    SF_B_P_T_Semantics_stmt_step_prefix_nth_mem A C lab_eq_s rel_vars p plength start_memory mem_update
                  with
                  | Error s =>
                      Error ("Error while stepping in source while trying to prove unrolled equivalence : " ++ s)
                  | NoError (RMState _ _ l e true mem) =>
                      search_equivalent_in_unrolled up (RState A l e true) mem lab_eq_u projection_func rel_vars
                        max_depth (S k)
                  | NoError (RMState _ _ l e false _) => NoError (Equ_ret true k)
                  end
              | NoError (Equ_ret false k) => NoError (Equ_ret false k)
              end
          end) A B C source unrolled rel_vars start_memory mem_update projection_func lab_eq_s lab_eq_u prefix_length
         max_depth) in H0.
  + apply error_neq_noerror in H0 ; contradiction.
  + destruct val eqn:Hval in H0.
    destruct is_eq eqn:His_eq in H0.
    destruct (SF_B_P_T_Semantics_stmt_step_prefix_nth_mem A C lab_eq_s rel_vars source (S prefix_length) start_memory
         mem_update) eqn:HSpl in H0.
    * rewrite HSpl in H1. apply error_neq_noerror in H1. contradiction.
    * destruct val0 eqn:Hval0 in H0.
      destruct relevant eqn:Hrelevant in H0.
      1:{
        rewrite HSpl in H1. rewrite Hval0 in H1.
        apply noerror_eq in H1. rewrite Hrelevant in H1. apply rmstate_eq in H1.
        destruct H1. destruct H2. destruct H3.
        rewrite H4 in H0.
        apply search_equivalent_witness_u in H0. rewrite H1 in H0. rewrite H2 in H0. assumption.
      }
      1:{
        rewrite HSpl in H1. rewrite Hval0 in H1.
        rewrite Hrelevant in H1.
        apply noerror_eq in H1. apply rmstate_eq in H1. destruct H1; destruct H2; destruct H3.
        discriminate H3.
      }
    * apply noerror_eq in H0 ; apply equret_eq in H0. destruct H0 ; discriminate H0.
Qed.

Theorem prover_irrelevant_eq_u :
forall (A B C : Type), forall (source: prog A), forall (unrolled: uprog B), forall (rel_vars: relevant_variables), forall (start_memory: C),
forall (mem_update: (relevant_state A)->C->C), forall (projection_func: A->C->B),
forall (lab_eq_s: A->A->bool), forall (lab_eq_u: B->B->bool), forall (max_depth: nat), forall (prefix_length: nat),
forall n,
forall l, forall e, forall mem,

step_semantics_eq_prover_u A B C source unrolled rel_vars start_memory mem_update projection_func lab_eq_s lab_eq_u (S prefix_length) max_depth = NoError (Equ_ret true n)
/\
(SF_B_P_T_Semantics_stmt_step_prefix_nth_mem A C lab_eq_s rel_vars source (S prefix_length) start_memory mem_update = NoError (RMState _ _ l e false mem))
->

step_semantics_eq_prover_u A B C source unrolled rel_vars start_memory mem_update projection_func lab_eq_s lab_eq_u prefix_length max_depth = NoError (Equ_ret true n)

.
Proof.
intros. destruct H.
unfold step_semantics_eq_prover_u in H.
destruct
(
(fix step_semantics_eq_prover_u
         (A B C : Type) (p : prog A) (up : uprog B) (rel_vars : relevant_variables) (start_memory : C)
         (mem_update : relevant_state A -> C -> C) (projection_func : A -> C -> B) (lab_eq_s : A -> A -> bool)
         (lab_eq_u : B -> B -> bool) (plength max_depth : nat) {struct plength} : error equ_ret :=
         match plength with
         | 0 => NoError (Equ_ret true 0)
         | S new_plength =>
             match
               step_semantics_eq_prover_u A B C p up rel_vars start_memory mem_update projection_func lab_eq_s lab_eq_u
                 new_plength max_depth
             with
             | Error s => Error ("Error while trying to prove unrolled equivalence : " ++ s)
             | NoError (Equ_ret true k) =>
                 match
                   SF_B_P_T_Semantics_stmt_step_prefix_nth_mem A C lab_eq_s rel_vars p plength start_memory mem_update
                 with
                 | Error s =>
                     Error ("Error while stepping in source while trying to prove unrolled equivalence : " ++ s)
                 | NoError (RMState _ _ l e true mem) =>
                     search_equivalent_in_unrolled up (RState A l e true) mem lab_eq_u projection_func rel_vars
                       max_depth (S k)
                 | NoError (RMState _ _ l e false _) => NoError (Equ_ret true k)
                 end
             | NoError (Equ_ret false k) => NoError (Equ_ret false k)
             end
         end) A B C source unrolled rel_vars start_memory mem_update projection_func lab_eq_s lab_eq_u prefix_length
        max_depth
) eqn:Hfix in H.
- apply error_neq_noerror in H. contradiction.
- destruct val eqn:Hval in H.
  destruct is_eq eqn:His_eq in H.
  + destruct (SF_B_P_T_Semantics_stmt_step_prefix_nth_mem A C lab_eq_s rel_vars source (S prefix_length) start_memory
        mem_update) eqn:HSpn in H.
     (*1*) apply error_neq_noerror in H. contradiction.
     (*2*) destruct val0 eqn:Hval0 in H.
           destruct relevant.
           * rewrite HSpn in H0. rewrite Hval0 in H0.
             apply noerror_eq in H0; apply rmstate_eq in H0.
             destruct H0. destruct H1. destruct H2. discriminate H2.
           * apply noerror_eq in H; apply equret_eq in H ; destruct H.
             rewrite H1 in Hval ; rewrite His_eq in Hval. rewrite Hval in Hfix. assumption.
  + apply noerror_eq in H; apply equret_eq in H ; destruct H. discriminate H.
Qed.

Theorem prover_relevant_gt_u :
forall (A B C : Type), forall (source: prog A), forall (unrolled: uprog B), forall (rel_vars: relevant_variables), forall (start_memory: C),
forall (mem_update: (relevant_state A)->C->C), forall (projection_func: A->C->B),
forall (lab_eq_s: A->A->bool), forall (lab_eq_u: B->B->bool), forall (max_depth: nat), forall (prefix_length: nat),
forall n,
forall l, forall e, forall mem,

step_semantics_eq_prover_u A B C source unrolled rel_vars start_memory mem_update projection_func lab_eq_s lab_eq_u (S prefix_length) max_depth = NoError (Equ_ret true n)
/\
(SF_B_P_T_Semantics_stmt_step_prefix_nth_mem A C lab_eq_s rel_vars source (S prefix_length) start_memory mem_update = NoError (RMState _ _ l e true mem))
->
(exists n',
step_semantics_eq_prover_u A B C source unrolled rel_vars start_memory mem_update projection_func lab_eq_s lab_eq_u prefix_length max_depth = NoError (Equ_ret true n')
/\ n' < n
)
.
Proof.
intros.
destruct H.
unfold step_semantics_eq_prover_u in H.
destruct
(
(fix step_semantics_eq_prover_u
         (A B C : Type) (p : prog A) (up : uprog B) (rel_vars : relevant_variables) (start_memory : C)
         (mem_update : relevant_state A -> C -> C) (projection_func : A -> C -> B) (lab_eq_s : A -> A -> bool)
         (lab_eq_u : B -> B -> bool) (plength max_depth : nat) {struct plength} : error equ_ret :=
         match plength with
         | 0 => NoError (Equ_ret true 0)
         | S new_plength =>
             match
               step_semantics_eq_prover_u A B C p up rel_vars start_memory mem_update projection_func lab_eq_s lab_eq_u
                 new_plength max_depth
             with
             | Error s => Error ("Error while trying to prove unrolled equivalence : " ++ s)
             | NoError (Equ_ret true k) =>
                 match
                   SF_B_P_T_Semantics_stmt_step_prefix_nth_mem A C lab_eq_s rel_vars p plength start_memory mem_update
                 with
                 | Error s =>
                     Error ("Error while stepping in source while trying to prove unrolled equivalence : " ++ s)
                 | NoError (RMState _ _ l e true mem) =>
                     search_equivalent_in_unrolled up (RState A l e true) mem lab_eq_u projection_func rel_vars
                       max_depth (S k)
                 | NoError (RMState _ _ l e false _) => NoError (Equ_ret true k)
                 end
             | NoError (Equ_ret false k) => NoError (Equ_ret false k)
             end
         end) A B C source unrolled rel_vars start_memory mem_update projection_func lab_eq_s lab_eq_u prefix_length
        max_depth
) eqn:Hfix in H.
- apply error_neq_noerror in H. contradiction.
- destruct val eqn:Hval in H.
  destruct is_eq eqn:His_eq in H.
  + destruct (SF_B_P_T_Semantics_stmt_step_prefix_nth_mem A C lab_eq_s rel_vars source (S prefix_length) start_memory
        mem_update) eqn:HSpn in H.
    (*1*)rewrite HSpn in H0. apply error_neq_noerror in H0. contradiction.
    (*2*)destruct val0 eqn:Hval0 in H. destruct relevant.
        * apply search_equivalent_increasing_u in H.
          rewrite His_eq in Hval. rewrite Hval in Hfix.
          exists n0.
          split.
          (*1*) assumption.
          (*2*) auto.

        *  rewrite HSpn in H0. rewrite Hval0 in H0.
           apply noerror_eq in H0.
           inversion H0.
  + inversion H.
Qed.

(*<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>
SOURCE IS EQUIVALENT TO UNROLLED
<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>*)

Definition n_is_equivalent_s {A B C: Type} (unrolled_state: relevant_state B) (source: prog A) (start_memory: C) (lab_eq_s: A->A->bool) (lab_eq_u: B->B->bool) (mem_update: (relevant_state A)->C->C) (projection_func: A->C->B) (rel_vars: relevant_variables) (n: nat): error bool :=
let current_state := SF_B_P_T_Semantics_stmt_step_prefix_nth_mem A C lab_eq_s rel_vars source n start_memory mem_update in
match current_state with
| NoError (RMState _ _ lbl e rel mem) =>
  NoError (states_are_equivalent (RState _ lbl e rel) unrolled_state mem lab_eq_u projection_func rel_vars)
| Error s => Error (String.append "Error while testing equivalence of nth state in unrolled : " s)
end
.

Theorem n_equivalent_s_to_witness :
forall (A B C : Type), forall (source: prog A), forall (unrolled_state: relevant_state B), forall (rel_vars: relevant_variables), forall (start_memory: C),
forall (projection_func: A->C->B), forall (lab_eq_s: A->A->bool), forall (mem_update: (relevant_state A)->C->C),
forall (lab_eq_u: B->B->bool), forall (n: nat),

n_is_equivalent_s unrolled_state source start_memory lab_eq_s lab_eq_u mem_update projection_func rel_vars n = NoError true

->
(
exists s,
SF_B_P_T_Semantics_stmt_step_prefix_nth_mem A C lab_eq_s rel_vars source n start_memory mem_update = NoError s
/\
(
match s with
|RMState _ _ lbl e rel mem => states_are_equivalent (RState A lbl e rel) unrolled_state mem lab_eq_u projection_func rel_vars = true
end
)
)
.
Proof.
intros.
unfold n_is_equivalent_s in H.
destruct (SF_B_P_T_Semantics_stmt_step_prefix_nth_mem A C lab_eq_s rel_vars source n start_memory mem_update) eqn:Hnthm.
+ apply error_neq_noerror in H. contradiction.
+ destruct val eqn:Hval. exists val.
  split. rewrite Hval. reflexivity.
  destruct val eqn:Hval1.
  apply noerror_eq in H. inversion Hval. auto.
Qed.

Fixpoint search_equivalent_in_source {A B C: Type} (source: prog A) (unrolled_state: relevant_state B) (start_memory: C) (lab_eq_s: A->A->bool) (lab_eq_u: B->B->bool) (mem_update: (relevant_state A)->C->C) (projection_func: A->C->B) (rel_vars: relevant_variables) (curr_depth: nat) (n: nat) : error equ_ret :=
match curr_depth with
| 0 =>
  match n_is_equivalent_s unrolled_state source start_memory lab_eq_s lab_eq_u mem_update projection_func rel_vars n with
  |Error s => Error (String.append "Error while looking for equivalent : " s)
  |NoError b => NoError (Equ_ret b n)
  end
| S new_depth =>
  match n_is_equivalent_s unrolled_state source start_memory lab_eq_s lab_eq_u mem_update projection_func rel_vars (n + curr_depth) with
    |Error s => Error (String.append "Error while looking for equivalent : " s)
    |NoError true => NoError (Equ_ret true (n+curr_depth))
    |NoError false => search_equivalent_in_source source unrolled_state start_memory lab_eq_s lab_eq_u mem_update projection_func rel_vars new_depth n
  end
end.

Theorem search_equivalent_cases_s:
forall (A B C : Type), forall (source: prog A), forall (unrolled_state: relevant_state B), forall (rel_vars: relevant_variables), forall (start_memory: C),
forall (projection_func: A->C->B), forall (lab_eq_s: A->A->bool), forall (mem_update: (relevant_state A)->C->C),
forall (lab_eq_u: B->B->bool), forall (n: nat), forall (k:nat),forall (curr_depth : nat),

search_equivalent_in_source source unrolled_state start_memory lab_eq_s lab_eq_u mem_update projection_func rel_vars (S curr_depth) n = NoError (Equ_ret true k )
->
search_equivalent_in_source source unrolled_state start_memory lab_eq_s lab_eq_u mem_update projection_func rel_vars curr_depth n = NoError (Equ_ret true k )
\/
( n_is_equivalent_s unrolled_state source start_memory lab_eq_s lab_eq_u mem_update projection_func rel_vars (n + (S curr_depth)) = NoError true
/\ (n + (S curr_depth) = k)
)
.
Proof.
induction curr_depth.
+ intro.
  unfold search_equivalent_in_source in H.
  destruct (n_is_equivalent_s unrolled_state source start_memory lab_eq_s lab_eq_u mem_update
        projection_func rel_vars (n + 1)) eqn:Hneq in H.
  - apply error_neq_noerror in H. contradiction.
  - destruct val eqn:Hval in H.
    * apply noerror_eq in H. apply equret_eq in H. destruct H.
      rewrite Hval in Hneq. right. split. assumption. assumption.
    * destruct (n_is_equivalent_s unrolled_state source start_memory lab_eq_s lab_eq_u mem_update
        projection_func rel_vars n) eqn:Hneq0 in H.
      (*1*)    apply error_neq_noerror in H. contradiction.
      (*2*)    unfold search_equivalent_in_source.
               destruct (n_is_equivalent_s unrolled_state source start_memory lab_eq_s lab_eq_u mem_update
    projection_func rel_vars n).
               apply error_neq_noerror in Hneq0. contradiction.
               apply noerror_eq in Hneq0. rewrite Hneq0. left ; assumption.
+ intro.
  unfold search_equivalent_in_source in H.
  destruct (n_is_equivalent_s unrolled_state source start_memory lab_eq_s lab_eq_u mem_update
        projection_func rel_vars (n + S (S curr_depth))) eqn:HSSneq in H.
  - apply error_neq_noerror in H ; contradiction.
  - destruct val eqn:Hval in H.
    * right. rewrite Hval in HSSneq. apply noerror_eq in H. apply equret_eq in H. destruct H.
      split ; assumption ; assumption.
    * left.
      unfold search_equivalent_in_source. assumption.
Qed.

Theorem search_equivalent_increasing_s:
forall (A B C : Type), forall (source: prog A), forall (unrolled_state: relevant_state B), forall (rel_vars: relevant_variables), forall (start_memory: C),
forall (projection_func: A->C->B), forall (lab_eq_s: A->A->bool),  forall (mem_update: (relevant_state A)->C->C),
forall (lab_eq_u: B->B->bool), forall (n: nat), forall (k:nat),forall (curr_depth : nat),

search_equivalent_in_source source unrolled_state start_memory lab_eq_s lab_eq_u mem_update projection_func rel_vars curr_depth n = NoError (Equ_ret true k )

->

n <= k
.
Proof.
induction curr_depth.
- intro. unfold search_equivalent_in_source in H.
  destruct (n_is_equivalent_s unrolled_state source start_memory lab_eq_s lab_eq_u mem_update
        projection_func rel_vars n) in H.
  apply error_neq_noerror in H; contradiction.
  destruct val.
  + apply noerror_eq in H. apply equret_eq in H. destruct H. rewrite H0. apply le_n.
  + apply noerror_eq in H. apply equret_eq in H. destruct H. discriminate H.
- intros.
  unfold search_equivalent_in_source in H.
  destruct (n_is_equivalent_s unrolled_state source start_memory lab_eq_s lab_eq_u mem_update projection_func rel_vars (n + S curr_depth)) eqn:Hneq in H.
  + apply error_neq_noerror in H ; contradiction.
  + destruct val.
    * apply noerror_eq in H. apply equret_eq in H. destruct H. rewrite <- H0.
      apply Nat.le_add_r.
    * apply IHcurr_depth in H. assumption.
Qed.

Theorem search_equivalent_witness_s:
forall (A B C : Type), forall (source: prog A), forall (unrolled_state: relevant_state B), forall (rel_vars: relevant_variables), forall (start_memory: C),
forall (projection_func: A->C->B), forall (lab_eq_s: A->A->bool), forall (mem_update: (relevant_state A)->C->C),
forall (lab_eq_u: B->B->bool), forall (n: nat), forall (k:nat),forall (curr_depth : nat),

search_equivalent_in_source source unrolled_state start_memory lab_eq_s lab_eq_u mem_update projection_func rel_vars curr_depth n = NoError (Equ_ret true k )

->

n_is_equivalent_s unrolled_state source start_memory lab_eq_s lab_eq_u mem_update projection_func rel_vars k = NoError true
.

Proof.
induction curr_depth.
+ intro.
  unfold search_equivalent_in_source in H.
  destruct (n_is_equivalent_s unrolled_state source start_memory lab_eq_s lab_eq_u mem_update projection_func rel_vars n) eqn:Hneq in H.
  - apply error_neq_noerror in H. contradiction.
  - apply noerror_eq in H. apply equret_eq in H.
    destruct H. rewrite H in Hneq. rewrite H0 in Hneq. assumption.
+ intro. apply search_equivalent_cases_s in H. destruct H.
  - apply IHcurr_depth in H. assumption.
  - destruct H. rewrite H0 in H. assumption.
Qed.

Fixpoint step_semantics_eq_prover_s (A B C: Type) (p: prog A) (up: uprog B) (rel_vars: relevant_variables) (start_memory: C) (mem_update: (relevant_state A)->C->C) (projection_func: A->C->B) (lab_eq_s: A->A->bool) (lab_eq_u: B->B->bool) (plength: nat) (max_depth: nat): error equ_ret :=
match plength with
|0 => NoError (Equ_ret true 0)
|S new_plength =>
  match step_semantics_eq_prover_s A B C p up rel_vars start_memory mem_update projection_func lab_eq_s lab_eq_u new_plength max_depth with
  |Error s => Error (String.append "Error while trying to prove unrolled equivalence : " s)
  |NoError (Equ_ret false k) => NoError (Equ_ret false k)
  |NoError (Equ_ret true k) =>
    match SF_B_P_T_Semantics_stmt_step_prefix_nth_U B lab_eq_u rel_vars up plength with
    |Error s => Error (String.append "Error while stepping in source while trying to prove unrolled equivalence : " s)
    |NoError rstate =>
      match rstate with
      |RState _  _ _ false => NoError (Equ_ret true k)
      |RState _  l e true  => search_equivalent_in_source p rstate start_memory lab_eq_s lab_eq_u mem_update projection_func rel_vars max_depth (S k)
      end
    end
  end
end
.

Theorem prover_0_true_s :
forall (A B C : Type), forall (source: prog A), forall (unrolled: uprog B), forall (rel_vars: relevant_variables), forall (start_memory: C),
forall (mem_update: (relevant_state A)->C->C), forall (projection_func: A->C->B),
forall (lab_eq_s: A->A->bool), forall (lab_eq_u: B->B->bool), forall (max_depth: nat),

step_semantics_eq_prover_s A B C source unrolled rel_vars start_memory mem_update projection_func lab_eq_s lab_eq_u 0 max_depth = NoError (Equ_ret true 0)
.
Proof.
intros. unfold step_semantics_eq_prover_u. reflexivity.
Qed.

Theorem prover_Sn_implies_n_s :
forall (A B C : Type), forall (source: prog A), forall (unrolled: uprog B), forall (rel_vars: relevant_variables), forall (start_memory: C),
forall (mem_update: (relevant_state A)->C->C), forall (projection_func: A->C->B),
forall (lab_eq_s: A->A->bool), forall (lab_eq_u: B->B->bool), forall (max_depth: nat), forall (prefix_length: nat),
forall n,

step_semantics_eq_prover_s A B C source unrolled rel_vars start_memory mem_update projection_func lab_eq_s lab_eq_u (S prefix_length) max_depth= NoError (Equ_ret true n)

->
(exists n',
step_semantics_eq_prover_s A B C source unrolled rel_vars start_memory mem_update projection_func lab_eq_s lab_eq_u prefix_length max_depth = NoError (Equ_ret true n')
)
.
Proof.
induction prefix_length.
+ intros. unfold step_semantics_eq_prover_s. exists 0. split.
+ intros.
  unfold step_semantics_eq_prover_s in H.
  destruct
  (
    match
        (fix step_semantics_eq_prover_s
           (A B C : Type) (p : prog A) (up : uprog B) (rel_vars : relevant_variables)
           (start_memory : C) (mem_update : relevant_state A -> C -> C)
           (projection_func : A -> C -> B) (lab_eq_s : A -> A -> bool)
           (lab_eq_u : B -> B -> bool) (plength max_depth : nat) {struct plength} :
             error equ_ret :=
           match plength with
           | 0 => NoError (Equ_ret true 0)
           | S new_plength =>
               match
                 step_semantics_eq_prover_s A B C p up rel_vars start_memory mem_update
                   projection_func lab_eq_s lab_eq_u new_plength max_depth
               with
               | Error s =>
                   Error ("Error while trying to prove unrolled equivalence : " ++ s)
               | NoError (Equ_ret true k) =>
                   match
                     SF_B_P_T_Semantics_stmt_step_prefix_nth_U B lab_eq_u rel_vars up
                       plength
                   with
                   | Error s =>
                       Error
                         ("Error while stepping in source while trying to prove unrolled equivalence : " ++
                          s)
                   | NoError (RState _ _ _ true as rstate) =>
                       search_equivalent_in_source p rstate start_memory lab_eq_s lab_eq_u
                         mem_update projection_func rel_vars max_depth
                         (S k)
                   | NoError (RState _ _ _ false) => NoError (Equ_ret true k)
                   end
               | NoError (Equ_ret false k) => NoError (Equ_ret false k)
               end
           end) A B C source unrolled rel_vars start_memory mem_update projection_func
          lab_eq_s lab_eq_u prefix_length max_depth
      with
      | Error s => Error ("Error while trying to prove unrolled equivalence : " ++ s)
      | NoError (Equ_ret true k) =>
          match
            SF_B_P_T_Semantics_stmt_step_prefix_nth_U B lab_eq_u rel_vars unrolled
              (S prefix_length)
          with
          | Error s =>
              Error
                ("Error while stepping in source while trying to prove unrolled equivalence : " ++
                 s)
          | NoError (RState _ _ _ true as rstate) =>
              search_equivalent_in_source source rstate start_memory lab_eq_s lab_eq_u
                mem_update projection_func rel_vars max_depth (S k)
          | NoError (RState _ _ _ false) => NoError (Equ_ret true k)
          end
      | NoError (Equ_ret false k) => NoError (Equ_ret false k)
      end
  ) eqn:Hfix in H.
  - apply error_neq_noerror in H. contradiction.
  - destruct val eqn:Hval in H.
    destruct is_eq.
    * exists n0. rewrite Hval in Hfix. assumption.
    * apply noerror_eq in H. apply equret_eq in H. destruct H. discriminate H.
Qed.

Theorem prover_witness_s :
forall (A B C : Type), forall (source: prog A), forall (unrolled: uprog B), forall (rel_vars: relevant_variables), forall (start_memory: C),
forall (mem_update: (relevant_state A)->C->C), forall (projection_func: A->C->B),
forall (lab_eq_s: A->A->bool), forall (lab_eq_u: B->B->bool), forall (max_depth: nat), forall (prefix_length: nat),
forall n,
forall l, forall e,

0 < prefix_length
/\
step_semantics_eq_prover_s A B C source unrolled rel_vars start_memory mem_update projection_func lab_eq_s lab_eq_u prefix_length max_depth = NoError (Equ_ret true n)
/\
(SF_B_P_T_Semantics_stmt_step_prefix_nth_U B lab_eq_u rel_vars unrolled prefix_length = NoError (RState _ l e true))
->

n_is_equivalent_s (RState _ l e true) source start_memory lab_eq_s lab_eq_u mem_update projection_func rel_vars n = NoError true

.
Proof.
induction prefix_length.
intros.
- destruct H. apply Nat.nlt_0_r in H. contradiction.
- intros.
  destruct H. destruct H0.
  unfold step_semantics_eq_prover_s in H0.
  destruct
  (
  (fix step_semantics_eq_prover_s
          (A B C : Type) (p : prog A) (up : uprog B) (rel_vars : relevant_variables)
          (start_memory : C) (mem_update : relevant_state A -> C -> C)
          (projection_func : A -> C -> B) (lab_eq_s : A -> A -> bool)
          (lab_eq_u : B -> B -> bool) (plength max_depth : nat) {struct plength} :
            error equ_ret :=
          match plength with
          | 0 => NoError (Equ_ret true 0)
          | S new_plength =>
              match
                step_semantics_eq_prover_s A B C p up rel_vars start_memory mem_update
                  projection_func lab_eq_s lab_eq_u new_plength max_depth
              with
              | Error s =>
                  Error ("Error while trying to prove unrolled equivalence : " ++ s)
              | NoError (Equ_ret true k) =>
                  match
                    SF_B_P_T_Semantics_stmt_step_prefix_nth_U B lab_eq_u rel_vars up
                      plength
                  with
                  | Error s =>
                      Error
                        ("Error while stepping in source while trying to prove unrolled equivalence : " ++
                         s)
                  | NoError (RState _ _ _ true as rstate) =>
                      search_equivalent_in_source p rstate start_memory lab_eq_s lab_eq_u
                        mem_update projection_func rel_vars max_depth
                        (S k)
                  | NoError (RState _ _ _ false) => NoError (Equ_ret true k)
                  end
              | NoError (Equ_ret false k) => NoError (Equ_ret false k)
              end
          end) A B C source unrolled rel_vars start_memory mem_update projection_func
         lab_eq_s lab_eq_u prefix_length max_depth
  ) in H0.
  + apply error_neq_noerror in H0 ; contradiction.
  + destruct val eqn:Hval in H0.
    destruct is_eq eqn:His_eq in H0.
    destruct (SF_B_P_T_Semantics_stmt_step_prefix_nth_U B lab_eq_u rel_vars unrolled
         (S prefix_length)) eqn:HSpl in H0.
    * rewrite HSpl in H1. apply error_neq_noerror in H1. contradiction.
    * destruct val0 eqn:Hval0 in H0.
      destruct relevant eqn:Hrelevant in H0.
      1:{
        rewrite HSpl in H1. rewrite Hval0 in H1.
        apply noerror_eq in H1. rewrite Hrelevant in H1. rewrite H1 in H0.
        apply search_equivalent_witness_s in H0. assumption.
      }
      1:{
        rewrite HSpl in H1. rewrite Hval0 in H1.
        rewrite Hrelevant in H1.
        apply noerror_eq in H1. inversion H1.
      }
    * apply noerror_eq in H0 ; apply equret_eq in H0. destruct H0 ; discriminate H0.
Qed.

Theorem prover_irrelevant_eq_s :
forall (A B C : Type), forall (source: prog A), forall (unrolled: uprog B), forall (rel_vars: relevant_variables), forall (start_memory: C),
forall (mem_update: (relevant_state A)->C->C), forall (projection_func: A->C->B),
forall (lab_eq_s: A->A->bool), forall (lab_eq_u: B->B->bool), forall (max_depth: nat), forall (prefix_length: nat),
forall n,
forall l, forall e,

step_semantics_eq_prover_s A B C source unrolled rel_vars start_memory mem_update projection_func lab_eq_s lab_eq_u (S prefix_length) max_depth = NoError (Equ_ret true n)
/\
(SF_B_P_T_Semantics_stmt_step_prefix_nth_U B lab_eq_u rel_vars unrolled (S prefix_length) = NoError (RState _ l e false))
->

step_semantics_eq_prover_s A B C source unrolled rel_vars start_memory mem_update projection_func lab_eq_s lab_eq_u prefix_length max_depth = NoError (Equ_ret true n)

.
Proof.
intros. destruct H.
unfold step_semantics_eq_prover_s in H.
destruct
(
(fix step_semantics_eq_prover_s
         (A B C : Type) (p : prog A) (up : uprog B) (rel_vars : relevant_variables)
         (start_memory : C) (mem_update : relevant_state A -> C -> C)
         (projection_func : A -> C -> B) (lab_eq_s : A -> A -> bool)
         (lab_eq_u : B -> B -> bool) (plength max_depth : nat) {struct plength} :
           error equ_ret :=
         match plength with
         | 0 => NoError (Equ_ret true 0)
         | S new_plength =>
             match
               step_semantics_eq_prover_s A B C p up rel_vars start_memory mem_update
                 projection_func lab_eq_s lab_eq_u new_plength max_depth
             with
             | Error s =>
                 Error ("Error while trying to prove unrolled equivalence : " ++ s)
             | NoError (Equ_ret true k) =>
                 match
                   SF_B_P_T_Semantics_stmt_step_prefix_nth_U B lab_eq_u rel_vars up plength
                 with
                 | Error s =>
                     Error
                       ("Error while stepping in source while trying to prove unrolled equivalence : " ++
                        s)
                 | NoError (RState _ _ _ true as rstate) =>
                     search_equivalent_in_source p rstate start_memory lab_eq_s lab_eq_u
                       mem_update projection_func rel_vars max_depth
                       (S k)
                 | NoError (RState _ _ _ false) => NoError (Equ_ret true k)
                 end
             | NoError (Equ_ret false k) => NoError (Equ_ret false k)
             end
         end) A B C source unrolled rel_vars start_memory mem_update projection_func
        lab_eq_s lab_eq_u prefix_length max_depth
) eqn:Hfix in H.
- apply error_neq_noerror in H. contradiction.
- destruct val eqn:Hval in H.
  destruct is_eq eqn:His_eq in H.
  + destruct (SF_B_P_T_Semantics_stmt_step_prefix_nth_U B lab_eq_u rel_vars unrolled
        (S prefix_length)) eqn:HSpn in H.
     (*1*) apply error_neq_noerror in H. contradiction.
     (*2*) destruct val0 eqn:Hval0 in H.
           destruct relevant.
           * rewrite HSpn in H0. rewrite Hval0 in H0. inversion H0.
           * apply noerror_eq in H; apply equret_eq in H ; destruct H.
             rewrite H1 in Hval ; rewrite His_eq in Hval. rewrite Hval in Hfix. assumption.
  + apply noerror_eq in H; apply equret_eq in H ; destruct H. discriminate H.
Qed.

Theorem prover_relevant_gt_s :
forall (A B C : Type), forall (source: prog A), forall (unrolled: uprog B), forall (rel_vars: relevant_variables), forall (start_memory: C),
forall (mem_update: (relevant_state A)->C->C), forall (projection_func: A->C->B),
forall (lab_eq_s: A->A->bool), forall (lab_eq_u: B->B->bool), forall (max_depth: nat), forall (prefix_length: nat),
forall n,
forall l, forall e,

step_semantics_eq_prover_s A B C source unrolled rel_vars start_memory mem_update projection_func lab_eq_s lab_eq_u (S prefix_length) max_depth = NoError (Equ_ret true n)
/\
(SF_B_P_T_Semantics_stmt_step_prefix_nth_U B lab_eq_u rel_vars unrolled (S prefix_length)  = NoError (RState _ l e true))
->
(exists n',
step_semantics_eq_prover_s A B C source unrolled rel_vars start_memory mem_update projection_func lab_eq_s lab_eq_u prefix_length max_depth = NoError (Equ_ret true n')
/\ n' < n
)
.
Proof.
intros.
destruct H.
unfold step_semantics_eq_prover_s in H.
destruct
(
(fix step_semantics_eq_prover_s
         (A B C : Type) (p : prog A) (up : uprog B) (rel_vars : relevant_variables)
         (start_memory : C) (mem_update : relevant_state A -> C -> C)
         (projection_func : A -> C -> B) (lab_eq_s : A -> A -> bool)
         (lab_eq_u : B -> B -> bool) (plength max_depth : nat) {struct plength} :
           error equ_ret :=
         match plength with
         | 0 => NoError (Equ_ret true 0)
         | S new_plength =>
             match
               step_semantics_eq_prover_s A B C p up rel_vars start_memory mem_update
                 projection_func lab_eq_s lab_eq_u new_plength max_depth
             with
             | Error s =>
                 Error ("Error while trying to prove unrolled equivalence : " ++ s)
             | NoError (Equ_ret true k) =>
                 match
                   SF_B_P_T_Semantics_stmt_step_prefix_nth_U B lab_eq_u rel_vars up plength
                 with
                 | Error s =>
                     Error
                       ("Error while stepping in source while trying to prove unrolled equivalence : " ++
                        s)
                 | NoError (RState _ _ _ true as rstate) =>
                     search_equivalent_in_source p rstate start_memory lab_eq_s lab_eq_u
                       mem_update projection_func rel_vars max_depth
                       (S k)
                 | NoError (RState _ _ _ false) => NoError (Equ_ret true k)
                 end
             | NoError (Equ_ret false k) => NoError (Equ_ret false k)
             end
         end) A B C source unrolled rel_vars start_memory mem_update projection_func
        lab_eq_s lab_eq_u prefix_length max_depth
) eqn:Hfix in H.
- apply error_neq_noerror in H. contradiction.
- destruct val eqn:Hval in H.
  destruct is_eq eqn:His_eq in H.
  + destruct (SF_B_P_T_Semantics_stmt_step_prefix_nth_U B lab_eq_u rel_vars unrolled
        (S prefix_length)) eqn:HSpn in H.
    (*1*)rewrite HSpn in H0. apply error_neq_noerror in H0. contradiction.
    (*2*)destruct val0 eqn:Hval0 in H. destruct relevant.
        * apply search_equivalent_increasing_s in H.
          rewrite His_eq in Hval. rewrite Hval in Hfix.
          exists n0.
          split.
          (*1*) assumption.
          (*2*) auto.

        *  rewrite HSpn in H0. rewrite Hval0 in H0.
           apply noerror_eq in H0.
           inversion H0.
  + inversion H.
Qed.

Definition step_semantics_equivalence (A B C: Type) (p: prog A) (up: uprog B) (rel_vars: relevant_variables) (start_memory: C) (mem_update: (relevant_state A)->C->C) (projection_func: A->C->B) (lab_eq_s: A->A->bool) (lab_eq_u: B->B->bool) (plength_u: nat) (plength_s: nat) (max_depth: nat): error bool :=
match step_semantics_eq_prover_u A B C p up rel_vars start_memory mem_update projection_func lab_eq_s lab_eq_u plength_u max_depth with
|Error s => Error (String.append "Error while checking that unrolled simulates source : " s)
|NoError (Equ_ret false _) => Error "unrolled can't simulate source"
|NoError (Equ_ret true _) =>
  match step_semantics_eq_prover_s A B C p up rel_vars start_memory mem_update projection_func lab_eq_s lab_eq_u plength_s max_depth with
  |Error s => Error (String.append "Error while checking that unrolled simulates source : " s)
  |NoError (Equ_ret true _) => NoError true
  |NoError (Equ_ret false _) => Error "source can't simulate unrolled"
  end
end
.

Definition example_prog :=
Prog nat
(* declarations *)
(
(VarInit "x"%string)
::
(VarInit "y"%string)
::
nil
)
(* statements *)
( Compound _
(
(VarAssign _ "x"%string (Num 0)  (mkLabelling _  1 2 1000 )   )
~~
(VarAssign _ "y"%string (Num 0)  (mkLabelling _ 2 3 1000  ))
~~
[|
(While _ (Bool true)
  (* body *)
  ( Compound _
  (
    (VarAssign _ "x"%string ( Plus (Var "x"%string) (Num 1) )  (mkLabelling _ 4 5 1000 )   )
    ~~
    [|
      (VarAssign _ "y"%string ( Plus (Var "y"%string) (Num 1) )  (mkLabelling _ 5 3 1000 )   )
    |]
  )
    (mkLabelling _ 4 3 1000 )
  )
  (mkLabelling _ 3 1000 1000 )
)
|]
)
(mkLabelling _ 3 1000 1000 )
)
(mkLabelling _ 1 1000 1000 )
.

Definition make_example_unrolled (n:nat) : uprog (classic_label):=
let fix make_unrolling (k: nat) : ne_list (ustatement classic_label) :=
  match k with
  | 0 => [| (UVarAssign _ "x"%string ( Plus (Var "x"%string) (Num 1) )
     (mkLabelling _ (mkLabel (S n) 4) (mkLabel 0 1000) (mkLabel 0 1000) )   ) |]
  | S k' =>
    (UVarAssign _ "x"%string ( Plus (Var "x"%string) (Num 1) )
     (mkLabelling _ (mkLabel ((S n)-k) 4) (mkLabel (S ((S n)-k)) 4) (mkLabel 0 1000) ) )
    ~~ (make_unrolling k')
  end
in

UProg classic_label
(* declarations *)
(
(VarInit "x"%string)
::
nil
)
(* statements *)
( UCompound _
(
(UVarAssign _ "x"%string (Num 0)  (mkLabelling _  (mkLabel 0 1) (mkLabel 1 4) (mkLabel 0 1000) )   )
~~
(make_unrolling n)
)
(mkLabelling _ (mkLabel 0 1) (mkLabel 0 1000) (mkLabel 0 1000) )
)
(mkLabelling _ (mkLabel 0 1) (mkLabel 0 1000) (mkLabel 0 1000) )
.

(*
Eval compute in SF_B_P_T_Semantics_stmt_step_prefix nat Nat.eqb (Rel_Vars ("x"%string::nil) nil) example_prog 10.
Eval compute in SF_B_P_T_Semantics_stmt_step_prefix_U classic_label eq_label (Rel_Vars ("x"%string::nil) nil) (make_example_unrolled 100) 10.
*)

Definition example_mem_update (state : relevant_state nat) (mem: nat) : nat :=
match state with
|RState _ lbl e rel =>
  match lbl with
  | 3 => S mem
  | _ => mem
  end
end.

Definition proj_example (label: nat) (memory: nat) : classic_label :=
match label with
|5 => mkLabel (S memory) 4
|2 => mkLabel 1 4
|_ => mkLabel 0 label
end.

(*
Eval compute in
step_semantics_equivalence nat classic_label nat example_prog (make_example_unrolled 2000)
(Rel_Vars ("x"%string::nil) nil) 0 example_mem_update proj_example
Nat.eqb eq_label 50 50 10
.
*)


Require Import FunctionalExtensionality.
Require Export Category SetCategory DiscreteCategory CategoryIsomorphisms.
Require Import Common NaturalNumbersObject.

Set Implicit Arguments.

Set Asymmetric Patterns.

Set Universe Polymorphism.

Notation IndexedTInitialOf obj coerce initial_obj :=
  ((fun o => exist _
                   (fun x : initial_obj%type => match x with end)
                   (fun _ => functional_extensionality_dep _ _ (fun x : initial_obj%type => match x with end)))
   : IsInitialObject (C := IndexedCatOf obj coerce) initial_obj%type).

Notation IndexedTTerminalOf obj coerce terminal_obj constr all_eq :=
  ((fun o : obj => exist (fun m : o -> terminal_obj => forall x : o -> terminal_obj, x = m)
                         (fun _ : o => constr)
                         (fun H : o -> terminal_obj => functional_extensionality_dep H
                                                                                (fun _ : o => constr)
                                                                                (fun x : o => all_eq _ _)))
   : IsTerminalObject (C := IndexedCatOf obj coerce) terminal_obj%type).

Notation IndexedEmptySetInitialOf obj coerce := (IndexedTInitialOf obj coerce Empty_set).
Notation IndexedFalseInitialOf obj coerce := (IndexedTInitialOf obj coerce False).

Notation IndexedUnitTerminalOf obj coerce := (IndexedTTerminalOf obj coerce unit tt unit_eq).
Notation IndexedTrueTerminalOf obj coerce := (IndexedTTerminalOf obj coerce True I True_eq).

Notation EmptySetInitialOf obj := (IndexedEmptySetInitialOf obj (fun x => x)).
Notation FalseInitialOf obj := (IndexedFalseInitialOf obj (fun x => x)).

Notation UnitTerminalOf obj := (IndexedUnitTerminalOf obj (fun x => x)).
Notation TrueTerminalOf obj := (IndexedTrueTerminalOf obj (fun x => x)).

Notation CoercedEmptySetInitialOf obj T := (IndexedEmptySetInitialOf obj (fun x => x : T)).
Notation CoercedFalseInitialOf obj T := (IndexedFalseInitialOf obj (fun x => x : T)).

Notation CoercedUnitTerminalOf obj T := (IndexedUnitTerminalOf obj (fun x => x : T)).
Notation CoercedTrueTerminalOf obj T := (IndexedTrueTerminalOf obj (fun x => x : T)).

Section InitialTerminal.
  Definition TypeCatFalseInitial : IsInitialObject (C := TypeCat) False := Eval simpl in FalseInitialOf Type.
  Definition SetCatFalseInitial : IsInitialObject (C := SetCat) False := Eval simpl in FalseInitialOf Set.
  Definition PropCatFalseInitial : IsInitialObject (C := PropCat) False := Eval simpl in FalseInitialOf Prop.

  Definition TypeCatEmptyInitial : IsInitialObject (C := TypeCat) Empty_set := Eval simpl in EmptySetInitialOf Type.
  Definition SetCatEmptyInitial : IsInitialObject (C := SetCat) Empty_set := Eval simpl in EmptySetInitialOf Set.

  Definition TypeCatTrueTerminal : IsTerminalObject (C := TypeCat) True := Eval simpl in TrueTerminalOf Type.
  Definition SetCatTrueTerminal : IsTerminalObject (C := SetCat) True := Eval simpl in TrueTerminalOf Set.
  Definition PropCatTrueTerminal : IsTerminalObject (C := PropCat) True := Eval simpl in TrueTerminalOf Prop.

  Definition TypeCatUnitTerminal : IsTerminalObject (C := TypeCat) unit := Eval simpl in UnitTerminalOf Type.
  Definition SetCatUnitTerminal : IsTerminalObject (C := SetCat) unit := Eval simpl in UnitTerminalOf Set.

  Definition TypeCatSingletonTerminal : IsTerminalObject (C := TypeCat) unit := Eval hnf in TypeCatUnitTerminal.
  Definition SetCatSingletonTerminal : IsTerminalObject (C := SetCat) unit := Eval hnf in SetCatUnitTerminal.
End InitialTerminal.

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

  Variables S : Type.

  Local Ltac t' :=
    match goal with
      | _ => progress (intros; subst; trivial)
      | _ => eexists; reflexivity
      | _ => discriminate
      | [ H : _ -> False |- _ ] => contradict H; solve [ t' ]
      | [ H : ~_ |- _ ] => contradict H; solve [ t' ]
      | [ dec : forall _, {_} + {_} |- _ ] =>
        match goal with
          | [ _ : appcontext[dec ?x] |- _ ] => destruct (dec x)
          | [ |- appcontext[dec ?x] ] => destruct (dec x)
        end
      | _ => apply functional_extensionality_dep; intro
      | _ => progress (unfold compose in *; simpl in *; fg_equal)
      | _ => progress apply_hyp'
      | _ => progress destruct_type bool
      | [ H : (_ -> exists _, _), x : _ |- _ ] => destruct (H x); clear H
      | _ => progress specialize_uniquely
    end.

  Local Ltac t :=
    repeat match goal with
             | _ => t'
             | [ H : ?A -> _ |- _ ] =>
               match goal with
                 | [ _ : A |- _ ] => fail 1 (* don't make an [A] if we already have one *)
                 | _ => let a := fresh in assert (a : A) by (repeat t'); specialize (H a)
               end
           end.

  Lemma InjMono B (f : B -> S) :
    (forall x y : B, f x = f y -> x = y)
    -> (forall A (g g' : A -> B), (compose f g) = (compose f g') -> g = g').
  Proof.
    t.
  Qed.

  Lemma MonoInj B (f : B -> S) :
    (forall A (g g' : A -> B), (compose f g) = (compose f g') -> g = g')
    -> (forall x y : B, f x = f y -> x = y).
  Proof.
    intros H x y; t.
    pose proof (fun H' => H bool (fun b => if b then x else y) (fun _ => y) H' true).
    t.
  Qed.

  Lemma SurjEpi A (f : A -> S) :
    (forall x : S, exists y : A, f y = x)
    -> (forall C (g g' : S -> C), (compose g f) = (compose g' f) -> g = g').
  Proof.
    t.
  Qed.

  Lemma EpiSurj A (f : A -> S) (member_dec : forall x : S, {exists y, f y = x} + {~exists y, f y = x}) :
    (forall C (g g' : S -> C), (compose g f) = (compose g' f) -> g = g')
    -> (forall x : S, exists y : A, f y = x).
  Proof.
    intro H.
    assert (H' := fun H' => H bool (fun y => if member_dec y then true else false) (fun y => true) H').
    clear H.
    t.
  Qed.
End EpiMono.

Section nat.
  Fixpoint NatBuilderFunction A (o : unit -> A) (s : A -> A) (n : nat) : A
    := match n with
         | 0 => o tt
         | S n' => s (NatBuilderFunction o s n')
       end.

  Local Ltac t :=
    simpl in *;
    repeat (split || intro || apply functional_extensionality_dep);
    destruct_head unit;
    split_and;
    subst;
    trivial;
    fg_equal;
    match goal with | [ n : nat |- _ ] => induction n end;
    simpl in *;
    congruence.

  Local Notation PartialBuild_NaturalNumbersPreObject T Cat :=
    (fun pf => @Build_NaturalNumbersPreObject T Cat
                                              nat
                                              (UnitTerminalOf T)
                                              (fun _ => 0)
                                              S
                                              (fun A q f => exist _ (NatBuilderFunction q f) (pf A q f))).

  Local Ltac build_nat T Cat :=
    let t0 := constr:(PartialBuild_NaturalNumbersPreObject T Cat) in
    let t0' := (eval simpl in t0) in
    refine (t0' _);
      abstract t.

  Let SetCatNaturalNumbersPreObject' : NaturalNumbersPreObject SetCat. build_nat Set SetCat. Defined.
  Definition SetCatNaturalNumbersPreObject := Eval hnf in SetCatNaturalNumbersPreObject'.
  Let TypeCatNaturalNumbersPreObject' : NaturalNumbersPreObject TypeCat. build_nat Type TypeCat. Defined.
  Definition TypeCatNaturalNumbersPreObject := Eval hnf in TypeCatNaturalNumbersPreObject'.
End nat.


(*

  Copyright 2014 Cornell University
  Copyright 2015 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

  VPrl is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  VPrl is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with VPrl.  If not, see <http://www.gnu.org/licenses/>.

  Website: http://nuprl.org/html/verification/
  Authors: Abhishek Anand & Vincent Rahli & Mark Bickford

*)

Require Export computation_apply.
Require Export approx_props2.
Require Export sequents_tacs.
Require Export sequents_tacs2.
Require Export per_props_equality.
Require Export sequents_equality.
Require Export per_props_nat.
Require Export per_can.
Require Export per_props_top.
Require Export integer_type.

(*
   H |- halts(t)

     By callbyvalueApply

     H |- halts (t a)

 *)
Definition rule_callbyvalue_apply {o}
           (H : barehypotheses)
           (t a: @NTerm o)
            :=
  mk_rule
    (mk_baresequent H (mk_conclax (mk_halts t) ))
    [ mk_baresequent H (mk_conclax
       (mk_halts (mk_apply t a)))
    ]
    [].

Lemma rule_callbyvalue_apply_true {o} :
  forall lib (H : barehypotheses)
         (t a: @NTerm o),
    rule_true lib (rule_callbyvalue_apply H t a).
Proof.
  unfold rule_callbyvalue_apply, rule_true, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.
  clear cargs.

  destseq; allsimpl.
  dLin_hyp; exrepnd.
  rename Hyp0 into hyp1.
  destseq; allsimpl; proof_irr; GC.
  exists (@covered_axiom o (nh_vars_hyps H)).
  vr_seq_true.
  vr_seq_true in hyp1.
  pose proof (hyp1 s1 s2 eqh sim) as hyp; clear hyp1.
  exrepnd.
  lsubst_tac.
  generalize_lsubstc_terms t1.
  generalize_lsubstc_terms t2.
  apply equality_in_halts in hyp1;exrepd.
  apply tequality_mkc_halts in hyp0; lsubst_tac.
  spcast.
  rename c into hasv.
  revert hyp0.
  generalize_lsubstc_terms a1.
  generalize_lsubstc_terms a2.
  introv hyp.
  assert (chaltsc lib (mkc_apply t1 a1)) as ch1 by (spcast; auto).
  assert (chaltsc lib (mkc_apply t2 a2)) as ch2 by (apply hyp; auto).
  spcast.
  apply hasvaluec_mkc_apply_implies_hasvaluec in ch1.
  apply hasvaluec_mkc_apply_implies_hasvaluec in ch2.
  split.
  - (* tequality *)
    apply tequality_mkc_halts. split; intro; spcast; auto.
  - (* equality *)
    apply equality_in_halts; sp; spcast; auto.
Qed.

(*
   H |- (<a,b> c) approx  bottom

     By applyPair

     NoSubgoals

 *)
Definition rule_apply_pair {o}
           (H : barehypotheses)
           (a b c: @NTerm o)
            :=
  mk_rule
    (mk_baresequent H (mk_conclax (mk_approx (mk_apply (mk_pair a b) c) mk_bottom)))
    []
    [].

Lemma apply_pair_not_valuelike {o} :
   forall lib (a b c : @NTerm o),
   !hasvalue_like lib (mk_apply (mk_pair a b) c).
Proof. introv hv. destruct hv as [v hv]. destruct hv as [red val]. destruct red as [k red].
       revert red. induction k; introv red.
       - apply reduces_in_atmost_k_steps_0 in red; subst. destruct val as [x | y].
        + inversion x.
        + inversion y.
      - apply reduces_in_atmost_k_steps_S in red; exrepnd.
        apply compute_step_apply_can_success in red1. repndors; exrepnd.
        + inversion red2.
        + inversion red1.
Qed.

Lemma rule_apply_pair_true {o} :
  forall lib (H : barehypotheses)
         (a b c: @NTerm o),
    rule_true lib (rule_apply_pair H a b c).
Proof.
  unfold rule_apply_pair, rule_true, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.
  clear cargs.

  destseq; allsimpl.
  dLin_hyp; exrepnd.
  destseq; allsimpl; proof_irr; GC.
  exists (@covered_axiom o (nh_vars_hyps H)).
  vr_seq_true.
  lsubst_tac.
  generalize_lsubstc_terms a1.
  generalize_lsubstc_terms b1.
  generalize_lsubstc_terms x1.
  generalize_lsubstc_terms a2.
  generalize_lsubstc_terms b2.
  generalize_lsubstc_terms x2.
  assert (approxc lib (mkc_apply (mkc_pair a1 b1) x1) mkc_bottom) as appr1.
  { destruct_cterms; allunfold @approxc; allsimpl.
     apply approx_assume_hasvalue; eauto 3 with slow.
    - apply isprogram_eq. apply isprog_apply; auto; apply isprog_pair; auto.
    - introv hvl. apply apply_pair_not_valuelike in hvl. inversion hvl. }
  assert( approxc lib (mkc_apply (mkc_pair a2 b2) x2) mkc_bottom) as appr2.
  { destruct_cterms; allunfold @approxc; allsimpl.
     apply approx_assume_hasvalue; eauto 3 with slow.
    - apply isprogram_eq. apply isprog_apply; auto; apply isprog_pair; auto.
    - introv hvl. apply apply_pair_not_valuelike in hvl. inversion hvl. }

  split.
  - (* tequality *)
    apply tequality_mkc_approx.
    split; intro; spcast; auto.
  - (* equality *)
    apply equality_in_approx; sp; spcast; auto;
    apply computes_to_valc_refl;
    unfold iscvalue, mkc_axiom; simpl; eauto 3 with slow.
Qed.

(*
   H |- ((inl a) b) approx  bottom

     By applyInl

     NoSubgoals

 *)
Definition rule_apply_inl {o}
           (H : barehypotheses)
           (a b: @NTerm o)
            :=
  mk_rule
    (mk_baresequent H (mk_conclax (mk_approx (mk_apply (mk_inl a) b) mk_bottom)))
    []
    [].

Lemma apply_inl_not_valuelike {o} :
   forall lib (a b : @NTerm o),
   !hasvalue_like lib (mk_apply (mk_inl a) b).
Proof. introv hv. destruct hv as [v hv]. destruct hv as [red val]. destruct red as [k red].
       revert red. induction k; introv red.
       - apply reduces_in_atmost_k_steps_0 in red; subst. destruct val as [x | y].
        + inversion x.
        + inversion y.
      - apply reduces_in_atmost_k_steps_S in red; exrepnd.
        apply compute_step_apply_can_success in red1. repndors; exrepnd.
        + inversion red2.
        + inversion red1.
Qed.

Lemma rule_apply_inl_true {o} :
  forall lib (H : barehypotheses)
         (a b: @NTerm o),
    rule_true lib (rule_apply_inl H a b).
Proof.
  unfold rule_apply_inl, rule_true, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.
  clear cargs.

  destseq; allsimpl.
  dLin_hyp; exrepnd.
  destseq; allsimpl; proof_irr; GC.
  exists (@covered_axiom o (nh_vars_hyps H)).
  vr_seq_true.
  lsubst_tac.
  generalize_lsubstc_terms a1.
  generalize_lsubstc_terms b1.
  generalize_lsubstc_terms a2.
  generalize_lsubstc_terms b2.
  assert (approxc lib (mkc_apply (mkc_inl a1) b1) mkc_bottom) as appr1.
  { destruct_cterms; allunfold @approxc; allsimpl.
     apply approx_assume_hasvalue; eauto 3 with slow.
    - apply isprogram_eq. apply isprog_apply; auto; apply isprog_inl; auto.
    - introv hvl. apply apply_inl_not_valuelike in hvl. inversion hvl. }
  assert( approxc lib (mkc_apply (mkc_inl a2) b2) mkc_bottom) as appr2.
  { destruct_cterms; allunfold @approxc; allsimpl.
     apply approx_assume_hasvalue; eauto 3 with slow.
    - apply isprogram_eq. apply isprog_apply; auto; apply isprog_inl; auto.
    - introv hvl. apply apply_inl_not_valuelike in hvl. inversion hvl. }

  split.
  - (* tequality *)
    apply tequality_mkc_approx.
    split; intro; spcast; auto.
  - (* equality *)
    apply equality_in_approx; sp; spcast; auto;
    apply computes_to_valc_refl;
    unfold iscvalue, mkc_axiom; simpl; eauto 3 with slow.
Qed.

(*
   H |- ((inr a) b) approx  bottom

     By applyInr

     NoSubgoals

 *)
Definition rule_apply_inr {o}
           (H : barehypotheses)
           (a b: @NTerm o)
            :=
  mk_rule
    (mk_baresequent H (mk_conclax (mk_approx (mk_apply (mk_inr a) b) mk_bottom)))
    []
    [].

Lemma apply_inr_not_valuelike {o} :
   forall lib (a b : @NTerm o),
   !hasvalue_like lib (mk_apply (mk_inr a) b).
Proof. introv hv. destruct hv as [v hv]. destruct hv as [red val]. destruct red as [k red].
       revert red. induction k; introv red.
       - apply reduces_in_atmost_k_steps_0 in red; subst. destruct val as [x | y].
        + inversion x.
        + inversion y.
      - apply reduces_in_atmost_k_steps_S in red; exrepnd.
        apply compute_step_apply_can_success in red1. repndors; exrepnd.
        + inversion red2.
        + inversion red1.
Qed.

Lemma rule_apply_inr_true {o} :
  forall lib (H : barehypotheses)
         (a b: @NTerm o),
    rule_true lib (rule_apply_inr H a b).
Proof.
  unfold rule_apply_inr, rule_true, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.
  clear cargs.

  destseq; allsimpl.
  dLin_hyp; exrepnd.
  destseq; allsimpl; proof_irr; GC.
  exists (@covered_axiom o (nh_vars_hyps H)).
  vr_seq_true.
  lsubst_tac.
  generalize_lsubstc_terms a1.
  generalize_lsubstc_terms b1.
  generalize_lsubstc_terms a2.
  generalize_lsubstc_terms b2.
  assert (approxc lib (mkc_apply (mkc_inr a1) b1) mkc_bottom) as appr1.
  { destruct_cterms; allunfold @approxc; allsimpl.
     apply approx_assume_hasvalue; eauto 3 with slow.
    - apply isprogram_eq. apply isprog_apply; auto; apply isprog_inr; auto.
    - introv hvl. apply apply_inr_not_valuelike in hvl. inversion hvl. }
  assert( approxc lib (mkc_apply (mkc_inr a2) b2) mkc_bottom) as appr2.
  { destruct_cterms; allunfold @approxc; allsimpl.
     apply approx_assume_hasvalue; eauto 3 with slow.
    - apply isprogram_eq. apply isprog_apply; auto; apply isprog_inr; auto.
    - introv hvl. apply apply_inr_not_valuelike in hvl. inversion hvl. }

  split.
  - (* tequality *)
    apply tequality_mkc_approx.
    split; intro; spcast; auto.
  - (* equality *)
    apply equality_in_approx; sp; spcast; auto;
    apply computes_to_valc_refl;
    unfold iscvalue, mkc_axiom; simpl; eauto 3 with slow.
Qed.

Definition rule_apply_int {o}
           (H : barehypotheses)
           (a b: @NTerm o)
            :=
  mk_rule
    (mk_baresequent H (mk_conclax (mk_approx (mk_apply a b) mk_bottom)))
    [mk_baresequent H (mk_conclax (mk_member a mk_int))]
    [].

Lemma apply_int_not_valuelike {o} :
   forall lib (a b : @NTerm o),
   isprogram a ->
   isprogram b ->
   {n : Z $ reduces_to lib a (mk_integer n)} ->
   !hasvalue_like lib (mk_apply a b).
Proof. introv ispa ispb red hv. destruct hv as [v c]. destruct c as [red2 val].
       exrepnd.
  apply  @reduces_to_implies_cequiv in red0; auto.
   apply  @reduces_to_implies_cequiv in red2; try apply isprogram_apply; auto.
   assert (cequiv lib (mk_apply (mk_integer n) b) (mk_apply a b)) as X.
   {repeat (prove_cequiv). apply cequiv_sym; auto. destruct ispb; auto. }

   assert (cequiv lib (mk_apply (mk_integer n) b) v).
   - eapply cequiv_trans; [exact X | auto].
   - destruct val; destruct v; allsimpl; auto; destruct o0; allsimpl; auto.
     + pose proof ( @cequiv_canonical_form o lib
                    (oterm (Can c) l) (mk_apply (mk_integer n) b) c l) as xx.
       dimp xx. constructor. eauto 3 with slow. constructor.
      apply cequiv_isprogram in X0. sp. exrepnd. destruct hyp1 as [r v]. destruct r as [k r].
      * revert r. induction k; introv red.
        { rw @reduces_in_atmost_k_steps_0 in red. inversion red. }
        { apply @reduces_in_atmost_k_steps_S in red. exrepnd.
          apply compute_step_apply_can_success in red3. repndors; exrepnd. inversion red4.
          inversion red3.
        }
      * apply cequiv_sym. auto.
      + dup red2 as red3. apply cequiv_isprogram in red3. destruct red3. sp.
        apply isprogram_exception_implies in i1. exrepnd. subst.
        assert (oterm Exc [bterm [] a0, bterm [] t] =e>( a0, lib)t) as yy.
        * exists 0. apply reduces_in_atmost_k_steps_0. refl.
        *  pose proof ( @cequiv_exception_weak o lib (oterm Exc [bterm [] a0, bterm [] t]) a0 t
                    (mk_apply (mk_integer n) b) yy
                        ) as xx. dimp xx.
          { eapply @cequiv_trans; apply @cequiv_sym. exact red2. auto. }
          { exrepnd. destruct hyp1 as [k r]. revert r. induction k; introv red.
             { rw @reduces_in_atmost_k_steps_0 in red. inversion red. }
             { apply @reduces_in_atmost_k_steps_S in red. exrepnd.
               apply compute_step_apply_can_success in red3. repndors; exrepnd. inversion red4.
               inversion red3.
        }
          }
Qed.

Lemma rule_apply_int_true {o} :
  forall lib (H : barehypotheses)
         (a b: @NTerm o),
    rule_true lib (rule_apply_int H a b).
Proof.
  unfold rule_apply_int, rule_true, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.
  clear cargs.

  destseq; allsimpl.
  dLin_hyp; exrepnd.
  destseq; allsimpl; proof_irr; GC.
  exists (@covered_axiom o (nh_vars_hyps H)).
  vr_seq_true.
  vr_seq_true  in Hyp0.
  pose proof (Hyp0 s1 s2 eqh sim) as hyp. clear Hyp0. exrepnd.
  lsubst_tac.
  generalize_lsubstc_terms a1.
  generalize_lsubstc_terms b1.
  generalize_lsubstc_terms a2.
  generalize_lsubstc_terms b2.
  rw @equality_in_member in hyp1; exrepnd.
  apply tequality_member_int in hyp0; auto.
  dup hyp1 as aint.
  unfold equality_of_int in hyp0. exrepnd. allsimpl. spcast.

  assert (approxc lib (mkc_apply a1 b1) mkc_bottom) as appr1.
  { destruct_cterms; allunfold @approxc; allsimpl.
     apply approx_assume_hasvalue; eauto 3 with slow.
    - apply isprogram_eq. apply isprog_apply; auto.
    - introv hvl; apply apply_int_not_valuelike in hvl; try apply isprog_eq; tcsp.
      exists k. unfold computes_to_valc in hyp0. allsimpl. destruct hyp0. auto.
   }
  assert( approxc lib (mkc_apply a2 b2) mkc_bottom) as appr2.
  { destruct_cterms; allunfold @approxc; allsimpl.
     apply approx_assume_hasvalue; eauto 3 with slow.
    - apply isprogram_eq. apply isprog_apply; auto; apply isprog_inr; auto.
    - introv hvl; apply apply_int_not_valuelike in hvl; try apply isprog_eq; tcsp.
      exists k. unfold computes_to_valc in hyp4. allsimpl. destruct hyp4. auto.
     }

  split.
  - (* tequality *)
    apply tequality_mkc_approx.
    split; intro; spcast; auto.
  - (* equality *)
    apply equality_in_approx; sp; spcast; auto;
    apply computes_to_valc_refl;
    unfold iscvalue, mkc_axiom; simpl; eauto 3 with slow.
Qed.

(*
*** Local Variables:
*** coq-load-path: ("." "./close/")
*** End:
*)


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

(******************************************************************************)
(* This file contains axioms that are used in some parts of the library.      *)
(* The selected set of axioms is known to be consistent with Coq's logic.     *)
(* These axioms are:                                                          *)
(*   - propositional extensionality (pext);                                   *)
(*   - functional extensionality (fext).                                      *)
(* This file also defines the dynamic type as an alias for sigT and           *)
(* Jonh Major equality via equality cast.                                     *)
(******************************************************************************)

From Coq Require Import ssreflect ssrfun Eqdep ClassicalFacts.
From pcm Require Import options.

(*****************************)
(* Axioms and extensionality *)
(*****************************)

(* We're additionally using the eq_rect_eq axiom (equivalent to UIP) from
   Coq.Logic.Eqdep for its two consequences: inj_pair2 and StreicherK *)

(* extensionality is needed for domains *)
Axiom pext : forall p1 p2 : Prop, (p1 <-> p2) -> p1 = p2.
Axiom fext : forall A (B : A -> Type) (f1 f2 : forall x, B x),
               (forall x, f1 x = f2 x) -> f1 = f2.

Lemma pf_irr (P : Prop) (p1 p2 : P) : p1 = p2.
Proof. by apply/ext_prop_dep_proof_irrel_cic/pext. Qed.

Lemma sval_inj A P : injective (@sval A P).
Proof.
move=>[x Hx][y Hy] /= H; move: Hx Hy; rewrite H=>*.
congr exist; apply: pf_irr.
Qed.

Lemma svalE A (P : A -> Prop) x H : sval (exist P x H) = x.
Proof. by []. Qed.

Lemma compf1 A B (f : A -> B) : f = f \o id.
Proof. by apply: fext. Qed.

Lemma comp1f A B (f : A -> B) : f = id \o f.
Proof. by apply: fext. Qed.

(*****************************************)
(* Cast and John Major Equality via cast *)
(*****************************************)

(* depends on StreicherK axiom *)

Section Cast.
Variable (T : Type) (interp : T -> Type).

Definition cast A B (pf : A = B) (v : interp B) : interp A :=
  ecast _ _ (esym pf) v.

Lemma eqc A (pf : A = A) (v : interp A) : cast pf v = v.
Proof. by move: pf; apply: Streicher_K. Qed.

Definition jmeq A B (v : interp A) (w : interp B) := exists pf, v = cast pf w.

Lemma jm_refl A (v : interp A) : jmeq v v.
Proof. by exists (erefl _); rewrite eqc. Qed.

Lemma jm_sym A B (v : interp A) (w : interp B) : jmeq v w -> jmeq w v.
Proof. by case=>? ->; subst B; rewrite eqc; apply: jm_refl. Qed.

Lemma jm_trans A B C (u : interp A) (v : interp B) (w : interp C) :
        jmeq u v -> jmeq v w -> jmeq u w.
Proof. by case=>? -> [? ->]; subst B C; rewrite !eqc; apply: jm_refl. Qed.

Lemma jmE A (v w : interp A) : jmeq v w <-> v = w.
Proof. by split=>[[?]|] ->; [rewrite eqc | apply: jm_refl]. Qed.

Lemma castE A B (pf1 pf2 : A = B) (v1 v2 : interp B) :
        v1 = v2 <-> cast pf1 v1 = cast pf2 v2.
Proof. by subst B; rewrite !eqc. Qed.

End Cast.

Arguments cast {T} interp [A][B] pf v.
Arguments jmeq {T} interp [A][B] v w.

#[export]
Hint Resolve jm_refl : core.

(* special notation for the common case when interp = id *)
Notation icast pf v := (@cast _ id _ _ pf v).
Notation ijmeq v w := (@jmeq _ id _ _ v w).

(* type dynamic is sigT *)

Section Dynamic.
Variables (A : Type) (P : A -> Type).

(** eta expand definitions to prevent universe inconsistencies when using
    the injectivity of constructors of datatypes depending on [[dynamic]] *)

Definition dynamic := sigT P.
Definition dyn := existT P.
Definition dyn_tp := @projT1 _ P.
Definition dyn_val := @projT2 _ P.
Definition dyn_eta := @sigT_eta _ P.
Definition dyn_injT := @eq_sigT_fst _ P.
Definition dyn_inj := @inj_pair2 _ P.

End Dynamic.

Prenex Implicits dyn_tp dyn_val dyn_injT dyn_inj.
Arguments dyn {T} interp {A} _ : rename.
Notation idyn v := (@dyn _ id _ v).

Lemma dynE (A B : Type) interp (v : interp A) (w : interp B) :
        jmeq interp v w <-> dyn interp v = dyn interp w.
Proof. by split=>[[pf ->]|[pf]]; subst B; [rewrite !eqc | move/dyn_inj=>->]. Qed.


Require Import StlcFix.LemmasEvaluation.
Require Import StlcFix.LemmasTyping.
Require Import StlcFix.SpecEvaluation.
Require Import StlcFix.SpecEquivalent.
Require Import StlcFix.SpecSyntax.
Require Import StlcFix.SpecTyping.
Require Import StlcFix.SpecAnnot.
Require Import StlcIso.LemmasEvaluation.
(* Require Import StlcIso.LemmasScoping. *)
Require Import StlcIso.SpecEvaluation.
Require Import StlcIso.SpecEquivalent.
(* Require Import StlcIso.SpecScoping. *)
Require Import StlcIso.SpecSyntax.
Require Import UValFI.UVal.

Module F.
  Include StlcFix.LemmasEvaluation.
  Include StlcFix.LemmasTyping.
  Include StlcFix.SpecEvaluation.
  Include StlcFix.SpecEquivalent.
  Include StlcFix.SpecSyntax.
  Include StlcFix.SpecTyping.
  Include StlcFix.SpecAnnot.
End F.

Module I.
  Include StlcIso.LemmasEvaluation.
  Include StlcIso.LemmasTyping.
  Include StlcIso.SpecEvaluation.
  Include StlcIso.SpecEquivalent.
  Include StlcIso.SpecAnnot.
  Include StlcIso.SpecTyping.
  Include StlcIso.SpecSyntax.
End I.

Inductive Prec : Set :=
| precise
| imprecise.

Inductive PTy : Set :=
| ptarr (τ₁ τ₂ : PTy)
| ptunit
| ptbool
| ptprod (τ₁ τ₂ : PTy)
| ptsum (τ₁ τ₂ : PTy)
| pEmulDV (n : nat) (p : Prec) (τ : I.Ty).

Notation "A p⊎ B" := (ptsum A B) (at level 85, right associativity).
Notation "A p× B" := (ptprod A B) (at level 85, right associativity).
Notation "A p⇒ B" := (ptarr A B) (at level 85, right associativity).

Fixpoint repEmul (τ : PTy) : F.Ty :=
  match τ with
    | ptarr τ₁ τ₂ => F.tarr (repEmul τ₁) (repEmul τ₂)
    | ptunit => F.tunit
    | ptbool => F.tbool
    | ptprod τ₁ τ₂ => F.tprod (repEmul τ₁) (repEmul τ₂)
    | ptsum τ₁ τ₂ => F.tsum (repEmul τ₁) (repEmul τ₂)
    | pEmulDV n p T => UValFI n T
  end.

Fixpoint fxToIs (τ : PTy) : I.Ty :=
  match τ with
    | ptunit => I.tunit
    | ptbool => I.tbool
    | ptprod τ₁ τ₂ => I.tprod (fxToIs τ₁) (fxToIs τ₂)
    | ptarr τ₁ τ₂ => I.tarr (fxToIs τ₁) (fxToIs τ₂)
    | ptsum τ₁ τ₂ => I.tsum (fxToIs τ₁) (fxToIs τ₂)
    | pEmulDV n p T => T
  end.

Definition OfTypeStlcFix (τ : PTy) (t : F.Tm) : Prop :=
  F.Value t ∧ (F.Typing F.empty t (repEmul τ) ).

(* Fixpoint OfTypeStlcIso' (τ : PTy) (t : U.UTm) : Prop := *)
(*   match τ with *)
(*     | ptarr τ₁ τ₂ => *)
(*       match t with *)
(*         | U.abs _ => True *)
(*         | _       => False *)
(*       end *)
(*     | ptunit => t = U.unit *)
(*     (* | ptbool => t = U.true ∨ t = U.false *) *)
(*     (* | ptprod τ₁ τ₂ => *) *)
(*     (*   match t with *) *)
(*     (*     | U.pair t₁ t₂ => OfTypeStlcIso' τ₁ t₁ ∧ OfTypeStlcIso' τ₂ t₂ *) *)
(*     (*     | _            => False *) *)
(*     (*   end *) *)
(*     | ptsum τ₁ τ₂ => *)
(*       match t with *)
(*         | U.inl t₁ => OfTypeStlcIso' τ₁ t₁ *)
(*         | U.inr t₂ => OfTypeStlcIso' τ₂ t₂ *)
(*         | _        => False *)
(*       end *)
(*     | pEmulDV n p => U.Value t *)
(*   end. *)
(* Arguments OfTypeStlcIso' !τ !t /. *)

Definition OfTypeStlcIso (τ : PTy) (t : I.Tm) : Prop :=
  I.Value t ∧ I.Typing (I.empty) t (fxToIs τ).

Arguments OfTypeStlcIso !τ !t /.

Definition OfType (τ : PTy) (t₁ : F.Tm) (t₂ : I.Tm) : Prop :=
  OfTypeStlcFix τ t₁ ∧ OfTypeStlcIso τ t₂.

Inductive PEnv : Set :=
| pempty
| pevar (Γ : PEnv) (τ : PTy).

Notation "Γ p▻ T" := (pevar Γ T) (at level 55, left associativity).

Fixpoint pdom (Γ : PEnv) : Dom :=
  match Γ with
    | pempty => 0
    | pevar Γ _ => S (pdom Γ)
  end.

Inductive wsPTy (γ : Dom) : PTy → Prop :=
| WsPTUnit : wsPTy γ ptunit
| WsPBool : wsPTy γ ptbool
| WsPFn {τ τ'} : wsPTy γ τ → wsPTy γ τ' → wsPTy γ (τ p⇒ τ')
| WsPSum {τ τ'} : wsPTy γ τ → wsPTy γ τ' → wsPTy γ (τ p⊎ τ')
| WsPProd {τ τ'} : wsPTy γ τ → wsPTy γ τ' → wsPTy γ (τ p× τ')
| WsPEmulDv {n p τ} : wsTy 0 τ → wsPTy γ (pEmulDV n p τ).

Section WellScoping.

  Inductive innerPClosed : PTy → Prop :=
    | innerPUnitClosed : innerPClosed ptunit
    | innerPBoolClosed : innerPClosed ptbool
    | innerPFnClosed {τ τ'} : innerPClosed τ → innerPClosed τ' → innerPClosed (τ p⇒ τ)
    | innerPSumClosed {τ τ'} : innerPClosed τ → innerPClosed τ' → innerPClosed (τ p⊎ τ)
    | innerPProdClosed {τ τ'} : innerPClosed τ → innerPClosed τ' → innerPClosed (τ p× τ)
    | innerPEmulDvClosed {n p τ} : ⟨ 0 ⊢ τ ⟩ → innerPClosed (pEmulDV n p τ).

  Lemma WsPTy_mono {n m : nat} {τ} : n <= m → wsPTy n τ → wsPTy m τ.
  Proof.
    intros ineq cτn.
    revert m ineq.
    induction cτn; constructor; eauto.
  Qed.

End WellScoping.

#[export]
Instance WsPTy : Ws PTy := wsPTy.

Section Application.

  Context {Y: Type}.
  Context {vrY: Vr Y}.
  Context {wkY: Wk Y}.

  Context {vrPTy: Vr PTy}.
  Context {liftYPTy: Lift Y PTy}.

  Fixpoint apPTy (ζ: Sub Y) (τ: PTy) {struct τ} : PTy :=
    match τ with
      | ptarr τ₁ τ₂ => ptarr (apPTy ζ τ₁) (apPTy ζ τ₂)
      | ptunit => ptunit
      | ptbool => ptbool
      | ptprod τ₁ τ₂ => ptprod (apPTy ζ τ₁) (apPTy ζ τ₂)
      | ptsum τ₁ τ₂ => ptsum (apPTy ζ τ₁) (apPTy ζ τ₂)
      | pEmulDV n p τ => pEmulDV n p τ
    end.

  Global Arguments apPTy ζ !τ.
End Application.

Reserved Notation "⟪  i : T p∈ Γ  ⟫"
  (at level 0, i at level 98, Γ at level 98).
Inductive GetEvarP : PEnv → Ix → PTy → Prop :=
  | GetEvarHere {Γ T} :
      ⟪   O : T p∈ Γ p▻ T  ⟫
  | GetEvarThere {Γ T T' i} :
      ⟪   i : T p∈ Γ      ⟫ →
      ⟪ S i : T p∈ Γ p▻ T' ⟫
where "⟪  i : T p∈ Γ  ⟫" := (GetEvarP Γ i T).

Lemma pdom_works {i T Γ} :
  ⟪ i : T p∈ Γ ⟫ → pdom Γ ∋ i.
Proof.
  induction 1; constructor; eauto.
Qed.

Lemma pdom_works_inv {i Γ} :
  pdom Γ ∋ i → ∃ τ, ⟪ i : τ p∈ Γ ⟫.
Proof.
  revert i. induction Γ; intros i.
  - inversion 1.
  - inversion 1.
    + subst. exists τ. constructor.
    + subst. destruct (IHΓ i0 H1) as (τ0 & iinΓ).
      exists τ0. constructor. assumption.
Qed.

Fixpoint repEmulCtx (Γ : PEnv) : F.Env :=
  match Γ with
    | pempty => F.empty
    | pevar Γ τ => F.evar (repEmulCtx Γ) (repEmul τ)
  end.

Lemma repEmulCtx_works {Γ i τ} :
  ⟪ i : τ p∈ Γ ⟫ →
  F.GetEvar (repEmulCtx Γ) i (repEmul τ).
Proof.
  induction 1; eauto using F.GetEvar.
Qed.

Fixpoint fxToIsCtx (Γ : PEnv) : I.Env :=
  match Γ with
  | pempty => I.empty
  | pevar Γ τ => I.evar (fxToIsCtx Γ) (fxToIs τ)
  end.

Lemma fxToIsCtx_works {Γ i τ} :
  ⟪ i : τ p∈ Γ ⟫ →
  I.GetEvar (fxToIsCtx Γ) i (fxToIs τ).
Proof.
  induction 1; eauto using I.GetEvar.
Qed.

Fixpoint embed (τ : F.Ty) : PTy :=
  match τ with
    | F.tunit => ptunit
    | F.tarr τ₁ τ₂ => ptarr (embed τ₁) (embed τ₂)
    | F.tbool => ptbool
    | F.tprod τ₁ τ₂ => ptprod (embed τ₁) (embed τ₂)
    | F.tsum τ₁ τ₂ => ptsum (embed τ₁) (embed τ₂)
  end.

Fixpoint embedCtx (Γ : F.Env) : PEnv :=
  match Γ with
    | F.empty => pempty
    | F.evar Γ τ => pevar (embedCtx Γ) (embed τ)
  end.

Lemma embedCtx_works {Γ i τ} :
  F.GetEvar Γ i τ →
  ⟪ i : embed τ p∈ embedCtx Γ ⟫.
Proof.
  induction 1; eauto using GetEvarP.
Qed.

Lemma embedCtx_works_inv {Γ i τ} :
  ⟪ i : τ p∈ embedCtx Γ ⟫ →
  exists τ', τ = embed τ' ∧ (F.GetEvar Γ i τ').
Proof.
  revert i τ. induction Γ; intros i τ' iτ; simpl in *; inversion iτ; subst.
  - exists τ; intuition.
  - destruct (IHΓ _ _ H3) as [τ'' [eq ty]].
    exists τ''; intuition; eauto using GetEvarP.
Qed.

Lemma OfTypeStlcIso_fxToIs {vu τ τ'}:
  fxToIs τ = fxToIs τ' ->
  OfTypeStlcIso τ vu ->
  OfTypeStlcIso τ' vu.
Proof.
  intros eq [vvu tyu].
  split; [assumption|].
  now rewrite <-eq.
Qed.


(* The theorem is still not proven... *)
Require Vector.
Require List.

Fixpoint lemA2 q (n:nat) (v : Vector.t bool n):
(Vector.fold_left orb q v )=false
->(Vector.fold_left orb false v )=false.
intro j.
destruct q.
2 : exact j.
revert n v j. fix U 2. intros n v j.
destruct v.
simpl. trivial.
simpl.
simpl in j.
Check (U n v).
Check (lemA2 h n v).
eapply  .

destruct h.

Fixpoint lemA1 (h:bool) (n:nat) (v : Vector.t bool n):
(Vector.fold_left orb false (Vector.cons bool h n v) )=false
-> h=false.
intro q.
simpl.

Fixpoint all_then_some (A:Type) (l:list bool) {struct l}:
(forall (b:bool), (List.fold_left orb l b) = b) <->
(forall (p:nat), (List.nth p l false) = false).
Proof.
destruct l.
simpl.
split. intros _ p.
destruct p; trivial.
intros _; reflexivity.

split.
* intros.
simpl.
destruct p.
destruct b.
pose (J:= proj1 (all_then_some A (cons true l)) H 0).
simpl in J.
exact J.
reflexivity.
 admit.
* admit.
Abort.

(*Check proj1 (all_then_some A (cons true l)) H.
destruct b.
simpl in * |- *.
destruct p.*)
Theorem lm000 (p : Fin.t 0): False.
Proof. exact (Fin.case0 (fun _ => False) p ). Defined.

(*
Definition rectS (P: forall {n}, t (S n) -> Type)
  (P1: forall n, @P n F1) (PS : forall {n} (p: t (S n)), P p -> P (FS p)):
  forall {n} (p: t (S n)), P p.
*)

Lemma all_then_some (A:Type): forall (n:nat)(p:Fin.t (S n)) (v:Vector.t bool (S n))
(H : Vector.fold_left orb false v = false),
 (Vector.nth v p) = false.
Proof.
(*destruct n.
intro p; apply Fin.case0; exact p.*)
fix i 1.
Check Fin.rectS (fun n p => forall (v : Vector.t bool (S n)), (Vector.nth v p = false)).
intros n p v K.
unshelve eapply (Fin.rectS (fun n p => forall (v : Vector.t bool (S n)), (Vector.nth v p = false))).
+ intros. simpl.
destruct v.
unfold Vector.nth.
simpl.

Check Fin.rectS.
unshelve eapply Fin.rectS.
4 : exact p.
intros.
apply i; exact K.
trivial.
Defined.
Check Fin.rectS.

induction p with Fin.rectS  .
intros p v H.
Print Fin.t.
eqn: j
destruct p.
inversion p.

destruct p, v eqn: w.
simpl in * |- *.

induction v.
inversion p.

destruct h.
admit.
simpl in H.
unfold Vector.nth.

(*pose (G:= IHv (@Fin.F1 n) H).
simpl.
destruct p.*)
Abort.

rewrite -> l01 in H.


Require Export SpecializedCategory Functor ComputableCategory.
Require Import Common Notations NaturalTransformation.

Set Implicit Arguments.

Generalizable All Variables.

Set Asymmetric Patterns.

Set Universe Polymorphism.

Section Grothendieck.
  Context `(Index2Cat : forall i : Index, SpecializedCategory (Index2Object i)).
  Let Cat := @ComputableCategory _ Index2Object Index2Cat.

  Local Coercion Index2Cat : Index >-> SpecializedCategory.

  (**
     Quoting Wikipedia:
     The Grothendieck construction is an auxiliary construction used
     in the mathematical field of category theory.

     Let
     [F : C -> Set]
     be a functor from any small category to the category of sets.
     The Grothendieck construct for [F] is the category [Γ F] whose
     objects are pairs [(c, x)], where [c : C] is an
     object and [x : F c] is an element, and for which the set
     [Hom (Γ F) (c1, x1) (c2, x2)] is the set of morphisms
     [f : c1 -> c2] in [C] such that [F.(MorphismOf) f x1 = x2].
     *)
  Context `(C : @SpecializedCategory objC).
  Variable F : SpecializedFunctor C Cat.

  Record CatGrothendieckPair := {
    CatGrothendieckC' : objC;
    CatGrothendieckX' : F CatGrothendieckC'
  }.

  Section GrothendieckInterface.
    Variable G : CatGrothendieckPair.

    Definition CatGrothendieckC : C := G.(CatGrothendieckC').
    Definition CatGrothendieckX : F CatGrothendieckC := G.(CatGrothendieckX').
  End GrothendieckInterface.

  Lemma CatGrothendieckPair_eta (x : CatGrothendieckPair) : Build_CatGrothendieckPair (CatGrothendieckC x) (CatGrothendieckX x) = x.
    destruct x; reflexivity.
  Qed.

  Definition CatGrothendieckCompose cs xs cd xd cd' xd' :
    { f : C.(Morphism) cd cd' & Morphism _ (F.(MorphismOf) f xd) xd' }
    -> { f : C.(Morphism) cs cd & Morphism _ (F.(MorphismOf) f xs) xd }
    -> { f : C.(Morphism) cs cd' & Morphism _ (F.(MorphismOf) f xs) xd' }.
    intros m2 m1.
    exists (Compose (projT1 m2) (projT1 m1)).
    refine (Compose (projT2 m2) _).
    rewrite FCompositionOf. (* ugh *)
    refine (MorphismOf (MorphismOf F (projT1 m2)) (projT2 m1)).
  Defined.

  Arguments CatGrothendieckCompose [cs xs cd xd cd' xd'] / _ _.

  Definition CatGrothendieckIdentity c x : { f : C.(Morphism) c c & Morphism _ (F.(MorphismOf) f x) x }.
    exists (Identity c).
    rewrite FIdentityOf.
    exact (Identity _).
  Defined.
(*
  Local Hint Extern 1 (@eq (sig _) _ _) => simpl_eq : category.
  Local Hint Extern 1 (@eq (sigT _) _ _) => simpl_eq : category.

  Definition CategoryOfCatElements : @SpecializedCategory CatGrothendieckPair.
    refine {|
        Morphism := (fun s d => _);
        Compose' := (fun _ _ _ m1 m2 => CatGrothendieckCompose m1 m2);
        Identity' := (fun o => CatGrothendieckIdentity (CatGrothendieckC o) (CatGrothendieckX o))
      |};
    repeat intro; hnf in *; expand;
    simpl_eq;
    destruct_sig;
    auto with category.
    Focus 3.
    unfold eq_rect_r.
    unfold eq_rect.
    unfold eq_sym.
    repeat match goal with
      | [ |- context[match ?E with _ => _ end] ] => (atomic E; fail 1) || let H := fresh in set (H := E)
    end.
        etransitivity.
        destruct
    Focus 2.
    rewrite FIdentityOf.
    destruct H0.

    simpl.
    repeat rewrite Associativity.
    repeat rewrite <- FCompositionOf.
    unfold eq_rect_r.
    unfold eq_sym.
    unfold eq_rect.
    destruct H0.
    destruct H.
    unfold
    destruct_head CatGrothendieckPair;
    simpl_eq.
    abstract (
        repeat intro; hnf in *; expand;
        destruct_head CatGrothendieckPair;
        destruct_sig;
        eauto with category
      ).
  Defined.

  Definition CatGrothendieckProjectionFunctor1 : SpecializedFunctor CategoryOfCatElements C.
    refine {|
        ObjectOf := (fun o : CategoryOfCatElements => CatGrothendieckC o);
        MorphismOf := (fun s d (m : CategoryOfCatElements.(Morphism) s d) => proj1_sig m)
      |};
    abstract (eauto with category; intros; simpl; reflexivity).
  Defined. *)
End Grothendieck.