Generalizable All Variables.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Set Reversible Pattern Implicit.
Set Primitive Projections.
Set Universe Polymorphism.

Require Export Coq.Program.Basics Coq.Program.Tactics
  Coq.Setoids.Setoid Coq.Classes.Morphisms.

Ltac trans P := apply (transitivity P).
Ltac rewrite2 E := rewrite E || rewrite <-E.
Ltac rewrite2_in E H := (rewrite E in H) || (rewrite <-E in H).
Ltac sapply H := let m := fresh "m" in
  pose H as m; simpl in m; apply m.
Ltac srewrite H := let m := fresh "m" in
  pose H as m; simpl in m; rewrite m.
Ltac mapequiv :=
  let x := fresh "x" in
  let x0 := fresh "x" in
  let E := fresh "E" in
  now intros x x0 E; rewrite E.
Ltac dmapequiv :=
  let x := fresh "x" in
  let x0 := fresh "x" in
  let E := fresh "E" in
  let y := fresh "y" in
  let y0 := fresh "y" in
  let E0 := fresh "E" in
  now intros x x0 E y y0 E0; simpl; rewrite E, E0.

Obligation Tactic :=
  (try now intros x); (try now split; intros x); intros;
  try (now mapequiv); try (now dmapequiv).

Notation "p .1" := (fst p) (at level 5, left associativity, format "p .1").
Notation "p .2" := (snd p) (at level 5, left associativity, format "p .2").

Declare Scope setoid_scope.
Open Scope setoid_scope.

Structure Setoid : Type := {
  scarrier :> Type;
  #[canonical=no] equal : relation scarrier;
  #[canonical=no] equal_equiv : Equivalence equal
}.
#[global] Existing Instance equal_equiv.

Notation "[  A  |  ==:  P  ]" := (@Build_Setoid A P _)
  (at level 0, A, P at level 99) : setoid_scope.
Notation "[ ==: x y => P ]" := [ _ | ==: fun x y => P ]
  (at level 0, x binder, y binder, P at level 99) : setoid_scope.
Notation "( == 'in' A )" := (@equal A)
  (at level 0, format "( == 'in' A )") : setoid_scope.
Notation "(==)" := (== in _) : setoid_scope.
Notation "x == y 'in' A" := (@equal A x y)
  (at level 70, y at next level, no associativity)
  : setoid_scope.
Notation "x == y" := (x == y in _)
  (at level 70, no associativity) : setoid_scope.

Canonical Structure PropSetoid := [ _ | ==: iff ].
Notation "'[Prop]'" := PropSetoid : setoid_scope.

Lemma sym {X : Setoid} {x y : X} : (x == y) == (y == x).
Proof. split; intros H; now symmetry. Defined.

Structure Map (X Y : Setoid) := {
  mapfun :> X -> Y;
  mapprf : Proper ((==) ==> (==)) mapfun
}.
#[global] Existing Instance mapprf.

Notation "'map' 'by' f" := (@Build_Map _ _ f _)
  (at level 200, no associativity).
Notation "'map' x => m" := (map by fun x => m)
  (at level 200, x binder, no associativity).

Program Canonical Structure MapSetoid (X Y : Setoid)
  := [ Map X Y | ==: ((==) ==> (==))%signature ].
Next Obligation.
  split; intros f.
  - apply mapprf.
  - intros g H a b E. symmetry. now apply H.
  - intros g h H H0 a b E. rewrite (H _ _ E). now apply H0.
Defined.

Notation "X [>] Y" := (@MapSetoid X Y)
  (at level 99, no associativity) : setoid_scope.
Notation "{ 'pred' X }" := (Map X [Prop])
  (at level 0, format "{ 'pred'  X }") : setoid_scope.
Notation "[ 'pred' X ]" := (X [>] [Prop])
  (at level 0, format "[ 'pred'  X ]") : setoid_scope.

Lemma map_equal `(f : Map X Y) x x0
  : x == x0 -> f x == f x0.
Proof. intros H. now rewrite H. Defined.

Structure Dymap (X Y Z : Setoid) := {
  dmapfun :> X -> Y -> Z;
  dmapprf : Proper ((==) ==> (==) ==> (==)) dmapfun
}.
#[global] Existing Instance dmapprf.

Notation "'dmap' 'by' f" := (@Build_Dymap _ _ _ f _)
  (at level 200, no associativity).
Notation "'dmap' x y => m" := (dmap by fun x y => m)
  (at level 200, x binder, y binder, no associativity).

Program Canonical Structure DymapSetoid {X Y Z : Setoid} :=
  [ Dymap X Y Z | ==: ((==) ==> (==) ==> (==))%signature ].
Next Obligation.
  split; intros f.
  - apply dmapprf.
  - intros g E x x0 Ex y y0 Ey. symmetry. now apply E.
  - intros g h E E0 x x0 Ex y y0 Ey.
    rewrite (E _ _ Ex _ _ Ey). now apply E0.
Defined.

Definition mcurry `(f : Dymap X Y Z) (x : X) := map by (f x).

Program Definition Comap {X Y : Setoid}
  := dmap (f : Map X Y) x => f x.
Notation "< f , a >" := (Comap f a)
  (at level 0, f, a at level 0, no associativity,
  format "< f ,  a >") : setoid_scope.

Lemma map_comap `{f : Map X Y} {a : X} : f a == <f, a>.
Proof. reflexivity. Qed.

Program Definition InducedSetoid {X} {Y : Setoid} (f : X -> Y) :=
  [ ==: x y => f x == f y ].
Next Obligation.
  split; intuition. intros x y z Exy Eyz. now rewrite Exy.
Defined.

#[projections(primitive=no)]
Structure Ensemble X := {
  ensconf :> {pred X}
}.

Notation "[  x  :  X  |  P  ]" :=
  (@Build_Ensemble _ (map (x : X) => P))
  (at level 0, x at level 99) : setoid_scope.
Notation "[  x  |  P  ]" := [ x : _ | P ]
  (at level 0, x binder, x, P at level 99) : setoid_scope.
Notation "'ens' 'by' P" := (@Build_Ensemble _ P)
  (at level 200, no associativity) : setoid_scope.
Notation "[  x 'in' A | P  ]" := [ x | A x /\ P ]
  (at level 0, x at level 99) : setoid_scope.
Notation "{ 'ens' X }" := (@Ensemble X)
  (at level 0, format "{ 'ens'  X }")
  : setoid_scope.

Canonical Structure EnsembleSetoid X
  := InducedSetoid (@ensconf X).
Notation "[ 'ens' X ]" := (@EnsembleSetoid X)
  (at level 0, format "[ 'ens'  X ]")
  : setoid_scope.
Program Canonical Structure ensconfM {X}
  : Map {ens X} [pred X] := map x => ensconf x.

#[projections(primitive=no)]
Structure sigS `(P : {pred X}) := {
  sval :> X;
  _ : P sval
}.

Notation "$[ x , H ]" := (@Build_sigS _ _ x H)
  (at level 0) : setoid_scope.
Notation "$[ x ]" := ($[x, _])
  (at level 0, format "$[ x ]") : setoid_scope.
Notation "$ x" := (@sval _ _ x)
  (at level 4, right associativity, format "$ x")
  : setoid_scope.

Canonical Structure sigSSetoid `(P : {pred X}) :=
  InducedSetoid (@sval _ P).
Notation "{ | P }" := (sigSSetoid P)
  (at level 0, no associativity, format "{  |  P }")
  : setoid_scope.
Program Canonical Structure inclS `{P : {pred X}}
  : Map { | P} X := map x => $x.

Lemma sigS_exists `{P : {pred X}} {Q : { |P} -> Prop}
  : (exists (x : X) (H : P x), Q $[_, H]) -> exists x : { |P}, Q x.
Proof. intros [x [HP HQ]]. now exists $[_, HP]. Defined.

Lemma forall_sigS `{P : {pred X}} {Q : { |P} -> Prop}
  : (forall x : { |P}, Q x) -> forall (x : X) (H : P x), Q $[_, H].
Proof. intros H x HP. apply H. Defined.

Ltac existsS T := let H := fresh "H" in
  apply sigS_exists; exists T; simpl;
  match goal with
  | |- exists _ : ?P, _ => assert P as H
  end; [intuition | exists H].

Ltac sigapply H := let m := fresh "m" in
  pose (forall_sigS H) as m; simpl in m; apply m; simpl.

Lemma val_sval `{P : {pred X}} {x : X} (H : P x)
  : x == $$[x, H].
Proof. reflexivity. Qed.

Coercion ens_setoid `(A : {ens X}) := { | ensconf A}.

Program Definition subens {X} :=
  dmap (A : {ens X}) (B : {ens X}) => forall x : A, B x.
