Require Import hmacdrbg.spec_hmac_drbg.
(*Require Import fcf.HMAC_DRBG_definitions_only.*)
Require Import fcf.HMAC_DRBG_nonadaptive.
Require Import sha.ByteBitRelations.
Require Import BinInt.
Require Import hmacdrbg.DRBG_functions.
Require Import hmacdrbg.HMAC_DRBG_algorithms.
Require Import hmacdrbg.HMAC256_DRBG_functional_prog.
Require Import sha.HMAC256_functional_prog.
Require Import fcf.DetSem.
Require Import sha.general_lemmas.
Require Import hmacdrbg.spec_hmac_drbg_pure_lemmas.
Require Import Coqlib.
Require Import fcf.Fold.
Import ListNotations.

Lemma false_zgt z a: false = (z >? a) -> z<=a.
Proof. unfold Z.gtb.
  remember (z ?= a). destruct c. symmetry in Heqc; apply Z.compare_eq in Heqc. subst; intros. omega.
  symmetry in Heqc. destruct (Z.compare_lt_iff z a); intros. apply H in Heqc. omega.
  discriminate.
Qed.
Lemma false_zge z a: false = (z >=? a) -> z<a.
Proof. unfold Z.geb.
  remember (z ?= a). destruct c; intros; try discriminate.
  symmetry in Heqc. destruct (Z.compare_lt_iff z a); intros. apply H0 in Heqc. omega.
Qed.
Lemma false_zge' z a (A:z<a): false = (z >=? a).
Proof.
  remember ((z >=? a)). destruct b; trivial. symmetry in Heqb. apply Z.geb_le in Heqb. omega.
Qed.

Lemma bytesToBits_InBlocks l: InBlocks 8 (bytesToBits l).
Proof.
  apply InBlocks_len; rewrite bytesToBits_len. exists (length l); omega.
Qed.

Lemma flatten_bytes_bits: forall m (M: Forall (Forall isbyteZ) m),
      flatten m = bitsToBytes (flatten (map bytesToBits m)).
Proof.
  induction m; simpl; trivial; intros.
  inv M. rewrite IHm; clear IHm; trivial.
  rewrite bitsToBytes_app, bytes_bits_bytes_id; trivial.
  apply bytesToBits_InBlocks.
Qed.

Lemma Forall_rev {A} P: forall (l:list A), Forall P l -> Forall P (rev l).
Proof.
  induction l; intros; simpl; trivial. inv H.
  rewrite hmac_pure_lemmas.Forall_app; auto.
Qed.

Lemma to_list_eq (A : Type) (n : nat) l: to_list l = @Vector.to_list A n l.
Proof. reflexivity. Qed.

Definition HMAC_Blist (k: Blist)(data: Blist): Blist :=
  bytesToBits (HMAC256 (bitsToBytes data) (bitsToBytes k)).

Definition HMAC_Bvec (k: Bvector.Bvector 256)(data: Blist): Bvector.Bvector 256.
  apply (of_list_length (bytesToBits (HMAC256 (bitsToBytes data) (bitsToBytes (to_list k)) ))).
  rewrite bytesToBits_len, hmac_common_lemmas.HMAC_length. reflexivity.
Defined.

Lemma HMAC_Blist_Bvec v k: HMAC_Blist (to_list k) v = to_list (HMAC_Bvec k v).
Proof. unfold HMAC_Blist, HMAC_Bvec. rewrite HMAC_equivalence.of_length_proof_irrel; trivial. Qed.

