Require Import Ynot.

Open Scope hprop_scope.
Open Scope stsepi_scope.

Definition T := ptr.
Definition M := nat.
Definition rep t (m: M) := t --> m.
Definition inc t m : STsep (m ~~ rep t m)
 (fun _:unit => m ~~ rep t (m + 1)).
  intros. refine (
    x <- ! t ;
    {{ t ::= x + 1 }} );
 unfold rep; sep fail auto.
Qed.

Require Import List.
Require Import IO.
Require Import FS.
Require Import Net.

(*
Definition Sent := axiom_UDP_Sent.
Definition Recd := axiom_UDP_Recd.
*)
Export UDP.

Inductive echoes (local: SockAddr) : Trace -> Prop :=
 | NilEchoes : echoes local nil
 | ConsEchoes : forall remote s past, echoes local past ->
    echoes local (Sent local remote s :: Recd local remote s :: past).

Definition echo_iter_t local := forall (tr: [Trace]),
 STsep (tr ~~ traced tr * [echoes local tr])
       (fun _:unit => tr ~~ Exists r :@ Trace,
          traced (r ++ tr) * [echoes local (r ++ tr)]).
(*
Definition recv := axiom_UDP_recv.
Definition send := axiom_UDP_send.
*)

Require Import RSep.

Lemma f : forall T (a b : T) (c: list T), (a :: (b :: c)) = (a :: b :: nil) ++ c.
 sep fail auto.
Qed.

Lemma lm1 : forall local x tr,
 (tr ~~ traced (Sent local (fst x) (snd x) :: Recd local (fst x) (snd x) :: tr) * [echoes local tr]) ==>
  (tr ~~ (Exists r :@ Trace, traced (r ++ tr) * [echoes local (r ++ tr)])).
 sep fail auto.  instantiate (2:= (Sent local a b) :: ((Recd local a b) :: nil)).
 sep fail auto. pose (ConsEchoes local a b x0 H). sep fail auto.
Qed.

Lemma lm : forall local x0 x,
   traced (Sent local (fst x) (snd x) :: Recd local (fst x) (snd x) :: x0) * [echoes local x0] ==>
   (Exists r :@ Trace, traced (r ++ x0) * [echoes local (r ++ x0)]) .
 sep fail auto.  instantiate (2:= (Sent local a b) :: ((Recd local a b) :: nil)).
 sep fail auto. pose (ConsEchoes local a b x0 H). sep fail auto.
Qed.

Definition echo (local: SockAddr) : echo_iter_t local.
  unfold echo_iter_t; intros; refine (
    x <- recv local tr <@> _  ;
    {{ send local (fst x) (snd x)  (tr ~~~ (Recd  local (fst x) (snd x) :: tr)) <@> _ }} );
  rsep fail auto. apply lm.
Qed.


Require Import VUtils.
Require Import List.
Require Import GM.
Require Import ZArith.
Require Import FImplTest.

Import ListNotations.

Open Local Scope nat_scope.
Open Local Scope string_scope.

Require Import Xlator.
Require Import RM.

Definition muXlator (m : tGMState) : tXlator :=
    mkXlator 0 0 0 [] [] [] [] m.

Open Scope Z_scope.
Definition regSet : tRegVals :=
    [0; 0; 0; 0; 0; 0; 0].

Open Local Scope nat_scope.

Definition muRM : tRMState :=
    ((regSet, regSet, regSet), (nil), (nil), 0, (nil), (nil)).

Definition convertGM2RM (gm : tGMState) (rm : tRMState) : tRMState :=
    let
        xlator := translate (muXlator gm)
    in
        RMi.loadMachine xlator.(fCode) xlator.(fCodeTable) rm.

Definition testConversion : tRMState :=
    convertGM2RM testGM muRM.

Open Scope Z_scope.

Eval compute in (runMachine 200 testConversion).