Next Obligation.
  intros A B E C D E0. split; intros H [x Hx];
  rewrite map_comap; rewrite2 E0; sigapply H;
  rewrite map_comap; now rewrite2 E.
Defined.
Notation "A '<=' B" := (@subens _ A B) : setoid_scope.

#[global]
Instance subens_trans {X} : Transitive (@subens X).
Proof.
  intros A B C LAB LBC x. apply (LBC $[_, LAB x]).
Qed.

Program Definition inclmap {X} {A B : {ens X}} (H : A <= B)
  : Map A B := map x => $[$x].

Definition ens_eq2 {X} (A B : {ens X}) := A <= B /\ B <= A.
Lemma enseq2_eq {X} (A B : {ens X}) : (ens_eq2 A B) == (A == B).
Proof.
  split.
  - intros [H H0] x y E. rewrite E. split;
    sigapply H || sigapply H0.
  - intros E. split; rewrite E; now intros [x H].
Defined.

Program Definition subens_ens {X} {A B : {ens X}}
  (_ : A <= B) : {ens B} := [ x : B | A x ].

Definition disjoint {X} {A B : {ens X}}
  := forall x : X, ~ (A x /\ B x).
Notation "A :><: B" := (@disjoint _ A B)
  (at level 70, no associativity) : setoid_scope.

Program Definition ensTfor (X : Setoid) := [ _ : X | True ].
Program Definition ens0 {X : Setoid} := [ _ : X | False ].
Program Definition ens1 {X : Setoid} a := [ x : X | x == a ].
Program Definition ensU {X} (A B : {ens X}) := [ x | A x \/ B x ].
Program Definition ensI {X} (A B : {ens X}) := [ x in A | B x ].
Program Definition ensC {X} (A : {ens X}) := [ x | ~ A x ].
Program Definition ensD {X} (A B : {ens X}) := [ x in A | ~ B x ].
Program Definition powens {X} (A : {ens X}) := [ B | B <= A ].

Program Definition idTmap {X : Setoid} := map _ : X => True.
Definition inT {X : Setoid} (a : X) := @Build_sigS X idTmap a I.

Notation "\0" := (@ens0 _) : setoid_scope.
Notation "[ == a ]" := (ens1 a)
  (at level 0, a at level 99, format "[ ==  a ]") : setoid_scope.
Notation "[ == a : T ]" := [ == (a : T)]
  (at level 0, a at level 99, format "[ ==  a   :  T ]")
  : setoid_scope.
Notation "A :|: B" := (ensU A B)
  (at level 50, left associativity): setoid_scope.
Notation "a |: A" := ([ == a] :|: A)
  (at level 50, left associativity) : setoid_scope.
Notation "[ == a1 ; a2 ; .. ; an ]" :=
  (ensU .. (a1 |: [ == a2]) .. [ == an])
  (at level 0, a1 at level 99,
   format "[ ==  a1 ;  a2 ;  .. ;  an ]") : setoid_scope.
Notation "A :&: B" := (ensI A B)
  (at level 40, left associativity) : setoid_scope.
Notation "~: A" := (ensC A)
  (at level 35, right associativity) : setoid_scope.
Notation "[ == ~ a ]" := (~: [ == a ])
  (at level 0, format "[ == ~  a ]") : setoid_scope.
Notation "A :\: B" := (ensD A B)
  (at level 50, left associativity) : setoid_scope.
Notation "A :\ a" := (A :\: [ == a ])
  (at level 50, left associativity) : setoid_scope.

Program Definition ensUInf `(S : {ens {ens X}}) :=
  [ x : X | exists U : S , ($U) x ].
Next Obligation.
  intros x y E. split; intros [U H]; exists U; now rewrite2 E.
Defined.

Program Definition ensIInf `(S : {ens {ens X}}) :=
  [ x : X | forall U : S, ($U) x ].
Next Obligation.
  intros x y E. split; intros H U; rewrite2 E; apply H.
Defined.

Program Definition imens {X Y} := dmap (f : Map X Y)
  (A : {ens X}) => [ y | exists (a : A), y == f a ].
Next Obligation.
  intros x y E. split; intros [a H]; exists a;
  now rewrite2 E.
Defined.
Next Obligation.
  intros f1 f2 Ef A1 A2 E. split; intros [[a Ha] E0]; simpl;
  existsS a; rewrite map_comap; (try now rewrite2 E);
  rewrite2 Ef; now rewrite2 H.
Defined.
Notation "f @: A" := (@imens _ _ f A)
  (at level 24, right associativity) : setoid_scope.

Program Definition preimens {X Y} := dmap (f : Map X Y)
  (B : {ens Y}) => [ x | B (f x) ].
Next Obligation.
  intros f f0 Ef A A0 E x y H. split; intros H0; simpl;
  rewrite !map_comap; rewrite2 E; rewrite2 Ef; now rewrite2 H.
Defined.
Notation "f -@: B" := (@preimens _ _ f B)
  (at level 24, right associativity) : setoid_scope.

Class Injective {A B : Setoid} (f : A -> B) := {
  inj : forall x y, f x == f y -> x == y
}.

Class Surjective {A B : Setoid} (f : A -> B) := {
  surj : forall y, exists x, y == (f x)
}.
Arguments surj {_} {_} _ {_}.

Class Bijective {A B : Setoid} (f : A -> B) := {
  bij_inj :> Injective f;
  bij_surj :> Surjective f
}.
#[global] Existing Instances bij_inj bij_surj.

Program Definition mapcomp {X Y Z} (f : Map X Y) (g : Map Y Z)
  : Map X Z := map x => g (f x).
Notation "g 'o' f" := (@mapcomp _ _ _ f g)
  (at level 60, right associativity) : setoid_scope.

Program Definition dmmcomp1 {X Y Z W} (f : Dymap X Y Z)
  (g : Map W X) := dmap w y => f (g w) y.
Notation "f 'o1' g" := (@dmmcomp1 _ _ _ _ f g)
  (at level 50, left associativity) : setoid_scope.

Program Definition dmmcomp2 {X Y Z W} (f : Dymap X Y Z)
  (g : Map W Y) := dmap x w => f x (g w).
Notation "f 'o2' g" := (@dmmcomp2 _ _ _ _ f g)
  (at level 50, left associativity) : setoid_scope.

Program Definition mdmcomp {X Y Z W} (g : Map Z W)
  (f : Dymap X Y Z) := dmap x y => g (f x y).
Notation "g o< f" := (@mdmcomp _ _ _ _ g f)
  (at level 60, right associativity) : setoid_scope.

Program Definition dmap21 {X Y Z} (f : Dymap X Y Z)
  := dmap y x => f x y.
Notation "f ><" := (@dmap21 _ _ _ f)
  (at level 10, left associativity) : setoid_scope.

Lemma mapcomp_reduc {X Y Z} {f g : Map Y Z} {h : Map X Y} :
  Surjective h -> f o h == g o h -> f == g.
Proof.
  intros [Sh] Heq x y Heq1. destruct (Sh y) as [x0 Heq2].
  rewrite Heq1, Heq2. now apply Heq.
Qed.

Lemma mapcomp_assoc {X Y Z W} {f : Map Z W} {g : Map Y Z}
  {h : Map X Y} : (f o g) o h == f o g o h.
Proof. intros x y Heq. now rewrite Heq. Qed.

#[global]
Instance sval_inj `{P : {pred X}} : Injective (@sval _ P).
Proof. split; intuition. Qed.

Program Canonical Structure PairSetoid (X Y : Setoid) :=
  [ ==: (p : X * Y) q => p.1 == q.1 /\ p.2 == q.2 ].
Next Obligation.
  split.
  - intros p. split; now simpl.
  - intros p1 p2 [E1 E2]. now split.
  - intros p1 p2 p3 [E1 E2] [E3 E4]. split;
    now rewrite E1 || rewrite E2.
Defined.

Program Definition pairens {X Y} (A : {ens X}) (B : {ens Y})
  : {ens (X * Y)%type} := [ p | A p.1 /\ B p.2 ].
Next Obligation.
  intros p1 p2 [E1 E2]. split; intros [Ap Bp]; split;
  try (now rewrite2 E1); now rewrite2 E2.
Defined.
Notation "{  A  ,  B  }" := (@pairens _ _ A B)
  (at level 0, A, B at level 99, no associativity)
  : setoid_scope.

Program Definition dmap_pmap `(f : Dymap X Y Z)
  : Map (X * Y)%type Z := map p => f p.1 p.2.
Next Obligation.
  intros p1 p2 [E1 E2]. now rewrite E1, E2.
Defined.