Goal forall k' v, bitsToBytes (to_list (HMAC_Bvec k' v)) = HMAC256  (bitsToBytes v) (bitsToBytes (to_list k')).
Proof. unfold HMAC_Bvec; intros.
  rewrite to_list_eq, HMAC_equivalence.of_length_proof_irrel, bytes_bits_bytes_id; trivial.
  apply isbyteZ_HMAC256.
Qed.

Lemma HMAC_DRBG_generate_helper_Z_equation':
  forall (HMAC : list Z -> list Z -> list Z) (key v : list Z) (requested_number_of_bytes : Z),
  0 < requested_number_of_bytes ->
  HMAC_DRBG_generate_helper_Z HMAC key v requested_number_of_bytes =
    let (v0, rest) := HMAC_DRBG_generate_helper_Z HMAC key v (requested_number_of_bytes - Z.of_nat 32) in
    (HMAC v0 key, rest ++ HMAC v0 key).
Proof. intros. rewrite HMAC_DRBG_generate_helper_Z_equation.
  remember (0 >=? requested_number_of_bytes). destruct b; trivial.
  symmetry in Heqb;  apply Z.geb_le in Heqb. omega.
Qed.
Lemma HMAC_DRBG_generate_helper_Z_equation0:
  forall (HMAC : list Z -> list Z -> list Z) (key v : list Z),
  HMAC_DRBG_generate_helper_Z HMAC key v 0 = (v, nil).
Proof. intros. rewrite HMAC_DRBG_generate_helper_Z_equation. trivial. Qed.

Lemma Genloop_Zlength_blocks : forall n eta k f v blocks u,
  @Gen_loop eta f k v n = (blocks,u) ->
  Zlength blocks = Z.of_nat n.
Proof.
  induction n.
+ simpl; intros. inv H. apply Zlength_nil.
+ intros. simpl in H. unfold to_list in *. remember (Gen_loop f k (f k (Vector.to_list v)) n).
  destruct p. inversion H; clear H. subst.
  symmetry in Heqp. apply IHn in Heqp.
  replace (Z.of_nat (S n)) with (1 + Z.of_nat n)%Z.
  2: symmetry; apply (Nat2Z.inj_add 1 n).
  rewrite <- Heqp. rewrite Zlength_cons. omega.
Qed.

(*Variant of fcf.HMAC_DRBG_definitions_only.Gen_loop that
  - specializes eta to 256
  - specializes f to HMAC256
  - replaces v'::bits with bits++[v']*)
Fixpoint Gen_loop_Bvec (k : Bvector 256) (v : Bvector 256) (n : nat)
  : list (Bvector 256) * Bvector 256 :=
  match n with
  | O => (nil, v)
  | S n' =>
    let v' := HMAC_Bvec k (to_list v) in
    let (bits, v'') := Gen_loop_Bvec k v' n' in
    (List.app bits (List.cons v' List.nil), v'')
  end.

(*A statement suitable for isntantiating the Variable HMAC_DRBG_nonadaptive.eqDecState*)
Lemma eqDecState : EqDec (HMAC_DRBG_nonadaptive.KV 256).
Proof. unfold KV, Bvector. specialize (@Vector_EqDec _ bool_EqDec 256); intros.
  apply pair_EqDec; trivial.
Qed.

Lemma GenloopBvec_ZlengthBlocks k: forall n v blocks u,
  Gen_loop_Bvec k v n = (blocks,u) -> Zlength blocks = Z.of_nat n.
Proof.
  induction n.
+ simpl; intros. inv H. apply Zlength_nil.
+ intros. simpl in H. remember (Gen_loop_Bvec k (HMAC_Bvec k (to_list v)) n).
  destruct p. inv H.
  symmetry in Heqp. apply IHn in Heqp.
  replace (Z.of_nat (S n)) with (1+Z.of_nat n)%Z.
  2: symmetry; apply (Nat2Z.inj_add 1 n).
  rewrite sublist.Zlength_app, Zlength_cons, Zlength_nil, Heqp. omega.
Qed.

(*Lemma stating the relationship between Genloop_bvec and the corresponding
  specialization of Gen_loop*)
Lemma GenloopBvec_Gen_loop k: forall n v blocks u,
  Gen_loop_Bvec k v n = (blocks,u) ->
  Gen_loop HMAC_Bvec k v n = (rev blocks, u).
Proof.
  induction n; simpl; intros.
+ inv H; trivial.
+ (*unfold to_list in H. *)
  remember (Gen_loop_Bvec k (HMAC_Bvec k (to_list v)) n) as p.
  destruct p; inv H.
  symmetry in Heqp. apply IHn in Heqp. rewrite Heqp; clear Heqp IHn.
  rewrite rev_app_distr; trivial.
Qed.

(*Variant of Gen_loop_bvec that uses Blist instead of Bvector 256*)
Fixpoint Gen_loop_Blist (k : Blist) (v : Blist) (n : nat)
  : list Blist * Blist :=
  match n with
  | O => (nil, v)
  | S n' =>
    let v' := HMAC_Blist k v in
    let (bits, v'') := Gen_loop_Blist k v' n' in
    (List.app bits (List.cons v' List.nil), v'')
  end.

(*Relationship between Gen_loop_Blist and Gen_loop_bvec*)
Lemma Gen_loop_Blist_Bvec k: forall n v blocks u,
  Gen_loop_Blist (to_list k) (to_list v) n = (blocks, u) ->
  forall blocks' u', Gen_loop_Bvec k v n = (blocks', u') ->
  u = to_list u' /\ blocks = map (@Vector.to_list _ 256) blocks'.
Proof.
induction n; simpl; intros; subst.
+ inv H; inv H0. split; trivial.
+ remember (Gen_loop_Blist (to_list k) (HMAC_Blist (to_list k) (to_list v)) n) as p; destruct p.
  inv H; symmetry in Heqp.
  remember (Gen_loop_Bvec k (HMAC_Bvec k (to_list v)) n) as q; destruct q.
  inv H0; symmetry in Heqq. rewrite HMAC_Blist_Bvec in Heqp.
  destruct (IHn _ _ _ Heqp _ _ Heqq) as [A B]; subst.
  rewrite HMAC_Blist_Bvec, to_list_eq, list_append_map. split; trivial.
Qed.

(*Variant of Gen_loop_bvec that uses list Z instead of Bvector 256*)
Fixpoint Gen_loop_Zlist (k : list Z) (v : list Z) (n : nat)
  : list (list Z) * (list Z) :=
  match n with
  | O => (nil, v)
  | S n' =>
    let v' := HMAC256 v k in
    let (bits, v'') := Gen_loop_Zlist k v' n' in
    (List.app bits (List.cons v' List.nil), v'')
  end.

Lemma Gen_loop_Zlist_isbyteZ k (K: Forall isbyteZ k):
  forall n v (V: Forall isbyteZ v),
  match Gen_loop_Zlist k v n with (blocks,u) =>
        Forall (Forall isbyteZ) blocks /\ Forall isbyteZ u
  end.
Proof. induction n; simpl; intros.
+ split; trivial.
+ remember (Gen_loop_Zlist k (HMAC256 v k) n) as p; destruct p.
  specialize (IHn (HMAC256 v k)). rewrite <- Heqp in IHn; destruct IHn. apply isbyteZ_HMAC256.
  split; trivial. rewrite hmac_pure_lemmas.Forall_app. split; trivial.
  constructor. apply isbyteZ_HMAC256. eauto.
Qed.

Lemma Gen_loop_Zlist_ZlengthBlocks k: forall n v blocks u,
  Gen_loop_Zlist k v n = (blocks,u) -> Zlength blocks = Z.of_nat n.
Proof. induction n; intros.
+ inv H; simpl. apply Zlength_nil.
+ rewrite Nat2Z.inj_succ; simpl in H.
  remember (Gen_loop_Zlist k (HMAC256 v k) n) as p; destruct p; inv H.
  specialize (IHn (HMAC256 v k)). rewrite <- Heqp in IHn; clear Heqp.
  rewrite sublist.Zlength_app, Zlength_cons, (IHn _ _ (eq_refl _)). simpl; omega.
Qed.

Lemma Gen_loop_Zlist_Blist k (K: Forall isbyteZ k):
  forall n v (V: Forall isbyteZ v),
  match Gen_loop_Zlist k v n with (blocks,u) =>
        Gen_loop_Blist (bytesToBits k) (bytesToBits v) n
        = (map bytesToBits blocks, bytesToBits u)
  end.
Proof. induction n; intros.
+ simpl; trivial.
+ simpl. remember (Gen_loop_Zlist k (HMAC256 v k) n).
  destruct p. specialize (IHn (HMAC256 v k)).
  rewrite <- Heqp in IHn; clear Heqp.
  remember (Gen_loop_Blist (bytesToBits k)
     (HMAC_Blist (bytesToBits k) (bytesToBits v)) n) as q.
  destruct q. unfold HMAC_Blist in *.
  rewrite ! bytes_bits_bytes_id in *; trivial.
  rewrite IHn in Heqq; clear IHn. inv Heqq. f_equal.
  rewrite map_app; trivial. apply isbyteZ_HMAC256.
Qed.

Lemma Gen_loop_Zlist_nestedV k: forall n v blocks u blocks' u',
  Gen_loop_Zlist k (HMAC256 v k) n = (blocks, u) ->
  Gen_loop_Zlist k v n = (blocks', u') ->
  u = HMAC256 u' k /\
  blocks = map (fun z => HMAC256 z k) blocks'.
Proof. induction n; simpl; intros.
+ inv H; inv H0. split; trivial.
+ remember (Gen_loop_Zlist k (HMAC256 v k) n) as p.
  remember (Gen_loop_Zlist k (HMAC256 (HMAC256 v k) k) n) as q.
  destruct p; destruct q. inv H. symmetry in Heqp, Heqq.
  specialize (IHn (HMAC256 v k)).
  rewrite Heqq, Heqp in IHn; clear Heqq Heqp. inv H0.
  specialize (IHn _ _ _ _ (eq_refl _) (eq_refl _)).
  destruct IHn as [? ?]; subst.  rewrite map_app. split; trivial.
Qed.

Lemma Gen_loop_Zlist_nestedV' k: forall n v blocks u,
  Gen_loop_Zlist k (HMAC256 v k) n = (blocks, u) ->
  exists blocks' u',
  Gen_loop_Zlist k v n = (blocks', u') /\
  u = HMAC256 u' k /\
  blocks = map (fun z => HMAC256 z k) blocks'.
Proof. induction n; simpl; intros.
+ inv H. exists nil, v. split; trivial. split; trivial.
+ remember (Gen_loop_Zlist k (HMAC256 v k) n) as p.
  remember (Gen_loop_Zlist k (HMAC256 (HMAC256 v k) k) n) as q.
  destruct p; destruct q. inv H. symmetry in Heqp, Heqq.
  specialize (IHn (HMAC256 v k) _ _ Heqq).
  rewrite Heqp in IHn; clear Heqq Heqp.
  destruct IHn as [aa [bb [AB [? ?]]]]; subst.
  inv AB. eexists; eexists; split. reflexivity. rewrite map_app.
  split; trivial.
Qed.

Definition Equiv n:= forall k v blocks u
   (G: Gen_loop_Zlist k v n = (blocks, u)) m
   (M: 32*(Z.of_nat n-1) < m <=32*(Z.of_nat n)),
   HMAC_DRBG_generate_helper_Z HMAC256 k v m = (u,flatten (rev blocks)).

Lemma E1: Equiv 1.
Proof. unfold Equiv. simpl; intros. inv G. simpl. rewrite app_nil_r.
 rewrite HMAC_DRBG_generate_helper_Z_equation'; try omega. simpl.
 rewrite HMAC_DRBG_generate_helper_Z_equation.
 assert (0 >=? m - 32 = true). apply Z.geb_le; omega.
 rewrite H; trivial.
Qed.

Lemma E2: Equiv 2.
Proof. unfold Equiv; simpl; intros.
  inv G; simpl.
 rewrite HMAC_DRBG_generate_helper_Z_equation'; try omega. simpl.
 rewrite HMAC_DRBG_generate_helper_Z_equation.
 assert (false = (0 >=? m - 32)) by (apply false_zge'; omega).
 rewrite <- H. simpl.
 rewrite HMAC_DRBG_generate_helper_Z_equation.
 assert ((0 >=? m - 32 - 32)= true) by (apply Z.geb_le; omega).
 rewrite H0. rewrite app_nil_r; trivial.
Qed. (*

Lemma E3: Equiv 3.
Proof. unfold Equiv, HMAC_DRBG_generate_helper_Z; simpl; intros.
  inv H; simpl. rewrite app_assoc, app_nil_r; trivial.
Qed.

Lemma E4: Equiv 4.
Proof. unfold Equiv, HMAC_DRBG_generate_helper_Z; simpl; intros.
  inv H; simpl. rewrite ! app_assoc, app_nil_r; trivial.
Qed.

Lemma E10: Equiv 10.
Proof. unfold Equiv, HMAC_DRBG_generate_helper_Z; simpl; intros.
  inv H; simpl. rewrite ! app_assoc, app_nil_r; trivial.
Qed.
*)
(*Hence, by induction the following equivalence property holds*)

Lemma E_aux k: forall n v blocks u,
               Gen_loop_Zlist k (HMAC256 v k) n = (blocks, u) ->
      flatten (rev blocks) ++ HMAC256 u k =
      HMAC256 (HMAC256 v k) k ++ flatten (rev (map (fun z : list Z => HMAC256 z k) blocks)).
Proof. induction n; intros.
+ inv H; simpl. rewrite app_nil_r; trivial.
+ simpl in H.
  remember (Gen_loop_Zlist k (HMAC256 (HMAC256 v k) k) n).
  destruct p. inv H. specialize (IHn (HMAC256 v k)).
  rewrite <- Heqp in IHn; clear Heqp.
  specialize (IHn _ _ (eq_refl _)).
  rewrite rev_app_distr in *. rewrite flatten_app, <- app_assoc, IHn; clear IHn.
  simpl. rewrite app_nil_r. f_equal. rewrite map_app, rev_app_distr.
  simpl; trivial.
Qed.

Lemma E: forall n, Equiv (S n).
Proof. induction n.
+ apply E1.
+ unfold Equiv in *; intros. remember (S n) as N.
  simpl in G.
  remember (Gen_loop_Zlist k (HMAC256 v k) N) as p.
  destruct p; symmetry in Heqp. inversion G; clear G. subst blocks l0.
  rewrite HMAC_DRBG_generate_helper_Z_equation'.
  Focus 2. rewrite Zmult_minus_distr_l in M.
    assert (64 <= 32 * Z.of_nat (S N)).
    { subst. replace 64 with (32*2) by omega. apply Z.mul_le_mono_nonneg_l. omega.
      clear. apply (Nat2Z.inj_le 2). omega. }
    omega.
  simpl.
  apply Gen_loop_Zlist_nestedV' in Heqp.
  destruct Heqp as [aa [bb [G [X L]]]]. subst u l.
  rewrite (IHn _ _ _ _ G); clear IHn.
  Focus 2. clear - M.
           rewrite Zmult_minus_distr_l in *. rewrite Nat2Z.inj_succ in M. simpl in *.
           omega.
  f_equal. rewrite rev_app_distr.

  subst N; simpl in G. remember (Gen_loop_Zlist k (HMAC256 v k) n).
  destruct p. inv G. rewrite map_app, ! rev_app_distr, ! flatten_app.
  simpl. rewrite ! app_nil_r, <- app_assoc. f_equal.
  symmetry in Heqp. apply (E_aux k n); trivial.
Qed.

Lemma EE n (N:(0<n)%nat): Equiv n.
Proof. destruct n. omega. apply E; trivial. Qed.

Definition GenUpdate_original_core (state : KV 256) (n : nat) :
  (list (Bvector 256) * KV 256) :=
  match state with (k, v) =>
    match Gen_loop HMAC_Bvec k v n with (bits, v') =>
        let k' := HMAC_Bvec k (to_list v' ++ zeroes) in
        let v'' := HMAC_Bvec k' (to_list v') in (bits, (k', v''))
    end
  end.

Definition GenUpdate_original_Bvec (state : KV 256) (n : nat) :
  (list (Bvector 256) * KV 256) :=
  match state with (k, v) =>
    match Gen_loop_Bvec k v n with (bits, v') =>
        let k' := HMAC_Bvec k (to_list v' ++ zeroes) in
        let v'' := HMAC_Bvec k' (to_list v') in (bits, (k', v''))
    end
  end.

Lemma GenUpdate_original_Bvec_correct state n:
  match GenUpdate_original_Bvec state n with (blocks, u) =>
     GenUpdate_original_core state n = (rev blocks, u) end.
Proof. unfold GenUpdate_original_Bvec, GenUpdate_original_core.
  destruct state as [k v].
  remember (Gen_loop_Bvec k v n) as p; destruct p; symmetry in Heqp.
  apply GenloopBvec_Gen_loop in Heqp. rewrite Heqp; trivial.
Qed.

Definition GenUpdate_original_Blist (state : Blist * Blist) (n : nat) :
  (list Blist * (Blist * Blist)) :=
  match state with (k, v) =>
    match Gen_loop_Blist k v n with (bits, v') =>
        let k' := HMAC_Blist k (v' ++ zeroes) in
        let v'' := HMAC_Blist k' v' in (bits, (k', v''))
    end
  end.

Lemma GenUpdate_original_Blist_Bvec k v n:
  match GenUpdate_original_Bvec (k,v) n with (blocks,(kk,u)) =>
    GenUpdate_original_Blist (@Vector.to_list _ 256 k, @Vector.to_list _ 256 v) n =
      (map (@Vector.to_list _ 256) blocks, (@Vector.to_list _ 256 kk, @Vector.to_list _ 256 u))
  end.
Proof. unfold GenUpdate_original_Bvec, GenUpdate_original_Blist.
  remember (Gen_loop_Bvec k v n) as p; symmetry in Heqp. destruct p as [bits v'].
  remember (Gen_loop_Blist (Vector.to_list k) (Vector.to_list v) n) as q; symmetry in Heqq.
  destruct q as [Bits V].
  destruct (Gen_loop_Blist_Bvec k n v Bits V Heqq _ _ Heqp); subst.
  rewrite ! HMAC_Blist_Bvec; trivial.
Qed.

Definition GenUpdate_original_Zlist (state : list Z * list Z) (n : nat) :
  (list (list Z) * (list Z * list Z)) :=
  match state with (k, v) =>
    match Gen_loop_Zlist k v n with (blocks, v') =>
        let k' := HMAC256 (v' ++ [Z0]) k in
        let v'' := HMAC256 v' k' in (blocks, (k', v''))
    end
  end.

Lemma GenUpdate_original_Zlist_ZlengthBlocks state n blocks state':
  GenUpdate_original_Zlist state n = (blocks,state') ->
  Zlength blocks = Z.of_nat n.
Proof. destruct state; simpl; intros.
  remember (Gen_loop_Zlist l l0 n) as p; destruct p; symmetry in Heqp.
  inv H. apply Gen_loop_Zlist_ZlengthBlocks in Heqp; rewrite Heqp; trivial.
Qed.

Lemma GenUpdate_original_Zlist_isbyteZ k (K: Forall isbyteZ k) v (V: Forall isbyteZ v) n blocks state':
  GenUpdate_original_Zlist (k,v) n = (blocks,state') ->
  Forall (Forall isbyteZ) blocks /\ Forall isbyteZ (fst state') /\ Forall isbyteZ (snd state').
Proof. simpl.
  remember (Gen_loop_Zlist k v n) as p; destruct p; symmetry in Heqp.
  specialize (Gen_loop_Zlist_isbyteZ _ K n _ V); rewrite Heqp. intros [A B] C; inv C.
  split; trivial. simpl. split; apply isbyteZ_HMAC256.
Qed.

Lemma GenUpdate_original_Zlist_Blist k v n
  (K: Forall isbyteZ k) (V: Forall isbyteZ v):
  match GenUpdate_original_Zlist (k,v) n with (blocks,(k',v')) =>
    GenUpdate_original_Blist (bytesToBits k, bytesToBits v) n =
         (map bytesToBits blocks,(bytesToBits k', bytesToBits v'))
  end.
Proof. unfold GenUpdate_original_Zlist, GenUpdate_original_Blist.
  remember (Gen_loop_Zlist k v n) as p; symmetry in Heqp. destruct p as [bits v'].
  specialize (Gen_loop_Zlist_Blist _ K n _ V). rewrite Heqp; intros Q. simpl in Q.
  remember (Gen_loop_Blist (bytesToBits k) (bytesToBits v) n) as q; destruct q.
  assert (W: (l, b) =(@map (list Z) ByteBitRelations.Blist bytesToBits bits, bytesToBits v')) by (rewrite <- Q, Heqq; trivial).
  clear Q Heqq; inv W. f_equal. unfold HMAC_Blist.
  assert (T: Forall (Forall isbyteZ) nil) by eauto.
  specialize (Gen_loop_Zlist_isbyteZ _ K n _ V); rewrite Heqp. intros [? ?].
  rewrite ! bitsToBytes_app, ! bytes_bits_bytes_id; trivial.
  f_equal. unfold zeroes. simpl. apply  isbyteZ_HMAC256.
  apply bytesToBits_InBlocks.
Qed.

(*Specialization of HMAC256_DRBG_generate_algorithm: no additional input*)
Definition FunGenerate RI (WS: DRBG_functions.DRBG_working_state) n: DRBG_functions.DRBG_generate_algorithm_result :=
           HMAC256_DRBG_functional_prog.HMAC256_DRBG_generate_algorithm RI
                                           WS
                                           n
                                           nil.
Opaque mult.

Lemma GenerateCorrect RI k v z n (Z: (z<=RI)%Z) (N:(0<n)%nat):
  match GenUpdate_original_Zlist (k,v) n with (blocks,(k',v')) =>
    FunGenerate RI (v, k, z) (Z.of_nat ((32 * n)%nat)) =
    generate_algorithm_success (firstn ((32 * n)%nat) (fcf.Fold.flatten (rev blocks))) (v',k',(z+1)%Z)
  end.
Proof. remember (GenUpdate_original_Zlist (k, v) n) as p; destruct p as [kk [vv zz]]; symmetry in Heqp.
  unfold GenUpdate_original_Zlist in Heqp.
  remember (Gen_loop_Zlist k v n) as q; destruct q as [blocks v']; symmetry in Heqq; inv Heqp.
  apply EE in Heqq; trivial. remember (Z.of_nat (32 * n)) as a.
  simpl. remember (z >? RI) as d. destruct d; symmetry in Heqd.
  + apply Zgt_is_gt_bool in Heqd; omega.
  + rewrite Z.mul_sub_distr_l in Heqq.
    rewrite Heqq. subst a; rewrite Nat2Z.id; trivial.
    subst a; clear -N. simpl. rewrite Nat2Z.inj_mul. simpl; omega.
Qed.
Opaque FunGenerate.

Lemma Generate_Blist_ok RI k v z n (Z: (z<=RI)%Z) l kk vv zz
    (K: Forall isbyteZ k) (V:Forall isbyteZ v) (N:(0<n)%nat):
    FunGenerate RI (v, k, z) (Z.of_nat ((32 * n)%nat)) = generate_algorithm_success l (kk,vv, zz) ->
    exists y,
    GenUpdate_original_Blist (bytesToBits k, bytesToBits v) n =
    (map bytesToBits y,(bytesToBits vv, bytesToBits kk)) /\ zz=z+1 /\
    l = firstn (32 * n) (flatten (rev y)).
Proof.
  remember (GenUpdate_original_Zlist (k,v) n) as g. symmetry in Heqg; destruct g as [a [b c]].
  specialize (GenerateCorrect RI k v z n Z N). rewrite Heqg; intros HH1 HH2.
  rewrite HH1 in HH2. exists a. inv HH2. repeat split; trivial.
  specialize (GenUpdate_original_Zlist_Blist k v n K V).
  rewrite Heqg; intros HH; rewrite HH; trivial.
Qed.

Lemma Generate_Bvec_ok' RI k v z n (Z: (z<=RI)%Z) l kk vv zz (N:(0<n)%nat)
    (K: Forall isbyteZ k) (KL: length (bytesToBits k) = 256%nat) (V:Forall isbyteZ v) (VL:length (bytesToBits v) = 256%nat):
    FunGenerate RI (v, k, z) (Z.of_nat ((32 * n)%nat)) = generate_algorithm_success l (kk,vv, zz) ->
    match GenUpdate_original_Bvec (of_list_length _ KL, of_list_length _ VL) n with (blocks, kv) =>
    zz=z+1 /\
    bitsToBytes (@Vector.to_list _ 256 (fst kv)) = vv /\
    bitsToBytes (@Vector.to_list _ 256 (snd kv)) = kk /\
          l = firstn (32 * n) (bitsToBytes (flatten (rev (map (@Vector.to_list _ 256) blocks))))
    end.
Proof.
  remember (GenUpdate_original_Zlist (k,v) n) as g. symmetry in Heqg; destruct g as [a [b c]].
  specialize (GenerateCorrect RI k v z n Z N). rewrite Heqg; intros HH1 HH2.
  rewrite HH1 in HH2. inv HH2.
  specialize (GenUpdate_original_Zlist_Blist k v n K V).
  rewrite Heqg. intros HH.
  specialize (GenUpdate_original_Blist_Bvec (of_list_length (bytesToBits k) KL)
                (of_list_length (bytesToBits v) VL) n); intros X.
  remember (GenUpdate_original_Bvec
    (of_list_length (bytesToBits k) KL, of_list_length (bytesToBits v) VL) n) as w.
  destruct w; symmetry in Heqw.
  simpl in X. simpl in Heqw. rewrite Heqw in X; clear Heqw.
  destruct k0 as [w u]. rewrite ! HMAC_equivalence.of_length_proof_irrel in X.
  simpl in HH. rewrite HH in X; clear HH. inv X. split. trivial. simpl.
  apply  GenUpdate_original_Zlist_isbyteZ in Heqg; trivial. destruct Heqg as [isbyteA [isbyteVV isbyteKK]].
  rewrite <- H1, <- H2, ! bytes_bits_bytes_id; trivial.
  repeat split; trivial.
  rewrite <- map_rev. f_equal. apply flatten_bytes_bits. apply Forall_rev; trivial.
Qed.
Lemma Generate_Bvec_ok RI k v z n (Z: (z<=RI)%Z) (N:(0<n)%nat)
              (K: Forall isbyteZ k) (KL: length (bytesToBits k) = 256%nat)
              (V:Forall isbyteZ v) (VL:length (bytesToBits v) = 256%nat):
    match GenUpdate_original_Bvec (of_list_length _ KL, of_list_length _ VL) n with (blocks, (kk,vv)) =>
          FunGenerate RI (v, k, z) (Z.of_nat ((32 * n)%nat))
          = generate_algorithm_success (firstn (32 * n) (bitsToBytes (flatten (rev (map (@Vector.to_list _ 256) blocks)))))
                                       (bitsToBytes (@Vector.to_list _ 256 vv), bitsToBytes (@Vector.to_list _ 256 kk), z+1)
    end.
Proof.
  remember (GenUpdate_original_Zlist (k,v) n) as g. symmetry in Heqg; destruct g as [a [b c]].
  specialize (GenerateCorrect RI k v z n Z N). rewrite Heqg; intros HH; rewrite HH.
  specialize (GenUpdate_original_Zlist_Blist _ _ n K V); rewrite Heqg; intros.
  remember ( GenUpdate_original_Bvec
    (of_list_length (bytesToBits k) KL, of_list_length (bytesToBits v) VL) n) as p.
  destruct p as [blocks [kk vv]]; symmetry in Heqp.
  specialize (GenUpdate_original_Blist_Bvec (of_list_length (bytesToBits k) KL)
                 (of_list_length (bytesToBits v) VL) n).
  simpl. simpl in Heqp. rewrite Heqp; clear Heqp. simpl in H.
  rewrite ! HMAC_equivalence.of_length_proof_irrel. rewrite H; clear H. intros. inv H.
  apply  GenUpdate_original_Zlist_isbyteZ in Heqg; trivial. destruct Heqg as [isbyteA [isbyteVV isbyteKK]].
  f_equal.
  - f_equal. rewrite <- map_rev. apply flatten_bytes_bits. apply Forall_rev; trivial.
  - rewrite ! bytes_bits_bytes_id; trivial.
Qed.

Lemma Generate_ok' RI k v z n (Z: (z<=RI)%Z) l kk vv zz (N:(0<n)%nat)
    (K: Forall isbyteZ k) (KL: length (bytesToBits k) = 256%nat) (V:Forall isbyteZ v) (VL:length (bytesToBits v) = 256%nat):
    FunGenerate RI (v, k, z) (Z.of_nat ((32 * n)%nat)) = generate_algorithm_success l (kk,vv, zz) ->
    match GenUpdate_original_core (of_list_length _ KL, of_list_length _ VL) n with (blocks, kv) =>
    zz=z+1 /\
    bitsToBytes (@Vector.to_list _ 256 (fst kv)) = vv /\
    bitsToBytes (@Vector.to_list _ 256 (snd kv)) = kk /\
          l = firstn (32 * n) (bitsToBytes (flatten (map (@Vector.to_list _ 256) blocks)))
    end.
Proof. intros.
  specialize (Generate_Bvec_ok' RI k v z n Z l kk vv zz N K KL V VL H); clear H; intros.
  remember (GenUpdate_original_Bvec
        (of_list_length (bytesToBits k) KL,
        of_list_length (bytesToBits v) VL) n) as p; symmetry in Heqp; destruct p as [blocks state].
  specialize (GenUpdate_original_Bvec_correct
               (of_list_length (bytesToBits k) KL,
                of_list_length (bytesToBits v) VL) n).
  rewrite Heqp; clear Heqp; intros Q; rewrite Q, map_rev; apply H.
Qed.
Lemma Generate_ok RI k v z n (Z: (z<=RI)%Z) (N:(0<n)%nat)
              (K: Forall isbyteZ k) (KL: length (bytesToBits k) = 256%nat)
              (V:Forall isbyteZ v) (VL:length (bytesToBits v) = 256%nat):
    match GenUpdate_original_core (of_list_length _ KL, of_list_length _ VL) n with (blocks, (kk,vv)) =>
          FunGenerate RI (v, k, z) (Z.of_nat ((32 * n)%nat))
          = generate_algorithm_success (firstn (32 * n) (bitsToBytes (flatten (map (@Vector.to_list _ 256) blocks))))
                                       (bitsToBytes (@Vector.to_list _ 256 vv), bitsToBytes (@Vector.to_list _ 256 kk), z+1)
    end.
Proof.
  remember (GenUpdate_original_Bvec
        (of_list_length (bytesToBits k) KL,
        of_list_length (bytesToBits v) VL) n) as p; destruct p as [blocks [kk vv]]; symmetry in Heqp.

  specialize (GenUpdate_original_Bvec_correct (of_list_length (bytesToBits k) KL,
         of_list_length (bytesToBits v) VL) n). rewrite Heqp.
  intros Q; rewrite Q; clear Q.
  specialize (Generate_Bvec_ok RI k v z n Z N K KL V VL). rewrite Heqp; clear Heqp.
  intros W; rewrite W, map_rev; trivial.
Qed.

Require Import hmacdrbg.entropy.
Require Import hmacdrbg.HMAC_DRBG_common_lemmas.

Lemma Bridge s I n bytes J ss (M: mbedtls_HMAC256_DRBG_generate_function s I n [] = ENTROPY.success (bytes, J) ss):
  match I with HMAC256DRBGabs K V reseed_counter entropy_len prediction_resistance reseed_interval =>
  reseed_counter <= reseed_interval -> prediction_resistance = false ->
  match J with (ws,sstrength,prflag) =>
  s=ss /\ FunGenerate reseed_interval (V,K,reseed_counter) n = DRBG_functions.generate_algorithm_success bytes ws
  end end.
Proof. destruct I. destruct J as [[ws sstrength] prf].
Transparent FunGenerate. simpl. Opaque FunGenerate. simpl in M.
remember (n >? 1024) as d; destruct d; try discriminate.
rewrite andb_negb_r in M. intros; subst.
apply Zgt_is_gt_bool_f in H. rewrite H.
remember (HMAC_DRBG_algorithms.HMAC_DRBG_generate_helper_Z HMAC256 key V n) as p; destruct p.
unfold HMAC256_DRBG_functional_prog.HMAC256_DRBG_generate_algorithm in M; simpl in M.
rewrite H, <- Heqp in M. inv M; split; trivial.
Qed.

(*The function occurring in the VST spec of mbedtls' random function ie no additional input*)
Definition mbedtls_generate s I n :=
   match mbedtls_HMAC256_DRBG_generate_function s I n []
   with ENTROPY.success (bytes, J) ss =>
          match J with ((((VV, KK), RC), _), PR) =>
            Some (bytes, ss, HMAC256DRBGabs KK VV RC (hmac256drbgabs_entropy_len I) PR
                                 (hmac256drbgabs_reseed_interval I))
          end
      | _ => None
   end.

Lemma Bridge' s I n bytes F ss (M: mbedtls_generate s I n = Some(bytes, ss, F)):
  match I with HMAC256DRBGabs K V reseed_counter entropy_len prediction_resistance reseed_interval =>
  reseed_counter <= reseed_interval -> prediction_resistance = false ->
  match F with HMAC256DRBGabs KK VV rc _ _ _ =>
  s=ss /\ rc=reseed_counter+1 /\
  FunGenerate reseed_interval (V,K,reseed_counter) n = DRBG_functions.generate_algorithm_success bytes ((VV,KK), rc)
  end end.
Proof. destruct I. destruct F. Transparent FunGenerate. simpl. Opaque FunGenerate.
unfold mbedtls_generate in M. simpl in M.
remember (n >? 1024) as d; destruct d; try discriminate.
rewrite andb_negb_r in M. intros; subst.
apply Zgt_is_gt_bool_f in H.  rewrite H.
remember (HMAC_DRBG_algorithms.HMAC_DRBG_generate_helper_Z HMAC256 key V n) as p; destruct p.
unfold HMAC256_DRBG_functional_prog.HMAC256_DRBG_generate_algorithm in M; simpl in M.
rewrite H, <- Heqp in M. inv M; auto.
Qed.

Lemma Bridge_ok' s I (n:nat) bytes F ss (M: mbedtls_generate s I (32 * Z.of_nat n) = Some(bytes, ss, F)) (N:(0 < n)%nat):
  match I with HMAC256DRBGabs k v reseed_counter entropy_len prediction_resistance reseed_interval =>
  reseed_counter <= reseed_interval -> prediction_resistance = false ->
  forall (K: Forall isbyteZ k) (KL: length (bytesToBits k) = 256%nat) (V:Forall isbyteZ v) (VL:length (bytesToBits v) = 256%nat),
  match F with HMAC256DRBGabs KK VV rc _ _ _ =>
  s=ss /\ rc=reseed_counter+1 /\
    match GenUpdate_original_core (Blist.of_list_length _ KL, Blist.of_list_length _ VL) n with (blocks, kv) =>
    bitsToBytes (@Vector.to_list _ 256 (fst kv)) = KK /\
    bitsToBytes (@Vector.to_list _ 256 (snd kv)) = VV /\
          bytes = firstn (32 * n) (bitsToBytes (Fold.flatten (map (@Vector.to_list _ 256) blocks)))
    end
  end end.
Proof.
 specialize (Bridge' _ _ _ _ _ _ M); destruct I; intros.
 specialize (H H0 H1). destruct F. destruct H as [HH1 [HH2 HH3]].
 split; trivial. split; trivial.
 specialize (Generate_ok' reseed_interval key V reseed_counter n H0 bytes V1 key0 reseed_counter0).
 rewrite Nat2Z.inj_mul. simpl. rewrite HH3.
 clear HH3 M.
 intros ZZ. specialize (ZZ N K KL V0 VL (eq_refl _)).
 remember (HMAC_DRBG_nonadaptive.Gen_loop HMAC_Bvec
           (Blist.of_list_length (bytesToBits key) KL)
           (Blist.of_list_length (bytesToBits V) VL) n) as q.
 destruct q. destruct ZZ as [_ ZZ].   apply ZZ.
Qed.

Lemma GenUpdate_original_core_length: forall n state l m
  (G: GenUpdate_original_core state n = (l,m)),
   length l = n%nat.
Proof. induction n; destruct state; simpl; intros.
+ inv G. simpl; omega.
+ remember (HMAC_DRBG_nonadaptive.Gen_loop HMAC_Bvec b
           (HMAC_Bvec b (HMAC_DRBG_nonadaptive.to_list b0)) n) as q.
  destruct q.  inv G. simpl. symmetry in Heqq. apply Genloop_Zlength_blocks in Heqq.
  rewrite (Zlength_correct l0) in Heqq. apply Nat2Z.inj in Heqq. subst; trivial.
Qed.

Lemma fold_vector_length: forall l m,
fold_left
  (fun (acc : nat) (a : Vector.t bool 256) =>
   (acc + Datatypes.length (Vector.to_list a))%nat) l m =
  (m + Datatypes.length l * 256)%nat.
Proof. induction l; simpl; intros. + omega.
+ rewrite IHl, Blist.to_list_length; clear IHl. omega.
Qed.

Lemma mbedtls_generate_Bridge s I (n:nat) bytes F ss (M: mbedtls_generate s I (32 * Z.of_nat n) = Some(bytes, ss, F)) (N:(0 < n)%nat):
  match I with HMAC256DRBGabs k v reseed_counter entropy_len prediction_resistance reseed_interval =>
  reseed_counter <= reseed_interval -> prediction_resistance = false ->
  forall (K: Forall isbyteZ k) (KL: length (bytesToBits k) = 256%nat) (V:Forall isbyteZ v) (VL:length (bytesToBits v) = 256%nat),
  match F with HMAC256DRBGabs KK VV rc _ _ _ =>
  s=ss /\ rc=reseed_counter+1 /\
    match GenUpdate_original_core (Blist.of_list_length _ KL, Blist.of_list_length _ VL) n with (blocks, kv) =>
    bitsToBytes (@Vector.to_list _ 256 (fst kv)) = KK /\
    bitsToBytes (@Vector.to_list _ 256 (snd kv)) = VV /\
          bytes = (bitsToBytes (Fold.flatten (map (@Vector.to_list _ 256) blocks)))
    end
  end end.
Proof.
 specialize (Bridge_ok' _ _ _ _ _ _ M N); destruct I; intros.
 specialize (H H0 H1 K KL V0 VL). destruct F. destruct H as [HH1 [HH2 HH3]].
 split; trivial. split; trivial.
 remember (GenUpdate_original_core
          (Blist.of_list_length (bytesToBits key) KL,
          Blist.of_list_length (bytesToBits V) VL) n) as q. destruct q.
 rewrite sublist.firstn_same in HH3. trivial.
 symmetry in Heqq. apply GenUpdate_original_core_length in Heqq.
 assert (Datatypes.length (bitsToBytes (Fold.flatten (map Vector.to_list l))) = (32*n)%nat).
 apply bitsToBytes_len_gen. rewrite CompFold.length_flatten. simpl. rewrite CompFold.fold_left_map_eq.
 subst n. rewrite fold_vector_length. simpl. rewrite (mult_comm 32). rewrite <- mult_assoc.
 replace (32*8)%nat with 256%nat. trivial. omega.
 rewrite H. omega.
Qed.

Require Import fcf.FCF.
Definition AsGame {A} f (a:A) : Comp (list (Bvector 256) * KV 256) := ret(f a).
Definition Generate_refactored state := AsGame (GenUpdate_original_core state).

Lemma Refactored kv n:
     comp_spec (fun x y => x=y)
               (@Generate _ HMAC_Bvec eqDecState kv n)
               (*(AsGame (GenUpdate_original_core kv) n)*) (ret (GenUpdate_original_core kv n)).
Proof.
  unfold AsGame, Generate, GenUpdate_original_core.
  destruct kv as [k v]. prog_simp. apply comp_spec_ret; trivial.
Qed.

Lemma OK256: (256 <> 0)%nat. Proof. omega. Qed.

Definition Instantiated_G1_G2_close := G1_G2_close OK256 HMAC_Bvec eqDecState.
(*How should we instantiate blocksPerCall numCalls : nat,
       (numCalls > 0)%nat ->
       (blocksPerCall > 0)%nat ->?*)
(* final theorem?
Theorem X_close kv :
  | Pr[AsGame (GenUpdate_original_core kv)] - Pr[@G_ideal 256] | <= (numCalls / 1) * Gi_Gi_plus_1_bound.
Proof.
  rewrite Generate_move_v_update.
  rewrite G_real_is_first_hybrid.
  rewrite G_ideal_is_last_hybrid.
  specialize (hybrid_argument (fun i => Pr[Gi_prg i]) Gi_adjacent_hybrids_close numCalls).
  intuition.
Qed.

(*Temporary stuff
Definition Generate_refactored (state : KV 256) (n : nat) :
  Comp (list (Bvector 256) * KV 256) := ret (GenUpdate_original_core state n).

Lemma Refactored kv n:
     comp_spec (fun x y => x=y)
               (@Generate _ HMAC_Bvec eqDecState kv n)
               (Generate_refactored kv n).
Proof.
  unfold Generate, Generate_refactored, GenUpdate_original_core.
  destruct kv as [k v]. prog_simp. apply comp_spec_ret; trivial.
Qed.*)
(*Could now optionally FCF-relate GenUpdate_original_refactored to Generate, for
  relational spec relating bvectors to list Z,  using the above Gallina equalities*)*)


Require Import vcfloat.VCFloat.
Require Import Interval.Tactic.
Import Binary Coq.Lists.List ListNotations.
Set Bullet Behavior "Strict Subproofs".
Section WITHNANS.
Context {NANS:Nans}.
Open Scope R_scope.

Definition turbine1_bmap_list := [Build_varinfo Tdouble 1%positive (-45e-1) (-3e-1);Build_varinfo Tdouble 2%positive (4e-1) (9e-1);Build_varinfo Tdouble 3%positive (38e-1) (78e-1)].

Definition turbine1_bmap :=
 ltac:(let z := compute_PTree (boundsmap_of_list turbine1_bmap_list) in exact z).

Definition turbine1 (v : ftype Tdouble) (w : ftype Tdouble) (r : ftype Tdouble) :=
  cast Tdouble (((((3)%F64 + ((2)%F64 / (r * r)%F64)%F64)%F64 - ((((125e-3)%F64 * ((3)%F64 - ((2)%F64 * v)%F64)%F64)%F64 * (((w * w)%F64 * r)%F64 * r)%F64)%F64 / ((1)%F64 - v)%F64)%F64)%F64 - (45e-1)%F64)%F64).

Definition turbine1_expr :=
 ltac:(let e' :=  HO_reify_float_expr constr:([1%positive;2%positive;3%positive]) turbine1 in exact e').

Derive turbine1_b
SuchThat (forall vmap, prove_roundoff_bound turbine1_bmap vmap turbine1_expr turbine1_b)
As turbine1_bound.
Proof.
idtac "Starting turbine1".
time "turbine1" (
try (subst turbine1_b; intro; prove_roundoff_bound);
try (prove_rndval; interval);
try (prove_roundoff_bound2; error_rewrites);
try (prune_terms (cutoff 70);
try match goal with |- (Rabs ?e <= ?a - 0)%R =>
  rewrite Rminus_0_r (* case prune terms will fail to produce reasonable bound on goal*)
end;
try match goal with |- (Rabs ?e <= ?a - ?b)%R =>
                      let G := fresh "G" in
                      interval_intro (Rabs e) as G ;
                      eapply Rle_trans;
                      [apply G | apply Rminus_plus_le_minus; apply Rle_refl] end);
try rewrite Rsqr_pow2;
try field_simplify_Rabs;
try match goal with |- Rabs ?a <= _ =>
interval_intro (Rabs a) with ( i_bisect vxH,
i_bisect v,
i_bisect v0, i_depth 20) as H'; apply H'; apply Rle_refl
end;
try match goal with |- Rabs ?a <= _ =>
interval_intro (Rabs a) with (
i_bisect v,
i_bisect v0, i_depth 20) as H'; apply H'; apply Rle_refl
end;
try match goal with |- Rabs ?a <= _ =>
interval_intro (Rabs a) with (
i_bisect v0, i_depth 20) as H'; apply H'; apply Rle_refl
end;
try match goal with |- Rabs ?a <= _ =>
interval_intro (Rabs a) with (
i_bisect v, i_depth 20) as H'; apply H'; apply Rle_refl
end;
try match goal with |- Rabs ?a <= _ =>
interval_intro (Rabs a) with (
i_bisect vxH, i_depth 20) as H'; apply H'; apply Rle_refl
end;
try match goal with |- Rabs ?a <= _ =>
interval_intro (Rabs a) as H'; apply H'; apply Rle_refl
end).
Qed.

Lemma check_turbine1_bound: ltac:(CheckBound turbine1_b 7.9e-14%F64).
Proof. reflexivity. Qed.

End WITHNANS.
Close Scope R_scope.


Set Warnings "-notation-overridden".

Require Import Coq.Logic.Eqdep_dec.

From Equations Require Import Equations.
Unset Equations With Funext.

Require Import Category.Lib.
Require Import Category.Theory.
Require Import Category.Instance.Coq.

Require Import Embed.Theory.Functor.Void.

Generalizable All Variables.
Set Universe Polymorphism.
Set Nested Proofs Allowed.

Section FunctorRefinedDef.
Context `{F : Coq ⟶ Coq}.
Context (x : F 1).

Definition refined (A : Type) :=
  { y : F A | void y = x }.

Definition fmap_refined {A B} (f : A -> B) (xss : refined A) : refined B.
destruct xss.
refine (exist _ (fmap f x0) _).
replace (@void Coq _ F _ (@fmap Coq Coq F A B f x0)) with ((void ∘ fmap f) x0) by reflexivity.
rewrite (@void_fmap Coq _ F _ _ f).
exact e.
Defined.

End FunctorRefinedDef.

Section FunctorRefined.
Context `{F : Coq ⟶ Coq}.
Context `(x : F 1).
Context `{F1_dec : EqDec (F 1)}.

(* Requires F1_dec *)
Lemma eq_refined {A} (xs ys : refined x A) (pf : proj1_sig xs = proj1_sig ys) : xs = ys.
destruct xs, ys.
unfold proj1_sig in pf.

refine (eq_sig (exist (λ y : F A, void y = x) x0 e) (exist (λ y : F A, void y = x) x1 e0) pf _).
simpl.
refine (UIP_dec F1_dec _ _).
Defined.

Lemma refined_EqDec {A} {FA_dec : EqDec (F A)} : EqDec (refined x A).
proper.
pose (H := eq_refined x0 y).
destruct x0, y.
simpl in H.
destruct (FA_dec x0 x1).

refine (Specif.left _).
exact (H e1).

refine (Specif.right _).
intro.
congruence.
Qed.

Polymorphic Program Instance refined_Functor : Coq ⟶ Coq := {|
  fmap {f g} := fmap_refined x
|}.
Next Obligation.
proper.
destruct x2.
unfold fmap_refined.
simpl.
refine (eq_refined _ _ _).
simpl.
rewrite (@fmap_respects _ Coq F x0 y x1 y0 H x2).
reflexivity.
Defined.

Next Obligation.
unfold fmap_refined.
simpl.
destruct x1.
refine (eq_refined _ _ _).
simpl.
rewrite (@fmap_id _ _ F).
reflexivity.
Defined.

Next Obligation.
unfold fmap_refined.
destruct x1.
simpl.
refine (eq_refined _ _ _).
simpl.
replace (fmap[F] (λ x2 : x0, f (g x2)) x1) with (fmap[F] (f ∘ g) x1) by reflexivity.
rewrite (@fmap_comp _ _ F).
reflexivity.
Defined.

End FunctorRefined.


Require Import Category.Lib.
Require Import Category.Theory.Category.
Require Import Category.Theory.Functor.
Require Import Category.Theory.Natural.Transformation.
Require Import Category.Construction.Opposite.
Require Import Category.Construction.Product.
Require Import Category.Instance.Fun.

Generalizable All Variables.

Section Closed.

Context {C : Category}.
Context {D : Category}.
Context {E : Category}.

#[local] Set Transparent Obligations.

Program Definition Curry (F : C^op ∏ D ⟶ E) : C^op ⟶ [D, E] := {|
  fobj := fun x => {|
    fobj := fun y => F (x, y);
    fmap := fun y z (f : y ~{D}~> z) => fmap[F] (id[x], f)
  |};
  fmap := fun x y (f : x ~{C^op}~> y) => {|
    transform := fun z => fmap[F] (f, id[z])
  |}
|}.
Next Obligation. now proper; simpl_eq; rewrite X. Qed.
Next Obligation. now rewrite <- fmap_comp; simpl; cat. Qed.
Next Obligation. now rewrite <- !fmap_comp; simpl; cat. Qed.
Next Obligation. now rewrite <- !fmap_comp; simpl; cat. Qed.
Next Obligation. now proper; rewrite X. Qed.
Next Obligation. now rewrite <- !fmap_comp; simpl; cat. Qed.

Program Definition Flip (F : C^op ∏ D ⟶ E) : D ∏ C^op ⟶ E := {|
  fobj := fun x => F (snd x, fst x);
  fmap := fun _ _ f => fmap[F] (snd f, fst f)
|}.
Next Obligation. now proper; simpl_eq; simpl in *; rewrite X, H. Qed.
Next Obligation. now rewrite <- fmap_comp. Qed.

Reserved Notation "[ X , Y ]"
  (at level 90, right associativity, format "[ X ,  Y ]").

(* jww (2018-10-05): TODO

Class Closed := {
  internal_hom_functor : C^op ∏ C ⟶ C
    where "[ X , Y ]" := (@internal_hom_functor (X, Y));
  unit_object : C;

  (* hom_id_iso  : Id[C] ≅[Fun] Curry internal_hom_functor unit_object; *)
  hom_id_iso {x} : x ≅ [unit_object, x];

  hom_id {x} : unit_object ~> [x, x];
  hom_compose {x y z} : [y, z] ~> [[x, y], [x, z]];

  hom_id_right {x y} :
    @hom_compose x y y ∘ hom_id << unit_object ~~> [[x, y], [x, y]] >> hom_id;

  hom_ {x y} :
    _ ∘ @hom_compose x x y
      << [x, y] ~~> [unit_object, [x, y]] >>
    to (hom_id_iso ([x, y]))
}.

Notation "[ X , Y ]" := (internal_hom_functor (X, Y))
  (at level 90, right associativity, format "[ X ,  Y ]") : object_scope.

Notation "[ X , ─ ]" := (Curry internal_hom_functor X)
  (at level 90, right associativity, format "[ X ,  ─ ]") : object_scope.

Notation "[ ─ , X ]" := (Curry (Flip internal_hom_functor) X)
  (at level 90, right associativity, format "[ ─ ,  X ]") : object_scope.

*)

End Closed.


Require Export prosa.util.all.
Require Export prosa.behavior.all.

(** * Job-Level Preemption Model *)
(** There are many equivalent ways to represent at which points in time a job
    is preemptable, i.e., where it can be forced to relinquish the processor on
    which it is executing. In Prosa, the various preemption models are
    represented with a single predicate [job_preemptable] that indicates, for
    given a job and a given degree of progress, whether the job is preemptable
    at its current point of execution. *)
Class JobPreemptable (Job : JobType) :=
  job_preemptable : Job -> work -> bool.

(** * Maximum and Last Non-preemptive Segment of a Job *)
(** In the following section we define the notions of the maximal and the last
    non-preemptive segments. *)
Section MaxAndLastNonpreemptiveSegment.

  (**  Consider any type of jobs with arrival times and execution costs... *)
  Context {Job : JobType}.
  Context `{JobArrival Job}.
  Context `{JobCost Job}.

  (** ... and consider any given preemption model. *)
  Context `{JobPreemptable Job}.

  (** It is useful to define a representation of the preemption points of a job
      as an actual sequence of points where this job can be preempted. To this
      end, we define [job_preemption_points j] as the sequence of all progress
      values at which job [j] is preemptable, according to
      [job_preemptable]. *)
  Definition job_preemption_points (j : Job) : seq work :=
    [seq ρ : work <- range 0 (job_cost j) | job_preemptable j ρ].

  (** We observe that the conversion indeed is an equivalent way of
      representing the set of preemption points. *)
  Remark conversion_preserves_equivalence:
    forall (j : Job) (ρ : work),
      ρ <= job_cost j ->
      job_preemptable j ρ <-> ρ \in job_preemption_points j.
  Proof.
    intros ? ? LE.
    case: (posnP (job_cost j)) => [ZERO|POS].
    { unfold job_preemption_points.
      split; intros PP.
      - move: LE; rewrite ZERO leqn0; move => /eqP EQ; subst.
        by simpl; rewrite PP.
      - rewrite ZERO in PP; simpl in PP.
        destruct (job_preemptable j 0) eqn:EQ; last by done.
        by move: PP => /orP [/eqP A1| FF]; subst.
    }
    have F: job_cost j == 0 = false.
    { by apply/eqP/neqP; rewrite -lt0n. }
    split; intros PP.
    all: unfold job_preemption_points in *.
    - rewrite mem_filter; apply/andP; split; first by done.
      by rewrite mem_iota subn0 add0n //; apply/andP; split.
    - by move: PP; rewrite mem_filter; move => /andP [PP _].
  Qed.

  (** We further define a function that, for a given job, yields the sequence
      of lengths of its nonpreemptive segments. *)
  Definition lengths_of_segments (j : Job) := distances (job_preemption_points j).

  (** Next, we define a function that determines the length of a job's longest
      nonpreemptive segment (or zero if the job is fully preemptive). *)
  Definition job_max_nonpreemptive_segment (j : Job) := max0 (lengths_of_segments j).

  (** Similarly, we define a function that yields the length of a job's last
      nonpreemptive segment (or zero if the job is fully preemptive). *)
  Definition job_last_nonpreemptive_segment (j : Job) := last0 (lengths_of_segments j).

  (** * Run-to-Completion Threshold of a Job *)

  (** Finally, we define the notion of a job's run-to-completion threshold: the
      run-to-completion threshold is the amount of service after which a job
      cannot be preempted until its completion. *)
  Definition job_run_to_completion_threshold (j : Job) :=
    job_cost j - (job_last_nonpreemptive_segment j - ε).

End MaxAndLastNonpreemptiveSegment.

(** * Model Validity  *)
(** In the following, we define properties that any reasonable job preemption
    model must satisfy. *)
Section PreemptionModel.

  (**  Consider any type of jobs with arrival times and execution costs... *)
  Context {Job : JobType}.
  Context `{JobArrival Job}.
  Context `{JobCost Job}.

  (** ... and any preemption model. *)
  Context `{JobPreemptable Job}.

  (** Consider any kind of processor model, ... *)
  Context {PState : Type}.
  Context `{ProcessorState Job PState}.

  (** ... any job arrival sequence, ... *)
  Variable arr_seq : arrival_sequence Job.

  (** ... and any given schedule. *)
  Variable sched : schedule PState.

  (** In the following, we define the notion of a valid preemption model.  To
      begin with, we require that a job has to be executed at least one time
      instant in order to reach a nonpreemptive segment. In other words, a job
      must start execution to become non-preemptive. *)
  Definition job_cannot_become_nonpreemptive_before_execution (j : Job) :=
    job_preemptable j 0.

  (** And vice versa, a job cannot remain non-preemptive after its completion. *)
  Definition job_cannot_be_nonpreemptive_after_completion (j : Job) :=
    job_preemptable j (job_cost j).

  (** Next, if a job [j] is not preemptable at some time instant [t], then [j]
      must be scheduled at time [t]. *)
  Definition not_preemptive_implies_scheduled (j : Job) :=
    forall t,
      ~~ job_preemptable j (service sched j t) ->
      scheduled_at sched j t.

  (** A job can start its execution only from a preemption point. *)
  Definition execution_starts_with_preemption_point (j : Job) :=
    forall prt,
      ~~ scheduled_at sched j prt ->
      scheduled_at sched j prt.+1 ->
      job_preemptable j (service sched j prt.+1).

  (** We say that a preemption model is a valid preemption model if
       all assumptions given above are satisfied for any job. *)
  Definition valid_preemption_model :=
    forall j,
      arrives_in arr_seq j ->
      job_cannot_become_nonpreemptive_before_execution j
      /\ job_cannot_be_nonpreemptive_after_completion j
      /\ not_preemptive_implies_scheduled j
      /\ execution_starts_with_preemption_point j.

End PreemptionModel.


From Undecidability.FOL Require Import FullSyntax.
From Undecidability.FOL.Arithmetics Require Import Signature Robinson NatModel.

From Undecidability.FOL.Incompleteness Require Import utils fol_utils qdec.
From Undecidability.FOL.Proofmode Require Import Theories ProofMode.

Require Import Lia.
Require Import String.

Open Scope string_scope.

Require Import Setoid.

Require Import Undecidability.Shared.Libs.DLW.Vec.vec.

Require Import String.
Open Scope string_scope.

Section bin_qdec.
  Existing Instance PA_preds_signature.
  Existing Instance PA_funcs_signature.
  Existing Instance interp_nat.

  Section lemmas.
    Context `{pei : peirce}.

    Lemma Q_add_assoc1 x y z t : Qeq ⊢ num t == (x ⊕ y) ⊕ z → num t == x ⊕ (y ⊕ z).
    Proof.
      induction t as [|t IH] in x |-*; fstart; fintros "H".
      - fassert ax_cases as "C"; first ctx.
        fdestruct ("C" x) as "[Hx|[x' Hx']]".
        + frewrite "H". frewrite "Hx".
          frewrite (ax_add_zero y). frewrite (ax_add_zero (y ⊕ z)).
          fapply ax_refl.
        + fexfalso. fapply (ax_zero_succ ((x' ⊕ y) ⊕ z)).
          frewrite <-(ax_add_rec z (x' ⊕ y)).
          frewrite <-(ax_add_rec y x').
          frewrite <-"Hx'". fapply "H".
      - fassert ax_cases as "C"; first ctx.
        fdestruct ("C" x) as "[Hx|[x' Hx']]".
        + frewrite "H". frewrite "Hx".
          frewrite (ax_add_zero y). frewrite (ax_add_zero (y ⊕ z)).
          fapply ax_refl.
        + frewrite "Hx'". frewrite (ax_add_rec (y ⊕ z) x').
          specialize (IH x').
          fapply ax_succ_congr. fapply IH.
          fapply ax_succ_inj.
          frewrite <-(ax_add_rec z (x' ⊕ y)).
          frewrite <-(ax_add_rec y x').
          frewrite <-"Hx'". fapply "H".
    Qed.
    Lemma Q_add_assoc2 x y z t : Qeq ⊢ num t == (x ⊕ y) ⊕ z → num t == y ⊕ (x ⊕ z).
    Proof.
      induction t as [|t IH] in x |-*; fstart; fintros "H".
      - fassert ax_cases as "C"; first ctx.
        fdestruct ("C" x) as "[Hx|[x' Hx']]".
        + frewrite "H". frewrite "Hx".
          frewrite (ax_add_zero y). frewrite (ax_add_zero z).
          fapply ax_refl.
        + fexfalso. fapply (ax_zero_succ ((x' ⊕ y) ⊕ z)).
          frewrite <-(ax_add_rec z (x' ⊕ y)).
          frewrite <-(ax_add_rec y x').
          frewrite <-"Hx'". fapply "H".
      - fassert ax_cases as "C"; first ctx.
        fdestruct ("C" x) as "[Hx|[x' Hx']]".
        + frewrite "H". frewrite "Hx".
          frewrite (ax_add_zero y). frewrite (ax_add_zero z).
          fapply ax_refl.
        + frewrite "Hx'". frewrite (ax_add_rec z x').
          pose proof (add_rec_swap2 t y (x' ⊕ z)). cbn in H.
          fapply ax_sym. fapply H. fapply ax_sym.
          fapply IH.
          fapply ax_succ_inj.
          frewrite <-(ax_add_rec z (x' ⊕ y)).
          frewrite <-(ax_add_rec y x').
          frewrite <-"Hx'". fapply "H".
    Qed.

    Lemma bin_bounded_forall_iff t φ : bounded_t 0 t ->
      Qeq ⊢ (∀∀ ($1 ⊕ $0 ⧀= t) → φ) ↔
            (∀ ($0 ⧀= t) → ∀ ($0 ⧀= t) → ($1 ⊕ $0 ⧀= t) → φ).
    Proof.
      intros Hb. destruct (closed_term_is_num Hb) as [t' Ht'].
      cbn. unfold "↑".
      fstart.
      fassert (t == num t') as "Ht" by fapply Ht'.
      fsplit.
      - fintros "H" x "Hx".
        fintros y "Hy" "Hxy".
        fapply "H". repeat rewrite (bounded_t_0_subst _ Hb). ctx.
      - fintros "H" x y. fintros "[z Hz]".
        fapply "H".
        + fexists (y ⊕ z).
          rewrite !(bounded_t_0_subst _ Hb).
          frewrite "Ht". fapply Q_add_assoc1.
          feapply ax_trans.
          * feapply ax_sym. fapply "Ht".
          * fapply "Hz".
        + fexists (x ⊕ z).
          rewrite !(bounded_t_0_subst _ Hb).
          frewrite Ht'. fapply Q_add_assoc2.
          feapply ax_trans.
          * feapply ax_sym. fapply "Ht".
          * fapply "Hz".
        + fexists z. ctx.
    Qed.
  End lemmas.

  Lemma Qdec_bin_bounded_forall t φ :
    Qdec φ -> Qdec (∀∀ $1 ⊕ $0 ⧀= t`[↑]`[↑] → φ).
  Proof.
    intros Hφ.
    eapply (@Qdec_iff' (∀ ($0 ⧀= t`[↑]) → ∀ ($0 ⧀= t`[↑]`[↑]) → ($1 ⊕ $0 ⧀= t`[↑]`[↑]) → φ)).
    - intros ρ Hb.
      cbn. rewrite !up_term.
      unfold "↑".
      assert (bounded_t 0 t`[ρ]) as Ht.
      { destruct (find_bounded_t t) as [k Hk].
        eapply subst_bounded_max_t; last eassumption. auto. }
      pose proof (@bin_bounded_forall_iff intu t`[ρ] φ Ht).
      pose proof (subst_Weak ρ H) as H'. change (List.map _ _) with Qeq in H'.
      apply frewrite_equiv_switch.
      cbn in H'.
      rewrite !(bounded_t_0_subst _ Ht). rewrite !(bounded_t_0_subst _ Ht) in H'.
      apply H'.
    - do 2 apply Qdec_bounded_forall.
      apply Qdec_impl.
      + apply Qdec_le.
      + assumption.
  Qed.

End bin_qdec.


(* Check that arguments of impredicative types are not considered
   subterms even through commutative cuts on functional arguments
   (example prepared by Bruno) *)

Inductive IMP : Prop :=
  CIMP : (forall A:Prop, A->A) -> IMP
| LIMP : (nat->IMP)->IMP.

Definition i0 := (LIMP (fun _ => CIMP (fun _ x => x))).

Fail Definition Paradox : False :=
 (fix F y o {struct o} : False :=
  match y with
  | tt => fun f =>
     match f 0 with
     | CIMP h => F y (h _ o)
     | _ => F y (f 0)
     end
  end match o with LIMP f => f | _ => fun _ => o end) tt i0.


Require Import Essentials.Notations.
Require Import Essentials.Types.
Require Import Essentials.Facts_Tactics.
Require Import Category.Main.
Require Import Functor.Functor Functor.Functor_Ops
        Functor.Representable.Hom_Func.
Require Import NatTrans.NatTrans NatTrans.Operations
        NatTrans.Func_Cat NatTrans.NatIso.
Require Import Ext_Cons.Prod_Cat.Prod_Cat Ext_Cons.Prod_Cat.Operations
        Ext_Cons.Prod_Cat.Nat_Facts.
Require Import Adjunction.Adjunction.
Require Import KanExt.Local.
Require Import Basic_Cons.Terminal.

Local Open Scope functor_scope.

(** In this module we show uniqueness of local kan extensions by
forming category of cones and showing that the local right kan
extensions are terminal objects of those categories.
 *)
Section Facts.
  Context {C C' : Category} (p : C –≻ C')
          {D : Category} (F : C –≻ D).

  Section LoKan_Cone_Morph_eq_simplify.
    Context {Cn Cn' : LoKan_Cone p F} (M M' : LoKan_Cone_Morph Cn Cn').

    (** Two local kan extension cone morphisms are equal if their underlying
natural transformations are. *)
    Theorem LoKan_Cone_Morph_eq_simplify : M = M' :> (_ –≻ _)%nattrans → M = M'.
    Proof.
      intros H.
      destruct M; destruct M'; cbn in *.
      ElimEq.
      PIR.
      trivial.
    Qed.

  End LoKan_Cone_Morph_eq_simplify.

  Section LoKan_id_Cone_Morph.
    Context (Cn : LoKan_Cone p F).

    Local Hint Extern 1 => apply NatTrans_eq_simplify; cbn.

    (** The identity cone morph. *)
    Program Definition LoKan_id_Cone_Morph : LoKan_Cone_Morph Cn Cn :=
      {|
        cone_morph := NatTrans_id _
      |}.

  End LoKan_id_Cone_Morph.

  Section LoKan_Cone_Morph_compose.
    Context {Cn Cn' Cn'' : LoKan_Cone p F}
            (h : LoKan_Cone_Morph Cn Cn')
            (h' : LoKan_Cone_Morph Cn' Cn'').

    (** Composition of cone morphs. *)
    Program Definition LoKan_Cone_Morph_compose : LoKan_Cone_Morph Cn Cn'' :=
      {|
        cone_morph := NatTrans_compose h h'
      |}.

    Next Obligation.
    Proof.
      rewrite (cone_morph_com h).
      rewrite (cone_morph_com h').
      rewrite NatTrans_compose_assoc.
      rewrite NatTrans_comp_hor_comp.
      rewrite NatTrans_id_unit_right.
      trivial.
    Qed.

  End LoKan_Cone_Morph_compose.

  Section LoKan_Cone_Morph_compose_assoc.
    Context {Cn Cn' Cn'' Cn''' : LoKan_Cone p F}
            (h : LoKan_Cone_Morph Cn Cn')
            (h' : LoKan_Cone_Morph Cn' Cn'')
            (h'' : LoKan_Cone_Morph Cn'' Cn''').

    (** Composition of cone morphs is associative. *)
    Theorem LoKan_Cone_Morph_compose_assoc :
      LoKan_Cone_Morph_compose h (LoKan_Cone_Morph_compose h' h'') =
      LoKan_Cone_Morph_compose (LoKan_Cone_Morph_compose h h') h''.
    Proof.
      apply LoKan_Cone_Morph_eq_simplify.
      apply NatTrans_compose_assoc.
    Qed.

  End LoKan_Cone_Morph_compose_assoc.

  (** id_unit_left and id_unit_right for cone morphs *)
  Section LoKan_id_Cone_Morph_unit.
    Context {Cn Cn' : LoKan_Cone p F} (h : LoKan_Cone_Morph Cn Cn').

    Theorem LoKan_id_Cone_Morph_unit_right :
      LoKan_Cone_Morph_compose (LoKan_id_Cone_Morph _) h = h.
    Proof.
      apply LoKan_Cone_Morph_eq_simplify.
      apply NatTrans_id_unit_right.
    Qed.

    Theorem LoKan_id_Cone_Morph_unit_left :
      LoKan_Cone_Morph_compose h (LoKan_id_Cone_Morph _) = h.
    Proof.
      apply LoKan_Cone_Morph_eq_simplify.
      apply NatTrans_id_unit_left.
    Qed.

  End LoKan_id_Cone_Morph_unit.

  (** Local kan extension cones form a category. *)
  Definition LoKan_Cone_Cat : Category :=
    {|
      Obj := LoKan_Cone p F;
      Hom := LoKan_Cone_Morph;
      compose :=
        fun _ _ _ h h' =>
          LoKan_Cone_Morph_compose h h';
      assoc :=
        fun _ _ _ _ =>
          LoKan_Cone_Morph_compose_assoc;
      assoc_sym :=
        fun _ _ _ _ f g h =>
          eq_sym (LoKan_Cone_Morph_compose_assoc f g h);
      id := LoKan_id_Cone_Morph;
      id_unit_left := @LoKan_id_Cone_Morph_unit_left;
      id_unit_right := @LoKan_id_Cone_Morph_unit_right
    |}.

  (** Local right kan extensions are terminal objects of
the category of cones. *)
  Section Local_Right_KanExt_terminal.
    Context (rke : Local_Right_KanExt p F).

    Program Definition Local_Right_KanExt_terminal : Terminal LoKan_Cone_Cat :=
      {|
        terminal := LRKE rke;
        t_morph := LRKE_morph_ex rke
      |}.

    Next Obligation.
    Proof.
      apply LoKan_Cone_Morph_eq_simplify.
      apply (LRKE_morph_unique rke).
    Qed.

  End Local_Right_KanExt_terminal.

  (** Local right kan extensions are unique – because they are
terminal objects in the category of cones. *)
  Section Local_Right_KanExt_unique.
    Context (rke rke' : Local_Right_KanExt p F).

    Theorem Local_Right_KanExt_unique :
      ((LRKE rke) ≃≃ (LRKE rke') ::> LoKan_Cone_Cat)%isomorphism.
    Proof (
        Terminal_iso
          (Local_Right_KanExt_terminal rke)
          (Local_Right_KanExt_terminal rke')
      ).

  End Local_Right_KanExt_unique.

  (** If cones are isomorphic, then also are objects of their their images. *)
  Section LoKan_Cone_Iso_object_Iso.
    Context {Cn Cn' : LoKan_Cone p F}
            (N : (Cn ≃≃ Cn' ::> LoKan_Cone_Cat)%isomorphism).

    Program Definition LoKan_Cone_Iso_object_Iso (c : C') :
      (Cn _o c ≃ Cn' _o c)%isomorphism :=
      {|
        iso_morphism := Trans (iso_morphism N) c;
        inverse_morphism := Trans (inverse_morphism N) c
      |}.

    Next Obligation.
    Proof.
      change (Trans (inverse_morphism N) c ∘ Trans (iso_morphism N) c)%morphism
      with (Trans ((inverse_morphism N) ∘ (iso_morphism N))%nattrans c).
      cbn_rewrite (f_equal (cone_morph) (left_inverse N)); trivial.
    Qed.

    Next Obligation.
    Proof.
      change (Trans (iso_morphism N) c ∘ Trans (inverse_morphism N) c)%morphism
      with (Trans ((iso_morphism N) ∘ (inverse_morphism N))%nattrans c).
      cbn_rewrite (f_equal (cone_morph) (right_inverse N)); trivial.
    Qed.

  End LoKan_Cone_Iso_object_Iso.

End Facts.


(** * Synthesis.CSE: Common sub-expression elimination  *)
Require Import Common DList Core Eqdep RTL.

(** This file implements one pass of common sub-expression elimination. *)

Definition type_cast {P : type -> Type} {t} t' (x : P t) : option (P t') :=
  (if type_eqb t t' as b return (type_eqb t t' = b -> option (P t'))
   then
     fun H : type_eqb t t' = true =>
       (fun Heq : t = t' =>
          match Heq in (_ = t) return option (P t) with
            | eq_refl => Some x
          end) (type_eqb_correct t t' H)
   else fun _ => None) eq_refl.

Lemma type_cast_inversion t t' (x:eval_type t') (y: eval_type t) : type_cast t x = Some y ->
                                                                   t = t'.
Proof.
  unfold type_cast.

  generalize (type_eqb_correct t' t). simpl. pattern (type_eqb t' t).
  destruct (type_eqb t' t); try discriminate.
  intros e.
  pose proof (e eq_refl). subst. reflexivity.
Qed.

Section s.
  Variable Phi : state.
  Variable st : eval_state Phi.

  Section t.
  (** The data-type of symbolic values: that is, values that are going
  to be compared and elimated in case of redundancy. *)

  Inductive sval : type -> Type :=
  | SVar: forall t, nat -> sval t
  | SRead : forall t, Common.var Phi (Treg t) -> sval t
  | SConstant : forall t, constant t -> sval t
  | SMux : forall t, sval Tbool -> sval t -> sval t -> sval t
  | STuple : forall l, DList.T sval l ->  sval (Ttuple l)
  | Sandb : sval B -> sval B -> sval B
  | Sorb : sval B -> sval B -> sval B
  | Sxorb : sval B -> sval B -> sval B
  | Snegb : sval B -> sval B
  | Seq : forall t : type, sval t -> sval t -> sval B
  | Slt : forall n : nat, sval (Int n) -> sval (Int n) -> sval B
  | Sle : forall n : nat, sval (Int n) -> sval (Int n) -> sval B
  | Sadd : forall n : nat, sval (Int n) -> sval (Int n) -> sval (Int n)
  | Ssub : forall n : nat, sval (Int n) -> sval (Int n) -> sval (Int n)
  | Slow : forall n m : nat, sval (Int (n + m)) -> sval (Int n)
  | Shigh : forall n m : nat, sval (Int (n + m)) -> sval (Int m)
  | ScombineLH : forall n m : nat,
                 sval (Int n) -> sval (Int m) -> sval (Int (n + m)).

  Arguments STuple {l}%list _%dlist.

  Section eval.
    Variable env: list ({t : type & eval_type t}).
    (** [eval_sval env sv] computes the denotation of [sv] in the environment [env] *)
    Fixpoint eval_sval {t} ( sv : sval t)   : option (eval_type t) :=
      let fold :=
          (fix fold l dl  : option (eval_type (Ttuple l)):=
           match dl in DList.T _ l return option (eval_type (Ttuple l)) with
                                        | [ :: ] => Some tt
                                        | t::q =>
                                            do t <- eval_sval t;
                                            do q <- fold _ q;
                                            Some (t,q)
           end%dlist)
      in
        match sv with
          | SVar t n =>
              do tx <- List.nth_error (env) n;
              match tx with
                  existT t' x =>
                    type_cast t x
              end
          | SRead t v => Some (DList.get v st)
          | SConstant t x => Some x
          | SMux t c l r  =>
              do c <- eval_sval  c;
              do l <- eval_sval  l;
              do r <- eval_sval  r;
              Some (if c then l else r)
          | STuple l x =>  fold _ x
          | Sandb a b => do a <- eval_sval a;
                        do b <- eval_sval b;
                        Some (andb a b)
          | Sorb a b => do a <- eval_sval a;
                       do b <- eval_sval b;
                       Some (orb a b)
          | Sxorb a b => do a <- eval_sval a;
                        do b <- eval_sval b;
                        Some (xorb a b)
          | Snegb a => do a <- eval_sval a;
                      Some (negb a)
          | Seq t a b => do a <- eval_sval a;
                        do b <- eval_sval b;
                        Some (type_eq t a b)
          | Slt n a b => do a <- eval_sval a;
                        do b <- eval_sval b;
                        Some (@Word.lt n a b)
          | Sle n a b => do a <- eval_sval a; do b <- eval_sval b; Some (@Word.le n a b)
          | Sadd n a b => do a <- eval_sval a;
                         do b <- eval_sval b;
                         Some (@Word.add n a b)
          | Ssub n a b => do a <- eval_sval a;
                         do b <- eval_sval b;
                         Some (@Word.sub n a b)
          | Slow n m a => do a <- eval_sval a;
                         Some (@Word.low n m a)
          | Shigh n m a => do a <- eval_sval a;
                          Some (Word.high n m a)
          | ScombineLH n m a b => do a <- eval_sval a;
                                 do b <- eval_sval b;
                                 Some (@Word.combineLH n m a b)
        end.
  End eval.

  Definition fstT (t : type) :=
    option (sval (match t with | Ttuple (a :: _) => a| _ => t end)).

  Definition sndT (t : type) :=
    option (sval (match t with | Ttuple (_ :: q) => Ttuple q | _ => t end)).

  Definition nthT (t' : type) t : Type :=
    match t' with | Ttuple l => Common.var l t| _ => (unit : Type)end ->
    option (sval (match t' with | Ttuple l => t | _ => t' end)).

  Variable Var : Core.type -> Type.

  Notation V := (fun t => Var t * sval t)%type.

  Notation "!!" := (None).
  Reserved Notation "x == y" (at level 30).

  (** The crux of this optimisation pass is the definition of the
  equivalence relation on symbolic values. Here we took a conservative
  approach, and perform CSE based on the head constructor.

  Yet, we could go one step further and, for instance, identify x and
  x[|x|;0] (that is, accessing to a subrange of x that is equal to x
  itself.) *)

  Fixpoint sval_eqb {a b} (va: sval a) (vb : sval b) : bool :=
    let fix pointwise  {la lb} (dla : DList.T sval la) (dlb : DList.T sval lb) : bool :=
        match dla, dlb with
          | [ :: ] , [ :: ] => true
          | t::q , t' :: q' => (sval_eqb t t' && pointwise q q')%bool
          | _, _ => false
        end%dlist in

      match va, vb with
        | SRead ta va, SRead tb vb => var_eqb va vb
        | SVar ta na, SVar tb nb  => type_eqb ta tb && NPeano.Nat.eqb na nb
        | SConstant ta ca, SConstant tb cb =>
            match type_cast tb ca with | Some ca =>  type_eq tb ca cb | None => false end
        | SMux ta ca la ra, SMux tb cb lb rb =>
            type_eqb ta tb && (ca == cb && la == lb && ra == rb)
        | STuple la dla, STuple lb dlb => pointwise dla dlb
        | Sandb a1 b1, Sandb a2 b2 => a1 ==  a2 && b1 == b2
        | Sorb  a1 b1, Sorb a2 b2 => a1 ==  a2 && b1 == b2
        | Sxorb a1 b1, Sxorb a2 b2 => a1 ==  a2 && b1 == b2
        | Snegb a1 , Snegb a2 => a1 ==  a2
        | Seq t1 a1 b1, Seq t2 a2 b2 =>
            type_eqb t1 t2 && (a1 == a2 && b1 == b2)
        | Slt n1 a1 b1, Slt n2 a2 b2 =>
          NPeano.Nat.eqb n1 n2 && (a1 == a2 && b1 == b2)
        | Sle n1 a1 b1, Sle n2 a2 b2 =>
          NPeano.Nat.eqb n1 n2 && (a1 == a2 && b1 == b2)
        | Sadd n1 a1 b1, Sadd n2 a2 b2 =>
          NPeano.Nat.eqb n1 n2 && (a1 == a2 && b1 == b2)
        | Ssub n1 a1 b1, Ssub n2 a2 b2 =>
          NPeano.Nat.eqb n1 n2 && (a1 == a2 && b1 == b2)
        | Slow n1 m1 a1, Slow n2 m2 a2 =>
          NPeano.Nat.eqb n1 n2 &&  NPeano.Nat.eqb m1 m2 && (a1 == a2)
        | Shigh n1 m1 a1, Shigh n2 m2 a2 =>
          NPeano.Nat.eqb n1 n2 &&  NPeano.Nat.eqb m1 m2 && (a1 == a2)
        | ScombineLH n1 m1 a1 b1, ScombineLH n2 m2 a2 b2 =>
          NPeano.Nat.eqb n1 n2 &&  NPeano.Nat.eqb m1 m2 && (a1 == a2) && b1 == b2

        (** We may check for more equivalences here, like [Slow 0 n x == x],
         but we refrain to do so for now, because it complicates the sval_eqb a lot *)

        | _, _ => false
      end%bool where "n == m" := (sval_eqb n m).

  (** The actual implementation of cse on expressions. Recall that
  expressions are in a 3-adress code like representation (that is, all
  intermediate expressions have been flattened).

  We start with expressions where variables are a pair of Var (an
  abstract representation of variables) and a symbolic value (of type
  [sval]). Each such expression is split into two parts: a regular
  expression (with variables in Var), and potentially a symbolic
  values (for values that can be represented).  *)

  Definition cse_expr t (e : expr Phi V t) : expr Phi Var t * option (sval t).
  refine (
      match e in expr _ _ t return expr Phi Var t * option (sval t) with
        | Einput t v => (Einput _ _ _ v, !!)
        | Eread t v => (Eread v, Some (SRead t v))
        | Evar t v => (Evar (fst v), Some (snd v))
        | Eread_rf n t v adr => (Eread_rf v (fst adr), !! )
        | Eandb a b => (Eandb _ _ (fst a) (fst b), Some (Sandb (snd a) (snd b)))
        | Eorb a b => (Eorb _ _ (fst a) (fst b), Some (Sorb (snd a) (snd b)))
        | Exorb a b => (Exorb _ _ (fst a) (fst b), Some (Sxorb (snd a) (snd b)))
        | Enegb a  => (Enegb _ _ (fst a),  Some (Snegb (snd a)))
        | Eeq t a b => (Eeq _ _ t (fst a) (fst b), Some (Seq t (snd a) (snd b)))
        | Elt n a b => (Elt _ _ n (fst a) (fst b), Some (Slt n (snd a) (snd b)))
        | Ele n a b => (Ele _ _ n (fst a) (fst b), Some (Sle n (snd a) (snd b)))
        | Eadd n a b => (Eadd _ _ n (fst a) (fst b), Some (Sadd n (snd a) (snd b)))
        | Esub n a b => (Esub _ _ n (fst a) (fst b), Some (Ssub n (snd a) (snd b)))
        | Elow n m a => (Elow _ _ n m (fst a), Some (Slow n m (snd a)))
        | Ehigh n m a => (Ehigh _ _ n m (fst a), Some (Shigh n m (snd a)))
        | EcombineLH n m a b => (EcombineLH _ _ n m (fst a) (fst b), Some (ScombineLH n m (snd a) (snd b)))
        | Econstant ty c =>  (Econstant c, Some (SConstant _ c))
        | Emux t c l r =>
            if sval_eqb (snd l) (snd r)
            then
              (Evar (fst l), Some (snd l))
            else
              (
                Emux (fst c) (fst l) (fst r),
                Some (SMux _ (snd c) (snd l) (snd r) )
              )
        | Efst l t x => (Efst (fst x),
                        match snd x in sval t' return fstT t' with
                          | @STuple (_ :: _) dl => Some  (DList.hd  dl)
                          | _ => !!
                        end)
        | Esnd l t x => (Esnd  (fst x),
                        match snd x in sval t' return sndT t' with
                          | @STuple (t::q) dl => Some  (@STuple q (DList.tl  dl))
                          | _ => !!
                        end)
        | Enth l t m x => (Enth  m (fst x),
                          match snd x in sval t' return nthT  t' t
                          with
                            | @STuple l dl => fun m => Some (DList.get  m dl)
                            | _ => fun _ => !!
                          end m)
        | Etuple l exprs => let x := DList.map (fun x dx => fst dx) exprs in
                            let y := DList.map (fun x dx => snd dx) exprs in
                             (Etuple  x, Some (STuple  y))
      end).

  Defined.

  Definition Env : Type := list ({t : type & ((sval t * Var t) : Type )%type}).

  Definition empty : Env := ([])%list.

  Fixpoint lookup (t : type) (sv: sval t) (E : Env) : option (Var t) :=
    match E with
      | [] => None
      | existT  t' (sv',x)::q =>
          (if type_eqb t' t as b
              return type_eqb t' t = b -> option (Var t)
           then
             (fun H : type_eqb t' t = true  =>
                let H := type_eqb_correct t' t H in
                  if sval_eqb sv sv'
                  then Some (eq_rect t' Var x t H)
                  else lookup _ sv q
             )
              else
            fun _ => lookup t sv q) eq_refl
    end%list.

  Definition add (t : type) (sv : sval t) (v : Var t) (env : Env) : Env :=
    ( env ++ [existT _ t (sv,v)])%list .

  (* Unfortunately, multiple reads from the same state elements cannot be shared *)
  Definition cse_telescope {A} (E: Env) (T : telescope Phi V A) : telescope Phi Var A.
  refine (let fix cse F T :=
              match T with
                | & x => & x
                | telescope_bind arg b cont =>
                    let (e,svo) := cse_expr arg b in
                      match svo with
                        | None => k :- e;
                            let sv := (SVar arg (List.length F)) in
                            let F := add arg sv k F in
                              cse F (cont (k,sv))
                        | Some sv =>
                            match lookup arg sv F with
                              | None =>
                                  k :-  e;
                                  let F := add arg  sv k F in
                                    cse F (cont (k,sv))
                              | Some old => cse F (cont (old, sv))
                            end
                      end
              end in cse E T).
  Defined.

  Definition cse_effect := (fun (a : mem) (x : (option ∘ effect V) a) =>
            match x with
              | Some x0 =>
                  match x0 in (effect _ s) return ((option ∘ effect Var) s) with
                    | effect_reg_write t x1 x2 =>
                        Some (effect_reg_write Var t (fst x1) (fst x2))
                    | effect_regfile_write n t x1 x2 x3 =>
                        Some (effect_regfile_write Var n t (fst x1) (fst x2) (fst x3))
                  end
              | None => !!
            end).
  Definition cse_effects (eff: effects Phi V) : effects Phi Var :=
    DList.map cse_effect eff.

  Definition cse_block  t (b : block Phi V t) : block Phi Var t :=
    k :-- cse_telescope empty b;
    match k with (v,g,e) =>
                   & (fst v, fst g, cse_effects  e)
    end.
End t.

Notation V := (fun t => (eval_type t * sval  t))%type.

(* Ltac d := *)
(*   match goal with *)
(*    H : context [do _ <- ?x; _] |- _ => *)
(*      let A := fresh in *)
(*      case_eq x; [intros ?X A | intros A]; rewrite A in H; simpl in H *)
(*   | |- context [do _ <- ?x; _] => *)
(*      case_eq x; intros; simpl *)
(*   end. *)

Ltac f :=
  match goal with
      |- context [fst ( _ , _ )] => simpl
    | |- context [fst ?x] => destruct x; simpl
    | |- context [Tuple.fst ( _ , _ )] => simpl
    | |- context [Tuple.fst ?x] => destruct x; simpl
    | |- context [snd ( _ , _ )] => simpl
    | |- context [snd ?x] => destruct x; simpl
    | |- context [Tuple.snd ( _ , _ )] => simpl
    | |- context [Tuple.snd ?x] => destruct x; simpl
  end;
  try (congruence || discriminate).
Notation "G |= x -- y" := (In _ _ _ x y G) (no associativity, at level 71).

Notation R := (fun G t x y => In _ _ t x y G).

Definition lift (env : Env eval_type) : list ({t : type & eval_type t}) :=
  List.map (fun x => match x with  existT t (sv,v) => existT _ t v end) env.

Require Seq.
Class Gamma_inv (G : Gamma eval_type V) (E : Env eval_type) :=
  {
    Gamma_inv_1 : forall t (x : eval_type t) y, G |= x -- y -> x = fst y;
    Gamma_inv_2 : forall t (x: eval_type t) y, G |= x -- y -> eval_sval (lift E) (snd y)  = Some x;
    Gamma_inv_3 : forall t x sv, Seq.In (existT _ t (sv , x))  E -> G |= x -- (x,sv)
  }.

Hint Resolve Gamma_inv_1 Gamma_inv_2 Gamma_inv_3.

Lemma Gamma_inv_2' G E (H : Gamma_inv G E) :
  forall t (x: eval_type t) y y', G |= x -- (y,y') -> eval_sval (lift E) y'  = Some x.
Proof.
  intros. change (y') with (snd (y,y')). eauto.
Qed.

Hint Resolve Gamma_inv_2'.

Ltac use :=
  match goal with
    | H : Some _ = None |- _ => discriminate
    | H : None = Some _ |- _ => discriminate
    | H : ?G |= ?x -- ?y |- context [?x] =>
        rewrite (Gamma_inv_1 _ _ _ H)
    | H : ?G |= ?x -- ?y,
      H' : eval_sval _ (snd ?y) = Some ?z |- context [?z] =>
        progress
          (assert (x = z) by (pose proof (Gamma_inv_2 _ _ _ H); congruence);
           subst)
    | H : ?G |= ?x -- ?y,
      H' : eval_sval _ (snd ?y) = None |- context [?z] =>
        pose proof (Gamma_inv_2 _ _ _ H); congruence
    | H : ?G |= ?x -- ?y |- context [eval_sval _ (snd ?y)] =>
        let p := fresh in
          assert ( p := Gamma_inv_2 _ _ _ H);
        simpl in p;
        rewrite p;
        clear p
    | H : Some _ = Some _ |- _ => injection H; intros; subst; clear H
    | H : ?x = ?x |- _ => clear H
  end.

Ltac save :=
  repeat match goal with
           | H : _ |= _ -- _ |- _ =>
             pose proof (Gamma_inv_1 _ _ _ H);
             pose proof (Gamma_inv_2 _ _ _ H);
               clear H
         end.

Arguments Gamma_inv_1  {G E} _ {t x y} _.
Arguments Gamma_inv_2  {G E} _ {t x y} _.
Arguments Gamma_inv_3  {G E} _ {t x sv} _.

Lemma type_cast_eq t (e : eval_type t) : type_cast t e = Some e.
Proof.
  unfold type_cast.
  generalize (type_eqb_correct t t). intros.
  generalize (type_eqb_refl t).
  destruct (type_eqb t t).

  rewrite (UIP_refl _ _ (e0 eq_refl)).
  simpl. reflexivity.
  discriminate.
Qed.

Require Import Equality.
Definition cast {t t'} (p : t = t') (b : sval  t) : sval (t') :=
  match p in (_ = y) return (sval ( y)) with
    | eq_refl => b
  end.

Lemma sval_eqb_correct' t1 t2 (sv : sval t1) (sv' : sval t2) (H : t2 = t1):
  sval_eqb  sv sv' = true -> sv = cast H sv'.
Proof.
  revert t1 t2 sv sv' H.
  fix IH 3.
  Ltac t :=
    (match goal with
         H: (?x && ?y)%bool = true |- _ => (rewrite Bool.andb_true_iff in H; destruct H)
       | H : type_eqb _ _ = true |- _ => apply type_eqb_correct in H
       | H : NPeano.Nat.eqb _ _ = true |- _ => apply NPeano.Nat.eqb_eq in H
       | H : var_eqb ?a ?b = true |- _ => apply var_eqb_correct_2 in H
       | H : ?x = ?y |- _ => (is_var x ; is_var y ; destruct H)
     end).

  destruct sv; destruct sv'; intros H; try discriminate; simpl; intros; repeat t;
  try solve [repeat match goal with
                     | H : sval_eqb ?x ?y = true |- _ => apply (IH _ _ x y eq_refl) in H; simpl in H; destruct H
                   end; clear IH; dependent destruction H; reflexivity].
  - reflexivity.
  - reflexivity.
  - rewrite type_cast_eq in H0.  apply type_eq_correct in H0. destruct H0. reflexivity.
  -
    {
      injection H. intros H'; destruct H'.
      dependent destruction H.
      simpl.
      revert l0 t t0 H0.
      {
        fix IHdl 2.
        intros l t1. destruct t1;  intros; DList.inv.
        reflexivity.
        repeat t.
        specialize (IHdl q t1 x0 H0). clear H0.
        apply IH with (H := eq_refl)in H. clear IH. simpl in H.
        subst. inject IHdl. injectT. reflexivity.
      }
  }
Qed.

Lemma sval_eqb_correct t (sv sv' : sval t) : sval_eqb  sv sv' = true -> sv = sv'.
Proof.
  intros. apply (sval_eqb_correct' t t sv sv' eq_refl H).
Qed.

Lemma cse_expr_correct : forall t e1 r1,
  eval_expr Phi st t e1 = r1 ->
  forall G (env : Env eval_type) e2,
    expr_equiv _ _ Phi (R G) t e1 e2 ->
    Gamma_inv G env
    -> match snd (cse_expr _ t  e2) with
        | Some sv => eval_sval ( lift env) sv  = Some r1
        | None => True
      end.
Proof.
  destruct 1; inversion 1; injectT;  try solve [simpl; auto]; intros; try solve [simpl; repeat use; reflexivity].
  - intros. simpl.
    case_eq (sval_eqb (snd l2) (snd r2)).
    * intros H'. simpl.
      assert (r1 = l1). apply sval_eqb_correct in H'.
      save. congruence.
      subst; destruct c1; save; congruence.
    * intros. simpl. repeat use; simpl. reflexivity.

  - intros.  simpl.
    destruct dl2 as [hd tl].  simpl.
    dependent destruction tl ; try tauto.
    save. subst. simpl in *. DList.inv. simpl_do. auto.
  - intros. repeat use. simpl.
    destruct dl2 as [hd tl].  simpl. dependent destruction tl; try tauto.
    save. subst. simpl in *. DList.inv. simpl_do. auto.
  - intros. simpl.
    destruct dl2 as [hd tl]. simpl.  dependent destruction tl; try tauto.
    clear X.
    save; simpl in *; simpl_do; subst.

    induction v; DList.inv; simpl in *; simpl_do; eauto.
  - simpl. repeat  use.  clear X.
    induction l; DList.inv.
    + reflexivity.
    + simpl in *.
      eapply IHl in p. clear IHl.  repeat use. simpl. rewrite p.  reflexivity.
Qed.

Lemma lem1  env G  t e1 e2 e'  sv :
  expr_equiv eval_type V Phi (RTL.R eval_type V G) t e1 e2 ->
  Gamma_inv G env ->
  cse_expr eval_type t e2 = (e', Some sv) ->
  eval_sval   (lift env) sv = Some (eval_expr Phi st t e1).
Proof.
  intros H H1 H2.
  pose (H' := cse_expr_correct  _ _ (eval_expr Phi st t e1) (refl_equal)).
  specialize (H' G env e2 H H1).
  rewrite H2 in H'.
  apply H'.
Qed.

Lemma lookup_1 env t (sv : sval t) e :
  lookup eval_type t sv (env) = Some e ->
  Seq.In (existT _ t (sv,e)) (env).
Proof.
  intros.
  induction env. discriminate.
  destruct a as [t' [sv' x']]. simpl in H.
  revert H. generalize (type_eqb_correct t' t). destruct (type_eqb t' t).  simpl. intros.
  pose proof (e0 eq_refl). subst.

  case_eq (sval_eqb sv sv'); intros.
  injectT. rewrite H0 in H.  apply sval_eqb_correct in H0. subst. inject H. apply Seq.In_cons.
  rewrite H0 in H. apply Seq.In_skip. auto.
  intros. apply Seq.In_skip.  auto.
Qed.

Lemma lem2  G env t e1 e2 sv :
  Seq.In (existT _ t (sv,e2)) (env) ->
  Gamma_inv G env ->
  eval_sval  (lift env) sv = Some e1 ->
  G |= e1 -- (e2, sv).
Proof.
  intros.

  apply (Gamma_inv_3 X0) in X.
  pose proof (Gamma_inv_2 X0 X).
  simpl in H0.

  assert ( e1 = e2). congruence.
  subst; auto.
Qed.

Lemma lemma_2 env G  t e1 e2 e3 e'  sv :
  expr_equiv eval_type V Phi (RTL.R eval_type V G) t e1 e2 ->
  Gamma_inv G env ->
  cse_expr eval_type t e2 = (e', Some sv) ->
  lookup eval_type t sv (env) = Some e3 ->
  eval_expr Phi st t e1 = e3.
Proof.
  intros.
  assert (eval_sval (lift env) sv = Some (eval_expr Phi st t e1)). eauto using lem1.

  apply lookup_1 in H0.
  apply (Gamma_inv_3  X0) in H0.
  apply (Gamma_inv_2  X0) in H0.
  simpl in *. congruence.
Qed.

Lemma Gamma_inv_cons G env t e sv :
  Gamma_inv G env ->
  eval_sval (lift env) sv  = Some e ->
  Gamma_inv (cons eval_type V t e (e,sv) G) env.
Proof.
  intros. constructor.
  - intros ty x y. inversion 1;injectT. reflexivity. eauto.
  - intros ty x y. inversion 1;injectT. simpl. eauto.  eauto.
  - intros. apply In_skip. eauto.
Qed.

Lemma nth_error_app {A} l :
  forall l' n (x : A), List.nth_error l n = Some x ->
                  List.nth_error (l ++ l') n = Some x.
Proof.
  induction l; destruct n; simpl; intuition.
  discriminate.
  discriminate.
Qed.

Lemma eval_sval_monotone  l l' t (x: eval_type t) :
  forall sv,
    eval_sval l sv  = Some x  ->
    eval_sval (l ++ l')  sv = Some x.
Proof.
  Ltac crush := repeat match goal with
    | H : context [(do _ <- _; _) = _] |- _ => invert_do H
    | |- context [do _ <- ?x ; _ ]  => case_eq x; intros; simpl
    | H : { _ : _ & _} |- _ => destruct H
    | H : List.nth_error ?l ?n = Some ?x,
      H': List.nth_error (?l ++ ?l') ?n = Some ?y |- _ =>
        pose proof (nth_error_app l l' n x H);
        assert (x = y) by congruence;
        clear H H'; subst
    | H : List.nth_error ?l ?n = Some ?x,
      H': List.nth_error (?l ++ ?l') ?n = None |- _ =>
        pose proof (nth_error_app l l' n x H);
        congruence
    | H : ?x = ?y , H' : ?x = ?z |- _ =>
        assert (y = z) by congruence; subst; try rewrite H, H'; clear H H'
    | H : Some ?x = Some ?y |- _ => injection H; clear H; intros; subst
    | |- Some _ = Some _ => f_equal
    | H : eval_sval ?l ?a = Some ?x,
      H' : eval_sval (?l ++ ?l') ?a = Some ?y,
      IH : forall (t : type) (x : eval_type t) (sv : sval t),
             eval_sval ?l sv = Some x -> eval_sval (?l ++ ?l') sv = Some x
             |- _ =>
      assert (x = y) by (pose proof (IH _ _ _ H); congruence); clear H
    | H : eval_sval ?l ?a = Some ?x,
      H' : eval_sval (?l ++ ?l') ?a = None,
      IH : forall (t : type) (x : eval_type t) (sv : sval t),
             eval_sval ?l sv = Some x -> eval_sval (?l ++ ?l') sv = Some x
             |- _ =>
      (pose proof (IH _ _ _ H); congruence)
  end;  auto || (try congruence) .
  revert t x.
  fix IH 3; destruct sv; simpl; try tauto; try (solve [crush]).
  - crush. injectT. auto.
  - intros. simpl_do.
    repeat (erewrite IH by eauto). simpl. reflexivity.
  - revert l0 x t.
    fix IHdl 3; destruct t.
    tauto.
    intros. simpl_do. apply IH in H0. apply IHdl in H. rewrite H0; rewrite H. reflexivity.
Qed.

Lemma nth_error_map {A B} {f : A -> B} l t  :
  List.nth_error (List.map f (l ++ [t])) (List.length l) = Some (f t).
Proof.
  induction l. reflexivity.
  simpl. auto.
Qed.

Lemma Gamma_inv_cons_var G env (Hg : Gamma_inv  G env) t (e : eval_type t):
      Gamma_inv (cons eval_type V t e (e, SVar t (Datatypes.length env)) G)
                (add eval_type t (SVar t (Datatypes.length env)) e env).
Proof.
  intros.
  constructor.
  - intros ty x y. inversion 1;injectT. reflexivity.  use; reflexivity.
  - intros ty x y. inversion 1;injectT. simpl. unfold lift. unfold add. simpl.
    rewrite nth_error_map. simpl.

    apply type_cast_eq.
    apply (Gamma_inv_2 Hg) in X0.
    unfold lift, add in *.

    destruct y as [ y sv].
    rewrite List.map_app.
    revert X0. clear X.
    match goal with |- context [List.map ?f _] => set (F := f) end.
    replace (List.length env) with (List.length (List.map F env)) by apply List.map_length.
    generalize (List.map F env).  intros. simpl.
    clear F. simpl in X0.
    apply eval_sval_monotone ; auto.

  - intros ty x y H. unfold add in H.  apply Seq.In_app in H.
    destruct H. apply In_skip. eauto.
    inversion i. injectT. apply In_ok. congruence. congruence. inversion X.
Qed.

Lemma Gamma_inv_cons_other G env (Hg : Gamma_inv G env) t (e : eval_type t) sv:
  eval_sval (lift env) sv = Some e ->
  Gamma_inv (cons eval_type V t e (e, sv) G)
            (add eval_type t sv e env).
Proof.
  constructor.
  - intros ty x y. inversion 1; subst; injectT; subst. reflexivity.   eauto.
  - intros ty x y. inversion 1; subst; injectT; subst.
    simpl. unfold lift, add. rewrite List.map_app. apply eval_sval_monotone. apply H.
    simpl. unfold lift, add. rewrite List.map_app. apply eval_sval_monotone. eapply Gamma_inv_2; eauto.
  - intros ty x sv' H0.
    unfold add in H0; apply Seq.In_app in H0.
    destruct H0. apply In_skip. eauto.
    apply Seq.In_cons_inversion in i. destruct i. injectT. inject e0. apply In_ok; auto.
    apply Seq.In_nil in i; tauto.
Qed.

Lemma Gamma_inv_empty : Gamma_inv  (nil _ _ ) (empty eval_type).
Proof.
  constructor.
  + intros ty x y H; inversion H.
  + intros ty x y H; inversion H.
  + intros. simpl in X. apply Seq.In_nil in X. tauto.
Qed.

End s.

Notation V := (fun t => (eval_type t * sval _  t))%type.

Lemma cse_effects_correct (Phi : state) st Delta G e  (Hg : Gamma_inv Phi st G e):
  forall e1 e2
  (H : effects_equiv eval_type V Phi (RTL.R eval_type V G) e1 e2),
   eval_effects Phi st e1 Delta =
   eval_effects Phi st (cse_effects Phi eval_type e2) Delta.
Proof.
  intros e1 e2 H.
  apply DList.map3_map.
  unfold effects_equiv in H. eapply DList.pointwise_map; [| apply H].

  clear H;simpl. intros t dt1 dt2 H v1 v2.
  unfold R in *; inversion H; injectT; simpl; clear H; trivial; destruct v2; try reflexivity.
  rewrite (@Gamma_inv_1 _ _ _ _ Hg _ _ _ X);
  rewrite (@Gamma_inv_1 _ _ _ _ Hg _ _ _ X0); trivial.
  rewrite (@Gamma_inv_1 _ _ _ _ Hg _ _ _ X);
  rewrite (@Gamma_inv_1 _ _ _ _ Hg _ _ _ X0);
  rewrite (@Gamma_inv_1 _ _ _ _ Hg _ _ _ X1); trivial.
Qed.

Lemma cse_expr_correct_2 Phi st G env (Hg : Gamma_inv Phi st G env) t:
  forall e1 e2, expr_equiv eval_type V Phi (RTL.R eval_type V G) t e1 e2 ->
           forall svo e, cse_expr Phi eval_type t e2 = (e,svo) ->
                           eval_expr Phi st t e1 = eval_expr Phi st t e.
Proof.
  Ltac crush :=
    repeat (match goal with
      | H: (_,_) = (_,_) |- _ => injection H; clear H; intros; subst
      | Hg : Gamma_inv _ _ _ _ ,  H : In _ _ _ ?x ?y _ |- context [?x] =>
        rewrite (Gamma_inv_1  _ _   _ _ _ H)
      | H : DList.T [] |- _ => DList.inversion
      | H : DList.T (_ :: _) |- _  => DList.inversion
      | H : DList.pointwise _ ( _ :: _) _ _ |- _ => apply DList.inversion_pointwise in H; destruct H
    end); try reflexivity; try f_equal.
  intros e1. destruct e1; intros e2 H; inversion H; injectT; simpl; intros; unfold RTL.R in *; crush.

  - case_eq (sval_eqb _  (snd l2) (snd r2)); intros H'; rewrite H' in H0.
    + apply sval_eqb_correct in H'. crush. simpl.

      Ltac save :=
        repeat match goal with
          | H : In _ _ _ _ _ _ |- _ =>
              pose proof (Gamma_inv_1 _ _ _ _ _ H);
              pose proof (Gamma_inv_2 _ _  _ _ _ H);
              clear H
      end.

      save. destruct H'.  subst. assert (fst l2 = fst r2) by congruence. rewrite H0.
      clear. match goal with |- context [ if ?x then _ else _] => destruct x; reflexivity end.
    + crush.
  - simpl. clear H.
    induction l; DList.inv;simpl; intuition.
    + crush. eauto.
Qed.

Lemma cse_telescope_correct (Phi: state) st t  Delta:
     forall (b : RTL.block Phi eval_type t)
       (b': RTL.block Phi V t)
       (G : Gamma eval_type V),
       block_equiv eval_type V Phi t G b b' ->
       forall e,
       Gamma_inv Phi st G e
     ->
   eval_telescope Phi st
     (fun x : eval_type t * bool * effects Phi eval_type =>
      let (y, e0) := x in
      let (p, g) := y in check g; Some (p, eval_effects Phi st e0 Delta)) b =
   eval_telescope Phi st
     (fun x : eval_type t * bool * effects Phi eval_type =>
      let (y, e0) := x in
      let (p, g) := y in check g; Some (p, eval_effects Phi st e0 Delta))
     (k :-- cse_telescope Phi eval_type e b';
      (let (p, e0) := k in
       let (v, g) := p in & (fst v, fst g, cse_effects Phi eval_type e0))).
Proof.
  induction 1; simpl; intros E INV.
  Ltac crush ::=
    repeat (match goal with
      | H: (_,_) = (_,_) |- _ => injection H; clear H; intros; subst
      | Hg : Gamma_inv _ _ _ _ ,  H : In _ _ _ ?x ?y _ |- context [?x] =>
        rewrite (Gamma_inv_1  _ _  _ _ _ H)
      | H : DList.T [] |- _ => DList.inversion
      | H : DList.T (_ :: _) |- _  => DList.inversion
      | H : DList.pointwise _ ( _ :: _) _ _ |- _ => apply DList.inversion_pointwise in H; destruct H
      | |- Some _ = Some _ => f_equal
      | |- (_,_) = (_,_) => f_equal
      | |- context [eval_type _] => simpl eval_type
    end); try reflexivity.

  - crush.
    match goal with |- context [check ?x; _] => destruct x; [|reflexivity]  end.
    crush. eauto using cse_effects_correct.
  -  case_eq (cse_expr Phi eval_type a e2); intros; simpl.
    + destruct o.
      case_eq (lookup Phi eval_type a s E); intros; simpl; apply H; clear H.
      * assert (H' : eval_expr Phi st a e1 = e3) by eauto using lem1, lemma_2.
        rewrite H'. apply Gamma_inv_cons; auto. subst. eauto using lem1.
      * assert (H' : eval_expr Phi st a e1 = eval_expr Phi st a e0).
        {
          pose proof H0; eapply lem1 in H0; eauto.
          eapply cse_expr_correct_2; eauto. }
        rewrite H'.
        assert (eval_sval Phi st (lift _ E) s  = Some (eval_expr Phi st a e1)) by eauto using lem1.
        apply Gamma_inv_cons_other; eauto.
        congruence.
      * apply H. clear H.
        assert (H' : eval_expr Phi st a e1 = eval_expr Phi st a e0) by
                (eauto using cse_expr_correct_2).
         rewrite H' in *.
         generalize (eval_expr Phi st a e0); intros.
         apply Gamma_inv_cons_var; auto.
Qed.

Theorem cse_correct Phi st t (b : Block Phi t) Delta : WF Phi t b ->
  eval_block Phi st t (b _) Delta = eval_block Phi st t (cse_block Phi eval_type t (b _)) Delta.
Proof.
  intros.
  eapply cse_telescope_correct; eauto using Gamma_inv_empty.
Qed.

Definition Compile Phi t (b : Block Phi t) : Block Phi t :=
  fun V => cse_block Phi V t (b _).

Theorem Compile_correct Phi t b (Hwf : WF Phi t b) st:
  RTL.Next Phi st t (Compile Phi t b) =  RTL.Next Phi st t b.
Proof.
  unfold Next. intros. unfold Compile. symmetry. rewrite cse_correct; auto.
Qed.