Close Local Scope nat_scope.
Close Local Scope string_scope.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall O E Eprime A B C D X Bprimeprime Bprime Dprime : Universe, ((wd_ C O /\ (wd_ A O /\ (wd_ B O /\ (wd_ D O /\ (wd_ O E /\ (wd_ O Eprime /\ (wd_ E Eprime /\ (wd_ Eprime C /\ (wd_ Bprime O /\ (wd_ X O /\ (wd_ A Dprime /\ (wd_ C Bprime /\ (wd_ E Bprimeprime /\ (wd_ B Bprimeprime /\ (col_ O E A /\ (col_ O E B /\ (col_ O E C /\ (col_ O E D /\ (col_ O E X /\ (col_ O Eprime Bprimeprime /\ (col_ O Eprime Bprime /\ col_ O Eprime Dprime))))))))))))))))))))) -> col_ O D A)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Export euclidean__axioms.
Require Export euclidean__defs.
Require Export euclidean__tactics.
Require Export lemma__Playfairhelper2.
Require Export lemma__betweennotequal.
Require Export lemma__crisscross.
Require Export lemma__inequalitysymmetric.
Require Export lemma__parallelflip.
Require Export logic.
Definition lemma__Playfair : forall A B C D E, (euclidean__defs.Par A B C D) -> ((euclidean__defs.Par A B C E) -> (euclidean__axioms.Col C D E)).
Proof.
intro A.
intro B.
intro C.
intro D.
intro E.
intro H.
intro H0.
assert (* Cut *) (euclidean__axioms.neq A B) as H1.
- assert (exists U V u v X, (euclidean__axioms.neq A B) /\ ((euclidean__axioms.neq C E) /\ ((euclidean__axioms.Col A B U) /\ ((euclidean__axioms.Col A B V) /\ ((euclidean__axioms.neq U V) /\ ((euclidean__axioms.Col C E u) /\ ((euclidean__axioms.Col C E v) /\ ((euclidean__axioms.neq u v) /\ ((~(euclidean__defs.Meet A B C E)) /\ ((euclidean__axioms.BetS U X v) /\ (euclidean__axioms.BetS u X V))))))))))) as H1 by exact H0.
assert (exists U V u v X, (euclidean__axioms.neq A B) /\ ((euclidean__axioms.neq C E) /\ ((euclidean__axioms.Col A B U) /\ ((euclidean__axioms.Col A B V) /\ ((euclidean__axioms.neq U V) /\ ((euclidean__axioms.Col C E u) /\ ((euclidean__axioms.Col C E v) /\ ((euclidean__axioms.neq u v) /\ ((~(euclidean__defs.Meet A B C E)) /\ ((euclidean__axioms.BetS U X v) /\ (euclidean__axioms.BetS u X V))))))))))) as __TmpHyp by exact H1.
destruct __TmpHyp as [x H2].
destruct H2 as [x0 H3].
destruct H3 as [x1 H4].
destruct H4 as [x2 H5].
destruct H5 as [x3 H6].
destruct H6 as [H7 H8].
destruct H8 as [H9 H10].
destruct H10 as [H11 H12].
destruct H12 as [H13 H14].
destruct H14 as [H15 H16].
destruct H16 as [H17 H18].
destruct H18 as [H19 H20].
destruct H20 as [H21 H22].
destruct H22 as [H23 H24].
destruct H24 as [H25 H26].
assert (exists U V u v X, (euclidean__axioms.neq A B) /\ ((euclidean__axioms.neq C D) /\ ((euclidean__axioms.Col A B U) /\ ((euclidean__axioms.Col A B V) /\ ((euclidean__axioms.neq U V) /\ ((euclidean__axioms.Col C D u) /\ ((euclidean__axioms.Col C D v) /\ ((euclidean__axioms.neq u v) /\ ((~(euclidean__defs.Meet A B C D)) /\ ((euclidean__axioms.BetS U X v) /\ (euclidean__axioms.BetS u X V))))))))))) as H27 by exact H.
assert (exists U V u v X, (euclidean__axioms.neq A B) /\ ((euclidean__axioms.neq C D) /\ ((euclidean__axioms.Col A B U) /\ ((euclidean__axioms.Col A B V) /\ ((euclidean__axioms.neq U V) /\ ((euclidean__axioms.Col C D u) /\ ((euclidean__axioms.Col C D v) /\ ((euclidean__axioms.neq u v) /\ ((~(euclidean__defs.Meet A B C D)) /\ ((euclidean__axioms.BetS U X v) /\ (euclidean__axioms.BetS u X V))))))))))) as __TmpHyp0 by exact H27.
destruct __TmpHyp0 as [x4 H28].
destruct H28 as [x5 H29].
destruct H29 as [x6 H30].
destruct H30 as [x7 H31].
destruct H31 as [x8 H32].
destruct H32 as [H33 H34].
destruct H34 as [H35 H36].
destruct H36 as [H37 H38].
destruct H38 as [H39 H40].
destruct H40 as [H41 H42].
destruct H42 as [H43 H44].
destruct H44 as [H45 H46].
destruct H46 as [H47 H48].
destruct H48 as [H49 H50].
destruct H50 as [H51 H52].
exact H33.
- assert (* Cut *) (euclidean__axioms.neq C D) as H2.
-- assert (exists U V u v X, (euclidean__axioms.neq A B) /\ ((euclidean__axioms.neq C E) /\ ((euclidean__axioms.Col A B U) /\ ((euclidean__axioms.Col A B V) /\ ((euclidean__axioms.neq U V) /\ ((euclidean__axioms.Col C E u) /\ ((euclidean__axioms.Col C E v) /\ ((euclidean__axioms.neq u v) /\ ((~(euclidean__defs.Meet A B C E)) /\ ((euclidean__axioms.BetS U X v) /\ (euclidean__axioms.BetS u X V))))))))))) as H2 by exact H0.
assert (exists U V u v X, (euclidean__axioms.neq A B) /\ ((euclidean__axioms.neq C E) /\ ((euclidean__axioms.Col A B U) /\ ((euclidean__axioms.Col A B V) /\ ((euclidean__axioms.neq U V) /\ ((euclidean__axioms.Col C E u) /\ ((euclidean__axioms.Col C E v) /\ ((euclidean__axioms.neq u v) /\ ((~(euclidean__defs.Meet A B C E)) /\ ((euclidean__axioms.BetS U X v) /\ (euclidean__axioms.BetS u X V))))))))))) as __TmpHyp by exact H2.
destruct __TmpHyp as [x H3].
destruct H3 as [x0 H4].
destruct H4 as [x1 H5].
destruct H5 as [x2 H6].
destruct H6 as [x3 H7].
destruct H7 as [H8 H9].
destruct H9 as [H10 H11].
destruct H11 as [H12 H13].
destruct H13 as [H14 H15].
destruct H15 as [H16 H17].
destruct H17 as [H18 H19].
destruct H19 as [H20 H21].
destruct H21 as [H22 H23].
destruct H23 as [H24 H25].
destruct H25 as [H26 H27].
assert (exists U V u v X, (euclidean__axioms.neq A B) /\ ((euclidean__axioms.neq C D) /\ ((euclidean__axioms.Col A B U) /\ ((euclidean__axioms.Col A B V) /\ ((euclidean__axioms.neq U V) /\ ((euclidean__axioms.Col C D u) /\ ((euclidean__axioms.Col C D v) /\ ((euclidean__axioms.neq u v) /\ ((~(euclidean__defs.Meet A B C D)) /\ ((euclidean__axioms.BetS U X v) /\ (euclidean__axioms.BetS u X V))))))))))) as H28 by exact H.
assert (exists U V u v X, (euclidean__axioms.neq A B) /\ ((euclidean__axioms.neq C D) /\ ((euclidean__axioms.Col A B U) /\ ((euclidean__axioms.Col A B V) /\ ((euclidean__axioms.neq U V) /\ ((euclidean__axioms.Col C D u) /\ ((euclidean__axioms.Col C D v) /\ ((euclidean__axioms.neq u v) /\ ((~(euclidean__defs.Meet A B C D)) /\ ((euclidean__axioms.BetS U X v) /\ (euclidean__axioms.BetS u X V))))))))))) as __TmpHyp0 by exact H28.
destruct __TmpHyp0 as [x4 H29].
destruct H29 as [x5 H30].
destruct H30 as [x6 H31].
destruct H31 as [x7 H32].
destruct H32 as [x8 H33].
destruct H33 as [H34 H35].
destruct H35 as [H36 H37].
destruct H37 as [H38 H39].
destruct H39 as [H40 H41].
destruct H41 as [H42 H43].
destruct H43 as [H44 H45].
destruct H45 as [H46 H47].
destruct H47 as [H48 H49].
destruct H49 as [H50 H51].
destruct H51 as [H52 H53].
exact H36.
-- assert (* Cut *) (~(~((euclidean__defs.CR A D B C) \/ (euclidean__defs.CR A C B D)))) as H3.
--- intro H3.
assert (* Cut *) (euclidean__defs.Par A B D C) as H4.
---- assert (* Cut *) ((euclidean__defs.Par B A C D) /\ ((euclidean__defs.Par A B D C) /\ (euclidean__defs.Par B A D C))) as H4.
----- apply (@lemma__parallelflip.lemma__parallelflip A B C D H).
----- destruct H4 as [H5 H6].
destruct H6 as [H7 H8].
exact H7.
---- assert (* Cut *) (euclidean__defs.CR A C D B) as H5.
----- apply (@lemma__crisscross.lemma__crisscross A D B C H4).
------intro H5.
apply (@H3).
-------left.
exact H5.

----- assert (exists p, (euclidean__axioms.BetS A p C) /\ (euclidean__axioms.BetS D p B)) as H6 by exact H5.
destruct H6 as [p H7].
destruct H7 as [H8 H9].
assert (* Cut *) (euclidean__axioms.neq D B) as H10.
------ assert (* Cut *) ((euclidean__axioms.neq p B) /\ ((euclidean__axioms.neq D p) /\ (euclidean__axioms.neq D B))) as H10.
------- apply (@lemma__betweennotequal.lemma__betweennotequal D p B H9).
------- destruct H10 as [H11 H12].
destruct H12 as [H13 H14].
exact H14.
------ assert (* Cut *) (euclidean__axioms.neq B D) as H11.
------- apply (@lemma__inequalitysymmetric.lemma__inequalitysymmetric D B H10).
------- assert (* Cut *) (euclidean__axioms.BetS B p D) as H12.
-------- apply (@euclidean__axioms.axiom__betweennesssymmetry D p B H9).
-------- assert (* Cut *) (euclidean__defs.CR A C B D) as H13.
--------- exists p.
split.
---------- exact H8.
---------- exact H12.
--------- apply (@H3).
----------right.
exact H13.

--- assert (* Cut *) (euclidean__axioms.Col C D E) as H4.
---- assert (* Cut *) ((euclidean__defs.CR A D B C) \/ (euclidean__defs.CR A C B D)) as H4.
----- apply (@euclidean__tactics.NNPP ((euclidean__defs.CR A D B C) \/ (euclidean__defs.CR A C B D))).
------intro H4.
assert (* Cut *) (False) as H5.
------- apply (@H3 H4).
------- assert (* Cut *) ((euclidean__defs.CR A D B C) -> False) as H6.
-------- intro H6.
apply (@H4).
---------left.
exact H6.

-------- assert (* Cut *) ((euclidean__defs.CR A C B D) -> False) as H7.
--------- intro H7.
apply (@H4).
----------right.
exact H7.

--------- contradiction H5.

----- assert ((euclidean__defs.CR A D B C) \/ (euclidean__defs.CR A C B D)) as H5 by exact H4.
assert ((euclidean__defs.CR A D B C) \/ (euclidean__defs.CR A C B D)) as __TmpHyp by exact H5.
destruct __TmpHyp as [H6|H6].
------ assert (* Cut *) (euclidean__axioms.Col C D E) as H7.
------- assert (* Cut *) ((euclidean__defs.CR A D B C) \/ (euclidean__defs.CR A C B D)) as H7.
-------- apply (@euclidean__tactics.NNPP ((euclidean__defs.CR A D B C) \/ (euclidean__defs.CR A C B D)) H3).
-------- apply (@euclidean__tactics.not__nCol__Col C D E).
---------intro H8.
apply (@euclidean__tactics.Col__nCol__False C D E H8).
----------apply (@lemma__Playfairhelper2.lemma__Playfairhelper2 A B C D E H H0 H6).