Program Definition imens2 `(f : Dymap X Y Z) :=
  dmap (A : {ens X}) (B : {ens Y})
  => [ z | exists (a : A) (b : B), z == f a b ].
Next Obligation.
  intros z1 z2 E. split; intros [a [b E1]];
  exists a, b; now rewrite2 E.
Defined.
Next Obligation.
  intros A A0 EA B B0 EB. split; intros [[a Aa] [[b Bb] E]];
  existsS a; try existsS b; (try now rewrite <-E);
  rewrite map_comap; (try now rewrite2 EA); now rewrite2 EB.
Defined.
Notation "f @2: ( A , B )" := (@imens2 _ _ _ f A B)
  (at level 24, right associativity) : setoid_scope.

Program Definition dmap_curry1_map `(f : Dymap X Y Z)
  := map (x : X) => map by f x.
Notation "f '^m'" := (@dmap_curry1_map _ _ _ f)
  (at level 10, no associativity) : setoid_scope.

Program Definition dmap_curry2_map `(f : Dymap X Y Z)
  := map (y : Y) => map x => f x y.
Notation "f ^~" := (@dmap_curry2_map _ _ _ f)
  (at level 10, no associativity) : setoid_scope.

Definition Ope X := Map X X.
Definition Binop X := Dymap X X X.

Class Associative {X : Setoid} (op : X -> X -> X) := {
  assoc : forall x y z, op x (op y z) == op (op x y) z
}.

Class LIdentical {X : Setoid} (op : X -> X -> X) e := {
  identl : forall x, op e x == x
}.

Class RIdentical {X : Setoid} (op : X -> X -> X) e := {
  identr : forall x, op x e == x
}.

Class Identical {X : Setoid} (op : X -> X -> X) e := {
  id_identl :> LIdentical op e;
  id_identr :> RIdentical op e
}.
#[global] Existing Instances id_identl id_identr.

Close Scope setoid_scope.


Require Import Crypto.Specific.Framework.RawCurveParameters.
Require Import Crypto.Util.LetIn.

(***
Modulus : 2^206 - 5
Base: 25.75
***)

Definition curve : CurveParameters :=
  {|
    sz := 8%nat;
    base := 25 + 3/4;
    bitwidth := 32;
    s := 2^206;
    c := [(1, 5)];
    carry_chains := Some [seq 0 (pred 8); [0; 1]]%nat;

    a24 := None;
    coef_div_modulus := Some 2%nat;

    goldilocks := None;
    karatsuba := None;
    montgomery := false;
    freeze := Some true;
    ladderstep := false;

    mul_code := None;

    square_code := None;

    upper_bound_of_exponent_loose := None;
    upper_bound_of_exponent_tight := None;
    allowable_bit_widths := None;
    freeze_extra_allowable_bit_widths := None;
    modinv_fuel := None
  |}.

Ltac extra_prove_mul_eq _ := idtac.
Ltac extra_prove_square_eq _ := idtac.


Require Import
        Fiat.BinEncoders.Env.Common.Specs
        Fiat.BinEncoders.Env.Lib2.WordOpt.
Require Import
        Bedrock.Word
        Coq.Strings.Ascii
        Coq.Numbers.BinNums
        Coq.NArith.BinNat.

Section Ascii.
  Context {B : Type}.
  Context {cache : Cache}.
  Context {cacheAddNat : CacheAdd cache nat}.
  Context {transformer : Transformer B}.
  Context {transformerUnit : QueueTransformerOpt transformer bool}.

  Definition encode_ascii_Spec (c : ascii) (ce : CacheEncode)
    : Comp (B * CacheEncode) :=
    encode_word_Spec (NToWord 8 (N_of_ascii c)) ce.

  Definition encode_ascii_Impl (c : ascii) (ce : CacheEncode)
    : B * CacheEncode :=
    encode_word_Impl (NToWord 8 (N_of_ascii c)) ce.

  Definition decode_ascii (b : B) (cd : CacheDecode) : option (ascii * B * CacheDecode) :=
    `(n, b, cd) <- decode_word (sz:=8) b cd;
      Some (ascii_of_N (wordToN n), b, cd).

  Open Local Scope nat.
  Theorem Ascii_decode_correct
          {P : CacheDecode -> Prop}
          (P_OK : forall b cd, P cd -> P (addD cd b))
    :
      encode_decode_correct_f cache transformer (fun n => True)
                              (fun _ _ => True)
                              encode_ascii_Spec decode_ascii P.
  Proof.
    unfold decode_ascii; split.
    {
      intros env env' xenv c c' ext env_OK Eeq Ppred Ppred_rest Penc.
      destruct (proj1 (Word_decode_correct (sz := 8) P_OK) _ _ _ _ _ ext env_OK Eeq I I Penc) as [? [? [? xenv_OK] ] ].
      rewrite H; simpl.
      eexists; intuition eauto.
      repeat f_equal.
      rewrite wordToN_nat. rewrite NToWord_nat.
      destruct (wordToNat_natToWord' 8 (BinNat.N.to_nat (N_of_ascii c))).
      assert (x0 = 0).
      { destruct x0; eauto; exfalso.
        remember (wordToNat (natToWord 8 (BinNat.N.to_nat (N_of_ascii c)))) as xx; clear Heqxx.
        replace (xx + S x0 * pow2 8) with (256 + (xx + x0 * 256)) in H1.
        assert (BinNat.N.to_nat (N_of_ascii c) < 256).
        assert (N.lt (N_of_ascii c) 256).
        clear H. induction c; repeat (match goal with
                                      | B : bool |- _ => destruct B
                                      end); simpl; unfold Nlt; eauto.
        change (256%nat) with (N.to_nat 256).
        apply Nomega.Nlt_out. eauto.
        omega. change (pow2 8) with 256. omega.
      }
      subst. rewrite <- plus_n_O in H1. rewrite H1. clear H1.
      rewrite Nnat.N2Nat.id. rewrite ascii_N_embedding. eauto.
    }
    { intros env xenv xenv' n n' ext Eeq OK_env' Penc.
      destruct (decode_word n' xenv) as [ [ [? ? ] ? ] | ] eqn: ? ;
        simpl in *; try discriminate.
      injections.
      eapply (proj2 (Word_decode_correct P_OK)) in Heqo;
        destruct Heqo as [? [? ?] ]; destruct_ex; intuition; subst; eauto.
      unfold encode_word_Spec in *; computes_to_inv; injections.
      repeat eexists; eauto.
      repeat f_equal.
      rewrite N_ascii_embedding.
      rewrite NToWord_nat, wordToN_nat.
      rewrite Nnat.Nat2N.id.
      rewrite natToWord_wordToNat; eauto.
      rewrite wordToN_nat.
      pose proof (wordToNat_bound w).
      simpl in H2.
      eapply Nomega.Nlt_in.
      rewrite Nnat.Nat2N.id.
      eauto.
    }
  Qed.

  Lemma ascii_decode_lt
    : forall (b3 : B) (cd0 : CacheDecode) (a : ascii) (b' : B) (cd' : CacheDecode),
      decode_ascii b3 cd0 = Some (a, b', cd') -> lt_B b' b3.
  Proof.
    unfold decode_ascii; intros.
    destruct (WordOpt.decode_word b3 cd0) as [ [ [? ?] ?] | ] eqn: ? ;
      simpl in *; try discriminate.
    apply WordOpt.decode_word_lt in Heqo.
    injections; eauto.
  Qed.

  Lemma ascii_decode_le :
    forall (b : B) (cd : CacheDecode) (a : ascii) (b' : B) (cd' : CacheDecode),
      decode_ascii b cd = Some (a, b', cd') -> le_B b' b.
  Proof.
    unfold decode_ascii, DecodeBindOpt2; intros.
    destruct (decode_word b cd) as [ [ [? ? ] ?] | ] eqn: decode_b; simpl in H;
      try discriminate; injections.
    eauto using decode_word_le.
  Qed.

End Ascii.


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 AB BC ABC Cprime Bprime BCprime : Universe, ((wd_ A O /\ (wd_ B O /\ (wd_ C O /\ (wd_ O E /\ (wd_ O Eprime /\ (wd_ E Eprime /\ (wd_ Bprime O /\ (wd_ BC O /\ (wd_ C Cprime /\ (col_ O E A /\ (col_ O E B /\ (col_ O E AB /\ (col_ O E C /\ (col_ O E BC /\ (col_ O E ABC /\ (col_ O Eprime Cprime /\ (col_ O Eprime Bprime /\ col_ O Eprime BCprime))))))))))))))))) -> col_ O Bprime Cprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall A B C IB XB IA XA X : Universe, ((wd_ A B /\ (wd_ B C /\ (wd_ A C /\ (wd_ IB B /\ (wd_ IA A /\ (wd_ XA B /\ (wd_ XB A /\ (wd_ X A /\ (wd_ X B /\ (wd_ XB B /\ (wd_ XA A /\ (col_ A C X /\ (col_ XA X A /\ (col_ XB X B /\ (col_ B XA C /\ (col_ A XB C /\ (col_ A XA IA /\ col_ B XB IB))))))))))))))))) -> col_ C A IA)).
Proof.
  time tac.
Qed.

End FOFProblem.


(******************************************************************************
September 2004
Authors: Jean-Yves Vion-dury and Pierre Geneves
jean-yves.vion-dury@xrce.xerox.com
WAM Research Project, INRIA Rhone-Alpes and Xerox Research Center Europe

pierre.geneves@inrialpes.fr
WAM Research Project, INRIA Rhone-Alpes

Please do not reuse or publish this code without explicit consent from authors.

*********************************************************************************)
Require Import zorder.
Require Import graphInt.
Require Export xmlTree.
Require Import XPath.
Require Export XPathInduction.

(* ============================================================================= *)

Definition Tree := XTree.DGraph.
(*
Variable tree : Tree.
Hypothesis wfXml : wfXmlTree tree.
*)

(* Semantics of Axes and NodeTests *)

Definition test_node (t : Tree) (y : NodeTest) (x : NodeId) : bool :=
  match XTree.get_node t x with
  | Some node =>
      match node, y with
      | _, _node => true
      | element _, _any => true
      | attr _ _, _any => true
      | nmspace _, _any => true
      | text _, _text => true
      | element nm, name nm' => if XName.A_eq nm nm' then true else false
      | attr nm _, name nm'  => if XName.A_eq nm nm' then true else false
      | nmspace nm, name nm' => if XName.A_eq nm nm' then true else false
      | attr _ _, _attribute => true
      | element _, _element => true
      | comment _, _comment => true
      | pi _ _, _pi => true
      | _, _ => false
      end
  | None => false
  end.

Definition is_attr (t : Tree) (x : NodeId) : bool :=
  match XTree.get_node t x with
  | Some node => match node with
                 | attr _ _ => true
                 | _ => false
                 end
  | None => false
  end.

Definition is_nmspace (t : Tree) (x : NodeId) : bool :=
  match XTree.get_node t x with
  | Some node => match node with
                 | nmspace _ => true
                 | _ => false
                 end
  | None => false
  end.

(*
Definition f  (a:Axis) (x y:NodeId) (t:Tree) : Prop :=
match a with
| child =>  s_in y (XTree.children t x)=true
| descendant => s_in y (XTree.descendants t x)=true
| self => x=y
| descendant_or_self =>  x=y \/ (s_in y (XTree.descendants t x)=true)
| attribute => (s_in y (XTree.children t x)=true) /\ (is_attr t x)=true
| namespace => (s_in y (XTree.children t x)=true) /\ (is_nmspace t x)=true
end.
*)

Definition f  (a:Axis) (x:NodeId) (t:Tree) : NodeSet :=
match a with
| child =>  XTree.children t x
| descendant => XTree.descendants t x
| self => single x
| descendant_or_self =>  ZSet.union (ZSet.single x) (XTree.descendants t x)
| attribute => ZSet.filter (XTree.children t x) (is_attr t)
| namespace => ZSet.filter (XTree.children t x) (is_nmspace t)
end.

(* test wether x2 is before x1 *)
Definition order_before (t : Tree) (x1 x2 : NodeId) :=
  match XTree.get_order t x1 with
  | Some i1 =>
      match XTree.get_order t x2 with
      | Some i2 => Zlt_bool i2 i1
      | _ => false
      end
  | _ => false
  end.

(* test wether x2 is after x1 *)
Definition order_after (t : Tree) (x1 x2 : NodeId) :=
  match XTree.get_order t x1 with
  | Some i1 =>
      match XTree.get_order t x2 with
      | Some i2 => Zlt_bool i1 i2
      | _ => false
      end
  | _ => false
  end.

Module M_Phi := genMapping myOrder M3.
Definition Phi := M_Phi.Mapping.

(* Denotational Semantics *)

Fixpoint semanS (env : Phi) (t : Tree) (p : XPath)
 (x : NodeId) {struct p} : NodeSet :=
  match p with
  | void => emptyNS
  | top => XTree.roots t x
  | slash p1 p2 => ZSet.product (semanS env t p1 x) (semanS env t p2)
  | union p1 p2 => ZSet.union (semanS env t p1 x) (semanS env t p2 x)
  | inter p1 p2 => ZSet.inter (semanS env t p1 x) (semanS env t p2 x)
  | qualif p1 q2 => ZSet.filter (semanS env t p1 x) (semanQ env t q2)
  | step a n => ZSet.filter (f a x t) (test_node t n)
  end

 with semanQ (env : Phi) (t : Tree) (q : XQualif) (x : NodeId) {struct q} :
 bool :=
  match q with
  | _true => true
  | _false => false
  | not q1 => if semanQ env t q1 x then false else true
  | and q1 q2 => if semanQ env t q1 x then semanQ env t q2 x else false
  | or q1 q2 => if semanQ env t q1 x then true else semanQ env t q2 x
  | leq p1 p2 => ZSet.incl (semanS env t p1 x) (semanS env t p2 x)
  end.

(* Logical Semantics *)

Fixpoint Rp (t : Tree) (p : XPath) (x y : NodeId) {struct p} : Prop :=
  match p with
  | void => False
  | top => s_in y (XTree.roots t x)=true
  | union p1 p2 => Rp t p1 x y \/ Rp t p2 x y
  | inter p1 p2 => Rp t p1 x y /\ Rp t p2 x y
  | slash p1 p2 => exists z : NodeId, Rp t p1 x z  /\  Rp t p2 z y
  | qualif p q => Rp t p x y /\ Rq t q y
  | step a n => (s_in y (f a x t))=true /\ (test_node t n y)=true
  end

 with Rq (t : Tree) (q : XQualif) (x : NodeId) {struct q} : Prop :=
  match q with
  | _true => True
  | _false => False
  | not q => ~ Rq t q x
  | and q1 q2 => Rq t q1 x /\ Rq t q2 x
  | or q1 q2 => Rq t q1 x \/ Rq t q2 x
  | leq p1 p2 => forall z : NodeId, Rp t p1 x z -> Rp t p2 x z
  end.

Require Import XPathGrammar.

 Notation "'Ƥ' [ p ] ( tree , x ↝  y ) " := (Rp tree p x y) (at level 0) : Xp.
 Notation "'ǫ' [ q ] ( tree , x ) " := (Rq tree q x) (at level 0) : Xq.

(* just to check the parsing of notation*)
 Remark AA: forall x y:NodeId,  forall tree:Tree,  Ƥ[void ] ( tree , x  ↝ y ).
Abort.

  (* Pourquoi ne pas faire un interpreteur avec une relation inductive
  ca permettrait d'utiliser constructor et inversion!!

  pb: il faudrait la caractériser... (terminaison)*)


Require Import Verse.
Import VerseNotations.
Require Import Verse.CryptoLib.blake2.
Require Import PeanoNat.
Require Import Bvector.
Require Import BinNat.
Require Import NArith.

(** * Blake2 implementation in C

This module provides the implementation of blake2 hashes in C. Both
blake2b and blake2s implementations can be recovered from this module
by passing the apporpriate config module [C : CONFIG].

*)

Module Blake2 (C : CONFIG).

  Import C.

  Definition Hash  := Array HASH_SIZE  hostE Word.
  Definition Block := Array BLOCK_SIZE littleE Word.
  Definition IV i (pf : i < 8) := Vector.nth_order IVVec pf.

  (** Unlike the sha2 hashes, there is a difference in the structure
      of blake2 in that there are special steps to be taken for the
      last block. We leave out the padding issue for the last block
      and expect the calling function to take care of this. Even
      ignoring the padding, there are certain differences in the two.

      - As opposed to a Merkel-Damgard hash like sha512, every block
        needs the length of the message hashed sofar as its
        argument. In the initial blocks, the lengths get updated by
        the blocksize. However, the last block could be partial and
        hence including this length in the compression should be done
        carefully.

      - The last block also needs special finalisation flags. While,
        these flags can be fixed when blake2 is run as a cryptographic
        hash, the blake2 standard allows for other modes of operation
        like message authentication and tree hashing which uses
        different finalisation flags. Implementations here provide the
        flexibility for tweaking these.

      Due to the above reason, the module provides two functions, a
      _blake2 iterator_, or _iterator_ for short that handles data in
      multiples of blocks, and the _blake2 last block compressor_ or
      _compressor_ for short which handles the last block of the
      message.

      We follow the standard idiom where the code for the iterator and
      the last block compressor is wrapped into a section called
      [Program].  *)

  Section Program.

    (** ** Program variables.

      The program parameters and other variables become parameters to
      the section of type [VariableT]. The iterator and the last block
      compressor share a lot of program variables but there are indeed
      variables that are relevant to one but not the other. We define
      all these variables together in the same section. Since any coq
      definition inside a section only has parameters that are
      mentioned in the definiton, this works out well for use. The
      only difference is that we need to be have two sets of
      parameter, stack and register declaration in the code.

     *)

    Variable progvar : VariableT.

    Section Params.
      (** *** Parameters.

          The difference in the parameter list comes due to the
          following reasons.

          - The iterator does not need to mention its message and the
            count as these are implicitly supplied during the code
            generation of an iterator, where as for the last block
            compressor needs to define these explicitly.

          - The iterator is not done with the message yet, so it has a
            responsibility to update the total count of bytes
            processed.  On the other hand the last block compressor
            only needs the count of the bytes processed while
            compressing the last block. Since there are no more blocks
            of message, it need not update the count value. Due to the
            above difference, the count, kept track of using two
            words, is passed as a reference variable in iterator as
            opposed to normal variables in the last block compressor.

          - Finally the last block compressor needs finalisation
            constants that need to be passed around which clearly the
            iterator does not need

          To summarise we have the following

          - The reference variables [UpperRef], and [LowerRef] that is
            unique to to the iterator,

          - The variables [LastBlock], [NBytes], [Upper] [Lower], [f0]
            and [f1] unique to the last block iterator, and

          - The variable [hash] which is common to both.

       *)

    Variable UpperRef LowerRef : progvar of type (Ref Word).

    Variable LastBlock : progvar of type Block.
    Variable NBytes    : progvar of type Word.
    Variable Upper Lower : progvar of type Word.
    Variable f0 f1: progvar of type Word.

    Variable hash : progvar of type Hash.

    Section Locals.

      (** *** The local variables

        The iterator also keeps a copy of the hash in local variables
        to speed up access. On register rich machines this could
        potentially end up on actual registers and hence could become
        fast.

       *)

      Variable H : Vector.t (progvar of type Word) 8.
      Variable message_variables : Vector.t (progvar of type Word) 16.

    (** *** The state variables

        The state of the hashing function is a 4x4 matrix of
        words. The rounds transform this state using the [G] functions
        applied to either the rows or the diagonals of this matrix.

     *)
      Variable v0 v4 v8  v12
               v1 v5 v9  v13
               v2 v6 v10 v14
               v3 v7 v11 v15 : progvar of type Word.

      Definition state := [ v0 ; v4 ; v8  ; v12;
                            v1 ; v5 ; v9  ; v13;
                            v2 ; v6 ; v10 ; v14;
                            v3 ; v7 ; v11 ; v15
                          ].

      (** *** Variables to maintain byte count

          Recall that each of the blake2 blocks is compressed using a
          compression function that makes use of the length of the
          message as auxiliary input. The message length is kept track
          of as a set of two words and hence we need to explicitly do
          arithmetic in twice the precision. In the iterator this byte
          count is kept in the reference variables [UpperRef] and
          [LowerRef] where as in the last block compressor it is
          merely passed as parameters [Upper] and [Lower]. As a result
          these functions have the following additional register
          variables.

          - The [C] and the [LMSB] registers used to perform the count
            update with twice the precision. The variable [C] is used
            to compute the carry generated when the lower words are
            added and the [LMSB] is used as an intermediate register
            to hold the most significant bit of the lower portion of
            the count.

          - The iterator also define two variables [U] and [V] that is
            to be used instead of the reference variables [UpperRef] and
            [LowerRef].

       *)

      Variable C LMSB : progvar of type Word.
      Variable U L    : progvar of type Word.

      (** ** Updating the count.

        The main idea is to compute the carry arising while adding the
        lower word.

        - Compute the carry occurring on most significant bit by
          masking off the MSB and performing the addition. Shift it to
          the least significant bit.

        - Compute the MSB of the lower word and shift it to the least
          significant bit.

        - Add the previous two carries to obtain the carry occurring
          on the MSB of the lower word in bit position 2.

        - Shift it right once more to obtain the actual carry.

       *)

      Section UpdateCount.

        Hint Resolve Nat.add_pos_pos : natineq.
        Hint Resolve Nat.add_pos_nonneg : natineq.
        Hint Constructors le : natineq.
        Lemma zeroLtPower2 : forall n, 0 < 2 ^ n.
          intros; induction n; simpl; eauto with natineq.
        Qed.
        Hint Resolve zeroLtPower2 : natineq.

      (* To make the update count work uniformly both for the iterator
         as well as the last block compressor, we need to parameterise
         over both the upper and lower arguments and also the size
         argument.
       *)

      Variable A : Type.
      Variable a_is_expr : EXPR progvar Word A.
      Variable byteCount : A.

      Definition UPDATE_COUNTER (u l : progvar of type Word) : Repeat (statement progvar) :=
        [code| (* We first ensure that the variable C gets the carry that overflows
             when l is added bsize. For this we first need to get the msb of l
             into the lsb position
           *)
          LMSB := l;
          `toTopBitsUpdate 1 LMSB`; (* get the msb to the lsb *)
          (* Now get the carry that flows into MSB from the previous bits *)
          C  := `clearOnlyUpper 1 l`; (* select every bit except msb *)
          C  += byteCount;         (* carry at the msb position   *)
          `toTopBitsUpdate 1 C`;         (* move it to the lsb *)

          C  += LMSB; (* the second now has the carry of the addition    *)
          C  ≫= `1`;   (* move it to the lsb so that it can be added to u *)

          (* increment the u:l byte count. u gets added the carry and
             l the bsize
           *)
        u  += C;
        l  += byteCount

        |].

      End UpdateCount.

    Arguments UPDATE_COUNTER [A a_is_expr] _ _ _ .

    (** The update count function as defined for the iterator and the
        last block compressor respectively *)

    Definition BSIZE : nat := (BLOCK_SIZE * size Word).
    Definition UPDATE_COUNTER_ITER := UPDATE_COUNTER BSIZE U L.

    Definition UPDATE_COUNTER_LAST := UPDATE_COUNTER NBytes Upper Lower.

    (** ** The blake round function.

      A single round of blake function consists of performing the G
      function, first on the rows and then on the diagonals of the
      state matrix. The message words that are used change merely
      permuted and then used respectively.

     *)

    (** *** The G function.

        The G function defined below takes 4 words which constitute
        either a row or a diagonal of the state matrix. In addition it
        takes two message words

     *)

    Definition G (a b c d m0 m1 : progvar of type Word) : Repeat (statement progvar) :=
      [code|
        a += b; a += m0; d ⊕= a; d := d ⋙ R0;
        c += d;          b ⊕= c; b := b ⋙ R1;
        a += b; a += m1; d ⊕= a; d := d ⋙ R2;
        c += d;          b ⊕= c; b := b ⋙ R3
      |].

    (** *** Message permutations.

       Each round uses the entire set of the message word but
       in different order captured by a message permutations

     *)

    Definition Perm := Vector.t {i | i < BLOCK_SIZE} BLOCK_SIZE.
    Definition RoundPerms : Vector.t Perm 10
      := [
          shuffleIndices [0 ;  1;  2;  3;  4;  5;  6;  7;  8;  9; 10; 11; 12; 13; 14; 15];
	  shuffleIndices [14; 10;  4;  8;  9; 15; 13;  6;  1; 12;  0;  2; 11;  7;  5;  3];
	  shuffleIndices [11;  8; 12;  0;  5;  2; 15; 13; 10; 14;  3;  6;  7;  1;  9;  4];
	  shuffleIndices [7 ;  9;  3;  1; 13; 12; 11; 14;  2;  6;  5; 10;  4;  0; 15;  8];
	  shuffleIndices [9 ;  0;  5;  7;  2;  4; 10; 15; 14;  1; 11; 12;  6;  8;  3; 13];
	  shuffleIndices [2 ; 12;  6; 10;  0; 11;  8;  3;  4; 13;  7;  5; 15; 14;  1;  9];
	  shuffleIndices [12;  5;  1; 15; 14; 13;  4; 10;  0;  7;  6;  3;  9;  2;  8; 11];
	  shuffleIndices [13; 11;  7; 14; 12;  1;  3;  9;  5;  0; 15;  4;  8;  6;  2; 10];
	  shuffleIndices [6 ; 15; 14;  9; 11;  3;  0;  8; 12;  2; 13;  7;  1;  4; 10;  5];
          shuffleIndices [10;  2;  8;  4;  7;  6;  1;  5; 15; 11;  9; 14;  3; 12; 13;  0]
        ]%vector.

    (** Let us digress a bit and prove that the above shuffles are
        indeed permutations.  *)
    Tactic Notation "crush_forall" tactic(tac)
      := repeat match goal with
                | [ |- Vector.Forall _  _  ] => constructor
                | _ => tac
                end.

    Theorem round_perms_are_permutations :  Vector.Forall (@Permutation BLOCK_SIZE) RoundPerms.
    (** TODO This proof is too slow in the current version fix it *)
    (*
      crush_forall (compute; crush_permutation_obligation 16).
      Qed.
     *)

    Abort.

    (** *** The round function.

         We now give the blake round function as a section
         parameterised by the round number.

     *)
    Section Round.

      Variable r : nat.

      (** The register cache corresponding to the permuted message *)
      Definition M : VarIndex progvar BLOCK_SIZE Word.
        verse (varIndex (select message_variables
                                (@Vector.nth_order _ _ RoundPerms (r mod 10) _))).
      Defined.

      Definition BLAKE_ROUND : Repeat (statement progvar).
        verse (G v0 v4 v8  v12 (M 0 _) (M 1 _) ++
               G v1 v5 v9  v13 (M 2 _) (M 3 _) ++
               G v2 v6 v10 v14 (M 4 _) (M 5 _) ++
               G v3 v7 v11 v15 (M 6 _) (M 7 _) ++

               G v0 v5 v10 v15 (M 8 _)  (M 9  _) ++
               G v1 v6 v11 v12 (M 10 _) (M 11 _) ++
               G v2 v7 v8  v13 (M 12 _) (M 13 _) ++
               G v3 v4 v9  v14 (M 14 _) (M 15 _))%list.
      Defined.
    End Round.

    (** The entire set of rounds *)
    Definition ALL_ROUNDS := iterate (fun r (_ : r < ROUNDS) => BLAKE_ROUND r).

    Definition SETUP : Repeat (statement progvar).
      verse ( [code| U := UpperRef [ 0 ]; L := LowerRef [ 0 ] |] ++ loadCache hash H )%list.
    Defined.

    (** ** The initialisation of state.

        The initialisation uses the previous hash values and the
        iv. Depending on whether the initialisation for a block in
        between or the last block there is a slight difference in the
        initialisation code.

     *)
    Definition INIT_STATE : Repeat (statement progvar).
      verse
        [code|
          v0  := H[0];
	  v1  := H[1];
	  v2  := H[2];
	  v3  := H[3];
	  v4  := H[4];
	  v5  := H[5];
	  v6  := H[6];
	  v7  := H[7];
          v8  := IV[0];
	  v9  := IV[1];
	  v10 := IV[2];
	  v11 := IV[3];
	  v12 := IV[4] ⊕ L;
	  v13 := IV[5] ⊕ U;
	  v14 := IV[6];
	  v15 := IV[7]
        |].
    Defined.

    Definition INIT_STATE_LAST : Repeat (statement progvar).
      verse
        [code|
          v0 := H[0];
	  v1 := H[1];
	  v2 := H[2];
	  v3 := H[3];
	  v4 := H[4];
	  v5 := H[5];
	  v6 := H[6];
	  v7 := H[7];
	  v8  := IV[0];
	  v9  := IV[1];
	  v10 := IV[2];
	  v11 := IV[3];
	  v12 := IV[4] ⊕ Lower;
	  v13 := IV[5] ⊕ Upper;
	  v14 := IV[6] ⊕ f0;
	  v15 := IV[7] ⊕ f1
        |].
      Defined.

    (** ** Load message into register cache.

        To speed up the hashing we load the message into the register
        cache W.

     *)
    Definition W : VarIndex progvar BLOCK_SIZE Word := varIndex message_variables.
    Definition LOAD_MESSAGE_I (blk : progvar of type Block) (i : nat) (pf : i < BLOCK_SIZE)
      : Repeat (statement progvar).
      verse [code| `W i _` := blk [ i ] |].
    Defined.
    Definition LOAD_MESSAGE (blk : progvar of type Block)
      := foreach (indices blk) (LOAD_MESSAGE_I blk).

    (** ** Updating the hash.

        After performing the rounds of blake, the hash gets updated as follows.

     *)
    Definition UPDATE_HASH : Repeat (statement progvar).
      verse
      [code|
        H[0] ⊕= v0 ; H[0] ⊕= v8;
        H[1] ⊕= v1 ; H[1] ⊕= v9;
        H[2] ⊕= v2 ; H[2] ⊕= v10;
        H[3] ⊕= v3 ; H[3] ⊕= v11;
        H[4] ⊕= v4 ; H[4] ⊕= v12;
        H[5] ⊕= v5 ; H[5] ⊕= v13;
        H[6] ⊕= v6 ; H[6] ⊕= v14;
        H[7] ⊕= v7 ; H[7] ⊕= v15
      |].
      Defined.

    (** In the iterator one needs to update the hash array as well as
        the reference variables UpperRef and LowerRef.  *)
    Definition FINALISE : Repeat (statement progvar).
      verse ([code| UpperRef [ 0 ] <- U ; LowerRef [ 0 ] <- L |] ++ moveBackCache hash H )%list.
    Defined.

    Definition PROCESS_BLOCK blk :=
      ( LOAD_MESSAGE blk
                     ++ ALL_ROUNDS
                     ++ UPDATE_HASH)%list.

    (** ** The BLAKE2 iterator and the last block compressor.  *)
    Definition compress : iterator progvar Block :=
      {| setup   := SETUP;
         process := fun blk => (UPDATE_COUNTER_ITER ++ INIT_STATE ++ PROCESS_BLOCK blk);
         finalise := FINALISE
      |}%list.

    Definition lastBlock : Repeat (statement progvar) :=
      (loadCache hash H
                 ++ UPDATE_COUNTER_LAST
                 ++ INIT_STATE_LAST
                 ++ PROCESS_BLOCK  LastBlock
                 ++ moveBackCache hash H)%list.

    End Locals.
    Definition Compressor := do compress end.
    Definition LastBlockCompressor := do lastBlock end.

    End Params.
  End Program.

End Blake2.


Require Import Syntax.
Require Import SemanticsStatic.
Require Import Coq.Strings.String.

Definition testPsi0: reactiveEnv := Datatypes.nil.
Definition testPsi1: reactiveEnv := Datatypes.cons (Signal Unit on Peer "_") Datatypes.nil.
Definition testGamma1: varEnv := idUpdate (Id "x") Tnat (idUpdate (Id "y") Unit idEmpty).
Definition testDelta1: placeEnv := idUpdate (Id "x") (Unit on (Peer "px")) idEmpty.
Definition testTies1 := Ties [
  "p0" -*-> "pm", "p0" -?-> "po", "p0" -1-> "ps", "p0" -0-> "pn",
  "pm" -1-> "p0", "po" -1-> "p0", "ps" -1-> "p0", "pn" -1-> "p0"].
Definition testPeerTyping1 := TypedInstances [
  4 : "pm", 3 : "po", 2 : "ps", 1 : "pn", 0 : "p0"].

Example a1:
  (Program NoTies NoTypedInstances) :: testPsi0; emptyPlaceEnv; emptyVarEnv; Peer "dummy"
  |- lambda (Id "x") Unit (idApp (Id "x")) : Unit ~> Unit.
Proof.
apply T_Abs.
apply T_Var.
simpl.
unfold idUpdate, Maps.p_update, Maps.t_update.
destruct id_dec; try contradiction.
left.
reflexivity.
Qed.

Example a2:
  (Program testTies1 testPeerTyping1) :: testPsi0; emptyPlaceEnv; emptyVarEnv; Peer "p0"
  |- asLocalIn (Id "x") Unit unit (idApp (Id "x")) (Unit on (Peer "po")) : Option Unit.
Proof.
eapply T_Comp.
- apply U_Unit.
- apply U_Unit.
- apply T_Unit.
- apply T_Var.
  simpl.
  unfold idUpdate, Maps.p_update, Maps.t_update.
  destruct id_dec; try contradiction.
  left.
  reflexivity.
- cbv. split. + congruence. + congruence.
- reflexivity.
Qed.

Example a3:
  ~ (Program testTies1 testPeerTyping1) :: testPsi0; emptyPlaceEnv; emptyVarEnv; Peer "p0"
    |- asLocalIn (Id "y") Unit unit (idApp (Id "x")) (Unit on (Peer "po")) : Option Unit.
Proof.
intro.
inversion H.
contradict H15.
clear.
intro.
inversion H.
contradict H6.
clear.
intro.
destruct H.
- unfold idUpdate, Maps.p_update, Maps.t_update in H.
  case_eq (id_dec (Id "x") (Id "y")); intros H_eq.
  + inversion H_eq.
  + inversion H.
- destruct H.
  unfold emptyPlaceEnv, idEmpty, Maps.p_empty in H0.
  inversion H0.
Qed.

Example a4:
  (Program testTies1 testPeerTyping1) :: testPsi0; emptyPlaceEnv; emptyVarEnv; Peer "p0"
  |- lambda (Id "x") Unit (asLocalIn (Id "x") Unit unit (idApp (Id "x")) (Unit on (Peer "po"))) : Unit ~> Option Unit.
Proof.
apply T_Abs.
eapply T_Comp.
- apply U_Unit.
- apply U_Unit.
- apply T_Unit.
- apply T_Var.
  simpl.
  unfold idUpdate, Maps.p_update, Maps.t_update.
  destruct id_dec; try contradiction.
  left.
  reflexivity.
- cbv. split. + congruence. + congruence.
- reflexivity.
Qed.

Example a5:
  ~ (Program testTies1 testPeerTyping1) :: testPsi0; emptyPlaceEnv; emptyVarEnv; Peer "p0"
    |- lambda (Id "x") Unit (asLocalIn (Id "y") Unit unit (idApp (Id "x")) (Unit on (Peer "po"))) : Unit ~> Option Unit.
Proof.
intro.
inversion H.
contradict H6.
clear.
intro.
inversion H.
contradict H15.
clear.
intro.
inversion H.
contradict H6.
clear.
intro.
destruct H.
- unfold
    idUpdate, Maps.p_update, Maps.t_update,
    emptyVarEnv, idEmpty, Maps.p_empty in H.
  case_eq (id_dec (Id "x") (Id "y")); intros H_eq.
  + inversion H_eq.
  + inversion H.
- destruct H.
  unfold emptyPlaceEnv, idEmpty, Maps.p_empty in H0.
  congruence.
Qed.

Example test_pltIsWellTyped_TEnd_1:
  (Program NoTies NoTypedInstances) :: testPsi0; emptyPlaceEnv |- pUnit.
Proof. apply T_End. Qed.

Example test_pltIsWellTyped_TEnd_2:
  (Program NoTies NoTypedInstances) :: testPsi1; testDelta1 |- pUnit.
Proof. apply T_End. Qed.

Example test_hasType_TUnit_1:
  (Program NoTies NoTypedInstances) :: testPsi0; emptyPlaceEnv; emptyVarEnv; Peer "dummy" |- unit : Unit.
Proof. apply T_Unit. Qed.

Example test_pltIsWellTyped_TPlace_1:
  (Program NoTies NoTypedInstances) :: testPsi1; testDelta1 |- placed (Id "x") (Unit on (Peer "px")) unit pUnit.
Proof.
  apply T_Place.
  - apply T_End.
  - apply T_Unit.
Qed.

Example test_hasType_TVar_normalVar_1:
  (Program NoTies NoTypedInstances) :: testPsi0; emptyPlaceEnv; testGamma1; Peer "p1" |- idApp (Id "x") : Tnat.
Proof. apply T_Var. left. reflexivity. Qed.

Example test_hasType_TVar_placedVar_2:
  (Program NoTies NoTypedInstances) :: testPsi0; testDelta1; emptyVarEnv; Peer "px" |- idApp (Id "x") : Unit.
Proof. apply T_Var. right. split. - reflexivity. - reflexivity. Qed.

Example test_hasType_TAbs_1:
    (Program NoTies NoTypedInstances) :: testPsi0; emptyPlaceEnv; emptyVarEnv; Peer "dummy" |- lambda (Id "x") Tnat unit : Tnat ~> Unit.
Proof. apply T_Abs. apply T_Unit. Qed.

Example test_hasType_TAbs_2:
    (Program NoTies NoTypedInstances) :: testPsi0; emptyPlaceEnv; emptyVarEnv; Peer "dummy" |- lambda (Id "x") Tnat (idApp (Id "x")) : Tnat ~> Tnat.
Proof. apply T_Abs. apply T_Var. left. reflexivity. Qed.

Example test_hasType_TAbs_3:
  (Program NoTies NoTypedInstances) :: testPsi0; emptyPlaceEnv; testGamma1; Peer "_" |- lambda (Id "x") Unit (idApp (Id "x")) : Unit ~> Unit.
Proof. apply T_Abs. apply T_Var. left. reflexivity. Qed.

Example test_hasType_TApp_1:
  (Program NoTies NoTypedInstances) :: testPsi0; emptyPlaceEnv; emptyVarEnv; Peer "dummy" |- app (lambda (Id "x") Unit unit) unit : Unit.
Proof.
  apply T_App with (T2 := Unit).
  - apply T_Abs. apply T_Unit.
  - apply T_Unit.
Qed.

Example test_hasType_TApp_2:
  (Program NoTies NoTypedInstances) :: testPsi0; emptyPlaceEnv; emptyVarEnv; Peer "dummy" |- app (lambda (Id "x") Unit (idApp (Id "x"))) unit : Unit.
Proof.
  apply T_App with (T2 := Unit).
  - apply T_Abs. apply T_Var. left. reflexivity.
  - apply T_Unit.
Qed.

Example test_hasType_TNil_1:
  (Program NoTies NoTypedInstances) :: testPsi0; emptyPlaceEnv; emptyVarEnv; Peer "dummy" |- nil Unit : List Unit.
Proof. apply T_Nil. Qed.

Example test_hasType_TCons_1:
  (Program NoTies NoTypedInstances) :: testPsi0; emptyPlaceEnv; emptyVarEnv; Peer "dummy" |- cons unit (nil Unit) : List Unit.
Proof.
  apply T_Cons.
  - apply T_Unit.
  - apply T_Nil.
Qed.

Example test_hasType_TSome_1:
    (Program NoTies NoTypedInstances) :: testPsi0; emptyPlaceEnv; emptyVarEnv; Peer "dummy" |- some unit : Option Unit.
Proof. apply T_Some. apply T_Unit. Qed.

Example test_hasType_TNone_1:
    (Program NoTies NoTypedInstances) :: testPsi0; emptyPlaceEnv; emptyVarEnv; Peer "dummy" |- none Unit : Option Unit.
Proof. apply T_None. Qed.

Example test_hasType_TPeer_1:
  (Program testTies1 testPeerTyping1) :: testPsi0; emptyPlaceEnv; emptyVarEnv; Peer "p0" |- peerApp (Instance 0) : Remote (Peer "p0").
Proof. apply T_Peer. simpl. congruence. Qed.

Example test_hasType_TAsLocal_single_1:
  testTies1 (Peer "p0", Peer "ps") = Single /\
  (Program testTies1 NoTypedInstances) :: testPsi0; emptyPlaceEnv; emptyVarEnv; Peer "p0"
    |- asLocal unit (Unit on (Peer "ps")) : Unit.
Proof.
  split.
  - reflexivity.
  - apply T_AsLocal with (P0 := (Peer "p0")).
    + apply U_Unit.
    + apply T_Unit.
    + cbv. split. * congruence. * congruence.
    + reflexivity.
Qed.

Example test_hasType_TAsLocal_optional_1:
  testTies1 (Peer "p0", Peer "po") = Optional /\
  (Program testTies1 NoTypedInstances) :: testPsi0; emptyPlaceEnv; emptyVarEnv; Peer "p0"
    |- asLocal unit (Unit on (Peer "po")) : Option Unit.
Proof.
  split.
  - reflexivity.
  - apply T_AsLocal with (P0 := (Peer "p0")).
    + apply U_Unit.
    + apply T_Unit.
    + cbv. split. * congruence. * congruence.
    + reflexivity.
Qed.

Example test_hasType_TAsLocal_multiple_1:
  testTies1 (Peer "p0", Peer "pm") = Multiple /\
  (Program testTies1 NoTypedInstances) :: testPsi0; emptyPlaceEnv; emptyVarEnv; Peer "p0"
    |- asLocal unit (Unit on (Peer "pm")) : List Unit.
Proof.
  split.
  - reflexivity.
  - apply T_AsLocal with (P0 := (Peer "p0")).
    + apply U_Unit.
    + apply T_Unit.
    + cbv. split. * congruence. * congruence.
    + reflexivity.
Qed.

Example test_hasType_TAsLocalFrom_single_1:
  typed_peer_instances_type testPeerTyping1 (PeerInstance 2) = Some (Peer "ps") /\
  testTies1 (Peer "p0", Peer "ps") = Single /\
  (Program testTies1 testPeerTyping1) :: testPsi0; emptyPlaceEnv; emptyVarEnv; Peer "p0"
    |- asLocalFrom unit (Unit on (Peer "ps")) (peerApp (Instance 2)) : Unit.
Proof.
  split.
  - reflexivity.
  - split.
    + reflexivity.
    + apply T_AsLocalFrom with (P0 := Peer "p0").
      * apply U_Unit.
      * apply T_Unit.
      * cbv. { split. - congruence. - congruence. }
      * apply T_Peer. simpl. congruence.
Qed.

Example test_hasType_TAsLocalFrom_optional_1:
  typed_peer_instances_type testPeerTyping1 (PeerInstance 3) = Some (Peer "po") /\
  testTies1 (Peer "p0", Peer "po") = Optional /\
  (Program testTies1 testPeerTyping1) :: testPsi0; emptyPlaceEnv; emptyVarEnv; Peer "p0"
    |- asLocalFrom unit (Unit on (Peer "po")) (peerApp (Instance 3)) : Unit.
Proof.
  split.
  - reflexivity.
  - split.
    + reflexivity.
    + apply T_AsLocalFrom with (P0 := Peer "p0").
      * apply U_Unit.
      * apply T_Unit.
      * cbv. { split. - congruence. - congruence. }
      * apply T_Peer. simpl. congruence.
Qed.

Example test_hasType_TAsLocalFrom_multiple_1:
  typed_peer_instances_type testPeerTyping1 (PeerInstance 4) = Some (Peer "pm") /\
  testTies1 (Peer "p0", Peer "pm") = Multiple /\
  (Program testTies1 testPeerTyping1) :: testPsi0; emptyPlaceEnv; emptyVarEnv; Peer "p0"
    |- asLocalFrom unit (Unit on (Peer "pm")) (peerApp (Instance 4)) : Unit.
Proof.
  split.
  - reflexivity.
  - split.
    + reflexivity.
    + apply T_AsLocalFrom with (P0 := Peer "p0").
      * apply U_Unit.
      * apply T_Unit.
      * cbv. { split. - congruence. - congruence. }
      * apply T_Peer. simpl. congruence.
Qed.

Example test_hasType_TComp_single_1:
  testTies1 (Peer "p0", Peer "ps") = Single /\
  (Program testTies1 NoTypedInstances) :: testPsi0; emptyPlaceEnv; emptyVarEnv; Peer "p0"
    |- asLocalIn (Id "x") Unit unit unit (Unit on (Peer "ps")) : Unit.
Proof.
  split.
  - reflexivity.
  - apply T_Comp with (P0 := Peer "p0") (T0 := Unit).
    + apply U_Unit.
    + apply U_Unit.
    + apply T_Unit.
    + apply T_Unit.
    + cbv. split. * congruence. * congruence.
    + reflexivity.
Qed.

Example test_hasType_TComp_optional_1:
  testTies1 (Peer "p0", Peer "po") = Optional /\
  (Program testTies1 NoTypedInstances) :: testPsi0; emptyPlaceEnv; emptyVarEnv; Peer "p0"
    |- asLocalIn (Id "x") Unit unit unit (Unit on (Peer "po")) : Option Unit.
Proof.
  split.
  - reflexivity.
  - apply T_Comp with (P0 := Peer "p0") (T0 := Unit).
    + apply U_Unit.
    + apply U_Unit.
    + apply T_Unit.
    + apply T_Unit.
    + cbv. split. * congruence. * congruence.
    + reflexivity.
Qed.

Example test_hasType_TComp_multiple_1:
  testTies1 (Peer "p0", Peer "pm") = Multiple /\
  (Program testTies1 NoTypedInstances) :: testPsi0; emptyPlaceEnv; emptyVarEnv; Peer "p0"
    |- asLocalIn (Id "x") Unit unit unit (Unit on (Peer "pm")) : List Unit.
Proof.
  split.
  - reflexivity.
  - apply T_Comp with (P0 := Peer "p0") (T0 := Unit).
    + apply U_Unit.
    + apply U_Unit.
    + apply T_Unit.
    + apply T_Unit.
    + cbv. split. * congruence. * congruence.
    + reflexivity.
Qed.

Example test_hasType_TComp_single_2:
  testTies1 (Peer "p0", Peer "ps") = Single /\
  (Program testTies1 NoTypedInstances) :: testPsi0; emptyPlaceEnv; emptyVarEnv; Peer "p0"
    |- asLocalIn (Id "x") Unit unit (idApp (Id "x")) (Unit on (Peer "ps")) : Unit.
Proof.
  split.
  - reflexivity.
  - apply T_Comp with (P0 := Peer "p0") (T0 := Unit).
    + apply U_Unit.
    + apply U_Unit.
    + apply T_Unit.
    + apply T_Var. left. reflexivity.
    + cbv. split. * congruence. * congruence.
    + reflexivity.
Qed.

Example test_hasType_TCompFrom_single_1:
  typed_peer_instances_type testPeerTyping1 (PeerInstance 2) = Some (Peer "ps") /\
  testTies1 (Peer "p0", Peer "ps") = Single /\
  (Program testTies1 testPeerTyping1) :: testPsi0; emptyPlaceEnv; emptyVarEnv; Peer "p0"
    |- asLocalInFrom (Id "x") (*:*) Unit (*=*) unit (*in*) unit (*:*) (Unit on (Peer "ps"))
                     (*from*) (peerApp (Instance 2))
    : Unit.
Proof.
  split.
  - reflexivity.
  - split.
    + reflexivity.
    + apply T_ComFrom with (T0 := Unit) (P0 := Peer "p0").
      * apply U_Unit.
      * apply U_Unit.
      * apply T_Unit.
      * apply T_Unit.
      * cbv. { split. - congruence. - congruence. }
      * apply T_Peer. simpl. congruence.
Qed.

Example test_hasType_TCompFrom_single_2:
  typed_peer_instances_type testPeerTyping1 (PeerInstance 2) = Some (Peer "ps") /\
  testTies1 (Peer "p0", Peer "ps") = Single /\
  (Program testTies1 testPeerTyping1) :: testPsi0; emptyPlaceEnv; emptyVarEnv; Peer "p0"
    |- asLocalInFrom (Id "x") (*:*) Unit (*=*) unit (*in*) (idApp (Id "x"))
                     (*:*) (Unit on (Peer "ps"))
                     (*from*) (peerApp (Instance 2))
    : Unit.
Proof.
  split.
  - reflexivity.
  - split.
    + reflexivity.
    + apply T_ComFrom with (T0 := Unit) (P0 := Peer "p0").
      * apply U_Unit.
      * apply U_Unit.
      * apply T_Unit.
      * apply T_Var. left. reflexivity.
      * cbv. { split. - congruence. - congruence. }
      * apply T_Peer. simpl. congruence.
Qed.

Example test_hasType_TReactive_1:
  reactive_type (Reactive 0) testPsi1 = Some (Signal Unit on Peer "_") /\
  (Program NoTies NoTypedInstances) :: testPsi1; emptyPlaceEnv; emptyVarEnv; Peer "_" |- reactApp (Reactive 0) : Signal Unit.
Proof.
  split.
  - reflexivity.
  - apply T_Reactive with (T1 := Unit). + reflexivity. + left. reflexivity.
Qed.

Example test_hasType_TSignal_1:
  (Program NoTies NoTypedInstances) :: testPsi0; emptyPlaceEnv; emptyVarEnv; Peer "dummy" |- signal unit : Signal Unit.
Proof. apply T_Signal. apply T_Unit. Qed.

Example test_hasType_TReactiveVal_1:
  (Program NoTies NoTypedInstances) :: testPsi0; emptyPlaceEnv; emptyVarEnv; Peer "dummy" |- var unit : Var Unit.
Proof. apply T_ReactiveVar. apply T_Unit. Qed.

Example test_hasType_TNow_signal_1:
  (Program NoTies NoTypedInstances) :: testPsi0; emptyPlaceEnv; emptyVarEnv; Peer "dummy" |- now (signal unit) : Unit.
Proof.
  apply T_Now with (T0 := Signal Unit).
  - apply T_Signal. apply T_Unit.
  - left. reflexivity.
Qed.

Example test_hasType_TNow_var_1:
  (Program NoTies NoTypedInstances) :: testPsi0; emptyPlaceEnv; emptyVarEnv; Peer "dummy" |- now (var unit) : Unit.
Proof.
  eapply T_Now.
  - apply T_ReactiveVar. apply T_Unit.
  - right. reflexivity.
Qed.

Example test_hasType_TSet_1:
  (Program NoTies NoTypedInstances) :: testPsi0; emptyPlaceEnv; emptyVarEnv; Peer "dummy" |- set (var unit) unit : Unit.
Proof.
  apply T_Set with (T := Unit).
  - apply T_ReactiveVar. apply T_Unit.
  - apply T_Unit.
Qed.

Example test_hasType_TSet_2:
  (Program NoTies NoTypedInstances) :: testPsi0; emptyPlaceEnv; emptyVarEnv; Peer "dummy"
    |- set (var (lambda (Id "x") Unit unit))
           (*:=*) (lambda (Id "x") Unit unit)
    : Unit.
Proof.
  assert (H: (Program NoTies NoTypedInstances) :: testPsi0; emptyPlaceEnv; emptyVarEnv; Peer "dummy" |- lambda (Id "x") Unit unit : Unit ~> Unit).
  - apply T_Abs.
    apply T_Unit.
  - apply T_Set with (T := Unit ~> Unit).
    + apply T_ReactiveVar. assumption.
    + assumption.
Qed.