------- exact H7.
------ assert (exists p, (euclidean__axioms.BetS A p C) /\ (euclidean__axioms.BetS B p D)) as H7 by exact H6.
destruct H7 as [p H8].
destruct H8 as [H9 H10].
assert (* Cut *) (euclidean__defs.CR B D A C) as H11.
------- assert (* Cut *) ((euclidean__defs.CR A D B C) \/ (euclidean__defs.CR A C B D)) as H11.
-------- apply (@euclidean__tactics.NNPP ((euclidean__defs.CR A D B C) \/ (euclidean__defs.CR A C B D)) H3).
-------- exists p.
split.
--------- exact H10.
--------- exact H9.
------- assert (* Cut *) (euclidean__defs.Par B A C D) as H12.
-------- assert (* Cut *) ((euclidean__defs.Par B A C D) /\ ((euclidean__defs.Par A B D C) /\ (euclidean__defs.Par B A D C))) as H12.
--------- apply (@lemma__parallelflip.lemma__parallelflip A B C D H).
--------- destruct H12 as [H13 H14].
destruct H14 as [H15 H16].
exact H13.
-------- assert (* Cut *) (euclidean__defs.Par B A C E) as H13.
--------- assert (* Cut *) ((euclidean__defs.Par B A C E) /\ ((euclidean__defs.Par A B E C) /\ (euclidean__defs.Par B A E C))) as H13.
---------- apply (@lemma__parallelflip.lemma__parallelflip A B C E H0).
---------- destruct H13 as [H14 H15].
destruct H15 as [H16 H17].
exact H14.
--------- assert (* Cut *) (euclidean__axioms.Col C D E) as H14.
---------- assert (* Cut *) ((euclidean__defs.CR A D B C) \/ (euclidean__defs.CR A C B D)) as H14.
----------- apply (@euclidean__tactics.NNPP ((euclidean__defs.CR A D B C) \/ (euclidean__defs.CR A C B D)) H3).
----------- apply (@euclidean__tactics.not__nCol__Col C D E).
------------intro H15.
apply (@euclidean__tactics.Col__nCol__False C D E H15).
-------------apply (@lemma__Playfairhelper2.lemma__Playfairhelper2 B A C D E H12 H13 H11).

---------- exact H14.
---- exact H4.
Qed.


Require Import hmacdrbg.spec_hmac_drbg.
Require Import VST.floyd.functional_base.
(*Require Import FCF.HMAC_DRBG_definitions_only.*)
Require Import hmacdrbg.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 compcert.lib.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. lia.
  symmetry in Heqc. destruct (Z.compare_lt_iff z a); intros. apply H in Heqc. lia.
  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. lia.
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. lia.
Qed.

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

Lemma flatten_bytes_bits: forall m,
      flatten m = bitsToBytes (flatten (map bytesToBits m)).
Proof.
  induction m; simpl; trivial; intros.
  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.
Qed.
Lemma HMAC_DRBG_generate_helper_Z_equation':
  forall (HMAC : list byte -> list byte -> list byte) (key v : list byte) (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)%list.
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. lia.
Qed.
Lemma HMAC_DRBG_generate_helper_Z_equation0:
  forall (HMAC : list byte -> list byte -> list byte) (key v : list byte),
  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. lia.
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. lia.
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 byte instead of Bvector 256*)
Fixpoint Gen_loop_Zlist (k : list byte) (v : list byte) (n : nat)
  : list (list byte) * (list byte) :=
  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_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; lia.
Qed.

Lemma Gen_loop_Zlist_Blist k:
  forall n 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.
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 lia. simpl.
 rewrite HMAC_DRBG_generate_helper_Z_equation.
 assert (0 >=? m - 32 = true). apply Z.geb_le; lia.
 rewrite H; trivial.
Qed.

Lemma E2: Equiv 2.
Proof. unfold Equiv; simpl; intros.
  inv G; simpl.
 rewrite HMAC_DRBG_generate_helper_Z_equation'; try lia. simpl.
 rewrite HMAC_DRBG_generate_helper_Z_equation.
 assert (false = (0 >=? m - 32)) by (apply false_zge'; lia).
 rewrite <- H. simpl.
 rewrite HMAC_DRBG_generate_helper_Z_equation.
 assert ((0 >=? m - 32 - 32)= true) by (apply Z.geb_le; lia).
 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 byte => HMAC256 z k) blocks)))%list.
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'.
  2:{ rewrite Zmult_minus_distr_l in M.
    assert (64 <= 32 * Z.of_nat (S N)).
    { subst. replace 64 with (32*2) by lia. apply Z.mul_le_mono_nonneg_l. lia.
      clear. apply (Nat2Z.inj_le 2). lia. }
    lia.
  }
  simpl.
  apply Gen_loop_Zlist_nestedV' in Heqp.
  destruct Heqp as [aa [bb [G [X L]]]]. subst u l.
  rewrite (IHn _ _ _ _ G); clear IHn.
  2:{  clear - M.
           rewrite Zmult_minus_distr_l in *. rewrite Nat2Z.inj_succ in M. simpl in *.
           lia.
  }
  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. lia. 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)%list 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)%list 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)%list 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 byte * list byte) (n : nat) :
  (list (list byte) * (list byte * list byte)) :=
  match state with (k, v) =>
    match Gen_loop_Zlist k v n with (blocks, v') =>
        let k' := HMAC256 (v' ++ [Byte.zero]) 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_Blist k v n:
  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 byte) ByteBitRelations.Blist bytesToBits bits, bytesToBits v')) by (rewrite <- Q, Heqq; trivial).
  clear Q Heqq; inv W. f_equal. unfold HMAC_Blist.
  rewrite ! bitsToBytes_app, ! bytes_bits_bytes_id; trivial.
  f_equal. unfold zeroes. simpl.
  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; lia.
  + 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; lia.
Qed.
Opaque FunGenerate.

Lemma Generate_Blist_ok RI k v z n (Z: (z<=RI)%Z) l kk vv zz
    (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).
  rewrite Heqg; intros HH; rewrite HH; trivial.
Qed.

Lemma Generate_Bvec_ok' RI (k: list byte) v z n (Z: (z<=RI)%Z) l kk vv zz (N:(0<n)%nat)
    (KL: Datatypes.length (bytesToBits k) = 256%nat) (VL:Datatypes.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).
  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.
  rewrite <- H1, <- H2, ! bytes_bits_bytes_id; trivial.
  repeat split; trivial.
  rewrite <- map_rev. f_equal. apply flatten_bytes_bits.
Qed.

Lemma Generate_Bvec_ok RI k v z n (Z: (z<=RI)%Z) (N:(0<n)%nat)
              (KL: Datatypes.length (bytesToBits k) = 256%nat)
              (VL:Datatypes.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 k v n); 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.
  f_equal.
  - f_equal. rewrite <- map_rev. apply flatten_bytes_bits.
  - 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)
    (KL: Datatypes.length (bytesToBits k) = 256%nat) (VL:Datatypes.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 KL 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)
              (KL: Datatypes.length (bytesToBits k) = 256%nat)
              (VL:Datatypes.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 KL 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 (KL: Datatypes.length (bytesToBits k) = 256%nat) (VL:Datatypes.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 V0 key0 reseed_counter0).
 rewrite Nat2Z.inj_mul. simpl. rewrite HH3.
 clear HH3 M.
 intros ZZ. specialize (ZZ N KL 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)),
   Datatypes.length l = n%nat.
Proof. induction n; destruct state; simpl; intros.
+ inv G. simpl; lia.
+ 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. + lia.
+ rewrite IHl, Blist.to_list_length; clear IHl. lia.
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 (KL: Datatypes.length (bytesToBits k) = 256%nat) (VL:Datatypes.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 KL 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 (Nat.mul_comm 32). rewrite <- Nat.mul_assoc.
 replace (32*8)%nat with 256%nat. trivial. lia.
 rewrite H. lia.
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. lia. 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 byte,  using the above Gallina equalities*)*)


(**************************************************************************)
(*                                                                        *)
(*     Sniper                                                             *)
(*     Copyright (C) 2021                                                 *)
(*                                                                        *)
(*     See file "AUTHORS" for the list of authors                         *)
(*                                                                        *)
(*   This file is distributed under the terms of the CeCILL-C licence     *)
(*                                                                        *)
(**************************************************************************)

Require Import SMTCoq.SMTCoq.
From MetaCoq Require Import All.
Require Import String.
Require Import ZArith.

(** Quoted useful terms **)

MetaCoq Quote Definition unit_reif := unit.

MetaCoq Quote Definition or_reif := Logic.or.

MetaCoq Quote Definition and_reif := Logic.and.

MetaCoq Quote Definition True_reif := True.

MetaCoq Quote Definition False_reif := False.

MetaCoq Quote Definition eq_reif := @eq.

MetaCoq Quote Definition bool_reif := bool.

MetaCoq Quote Definition Z_reif := Z.

MetaCoq Quote Definition nat_reif := nat.

Inductive impossible_term :=.
MetaCoq Quote Definition impossible_term_reif := impossible_term.

Definition nat_oind := {|
ind_name := "nat"%string;
ind_type := tSort (Universe.of_levels (inr Level.lSet));
ind_kelim := IntoAny;
ind_ctors := [("O"%string, tRel 0, 0);
             ("S"%string,
             tProd
               {|
               binder_name := nAnon;
               binder_relevance := Relevant |}
               (tRel 0) (tRel 1), 1)];
ind_projs := [];
ind_relevance := Relevant |}.

(** Tail-recursive (actually linear) version of List.length **)
Definition leng {A : Type} (l : list A ) :=
  let fix aux l acc :=
  match l with
  | [] => acc
  | _ :: l0 => aux l0 (S acc)
  end
  in aux l 0.

(** Tail-recursive (actually linear) version of List.rev **)

Definition tr_rev {A : Type} (l : list A) :=
  let fix aux l acc :=
  match l with
  | [] => acc
  | x :: l => aux l (x :: acc ) end
  in aux l [].

(** Tail-recursive (actually linear) version of flatten **)
Definition tr_flatten {A : Type} (l : list (list A)) :=
  let fix aux l acc :=
  match l with
  | [] => acc
  | l0 :: l => aux l (rev_append l0 acc)
  end in tr_rev (aux l []).

(** tr_revmap f [a1 ; ... ; an ] = [f an ; .... ; f a1 ]
 tail-recursive (actually linear)
**)
Definition tr_revmap {A B : Type } ( f : A -> B) (l : list A) :=
  let fix aux l acc :=
  match l with
  | [] => acc
  | x :: l => aux l (f x :: acc ) end
  in aux l [].

(** rec_acc_add [n_1 ; .... ; n_c ] = [n ]
**)
Definition rev_acc_add l :=
let fix aux l s acc :=
match l with
  | [] => acc
  | x :: l => let s' := x+s in aux l s'  (s' :: acc)
end in aux l 0 [].

Goal False.
let x := constr:(rev_acc_add [2 ; 3 ; 8]) in pose x as kik ; compute in kik.
Abort.

(** Tail-recursive (actually linear) version of List.map
    Sometimes, cannot replace List.map, because Coq cannot guess the decreasing argument
**)

Definition tr_map {A B : Type} (f: A -> B) (l : list A) :=
  let l0 := tr_rev l in
  let fix aux l acc :=
  match l with
  | [] => acc
  | x :: l => aux l (f x :: acc ) end
  in aux l0 [].

(** Functions to build MetaCoq terms **)

(*  declaring variables   *)
Open Scope string_scope.

Definition mkNamed s := ({| binder_name := nNamed (s%string); binder_relevance := Relevant |} : aname).
Definition mkNAnon := {| binder_name := nAnon; binder_relevance := Relevant |}.

Definition mkNamedtry := mkNamed (("B"%string) : ident).

Definition mkEq (B t1 t2 : term) := tApp eq_reif [B ; t1 ; t2].

Definition mkProd T u :=
tProd mkNAnon T u.

Definition mkLam Ty t := match Ty with
| tSort _ => tLambda (mkNamed "A") Ty t
| _ => tLambda (mkNamed "x") Ty t
end.

Definition mkProdName na T u := (* \TODO use mkProdName in files *)
tProd (mkNamed na) T u.

(* mkProd [A1 ; .... ; An ] t = tProd _ An. ... tProd _ A1. t   (reverts list) *)
(* warning: t should have been previously lifted if necessary*)
Fixpoint mkProd_rec (l : list term)  (t: term) :=
match l with
| [] => t
| x :: xs => mkProd_rec xs (tProd (mkNamed "x")  x t)
end.

(* same thing but one provides a name for the bound variables *)
Fixpoint mkProd_rec_n (na : ident) (l : list term)  (t: term) :=
(* warning: t should have been previously lifted *)
match l with
| [] => t
| x :: xs => mkProd_rec_n na xs (tProd (mkNamed na)  x t)
end.

(** mkLam [A1 ; .... ; An ] t = Lam "x/A" An. ... tProd "x/A" A1. t   (reverts list) **)
(** tail-recursive **)
(* warning: t should have been previously lifted if necessary*)
Fixpoint mkLam_rec (l : list term)  (t: term) :=
match l with
| [] => t
| x :: xs => mkLam_rec xs (mkLam x t)
end.

Close Scope string_scope.

Definition mkImpl A B := tProd mkNAnon A (lift0 1 B).

Definition mkNot (A :term) := mkImpl A False_reif.

Definition mkAnd (A B : term) := tApp and_reif [A ; B].

Definition mkOr (A B : term) := tApp or_reif [A ; B].

(** mkAnd_n [A1_reif ; ... ; An_reif ] =
    the reification of (A1 /\ A2) /\ ... An) (associates to the left **)
(** tail-recursive (actually linear) *)
Definition mkAnd_n (l : list term) :=
  match l with
  | [] => True_reif
  | t0 :: l0 =>
  let fix aux l acc := match l with
  | [] => acc
  | t :: l => aux l (tApp and_reif (acc :: [t]))
  end
  in aux l0 t0
  end.

(**  mkOr_n0 [A1_reif ; ... ; An_reif] produce the reification of(...(An \/ (A_{n-1}) ... A_2) \/ A_1)..)
     i.e. reverts list and associates to the *left* (better for SMTLib) **)
(**     tail-recursive **)
Definition mkOr_n (l : list term) :=
  match l with
  | [] => True_reif
  | t0 :: l0 =>
    let fix aux l acc := match l with
    | [] => acc
    | t :: l => aux l (tApp or_reif (acc :: [t]))
    end
    in aux l0 t0
  end.

Definition mkApp (u : term) (l : list term) :=
tApp u l.

Definition mkApp_singl t u :=
mkApp t [u].

(* get_params_from_mind mind = (p , P)
  where p is the number of parameters of mind and lP the list of the parameters types *in order*
  (note that mind.(ind_params)) stores the types in *reverse* order
*)
(* \TODO it would be perhaps better to recover the types of the parameters in the reverse order  *)
Definition get_params_from_mind mind :=
  let p := mind.(ind_npars) in
  let l0 := tr_revmap (fun d => d.(decl_type)) mind.(ind_params)
in (p, l0).
(* \TODO maybe use this tactic in fo_prop_of_cons_tac *)

Fixpoint get_constructors_inductive (I : term) (e : global_env) :=
match I with
| tInd ind _ => match ind.(inductive_mind) with
          | (file, ident) => match e with
                      | [] => None
                      | (na,d) :: e' =>
                                (match d with
                                  | InductiveDecl mind => if (String.eqb
ident na.2) then let loind := ind_bodies mind in let list_ctors_opt := match loind with
| nil => None
| x :: xs => Some (x.(ind_ctors))
end in list_ctors_opt else get_constructors_inductive I e'
                                  | _ => get_constructors_inductive I e'
                               end)
    end
end
| _ => None
end.

(* Get the pair of the number of parameters of an inductive and the list of their types *)
Fixpoint get_info_params_inductive (I : term) (e : global_env) :=
match I with
| tInd ind _ => match ind.(inductive_mind) with
          | (file, ident) => match e with
                      | [] => None
                      | (na,d) :: e' =>
                                (match d with
                                  | InductiveDecl mind => if (String.eqb
ident na.2) then let prod := (ind_npars mind, tr_map (fun x => x.(decl_type)) (ind_params mind)) in Some prod else get_info_params_inductive I e'
                                  | _ => get_info_params_inductive I e'
                               end)
    end
end
| _ => None
end.

(** computes the list of one_inductive_body's in a term I which is a reified inductive **)
(* \TODO should problably also test the equality between paths, not only on the names *)
Fixpoint get_decl_inductive (I : term) (e : global_env) :=
match I with
| tInd ind _ => match ind.(inductive_mind) with
          | (file, ident) => match e with
                      | [] => None
                      | (na,d) :: e' =>
                                (match d with
                                  | InductiveDecl mind => if (String.eqb
ident na.2) then let loind := ind_bodies mind in Some loind else get_decl_inductive I e'
                                  | _ => get_decl_inductive I e'
                               end)
    end
end
| _ => None
end.

Definition no_prod (t: term) := match t with
  | tProd _ _ _ => false
  | _ => true
end.

(* no_prod* do not seem to be used --> \TODO remove   *)
Fixpoint no_prod_after_params (t : term) (p : nat) := match t with
   | tProd _ _ u => match p with
                   | 0 => false
                   | S n' => no_prod_after_params u n'
                  end
  | _ => true
end.

(* does not seem to be used anywhere ---> \TODO remove *)
Definition find_index_constructor_of_arity_zero (o : option (list ((ident × term) × nat))) := match o with
  | None => None
  | Some l => let fix aux l' acc :=
      match l' with
        | nil => None
        | x :: xs => if Nat.eqb (x.2) 0 then (Some acc) else aux xs (acc + 1)
      end in aux l 0
  end.

(* \TODO
1) give a better name
2) see if it is really useful
*)
Definition no_app t := match t with
| tApp u l => (u, l)
| _ => (t, [])
end.

Definition get_info_inductive (I : term) :=
let p := no_app I in match p.1 with
| tInd ind inst => Some (ind, inst)
| _ => None
end.

Ltac remove_option o := match o with
| Some ?x => constr:(x)
| None => fail "failure remove_option"
end.

Definition get_nth_constructor (I : term) (n : nat) : term :=
let g := get_info_inductive I in match g with
  | None => impossible_term_reif
  | Some (ind, inst) => tConstruct ind n inst
end.

(* \TODO : not useful --> remove *)
Definition mkApp_list (u : term) (l : list term) :=
tApp u l.

(* Implements beta reduction *)
(* \TODO : not used --> remove *)
Fixpoint typing_prod_list (T : term) (args : list term) :=
match T with
| tProd _ A U => match args with
        | nil => T
        | x :: xs => typing_prod_list (subst10 x U) xs
        end
| _ => T
end.

(* As the constructor contains a free variable to represent the inductive type, this fonction substitutes the given
inductive type and the parameters in the list of the type of the constructors *)
(* \seems inefficient, and better handled by debruijn0 --> remove \TODO *)
Fixpoint subst_type_constructor_list (l : list ((string × term) × nat)) (p : term × (list term)) :=
let T := p.1 in
let args := p.2 in
match l with
| nil => nil
| ((_, Ty), _):: l' => (typing_prod_list (subst10 T Ty) args) :: (subst_type_constructor_list l' p)
end.
(* \TMP
 | cons y' _ => let z := y'.(ind_ctors) in let u :=
subst_type_constructor_list z v in u
*)

Fixpoint get_decl (e : global_env) := match e with
| [] => []
| x :: e' => match (snd x) with
      | ConstantDecl u => match u.(cst_body) with
            | Some v => v :: get_decl e'
            | None => get_decl e'
            end
      | InductiveDecl u => get_decl e'
      end
end.

(* Check is a MetaCoq term is a sort which is not Prop *)
Definition is_type (t : term) := match t with
                                 | tSort s => negb (Universe.is_prop s)
                                 |_ => false
                                  end.

(* Get the nb of construcors of a reified inductive type if we have the reified global environment *)
Definition get_nb_constructors i Σ :=
match i with
| tInd indu _ => match lookup_env Σ indu.(inductive_mind) with
                | Some (InductiveDecl decl) => match ind_bodies decl with
                          | nil => 0
                          | x :: _ => Datatypes.length (ind_ctors x)
                          end
                | _ => 0
end
| _ => 0
end.

(** Generic tactics **)

Ltac prove_hypothesis H :=
repeat match goal with
  | H' := ?x : ?P |- _ =>  lazymatch P with
                | Prop => let def := fresh in assert (def : x) by
(intros; rewrite H; auto) ;  clear H'
          end
end.

Ltac get_head x := lazymatch x with ?x _ => get_head x | _ => x end.

Ltac get_tail x :=
let rec get_tail_aux x p :=
lazymatch x with ?y ?z => get_tail_aux y (z, p) | _ => p end
in get_tail_aux x impossible_term.

(* [inverse_tactic tactic] succceds when [tactic] fails, and the other way round *)
Ltac inverse_tactic tactic := try (tactic; fail 1).

(* [constr_neq t u] fails if and only if [t] and [u] are convertible *)
Ltac constr_neq t u := inverse_tactic ltac:(constr_eq t u).

Ltac is_not_in_tuple p z :=
lazymatch constr:(p) with
| (?x, ?y) => is_not_in_tuple constr:(x) z ; is_not_in_tuple constr:(y) z
| _ => constr_neq p z
end.

Ltac generalize_dependent_tuple p :=
lazymatch constr:(p) with
| (?x, ?y) => generalize_dependent_tuple constr:(x) ; generalize_dependent_tuple constr:(y)
| impossible_term => idtac
| ?x => try (generalize dependent x)
end.

Ltac notHyp T  :=
repeat match goal with
  | [H : _ |- _] => let U := type of H in constr_eq U T ; fail 2
end.

(* A tactic version of if/else *)
Ltac if_else_ltac tac1 tac2 b := lazymatch b with
  | true => tac1
  | false => tac2
end.

(* Returns the tuple of hypothesis in a local context *)
Ltac hyps :=
match goal with
| H : _ |- _ => let _ := match goal with _ => let T := type of H in let U := type of T in
constr_eq U Prop ; revert H end in let acc := hyps in
let _ := match goal with _ => intro H end in constr:((H, acc))
| _ => constr:(impossible_term)
end.

Ltac clear_dup :=
  match goal with
    | [ H : ?X |- _ ] => let U := type of X in constr_eq U Prop ;
      match goal with
        | [ H' : ?Y |- _ ] =>
          match H with
            | H' => fail 2
            | _ => unify X Y ; (clear H' || clear H)
          end
      end
  end.

Ltac clear_dups := repeat clear_dup.

(** Tactics to work on quoted MetaCoq terms **)

Ltac unquote_term t_reif :=
run_template_program (tmUnquote t_reif) ltac:(fun t =>
let x := constr:(t.(my_projT2)) in let y := eval hnf in x in pose y).

Ltac unquote_list l :=
match constr:(l) with
| nil => idtac
| cons ?x ?xs => unquote_term x ; unquote_list xs
end.

Ltac rec_quote_term t idn := (run_template_program (tmQuoteRec t) ltac:(fun x => (pose  x as idn))).

(* Allows to use MetaCoq without continuations *)
Ltac metacoq_get_value p :=
  let id := fresh in
  let _ := match goal with _ => run_template_program p
  (fun t => pose (id := t)) end in
  let x := eval cbv delta [id] in id in
  let _ := match goal with _ => clear id end in
  x.

(* Examples for metacoq_get_value *)
Goal True.
let x := metacoq_get_value (tmQuoteRec bool) in pose x.
let x := metacoq_get_value (tmQuote bool) in pose x.
let x := metacoq_get_value (tmQuote 0) in let y := metacoq_get_value (tmUnquote x) in pose y.
let x := metacoq_get_value (tmQuote 0) in let y := metacoq_get_value (tmUnquoteTyped nat x) in pose y.
Abort.

Ltac get_nb_constructors_tac i id :=
run_template_program (tmQuoteRec i) ltac:(fun i_reif_rec => let n :=
eval cbv in (get_nb_constructors i_reif_rec.2 i_reif_rec.1) in
pose (id := n)).

(*********************)
(* \TODO temporary inserts before putting order into auxiliary functions
         These functions should be removed from interp_alg_types *)

Definition dom_list_f ( B  :  term) (n : nat)  :=
  (* takes a type B := Prod A1 ... An . B'  and outputs (B,[A1; ... ; An]), at least if no dependencies *)
  (* does not handle debruijn indices *)
  let fix dlaux B n acc :=
  match n with
  | 0 => (B,tr_rev acc)
  | S n => match B with
          | tProd na A B' =>  dlaux B' n (A :: acc)
          | _ => (B,[]) (* this case shouldn't happen *)
          end
  end
  in dlaux B n [].

(* given an 'inductive' and i, the rank of an inductive body,
  outputs the 'inductive' associated to the same inductive type, whose rank is i
*)
Definition switch_inductive ( indu : inductive) (i : nat) :=
  match indu with
  | {| inductive_mind := kn ; inductive_ind := k |} => {| inductive_mind := kn ; inductive_ind := i |}
end.

(** in an inductive type I, the type of the constructors use de Bruijn indices to denote the inductive bodies of I.
For instance, for I = list, which has a unique inductive body, the type of :: is represented with:
cons_type_decl := tProd "A" Type_reif (tProd _ (tRel 0) (tProd _ (tApp (tRel 2) [tRel 1]) (tApp (tRel 3) [tRel 2])))
where the 1st occurrence of Rel 2 and the occurrence of Rel 3 represent the type list
See the term list_oind in aux_fun_tests.v.
Then if B is the type of the constructor as it is reified in the inductive type I, debruijn0 .... B outputs the real type of the constructor
e.g. debruijn0 (list_indu) 1 [] cons_type_decl gives
   tProd "A" Type_reif (tProd _ (tRel 0) (tProd _ (tApp list_reif [tRel 1]) (tApp list_reif [tRel 2])
   i.e. the reification forall (A: Type), A -> list A -> list A
   where list_reif is the reification for list
**)
(** tail-recursive **)
Definition debruijn0 (indu : inductive) (no : nat) (u : Instance.t ) (B : term) :=
  let fix aux1 k acc :=
    match k with
    | 0 => acc
    | S k => aux1 k  ((tInd (switch_inductive indu k) u):: acc)
    end in
  let oind_list := tr_rev (aux1 no [] )
  in  subst0 oind_list B .

(***********************)

(** Rel_list n l = [ tRel (n + l -1)) ; tRel (n + l -2 ) ; ... ; tRel l]
   (list of length n)
**) (** linear **)
Definition Rel_list (n l : nat) :=
  let  fix aux n  k acc  :=
  match n with
   | 0 => acc
   | S n => aux n  (S k) ((tRel k)::acc)
   end
   in aux n l [].

(* Reifies a term and calls is_type *)
Ltac is_type_quote t := let t' := eval hnf in t in let T :=
metacoq_get_value (tmQuote t') in if_else_ltac idtac fail ltac:(eval compute in (is_type T)).

Ltac is_type_quote_bool t := let t' := eval hnf in t in let T :=
metacoq_get_value (tmQuote t') in constr:(is_type T).

Fixpoint list_of_subterms (t: term) : list term := match t with
| tLambda _ Ty u => t :: (list_of_subterms Ty) ++ (list_of_subterms u)
| tProd _ Ty u => t :: (list_of_subterms Ty) ++ (list_of_subterms u)
| tLetIn _ u v w => t :: (list_of_subterms u) ++ (list_of_subterms v) ++ (list_of_subterms w)
| tCast t1 _ t2 => t :: (list_of_subterms t1) ++ (list_of_subterms t2)
| tApp u l => t :: (list_of_subterms u) ++ (List.flat_map list_of_subterms l)
| tCase _ t1 t2 l => t:: (list_of_subterms t1) ++ (list_of_subterms t2) ++
(List.flat_map (fun x => list_of_subterms (snd x)) l)
| tFix l _  => t :: (List.flat_map (fun x => list_of_subterms (x.(dbody))) l)
| tCoFix l _ => t :: (List.flat_map (fun x => list_of_subterms (x.(dbody))) l)
| _ => [t]
end.

Definition filter_closed (l: list term) := List.filter (closedn 0) l.

Ltac get_list_of_closed_subterms t := let t_reif := metacoq_get_value (tmQuote t) in
let l := eval cbv in (filter_closed (list_of_subterms t_reif)) in l.

Ltac return_unquote_tuple_terms l := let rec aux l acc :=
match constr:(l) with
| nil => constr:(acc)
| cons ?x ?xs =>
  let y := metacoq_get_value (tmUnquote x) in
  let u := constr:(y.(my_projT2)) in
  let w := eval hnf in u in
  let T := type of w in
  let b0 := ltac:(is_type_quote_bool T) in
  let b := eval hnf in b0 in
    match b with
    | true => (aux xs (pair w acc))
    | false => aux xs acc
    end
end
in aux l impossible_term.

Ltac return_tuple_subterms_of_type_type := match goal with
|- ?x => let l0 := (get_list_of_closed_subterms x) in let l := eval cbv in l0 in return_unquote_tuple_terms l
end.

Goal forall (A: Type) (x:nat) (y: bool) (z : list A), y = y -> z=z -> x = x.
let t := return_tuple_subterms_of_type_type in pose t.
Abort.

Goal forall (A : Type) (l : list A), Datatypes.length l = 0 -> l = nil.
let t := return_tuple_subterms_of_type_type in pose t.
Abort.

(* To reason on size of terms *)

Definition list_size :=
fun {A : Type} (size : A -> nat) =>
fix list_size (l : list A) : nat :=
  match l with
  | [] => 0
  | a :: v => S (size a + list_size v)
  end.

Definition def_size :=
fun (size : term -> nat) (x : def term) =>
size (dtype x) + size (dbody x).

Definition mfixpoint_size :=
fun (size : term -> nat) (l : mfixpoint term) =>
list_size (def_size size) l.

Fixpoint size (t : term) :=
match t with
| tEvar _ args => S (list_size size args)
| tProd _ A B => S (size A + size B)
| tLambda _ T M => S (size T + size M)
| tLetIn _ b t0 b' => S (size b + size t0 + size b')
| tApp u l => S (size u + (List.fold_left (fun acc x => size x + acc) l 0))
| tCase _ p c brs => S (size p + size c + list_size
           (fun x : nat * term =>
            size x.2) brs)
| tProj _ c => S (size c)
| tFix mfix _ | tCoFix mfix _ => S (mfixpoint_size size mfix)
| _ => 1
end.

Ltac fold_tuple Na p :=
lazymatch constr:(p) with
| (?x, ?y) => fold_tuple Na constr:(x) ; fold_tuple Na constr:(y)
| ?H => try fold Na in H
end.

From Ltac2 Require Import Ltac2.

Ltac2 has_local_def (c: constr) :=
let h := Control.hyps () in
let rec tac_rec c h :=
  match h with
  | x :: xs =>  match x with
    | (id, opt, cstr) => let c' := Control.hyp id in
    if Constr.equal c c' then
      match opt with
      | Some y => ltac1:(idtac)
      | None => tac_rec c xs
      end
    else tac_rec c xs
  end
  | [] => ltac1:(fail)
end
in tac_rec c h.

Ltac2 is_local_def (c: constr) :=
let h := Control.hyps () in
let rec tac_rec c h :=
  match h with
  | x :: xs =>  match x with
    | (id, opt, cstr) =>
      match opt with
      | Some c' => if Constr.equal c c' then ltac1:(idtac) else tac_rec c xs
      | None => tac_rec c xs
      end
  end
  | [] => ltac1:(fail)
end
in tac_rec c h.

Goal False.
pose (h := true). assert (H : forall (A : Type), A = A) by reflexivity. has_local_def &h.
Fail has_local_def &H. is_local_def 'true. pose (foo := (forall A : nat, A = A)).
is_local_def '(forall A : nat, A = A). Fail is_local_def 'false.
Abort.

Tactic Notation "has_local_def" constr(c) :=
let tac :=
ltac2:(cltac1 |- let cltac2 := Ltac1.to_constr cltac1 in
  match cltac2 with
  | None => ()
  | Some c => has_local_def c
end) in tac c.

Tactic Notation "is_local_def" constr(c) :=
let tac :=
ltac2:(cltac1 |- let cltac2 := Ltac1.to_constr cltac1 in
  match cltac2 with
  | None => ()
  | Some c => is_local_def c
end) in tac c.

(* new_hypothesis h h++h' returns h' *)
(* Note: code duplication with deciderel *)
Ltac2 rec new_hypothesis
(h1: (ident * constr option * constr) list)
(h2 : (ident * constr option * constr) list) :=
match h1 with
| [] => h2
| x :: xs => match h2 with
        | [] => []
        | y :: ys => new_hypothesis xs ys
      end
end.

Ltac2 rec hyps_printer (h : (ident * constr option * constr) list)
:=
match h with
| [] => ()
| x :: xs => match x with
            | (id, opt, cstr) =>
let () := Message.print (Message.concat (Message.of_ident id)
                                        (Message.concat (Message.of_string " : ")
                                                        (Message.of_constr cstr)))
in hyps_printer xs
end
end.


Require Import Effects.
Require Import list.Eff.

Set Universe Polymorphism.

Declare Effect list.Eff.

Definition foo := fun (A : Type) (x : A) => x.

Effect Translate foo using list.Eff.

Definition bar := fun (A B : Type) (f : A -> A -> B) (x : A) => f x x.

Effect Translate bar using list.Eff.

Effect Definition amb : forall A, A -> A -> A using list.Eff.
Proof.
refine (fun A => @happ A).
Defined.

Definition quz := foo Type Type.

Effect Translate quz using list.Eff.

Effect Translate bool using list.Eff.
Effect Translate eq using list.Eff.
Effect Translate list using list.Eff.
Effect Translate sum using list.Eff.
Effect Translate False using list.Eff.
Effect Translate sigT using list.Eff.
Effect Translate Datatypes.prod using list.Eff.

Lemma eq_is_eqᵒ : forall A x y, eqᵒ A x y -> x = y.
Proof.
intros A x y e.
destruct e; reflexivity.
Qed.

Effect Definition non_standard_bool : {b : bool & Datatypes.prod (b = true -> False) (b = false -> False) } using list.Eff.
Proof.
refine (ret _).
exists (list.Eff.cons _ trueᵒ (list.Eff.nil _ falseᵒ)).
refine (ret _); constructor; intros e; destruct e as [e|e _]; apply eq_is_eqᵒ in e; discriminate.
Defined.

Inductive btree_ := bleaf_ : btree_ | bnode_ : (M boolᵒ -> M btree_) -> btree_.

Effect Definition btree : Type using list.Eff.
Proof.
refine (Free btree_).
Defined.

Effect Definition bleaf : btree using list.Eff.
Proof.
refine (ret bleaf_).
Defined.

Effect Definition bnode : (bool -> btree) -> btree using list.Eff.
Proof.
refine (fun f => ret (bnode_ f)).
Defined.

Effect Definition btree_case : forall P, P -> ((bool -> btree) -> (bool -> P) -> P) -> btree -> P using list.Eff.
Proof.
intros P pleaf pnode t.
refine (hbind t (fix btree_case t := match t with bleaf_ => pleaf | bnode_ f => pnode f (fun b => hbind (f b) btree_case) end)).
Defined.

Definition θ_btree : btree -> (btree -> Type) -> Type :=
  btree_case ((btree -> Type) -> Type) (fun k => k bleaf) (fun f _ k => k (bnode f)).

Effect Translate θ_btree using list.Eff.

Effect Definition btree_rect : forall (P : btree -> Type),
  (θ_btree bleaf P) ->
    (forall (f : bool -> btree), (forall b, θ_btree (f b) P) -> θ_btree (bnode f) P) ->
    forall t, θ_btree t P using list.Eff.
Proof.
intros P pleaf pnode t.
refine (pbind t P _).
refine (fix btree_rect t := _).
refine (
  match t with
  | bleaf_ => _
  | bnode_ f => _
  end
).
+ refine pleaf.
+ refine (pnode _ (fun b => _)).
  refine (pbind (f b) P _).
  refine (btree_rect).
Defined.


From iris.algebra Require Export cmra.
Set Default Proof Using "Type".

(** * Frame preserving updates *)
(* This quantifies over [option A] for the frame.  That is necessary to
   make the following hold:
     x ~~> P → Some c ~~> Some P
*)
Definition cmra_updateP {A : cmraT} (x : A) (P : A → Prop) := ∀ n mz,
  ✓{n} (x ⋅? mz) → ∃ y, P y ∧ ✓{n} (y ⋅? mz).
Instance: Params (@cmra_updateP) 1.
Infix "~~>:" := cmra_updateP (at level 70).

Definition cmra_update {A : cmraT} (x y : A) := ∀ n mz,
  ✓{n} (x ⋅? mz) → ✓{n} (y ⋅? mz).
Infix "~~>" := cmra_update (at level 70).
Instance: Params (@cmra_update) 1.

Section updates.
Context {A : cmraT}.
Implicit Types x y : A.

Global Instance cmra_updateP_proper :
  Proper ((≡) ==> pointwise_relation _ iff ==> iff) (@cmra_updateP A).
Proof.
  rewrite /pointwise_relation /cmra_updateP=> x x' Hx P P' HP;
    split=> ? n mz; setoid_subst; naive_solver.
Qed.
Global Instance cmra_update_proper :
  Proper ((≡) ==> (≡) ==> iff) (@cmra_update A).
Proof.
  rewrite /cmra_update=> x x' Hx y y' Hy; split=> ? n mz ?; setoid_subst; auto.
Qed.

Lemma cmra_update_updateP x y : x ~~> y ↔ x ~~>: (y =).
Proof. split=> Hup n z ?; eauto. destruct (Hup n z) as (?&<-&?); auto. Qed.
Lemma cmra_updateP_id (P : A → Prop) x : P x → x ~~>: P.
Proof. intros ? n mz ?; eauto. Qed.
Lemma cmra_updateP_compose (P Q : A → Prop) x :
  x ~~>: P → (∀ y, P y → y ~~>: Q) → x ~~>: Q.
Proof. intros Hx Hy n mz ?. destruct (Hx n mz) as (y&?&?); naive_solver. Qed.
Lemma cmra_updateP_compose_l (Q : A → Prop) x y : x ~~> y → y ~~>: Q → x ~~>: Q.
Proof.
  rewrite cmra_update_updateP.
  intros; apply cmra_updateP_compose with (y =); naive_solver.
Qed.
Lemma cmra_updateP_weaken (P Q : A → Prop) x :
  x ~~>: P → (∀ y, P y → Q y) → x ~~>: Q.
Proof. eauto using cmra_updateP_compose, cmra_updateP_id. Qed.
Global Instance cmra_update_preorder : PreOrder (@cmra_update A).
Proof.
  split.
  - intros x. by apply cmra_update_updateP, cmra_updateP_id.
  - intros x y z. rewrite !cmra_update_updateP.
    eauto using cmra_updateP_compose with subst.
Qed.
Lemma cmra_update_exclusive `{!Exclusive x} y:
  ✓ y → x ~~> y.
Proof. move=>??[z|]=>[/exclusiveN_l[]|_]. by apply cmra_valid_validN. Qed.

Lemma cmra_updateP_op (P1 P2 Q : A → Prop) x1 x2 :
  x1 ~~>: P1 → x2 ~~>: P2 → (∀ y1 y2, P1 y1 → P2 y2 → Q (y1 ⋅ y2)) →
  x1 ⋅ x2 ~~>: Q.
Proof.
  intros Hx1 Hx2 Hy n mz ?.
  destruct (Hx1 n (Some (x2 ⋅? mz))) as (y1&?&?).
  { by rewrite /= -cmra_op_opM_assoc. }
  destruct (Hx2 n (Some (y1 ⋅? mz))) as (y2&?&?).
  { by rewrite /= -cmra_op_opM_assoc (comm _ x2) cmra_op_opM_assoc. }
  exists (y1 ⋅ y2); split; last rewrite (comm _ y1) cmra_op_opM_assoc; auto.
Qed.
Lemma cmra_updateP_op' (P1 P2 : A → Prop) x1 x2 :
  x1 ~~>: P1 → x2 ~~>: P2 →
  x1 ⋅ x2 ~~>: λ y, ∃ y1 y2, y = y1 ⋅ y2 ∧ P1 y1 ∧ P2 y2.
Proof. eauto 10 using cmra_updateP_op. Qed.
Lemma cmra_update_op x1 x2 y1 y2 : x1 ~~> y1 → x2 ~~> y2 → x1 ⋅ x2 ~~> y1 ⋅ y2.
Proof.
  rewrite !cmra_update_updateP; eauto using cmra_updateP_op with congruence.
Qed.

Lemma cmra_update_op_l x y : x ⋅ y ~~> x.
Proof. intros n mz. rewrite comm cmra_op_opM_assoc. apply cmra_validN_op_r. Qed.
Lemma cmra_update_op_r x y : x ⋅ y ~~> y.
Proof. rewrite comm. apply cmra_update_op_l. Qed.

Lemma cmra_update_valid0 x y : (✓{0} x → x ~~> y) → x ~~> y.
Proof.
  intros H n mz Hmz. apply H, Hmz.
  apply (cmra_validN_le n); last lia.
  destruct mz. eapply cmra_validN_op_l, Hmz. apply Hmz.
Qed.

(** ** Frame preserving updates for total CMRAs *)
Section total_updates.
  Local Set Default Proof Using "Type*".
  Context `{CmraTotal A}.

  Lemma cmra_total_updateP x (P : A → Prop) :
    x ~~>: P ↔ ∀ n z, ✓{n} (x ⋅ z) → ∃ y, P y ∧ ✓{n} (y ⋅ z).
  Proof.
    split=> Hup; [intros n z; apply (Hup n (Some z))|].
    intros n [z|] ?; simpl; [by apply Hup|].
    destruct (Hup n (core x)) as (y&?&?); first by rewrite cmra_core_r.
    eauto using cmra_validN_op_l.
  Qed.
  Lemma cmra_total_update x y : x ~~> y ↔ ∀ n z, ✓{n} (x ⋅ z) → ✓{n} (y ⋅ z).
  Proof. rewrite cmra_update_updateP cmra_total_updateP. naive_solver. Qed.

  Context `{CmraDiscrete A}.

  Lemma cmra_discrete_updateP (x : A) (P : A → Prop) :
    x ~~>: P ↔ ∀ z, ✓ (x ⋅ z) → ∃ y, P y ∧ ✓ (y ⋅ z).
  Proof.
    rewrite cmra_total_updateP; setoid_rewrite <-cmra_discrete_valid_iff.
    naive_solver eauto using 0.
  Qed.
  Lemma cmra_discrete_update (x y : A) :
    x ~~> y ↔ ∀ z, ✓ (x ⋅ z) → ✓ (y ⋅ z).
  Proof.
    rewrite cmra_total_update; setoid_rewrite <-cmra_discrete_valid_iff.
    naive_solver eauto using 0.
  Qed.
End total_updates.
End updates.

(** * Transport *)
Section cmra_transport.
  Context {A B : cmraT} (H : A = B).
  Notation T := (cmra_transport H).
  Lemma cmra_transport_updateP (P : A → Prop) (Q : B → Prop) x :
    x ~~>: P → (∀ y, P y → Q (T y)) → T x ~~>: Q.
  Proof. destruct H; eauto using cmra_updateP_weaken. Qed.
  Lemma cmra_transport_updateP' (P : A → Prop) x :
    x ~~>: P → T x ~~>: λ y, ∃ y', y = cmra_transport H y' ∧ P y'.
  Proof. eauto using cmra_transport_updateP. Qed.
End cmra_transport.

(** * Product *)
Section prod.
  Context {A B : cmraT}.
  Implicit Types x : A * B.

  Lemma prod_updateP P1 P2 (Q : A * B → Prop) x :
    x.1 ~~>: P1 → x.2 ~~>: P2 → (∀ a b, P1 a → P2 b → Q (a,b)) → x ~~>: Q.
  Proof.
    intros Hx1 Hx2 HP n mz [??]; simpl in *.
    destruct (Hx1 n (fst <$> mz)) as (a&?&?); first by destruct mz.
    destruct (Hx2 n (snd <$> mz)) as (b&?&?); first by destruct mz.
    exists (a,b); repeat split; destruct mz; auto.
  Qed.
  Lemma prod_updateP' P1 P2 x :
    x.1 ~~>: P1 → x.2 ~~>: P2 → x ~~>: λ y, P1 (y.1) ∧ P2 (y.2).
  Proof. eauto using prod_updateP. Qed.
  Lemma prod_update x y : x.1 ~~> y.1 → x.2 ~~> y.2 → x ~~> y.
  Proof.
    rewrite !cmra_update_updateP.
    destruct x, y; eauto using prod_updateP with subst.
  Qed.
End prod.

(** * Option *)
Section option.
  Context {A : cmraT}.
  Implicit Types x y : A.

  Lemma option_updateP (P : A → Prop) (Q : option A → Prop) x :
    x ~~>: P → (∀ y, P y → Q (Some y)) → Some x ~~>: Q.
  Proof.
    intros Hx Hy; apply cmra_total_updateP=> n [y|] ?.
    { destruct (Hx n (Some y)) as (y'&?&?); auto. exists (Some y'); auto. }
    destruct (Hx n None) as (y'&?&?); rewrite ?cmra_core_r; auto.
    by exists (Some y'); auto.
  Qed.
  Lemma option_updateP' (P : A → Prop) x :
    x ~~>: P → Some x ~~>: from_option P False.
  Proof. eauto using option_updateP. Qed.
  Lemma option_update x y : x ~~> y → Some x ~~> Some y.
  Proof. rewrite !cmra_update_updateP; eauto using option_updateP with subst. Qed.
End option.


Require Import Kami.AllNotations.

Section Named.
  Variable sz: nat.
  Variable name: string.
  Local Notation "@^ x" := (name ++ "_" ++ x)%string (at level 0).

  (* The implementation which keeps incrementing a counter in one step and sends the value of the counter in the other *)
  Definition IncrementerImpl :=
    MODULE {
      Register @^"counter" : Bit sz <- Default
      with Register @^"counter1" : Bit sz <- Default
      with Register @^"isSending" : Bool <- true

      with Rule @^"send_and_inc" :=
      ( Read isSending: Bool <- @^"isSending" ;
        If #isSending
        then (
          Read counter: Bit sz <- @^"counter" ;
          Call "counterVal"(#counter: _);
          Write @^"isSending" <- !#isSending ;
          Retv)
        else (
          Read counter: Bit sz <- @^"counter" ;
          Write @^"counter" <- #counter + $1;
          Write @^"isSending" <- !#isSending ;
          Retv );
        Retv) }.

  (* The specification which combines the two actions in one rule *)
  Definition IncrementerSpec :=
    MODULE {
      Register @^"counter" : Bit sz <- Default
      with Register @^"counter1" : Bit sz <- Default

      with Rule @^"send_and_inc" :=
      ( Read counter: Bit sz <- @^"counter" ;
        Call "counterVal"(#counter: _);
        Write @^"counter" <- #counter + $1;
        Retv )
      }.

  (* The invariant connecting the state of the implementation with the
    state of the spec, including specifying the list of register register names, their types and values *)
  Record Incrementer_invariant (impl spec: RegsT) : Prop :=
    { counterImpl: word sz ;
      isSending: bool ;
      implEq : impl = (@^"counter", existT _ (SyntaxKind (Bit sz)) counterImpl)
                        :: (@^"counter1", existT _ (SyntaxKind (Bit sz)) $0)
                        :: (@^"isSending", existT _ (SyntaxKind Bool) isSending) :: nil ;
      specEq : spec = (@^"counter", existT _ (SyntaxKind (Bit sz))
                                           (if isSending then counterImpl else counterImpl ^+ $1))
                        :: (@^"counter1", existT  _ (SyntaxKind (Bit sz)) $0)
                        :: nil
    }.

Ltac bsimplify_simulatingRule name :=
  right;
  exists name;
  eexists; split; [eauto| do 2 eexists; split; [discharge_SemAction|]].

  (* Proving the trace inclusion of the implementation with respect to the spec *)
  Theorem Incrementer_TraceInclusion:
    TraceInclusion (Base IncrementerImpl) (Base IncrementerSpec).
  Proof.
    (* discharge_simulation with the name of the record holding the invariant will discharge most of the trivial goals and
      requires the user to specify, for each implementation rule or method, either a specification rule or method that
      produces the same method calls while maintaining the state invariant or a nil step in the specification.
      The former is simplified using simplify_simulatingRule, with the rule name.
      The latter is simplified using simplify_nilStep.
      discharge_CommonRegisterAuto discharges the goals that require that two methods or a method and rule of
      the implementation are not combinable by automatically searching for at least one register with the two actions write to *)
    discharge_simulation Incrementer_invariant; discharge_CommonRegisterAuto.
    - bsimplify_simulatingRule @^"send_and_inc"; subst.
      + auto.
      + simpl. discharge_string_dec.
        repeat (econstructor; eauto; simpl; subst).
        rewrite wzero_wplus; auto.
    - simplify_nilStep.
      econstructor; simpl; eauto; subst.
      rewrite ?negb_true_iff in *; subst.
      rewrite wzero_wplus; simpl; auto.

      (* Note that while this example does not create spurious existentials, usually, there is a plethora of existentials created that can be instantiated with arbitrary values as they do not affect the proof. These goals are discharged with the following two commands*)
      Unshelve.
      all: repeat constructor.
Qed.
End Named.