(*** Word-By-Word Montgomery Multiplication Proofs *)
Require Import Coq.ZArith.BinInt.
Require Import Coq.micromega.Lia.
Require Import Crypto.Arithmetic.Saturated.UniformWeight.
Require Import Crypto.Arithmetic.Saturated.MontgomeryAPI.
Require Import Crypto.Arithmetic.MontgomeryReduction.WordByWord.Abstract.Dependent.Definition.
Require Import Crypto.Arithmetic.MontgomeryReduction.WordByWord.Abstract.Dependent.Proofs.
Require Import Crypto.Arithmetic.MontgomeryReduction.WordByWord.Definition.
Require Import Crypto.Util.ZUtil.
Require Import Crypto.Util.Tactics.BreakMatch.

Local Open Scope Z_scope.
Local Coercion Z.pos : positive >-> Z.
Section WordByWordMontgomery.
  (** XXX TODO: pick better names for things like [R_numlimbs] *)
  Context (r : positive)
          (R_numlimbs : nat).
  Local Notation small := (@small (Z.pos r)).
  Local Notation eval := (@eval (Z.pos r)).
  Local Notation addT' := (@MontgomeryAPI.add_S1 (Z.pos r)).
  Local Notation addT := (@MontgomeryAPI.add (Z.pos r)).
  Local Notation scmul := (@scmul (Z.pos r)).
  Local Notation eval_zero := (@eval_zero (Z.pos r)).
  Local Notation small_zero := (@small_zero r (Zorder.Zgt_pos_0 _)).
  Local Notation small_scmul := (fun n a v _ _ _ => @small_scmul r (Zorder.Zgt_pos_0 _) n a v).
  Local Notation eval_join0 := (@eval_zero (Z.pos r) (Zorder.Zgt_pos_0 _)).
  Local Notation eval_div := (@eval_div (Z.pos r) (Zorder.Zgt_pos_0 _)).
  Local Notation eval_mod := (@eval_mod (Z.pos r)).
  Local Notation small_div := (@small_div (Z.pos r)).
  Local Notation eval_scmul := (fun n a v smallv abound vbound => @eval_scmul (Z.pos r) (Zorder.Zgt_pos_0 _) n a v smallv abound).
  Local Notation eval_addT := (@eval_add_same (Z.pos r) (Zorder.Zgt_pos_0 _)).
  Local Notation eval_addT' := (@eval_add_S1 (Z.pos r) (Zorder.Zgt_pos_0 _)).
  Local Notation drop_high := (@drop_high (S R_numlimbs)).
  Local Notation small_drop_high := (@small_drop_high (Z.pos r) (S R_numlimbs)).
  Context (A_numlimbs : nat)
          (N : T R_numlimbs)
          (A : T A_numlimbs)
          (B : T R_numlimbs)
          (k : Z).
  Context ri
          (r_big : r > 1)
          (small_A : small A)
          (ri_correct : r*ri mod (eval N) = 1 mod (eval N))
          (small_N : small N)
          (small_B : small B)
          (N_nonzero : eval N <> 0)
          (N_mask : Tuple.map (Z.land (Z.pos r - 1)) N = N)
          (k_correct : k * eval N mod r = (-1) mod r).
  Let R : positive := match (Z.pos r ^ Z.of_nat R_numlimbs)%Z with
                      | Z.pos R => R
                      | _ => 1%positive
                      end.
  Let Npos : positive := match eval N with
                         | Z.pos N => N
                         | _ => 1%positive
                         end.
  Local Lemma R_correct : Z.pos R = Z.pos r ^ Z.of_nat R_numlimbs.
  Proof.
    assert (0 < r^Z.of_nat R_numlimbs) by (apply Z.pow_pos_nonneg; lia).
    subst R; destruct (Z.pos r ^ Z.of_nat R_numlimbs) eqn:?; [ | reflexivity | ];
      lia.
  Qed.
  Local Lemma small_addT : forall n a b, small a -> small b -> small (@addT n a b).
  Proof.
    intros; apply MontgomeryAPI.small_add; auto; lia.
  Qed.
  Local Lemma small_addT' : forall n a b, small a -> small b -> small (@addT' n a b).
  Proof.
    intros; apply MontgomeryAPI.small_add_S1; auto; lia.
  Qed.

  Local Notation conditional_sub_cps := (fun V : T (S R_numlimbs) => @conditional_sub_cps (Z.pos r) _ V N _).
  Local Notation conditional_sub := (fun V : T (S R_numlimbs) => @conditional_sub (Z.pos r) _ V N).
  Local Notation eval_conditional_sub' := (fun V small_V V_bound => @eval_conditional_sub (Z.pos r) (Zorder.Zgt_pos_0 _) _  V N small_V small_N V_bound).

  Local Lemma eval_conditional_sub
    : forall v, small v -> 0 <= eval v < eval N + R -> eval (conditional_sub v) = eval v + if eval N <=? eval v then -eval N else 0.
  Proof. rewrite R_correct; exact eval_conditional_sub'. Qed.
  Local Notation small_conditional_sub' := (fun V small_V V_bound => @small_conditional_sub (Z.pos r) (Zorder.Zgt_pos_0 _) _ V N small_V small_N V_bound).
  Local Lemma small_conditional_sub
    : forall v : T (S R_numlimbs), small v -> 0 <= eval v < eval N + R -> small (conditional_sub v).
  Proof. rewrite R_correct; exact small_conditional_sub'. Qed.

  Local Lemma A_bound : 0 <= eval A < Z.pos r ^ Z.of_nat A_numlimbs.
  Proof. apply eval_small; auto; lia. Qed.
  Local Lemma B_bound' : 0 <= eval B < r^Z.of_nat R_numlimbs.
  Proof. apply eval_small; auto; lia. Qed.
  Local Lemma N_bound' : 0 <= eval N < r^Z.of_nat R_numlimbs.
  Proof. apply eval_small; auto; lia. Qed.
  Local Lemma N_bound : 0 < eval N < r^Z.of_nat R_numlimbs.
  Proof. pose proof N_bound'; lia. Qed.
  Local Lemma Npos_correct: eval N = Z.pos Npos.
  Proof. pose proof N_bound; subst Npos; destruct (eval N); [ | reflexivity | ]; lia. Qed.
  Local Lemma N_lt_R : eval N < R.
  Proof. rewrite R_correct; apply N_bound. Qed.
  Local Lemma B_bound : 0 <= eval B < R.
  Proof. rewrite R_correct; apply B_bound'. Qed.
  Local Lemma eval_drop_high : forall v, small v -> eval (drop_high v) = eval v mod (r * r^Z.of_nat R_numlimbs).
  Proof.
    intros; erewrite eval_drop_high by (eassumption || lia).
    f_equal; unfold uweight.
    rewrite Znat.Nat2Z.inj_succ, Z.pow_succ_r by lia; reflexivity.
  Qed.

  Local Notation redc_body_no_cps := (@redc_body_no_cps r R_numlimbs N).
  Local Notation redc_body_cps := (@redc_body_cps r R_numlimbs N).
  Local Notation redc_body := (@redc_body r R_numlimbs N).
  Local Notation redc_loop_no_cps := (@redc_loop_no_cps r R_numlimbs N B k).
  Local Notation redc_loop_cps := (@redc_loop_cps r R_numlimbs N B k).
  Local Notation redc_loop := (@redc_loop r R_numlimbs N B k).
  Local Notation pre_redc_no_cps := (@pre_redc_no_cps r R_numlimbs N A_numlimbs A B k).
  Local Notation pre_redc_cps := (@pre_redc_cps r R_numlimbs N A_numlimbs A B k).
  Local Notation pre_redc := (@pre_redc r R_numlimbs N A_numlimbs A B k).
  Local Notation redc_no_cps := (@redc_no_cps r R_numlimbs N A_numlimbs A B k).
  Local Notation redc_cps := (@redc_cps r R_numlimbs N A_numlimbs A B k).
  Local Notation redc := (@redc r R_numlimbs N A_numlimbs A B k).

  Definition redc_no_cps_bound : 0 <= eval redc_no_cps < R
    := @redc_bound T (@eval) (@zero) (@divmod) r r_big R R_numlimbs R_correct (@small) eval_zero small_zero eval_div eval_mod small_div (@scmul) eval_scmul small_scmul (@addT) eval_addT small_addT (@addT') eval_addT' small_addT' drop_high eval_drop_high small_drop_high N Npos Npos_correct small_N N_lt_R conditional_sub eval_conditional_sub B B_bound small_B ri k A_numlimbs A small_A A_bound.
  Definition redc_no_cps_bound_N : eval B < eval N -> 0 <= eval redc_no_cps < eval N
    := @redc_bound_N T (@eval) (@zero) (@divmod) r r_big R R_numlimbs R_correct (@small) eval_zero small_zero eval_div eval_mod small_div (@scmul) eval_scmul small_scmul (@addT) eval_addT small_addT (@addT') eval_addT' small_addT' drop_high eval_drop_high small_drop_high N Npos Npos_correct small_N N_lt_R conditional_sub eval_conditional_sub B B_bound small_B ri k A_numlimbs A small_A.
  Definition redc_no_cps_mod_N
    : (eval redc_no_cps) mod (eval N) = (eval A * eval B * ri^(Z.of_nat A_numlimbs)) mod (eval N)
    := @redc_mod_N T (@eval) (@zero) (@divmod) r r_big R R_numlimbs R_correct (@small) eval_zero small_zero eval_div eval_mod small_div (@scmul) eval_scmul small_scmul (@addT) eval_addT small_addT (@addT') eval_addT' small_addT' drop_high eval_drop_high small_drop_high N Npos Npos_correct small_N N_lt_R conditional_sub eval_conditional_sub B B_bound small_B ri ri_correct k k_correct A_numlimbs A small_A A_bound.
  Definition small_redc_no_cps
    : small redc_no_cps
    := @small_redc T (@eval) (@zero) (@divmod) r r_big R R_numlimbs R_correct (@small) eval_zero small_zero eval_div eval_mod small_div (@scmul) eval_scmul small_scmul (@addT) eval_addT small_addT (@addT') eval_addT' small_addT' drop_high eval_drop_high small_drop_high N Npos Npos_correct small_N N_lt_R conditional_sub small_conditional_sub B B_bound small_B ri k A_numlimbs A small_A A_bound.

  Lemma redc_body_cps_id pred_A_numlimbs (A' : T (S pred_A_numlimbs)) (S' : T (S R_numlimbs)) {cpsT} f
    : @redc_body_cps pred_A_numlimbs A' B k S' cpsT f = f (redc_body A' B k S').
  Proof.
    unfold redc_body, redc_body_cps, LetIn.Let_In.
    repeat first [ reflexivity
                 | break_innermost_match_step
                 | progress autorewrite with uncps ].
  Qed.

  Lemma redc_loop_cps_id (count : nat) (A_S : T count * T (S R_numlimbs)) {cpsT} f
    : @redc_loop_cps cpsT count f A_S = f (redc_loop count A_S).
  Proof.
    unfold redc_loop.
    revert A_S f.
    induction count as [|count IHcount].
    { reflexivity. }
    { intros [A' S']; simpl; intros.
      etransitivity; rewrite @redc_body_cps_id; [ rewrite IHcount | ]; reflexivity. }
  Qed.
  Lemma pre_redc_cps_id {cpsT} f : @pre_redc_cps cpsT f = f pre_redc.
  Proof.
    unfold pre_redc, pre_redc_cps.
    etransitivity; rewrite redc_loop_cps_id; [ | reflexivity ]; break_innermost_match;
      reflexivity.
  Qed.
  Lemma redc_cps_id {cpsT} f : @redc_cps cpsT f = f redc.
  Proof.
    unfold redc, redc_cps.
    etransitivity; rewrite pre_redc_cps_id; [ | reflexivity ];
      autorewrite with uncps;
      reflexivity.
  Qed.

  Lemma redc_body_id_no_cps pred_A_numlimbs A' S'
    : @redc_body pred_A_numlimbs A' B k S' = redc_body_no_cps B k (A', S').
  Proof.
    unfold redc_body, redc_body_cps, redc_body_no_cps, Abstract.Dependent.Definition.redc_body, LetIn.Let_In, id.
    repeat autounfold with word_by_word_montgomery.
    repeat first [ reflexivity
                 | progress cbn [fst snd id]
                 | progress autorewrite with uncps
                 | break_innermost_match_step
                 | f_equal; [] ].
  Qed.
  Lemma redc_loop_cps_id_no_cps count A_S
    : redc_loop count A_S = redc_loop_no_cps count A_S.
  Proof.
    unfold redc_loop_no_cps, id.
    revert A_S.
    induction count as [|count IHcount]; simpl; [ reflexivity | ].
    intros [A' S']; unfold redc_loop; simpl.
    rewrite redc_body_cps_id, redc_loop_cps_id, IHcount, redc_body_id_no_cps.
    reflexivity.
  Qed.
  Lemma pre_redc_cps_id_no_cps : pre_redc = pre_redc_no_cps.
  Proof.
    unfold pre_redc, pre_redc_cps, pre_redc_no_cps, Abstract.Dependent.Definition.pre_redc.
    rewrite redc_loop_cps_id, (surjective_pairing (redc_loop _ _)).
    rewrite redc_loop_cps_id_no_cps; reflexivity.
  Qed.
  Lemma redc_cps_id_no_cps : redc = redc_no_cps.
  Proof.
    unfold redc, redc_no_cps, redc_cps, Abstract.Dependent.Definition.redc.
    rewrite pre_redc_cps_id, pre_redc_cps_id_no_cps.
    autorewrite with uncps; reflexivity.
  Qed.

  Lemma redc_bound : 0 <= eval redc < R.
  Proof. rewrite redc_cps_id_no_cps; apply redc_no_cps_bound. Qed.
  Lemma redc_bound_N : eval B < eval N -> 0 <= eval redc < eval N.
  Proof. rewrite redc_cps_id_no_cps; apply redc_no_cps_bound_N. Qed.
  Lemma redc_mod_N
    : (eval redc) mod (eval N) = (eval A * eval B * ri^(Z.of_nat A_numlimbs)) mod (eval N).
  Proof. rewrite redc_cps_id_no_cps; apply redc_no_cps_mod_N. Qed.
  Lemma small_redc
    : small redc.
  Proof. rewrite redc_cps_id_no_cps; apply small_redc_no_cps. Qed.

  Section add_sub.
    Context (Av Bv : T R_numlimbs)
            (small_Av : small Av)
            (small_Bv : small Bv)
            (Av_bound : 0 <= eval Av < eval N)
            (Bv_bound : 0 <= eval Bv < eval N).
    Local Notation add_no_cps := (@add_no_cps r R_numlimbs N Av Bv).
    Local Notation add_cps := (@add_cps r R_numlimbs N Av Bv).
    Local Notation add := (@add r R_numlimbs N Av Bv).
    Local Notation sub_no_cps := (@sub_no_cps r R_numlimbs N Av Bv).
    Local Notation sub_cps := (@sub_cps r R_numlimbs N Av Bv).
    Local Notation sub := (@sub r R_numlimbs N Av Bv).
    Local Notation opp_no_cps := (@opp_no_cps r R_numlimbs N Av).
    Local Notation opp_cps := (@opp_cps r R_numlimbs N Av).
    Local Notation opp := (@opp r R_numlimbs N Av).
    Local Notation sub_then_maybe_add_cps :=
       (fun p q => @sub_then_maybe_add_cps (Z.pos r) R_numlimbs (Z.pos r - 1) p q N).
    Local Notation sub_then_maybe_add :=
      (fun p q => @sub_then_maybe_add (Z.pos r) R_numlimbs (Z.pos r - 1) p q N).
    Local Notation eval_sub_then_maybe_add :=
      (fun p q smp smq => @eval_sub_then_maybe_add (Z.pos r) (Zorder.Zgt_pos_0 _) _ (Z.pos r - 1) p q N smp smq small_N N_mask).
    Local Notation small_sub_then_maybe_add :=
      (fun p q => @small_sub_then_maybe_add (Z.pos r) (Zorder.Zgt_pos_0 _) _ (Z.pos r - 1) p q N).

    Definition add_no_cps_bound : 0 <= eval add_no_cps < eval N
      := @add_bound T (@eval) r R R_numlimbs (@small) (@addT) (@eval_addT) (@small_addT) N N_lt_R (@conditional_sub) (@eval_conditional_sub) Av Bv small_Av small_Bv Av_bound Bv_bound.
    Definition sub_no_cps_bound : 0 <= eval sub_no_cps < eval N
      := @sub_bound T (@eval) r R R_numlimbs (@small) N (@sub_then_maybe_add) (@eval_sub_then_maybe_add) Av Bv small_Av small_Bv Av_bound Bv_bound.
    Definition opp_no_cps_bound : 0 <= eval opp_no_cps < eval N
      := @opp_bound T (@eval) (@zero) r R R_numlimbs (@small) (@eval_zero) (@small_zero) N (@sub_then_maybe_add) (@eval_sub_then_maybe_add) Av small_Av Av_bound.

    Definition small_add_no_cps : small add_no_cps
      := @small_add T (@eval) r R R_numlimbs (@small) (@addT) (@eval_addT) (@small_addT) N N_lt_R (@conditional_sub) (@small_conditional_sub) Av Bv small_Av small_Bv Av_bound Bv_bound.
    Definition small_sub_no_cps : small sub_no_cps
      := @small_sub T R_numlimbs (@small) (@sub_then_maybe_add) (@small_sub_then_maybe_add) Av Bv.
    Definition small_opp_no_cps : small opp_no_cps
      := @small_opp T (@zero) R_numlimbs (@small) (@sub_then_maybe_add) (@small_sub_then_maybe_add) Av.

    Definition eval_add_no_cps : eval add_no_cps = eval Av + eval Bv + (if eval N <=? eval Av + eval Bv then - eval N else 0)
      := @eval_add T (@eval) r R R_numlimbs (@small) (@addT) (@eval_addT) (@small_addT) N N_lt_R (@conditional_sub) (@eval_conditional_sub) Av Bv small_Av small_Bv Av_bound Bv_bound.
    Definition eval_sub_no_cps : eval sub_no_cps = eval Av - eval Bv + (if eval Av - eval Bv <? 0 then eval N else 0)
      := @eval_sub T (@eval) R_numlimbs (@small) N (@sub_then_maybe_add) (@eval_sub_then_maybe_add) Av Bv small_Av small_Bv Av_bound Bv_bound.
    Definition eval_opp_no_cps : eval opp_no_cps = (if eval Av =? 0 then 0 else eval N) - eval Av
      := @eval_opp T (@eval) (@zero) r R R_numlimbs (@small) (@eval_zero) (@small_zero) N (@sub_then_maybe_add ) (@eval_sub_then_maybe_add) Av small_Av Av_bound.

    Definition eval_add_no_cps_mod_N : eval add_no_cps mod eval N = (eval Av + eval Bv) mod eval N
      := @eval_add_mod_N T (@eval) r R R_numlimbs (@small) (@addT) (@eval_addT) (@small_addT) N N_lt_R (@conditional_sub) (@eval_conditional_sub) Av Bv small_Av small_Bv Av_bound Bv_bound.
    Definition eval_sub_no_cps_mod_N : eval sub_no_cps mod eval N = (eval Av - eval Bv) mod eval N
      := @eval_sub_mod_N T (@eval) R_numlimbs (@small) N (@sub_then_maybe_add) (@eval_sub_then_maybe_add) Av Bv small_Av small_Bv Av_bound Bv_bound.
    Definition eval_opp_no_cps_mod_N : eval opp_no_cps mod eval N = (-eval Av) mod eval N
      := @eval_opp_mod_N T (@eval) (@zero) r R R_numlimbs (@small) (@eval_zero) (@small_zero) N (@sub_then_maybe_add) (@eval_sub_then_maybe_add) Av small_Av Av_bound.

    Lemma add_cps_id_no_cps : add = add_no_cps.
    Proof.
      unfold add_no_cps, add, add_cps, Abstract.Dependent.Definition.add; autorewrite with uncps; reflexivity.
    Qed.
    Lemma sub_cps_id_no_cps : sub = sub_no_cps.
    Proof.
      unfold sub_no_cps, sub, sub_cps, Abstract.Dependent.Definition.sub; autorewrite with uncps; reflexivity.
    Qed.
    Lemma opp_cps_id_no_cps : opp = opp_no_cps.
    Proof.
      unfold opp, opp_cps, opp_no_cps, Abstract.Dependent.Definition.opp, sub_no_cps, sub, sub_cps, Abstract.Dependent.Definition.sub; autorewrite with uncps; reflexivity.
    Qed.

    Lemma add_cps_id {cpsT} f : @add_cps cpsT f = f add.
    Proof. unfold add, add_cps; autorewrite with uncps; reflexivity. Qed.
    Lemma sub_cps_id {cpsT} f : @sub_cps cpsT f = f sub.
    Proof. unfold sub, sub_cps; autorewrite with uncps. reflexivity. Qed.
    Lemma opp_cps_id {cpsT} f : @opp_cps cpsT f = f opp.
    Proof. unfold opp, opp_cps, sub, sub_cps; autorewrite with uncps. reflexivity. Qed.

    Local Ltac do_rewrite :=
      first [ rewrite add_cps_id_no_cps
            | rewrite sub_cps_id_no_cps
            | rewrite opp_cps_id_no_cps ].
    Local Ltac do_apply :=
      first [ apply add_no_cps_bound
            | apply sub_no_cps_bound
            | apply opp_no_cps_bound
            | apply small_add_no_cps
            | apply small_sub_no_cps
            | apply small_opp_no_cps
            | apply eval_add_no_cps
            | apply eval_sub_no_cps
            | apply eval_opp_no_cps
            | apply eval_add_no_cps_mod_N
            | apply eval_sub_no_cps_mod_N
            | apply eval_opp_no_cps_mod_N ].
    Local Ltac t := do_rewrite; do_apply.

    Lemma add_bound : 0 <= eval add < eval N. Proof. t. Qed.
    Lemma sub_bound : 0 <= eval sub < eval N. Proof. t. Qed.
    Lemma opp_bound : 0 <= eval opp < eval N. Proof. t. Qed.

    Lemma small_add : small add. Proof. t. Qed.
    Lemma small_sub : small sub. Proof. t. Qed.
    Lemma small_opp : small opp. Proof. t. Qed.

    Lemma eval_add : eval add = eval Av + eval Bv + (if eval N <=? eval Av + eval Bv then - eval N else 0).
    Proof. t. Qed.
    Lemma eval_sub : eval sub = eval Av - eval Bv + (if eval Av - eval Bv <? 0 then eval N else 0).
    Proof. t. Qed.
    Lemma eval_opp : eval opp = (if eval Av =? 0 then 0 else eval N) - eval Av.
    Proof. t. Qed.

    Lemma eval_add_mod_N : eval add mod eval N = (eval Av + eval Bv) mod eval N.
    Proof. t. Qed.
    Lemma eval_sub_mod_N : eval sub mod eval N = (eval Av - eval Bv) mod eval N.
    Proof. t. Qed.
    Lemma eval_opp_mod_N : eval opp mod eval N = (-eval Av) mod eval N.
    Proof. t. Qed.
  End add_sub.

  Section nonzero.
    Lemma nonzero_cps_id Av {cpsT} f : @nonzero_cps R_numlimbs Av cpsT f = f (@nonzero R_numlimbs Av).
    Proof. unfold nonzero, nonzero_cps; autorewrite with uncps; reflexivity. Qed.

    Lemma eval_nonzero Av : small Av -> @nonzero R_numlimbs Av = 0 <-> eval Av = 0.
    Proof. apply eval_nonzero; lia. Qed.
  End nonzero.
End WordByWordMontgomery.

Hint Rewrite redc_body_cps_id redc_loop_cps_id pre_redc_cps_id redc_cps_id add_cps_id sub_cps_id opp_cps_id : uncps.


Require Export EnvLibA.
Require Export RelLibA.

Require Export Basics.
Require Export Coq.Program.Equality.
Require Import Coq.Init.Specif.
Require Import Coq.Arith.PeanoNat.
Require Import Omega.
Require Import Coq.Lists.List.

Require Export IdModTypeA.

Import ListNotations.

Module Static (IdT: IdModType) <: IdModType.
Export IdT.

Definition Id := IdT.Id.
Definition IdEqDec := IdT.IdEqDec.
Definition IdEq := IdT.IdEq.
Definition W := IdT.W.
Definition Loc_PI := IdT.Loc_PI.
Definition BInit := IdT.BInit.
Definition WP := IdT.WP.

(** effect handler record *)

Record XFun (T1 T2: Type) : Type := {
    b_mod : W -> T1 -> prod W T2 ;
    b_exec : W -> T1 -> W := fun state input => fst (b_mod state input) ;
    b_eval : W -> T1 -> T2 := fun state input => snd (b_mod state input)
}.

(** some admissible value types *)

Instance NatVT : ValTyp nat.

Instance UnitVT : ValTyp unit.

Instance BoolVT : ValTyp bool.

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

(**** value types in the deep embedding *)

(** the type of value types -
    syntactic types are parametrised by semantic ones *)
Definition VTyp : Type := sig ValTyp.

(** smart value type constructor *)
Definition vtyp (T: Type) {VT: ValTyp T} : VTyp :=
    @exist Type ValTyp T VT.

(** extractor *)
Definition vtypExt (t: VTyp) : Type := proj1_sig t.

(** value type abbreviations *)

Definition Nat : VTyp := vtyp nat.

Definition Unit : VTyp := vtyp unit.

Definition Bool : VTyp := vtyp bool.

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

(** Parameter types *)
Inductive PTyp : Type := PT (ts: list VTyp).

(** Value-typing contexts *)
Definition valTC : Type := list (Id * VTyp).

(** Function types *)
Inductive FTyp : Type := FT (prs_type: valTC) (ret_type: VTyp).

(** Function-typing contexts *)
Definition funTC : Type := list (Id * FTyp).

(** extractors for function types *)
Definition extParType (ft: FTyp) : valTC :=
  match ft with FT ps _ => ps end.

Definition extRetType (ft: FTyp) : VTyp :=
  match ft with FT _ t => t end.

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

(**** Value expressions *)

(** the internal type of values, parametrised by a semantic type *)
Inductive ValueI (T: Type) : Type := Cst (v: T).

(** the external type of values, hiding the semantic type *)
Definition Value : Type := sigT ValueI.

(** smart value constructor *)
Definition cst (T: Type) (v: T) : Value :=
           @existT Type ValueI T (Cst T v).

(** extractors *)
Definition ValueI2T (T: Type) (v: ValueI T) : T :=
    match v with Cst _  x => x end.

Definition cstExt (v: Value) : projT1 v := ValueI2T (projT1 v) (projT2 v).

(** sanity conditions *)
Lemma cstSound1 (v: Value) : v = cst (projT1 v) (cstExt v).
Proof.
  unfold cst.
  unfold cstExt.
  destruct v as [T v].
  simpl.
  assert (v = Cst T (ValueI2T T v)).
  destruct v.
  simpl.
  reflexivity.
  rewrite <- H.
  reflexivity.
Defined.

Lemma cstSound2 (T: Type) (v: T) : v = cstExt (cst T v).
Proof.
  unfold cstExt.
  simpl.
  auto.
Defined.

Lemma cstEq (T: Type) (v1 v2: T) : cst T v1 = cst T v2 -> v1 = v2.
  intros.
  assert (projT2 (cst T v1) = projT2 (cst T v2)).
  intuition.
  simpl in H0.
  inversion H0; subst.
  reflexivity.
Defined.

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

(** Value environments *)
Definition valEnv : Type := list (Id * Value).

(** Quasi-values *)
Inductive QValue : Type := Var (x: Id) | QV (v: Value).

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

(** synactic tag type *)

Inductive Tag : Type := LL | RR.

(**** Terms *)

Inductive Fun : (** Functions *)
   Type := FC (fenv: Envr Id Fun)
              (tenv: valTC) (e0 e1: Exp) (x: Id) (n: nat)
with QFun : (** Quasi-functions *)
   Type := FVar (x: Id) | QF (v: Fun)
with Exp : (** Expressions *)
       Type :=
(*         Reset  *)
(*         | Read (W T: Type) (XF: XFun W T) (VT: ValTyp T)   *)
         | Modify (T1 T2: Type) (VT1: ValTyp T1) (VT2: ValTyp T2)
                  (XF: XFun T1 T2) (q: QValue)
         | Return (G: Tag) (q: QValue)
         | BindN (e1: Exp) (e2: Exp)
         | BindS (x: Id) (e1: Exp) (e2: Exp)
         | BindMS (fenv: Envr Id Fun) (venv: valEnv) (e: Exp)
         | Apply (q: QFun) (ps: Prms)
         | Val (v: Value)
         | IfThenElse (e1: Exp) (e2: Exp) (e3: Exp)
with Prms : (** Parameters *)
   Type := PS (es: list Exp).

Scheme Fun_mut := Induction for Fun Sort Type
with QFun_mut := Induction for QFun Sort Type
with Exp_mut := Induction for Exp Sort Type
with Prms_mut := Induction for Prms Sort Type.

Inductive Prog : (** Programs *)
       Type := prog (e: Exp)
             | define (x: Id) (f: Fun) (p: Prog).

(** Function environments *)
Definition funEnv : Type := Envr Id Fun.

(* Conversion from typing contexts to type lists *)
Definition env2ptyp (m: valTC) : PTyp := PT (map snd m).

(* Creation of value environments *)
Definition mkVEnv (tenv: valTC) (vs: list Value) : valEnv :=
     interleave (map fst tenv) vs.

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

(** Static semantics *)

(* definition of value typing *)
Inductive ValueTyping (v: Value) (t: VTyp) : Type :=
| ValueTypingC : let T := projT1 v
          in T = (proj1_sig t) ->
             ValTyp T ->
             ValueTyping v t.

(** smart value constructor *)
Definition valueTyping (T: Type) {VT: ValTyp T} (v: T) :
  ValueTyping (cst T v) (vtyp T) :=
   ValueTypingC (cst T v) (vtyp T) eq_refl VT.

Inductive IdTyping : valTC -> Id -> VTyp -> Type :=
   | Id_Typing : forall (tenv: valTC) (x: Id) (t: VTyp),
                    findET tenv x t ->
                    IdTyping tenv x t.

Inductive QValueTyping : valTC -> QValue -> VTyp -> Type :=
  | ProperValue_Typing : forall (tenv: valTC ) (v: Value) (t: VTyp),
                   ValueTyping v t ->
                   QValueTyping tenv (QV v) t
  | Var_Typing : forall (tenv: valTC) (x: Id) (t: VTyp),
                   IdTyping tenv x t ->
                   QValueTyping tenv (Var x) t.

Definition EnvTyping : valEnv -> valTC -> Type :=
    MatchEnvsT ValueTyping.

Inductive FunTyping : (** Functions *)
                  Fun -> FTyp -> Type :=
  | FunZ_Typing: forall (ftenv: funTC) (tenv: valTC)
                        (fenv: funEnv)
                        (e0 e1: Exp) (x: Id) (t: VTyp),
      MatchEnvsT FunTyping fenv ftenv ->
      ExpTyping ftenv tenv fenv e0 t ->
      FunTyping (FC fenv tenv e0 e1 x 0) (FT tenv t)
  | FunS_Typing: forall (ftenv: funTC) (tenv: valTC)
                        (fenv: funEnv)
            (e0 e1: Exp) (x: Id) (n: nat) (t: VTyp),
      let ftenv' := (x, FT tenv t) :: ftenv in
      let fenv' := (x, FC fenv tenv e0 e1 x n) :: fenv in
      MatchEnvsT FunTyping fenv ftenv ->
      ExpTyping ftenv' tenv fenv' e1 t ->
      FunTyping (FC fenv tenv e0 e1 x n) (FT tenv t) ->
      FunTyping (FC fenv tenv e0 e1 x (S n)) (FT tenv t)
with QFunTyping : (** Quasi-functions *)
                  funTC -> funEnv -> QFun -> FTyp -> Type :=
  | QF_Typing: forall (ftenv: funTC) (fenv: funEnv) (f: Fun) (ft: FTyp),
      FunTyping f ft ->
      QFunTyping ftenv fenv (QF f) ft
  | FVar_Typing: forall (ftenv: funTC) (fenv: funEnv)
                       (x: Id) (f: Fun) (ft: FTyp),
      MatchEnvs2BT FunTyping x f ft fenv ftenv ->
      QFunTyping ftenv fenv (FVar x) ft
with ExpTyping : (** expressions *)
        funTC -> valTC -> funEnv -> Exp -> VTyp -> Type :=
  | Modify_Typing : forall (ftenv: funTC) (tenv: valTC) (fenv: funEnv)
                           (T1 T2: Type) (VT1: ValTyp T1) (VT2: ValTyp T2)
                           (XF: XFun T1 T2) (q: QValue),
                     QValueTyping tenv q (vtyp T1) ->
                     ExpTyping ftenv tenv fenv
                               (Modify T1 T2 VT1 VT2 XF q) (vtyp T2)
  | Return_Typing : forall (G: Tag)
                           (ftenv: funTC) (tenv: valTC) (fenv: funEnv)
                           (q: QValue) (t: VTyp),
                       QValueTyping tenv q t ->
                       ExpTyping ftenv tenv fenv (Return G q) t
  | BindN_Typing : forall (ftenv: funTC) (tenv: valTC) (fenv: funEnv)
                          (e1 e2: Exp) (t1 t2: VTyp),
                       ExpTyping ftenv tenv fenv e1 t1 ->
                       ExpTyping ftenv tenv fenv e2 t2 ->
                       ExpTyping ftenv tenv fenv (BindN e1 e2) t2
  | BindS_Typing : forall (ftenv: funTC) (tenv: valTC)
                          (fenv: funEnv) (x: Id)
                          (e1 e2: Exp) (t1 t2: VTyp),
                       let tenv' := (x, t1) :: tenv in
                       ExpTyping ftenv tenv fenv e1 t1 ->
                       ExpTyping ftenv tenv' fenv e2 t2 ->
                       ExpTyping ftenv tenv fenv (BindS x e1 e2) t2
  | BindMS_Typing : forall (ftenv ftenvP ftenv': funTC)
                           (tenv tenvP tenv': valTC)
                           (fenv fenvP fenv': funEnv) (envP: valEnv)
                           (e: Exp) (t: VTyp),
                       MatchEnvsT ValueTyping envP tenvP ->
                       MatchEnvsT FunTyping fenv ftenv ->
                       MatchEnvsT FunTyping fenvP ftenvP ->
                       tenv' = tenvP ++ tenv ->
                       ftenv' = ftenvP ++ ftenv ->
                       fenv' = fenvP ++ fenv ->
                       ExpTyping ftenv' tenv' fenv' e t ->
                       ExpTyping ftenv tenv fenv (BindMS fenvP envP e) t
  | Apply_Typing : forall (ftenv: funTC) (tenv fps: valTC) (fenv: funEnv)
                          (q: QFun) (ps: Prms) (pt: PTyp) (t: VTyp),
              pt = PT (map snd fps) ->
              MatchEnvsT FunTyping fenv ftenv ->
              QFunTyping ftenv fenv q (FT fps t) ->
              PrmsTyping ftenv tenv fenv ps pt ->
              ExpTyping ftenv tenv fenv (Apply q ps) t
  | Val_Typing : forall (ftenv: funTC) (tenv: valTC) (fenv: funEnv)
                        (v: Value) (t: VTyp),
                       ValueTyping v t ->
                       ExpTyping ftenv tenv fenv (Val v) t
  | IfThenElse_Typing : forall (ftenv: funTC) (tenv: valTC) (fenv: funEnv)
                               (e1 e2 e3: Exp) (t: VTyp),
             ExpTyping ftenv tenv fenv e1 Bool ->
             ExpTyping ftenv tenv fenv e2 t ->
             ExpTyping ftenv tenv fenv e3 t ->
             ExpTyping ftenv tenv fenv (IfThenElse e1 e2 e3) t
with PrmsTyping : (** parameters *)
         funTC -> valTC -> funEnv -> Prms -> PTyp -> Type :=
| PS_Typing: forall (ftenv: funTC) (tenv: valTC) (fenv: funEnv)
                    (es: list Exp) (ts: list VTyp),
      Forall2T (ExpTyping ftenv tenv fenv) es ts ->
      PrmsTyping ftenv tenv fenv (PS es) (PT ts).

Definition FEnvTyping : funEnv -> funTC -> Type :=
    MatchEnvsT FunTyping.

Scheme FunTyping_mut := Induction for FunTyping Sort Type
with QFunTyping_mut := Induction for QFunTyping Sort Type
with ExpTyping_mut := Induction for ExpTyping Sort Type
with PrmsTyping_mut := Induction for PrmsTyping Sort Type.

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

Inductive ProgTyping : (** Functions *)
    funTC -> funEnv -> Prog -> VTyp -> Type :=
| Prog_Typing : forall (ftenv: funTC) (fenv: funEnv) (e: Exp) (t: VTyp),
                   MatchEnvsT FunTyping fenv ftenv ->
                   ProgTyping ftenv fenv (prog e) t
| Define_Typing : forall (ftenv ftenv': funTC) (fenv fenv': funEnv)
                         (x: Id) (f: Fun) (p: Prog)
                         (ft: FTyp) (t: VTyp),
      MatchEnvsT FunTyping fenv ftenv ->
      ftenv' = (x, ft) :: ftenv ->
      fenv' = (x, f) :: fenv ->
      QFunTyping ftenv fenv (QF f) ft ->
      ProgTyping ftenv' fenv' p t ->
      ProgTyping ftenv fenv (define x f p) t.

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

(** value typing lemmas from CRelLib *)

Definition ExTDefVal := ExRelValT ValueTyping.

Definition ExTDefValProj1 := ExRelValTProj1 ValueTyping.

Definition updateVEnvLemma := updateEnvLemmaT ValueTyping.

Definition overrideVEnvLemma := overrideEnvLemmaT ValueTyping.

Definition ValTypedByEnv := RelatedByEnvEP2_T ValueTyping.

Definition ValTypedByEnvA := RelatedByEnvEP_T ValueTyping.

(** fun typing lemmas from CRelLib *)

Definition ExTDefFun := ExRelValT FunTyping.

Definition ExTDefFunProj1 := ExRelValTProj1 FunTyping.

Definition updateFEnvLemma := updateEnvLemmaT FunTyping.

Definition overrideFEnvLemma := overrideEnvLemmaT FunTyping.

Definition FunTypedByEnv := RelatedByEnvEP2_T FunTyping.

Definition FunTypedByEnvA := RelatedByEnvEP_T FunTyping.

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

(** value lists  in Prop *)

Inductive isValue (e: Exp) : Prop :=
  IsValue : forall (v: Value), e = Val v -> isValue e.

Definition isValueList (ls : list Exp) : Prop :=
Forall isValue ls.

Inductive isValueList2
  (els : list Exp) (vls : list Value) : Prop :=
IsValueList2 :  els = map Val vls -> isValueList2 els vls.

(** value lists in Type *)

Inductive isValueT (e: Exp) : Type :=
  IsValueT : forall (v: Value), e = Val v -> isValueT e.

Definition isValueListT (ls : list Exp) : Type :=
ForallT isValueT ls.

Inductive isValueList2T
  (els : list Exp) (vls : list Value) : Type :=
IsValueList2T :  els = map Val vls -> isValueList2T els vls.

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

(** lemmas about value lists in Type *)

Lemma isValueList2IsValueT (els : list Exp) (vls : list Value) :
  isValueList2T els vls -> isValueListT els.
Proof.
  intros.
  inversion H; subst.
  unfold isValueList.
  revert H.
  induction vls.
  simpl.
  constructor.
  constructor.
  econstructor.
  reflexivity.
  eapply IHvls.
  constructor.
  auto.
Defined.

Lemma isValueList22_T (ls : list Exp) : isValueListT ls ->
             sigT (fun vs => isValueList2T ls vs).
Proof.
  induction ls.
  intros.
  exists nil.
  constructor.
  simpl.
  reflexivity.
  intros.
  assert (isValueListT ls).
  inversion X; subst.
  assumption.
  inversion X; subst.
  inversion X1; subst.
  eapply IHls in X0.
  destruct X0 as [vs1 X0].
  constructor 1 with (x := v::vs1).
  constructor.
  inversion X0; subst.
  simpl.
  reflexivity.
Defined.

Lemma ExTDefNatT (T: Type) {VT: ValTyp T}
           (tenv: valTC) (venv: valEnv) (t: VTyp) (x: Id):
    MatchEnvsT ValueTyping venv tenv ->
    findET tenv x t ->
    T = proj1_sig t ->
    sigT (fun v: T => findET venv x (cst T v)).
Proof.
  intros.
  subst.
  cut (sigT2 (findET venv x) (fun v: Value => ValueTyping v t)).
  intro.
  destruct X1 as [v E1 E2].
  inversion E2; subst.
  subst T.
  destruct v as [T b].
  destruct b.
  compute in H.
  assert (T = proj1_sig t).
  compute.
  assumption.
  clear H.
  subst.
  econstructor 1 with (x:=v).
  unfold cst.
  assumption.
  eapply ExTDefVal.
  eassumption.
  assumption.
Defined.

Lemma sameLengthVV (es : list Exp) (vs : list Value) :
  isValueList2 es vs -> length es = length vs.
Proof.
intros.
inversion H; subst.
clear H.
induction vs.
auto.
simpl.
rewrite IHvs.
reflexivity.
Defined.

Lemma sameLengthVV_T (es : list Exp) (vs : list Value) :
  isValueList2T es vs -> length es = length vs.
Proof.
intros.
inversion H; subst.
clear H.
induction vs.
auto.
simpl.
rewrite IHvs.
reflexivity.
Defined.

Lemma mapEq (ls1 ls2: list Value) :
   map Val ls1 = map Val ls2 -> ls1 = ls2.
Proof.
  revert ls2.
  induction ls1.
  induction ls2.
  auto.
  intros.
  simpl in H.
  inversion H.
  intros.
  destruct ls2.
  simpl in H.
  inversion H.
  simpl in H.
  inversion H; subst.
  assert (ls1 = ls2).
  eapply IHls1.
  assumption.
  rewrite H0.
  auto.
Defined.

Lemma vlaMapEq (vs1 vs2: list Value) : map Val vs1 = map Val vs2 -> vs1 = vs2.
Proof.
  intros.
  revert H.
  revert vs2.
  induction vs1.
  intro vs2.
  destruct vs2.
  auto.
  intros.
  simpl in H.
  inversion H.
  intros.
  destruct vs2.
  simpl in H.
  inversion H.
  simpl in H.
  inversion H; subst.
  eapply IHvs1 in H2.
  rewrite H2.
  auto.
Defined.

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

(** parameter typing *)

Definition vlsTyping (vs: list Value) (pt: list VTyp) : Type :=
           Forall2T ValueTyping vs pt.

Definition PrmsValTyping (es: list Exp) (ts: list VTyp) : Type :=
  sigT2 (isValueList2 es) (fun vs => vlsTyping vs ts).

Definition PrmsValTypingT (es: list Exp) (ts: list VTyp) : Type :=
  sigT2 (isValueList2T es) (fun vs => vlsTyping vs ts).

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

(** lemmas about parameter typing *)

Lemma prmsTypingAux_T (fps : valTC) (vls : list Value)
                       (h: length fps = length vls):
          vlsTyping vls (map snd fps) ->
                         MatchEnvsT ValueTyping (mkVEnv fps vls) fps.
Proof.
  unfold mkVEnv.
  intros.
  apply prmsTypingAux2_T.
  auto.
  eapply prmsTypingAux1_T.
  auto.
  auto.
Defined.

Lemma Exp2ValueTyping
      (ftenv: funTC) (tenv: valTC) (fenv: funEnv)
      (v: Value) (t: VTyp) :
  ExpTyping ftenv tenv fenv (Val v) t ->
  ValueTyping v t.
Proof.
  intros.
  dependent induction X.
  auto.
Defined.

Lemma Exp2ValueTypingA
      (ftenv: funTC) (tenv: valTC) (fenv: funEnv)
      (v: Value) (t: VTyp) :
  ExpTyping ftenv tenv fenv (Val v) t ->
  ExpTyping emptyE emptyE emptyE (Val v) t.
Proof.
intro.
constructor.
eapply Exp2ValueTyping.
eassumption.
Defined.

Lemma Value2ExpTyping
      (ftenv: funTC) (tenv: valTC) (fenv: funEnv)
      (v: Value) (t: VTyp) :
  ValueTyping v t ->
  ExpTyping ftenv tenv fenv (Val v) t.
Proof.
  intros.
  inversion H; subst.
  constructor.
  auto.
Defined.

Lemma prmsTypingAux01_T
      (ftenv: funTC) (tenv: valTC) (fenv: funEnv)
      (vs: list Value) (ts: list VTyp) :
          vlsTyping vs ts ->
          PrmsTyping ftenv tenv fenv (PS (map Val vs)) (PT ts).
Proof.
  unfold vlsTyping.
  intros.
  induction X.
  constructor.
  constructor.
  simpl.
  constructor.
  constructor.
  eapply Value2ExpTyping.
  auto.
  auto.
  inversion IHX; subst.
  auto.
Defined.

Lemma matchListsAux02_T
      (ftenv: funTC) (tenv: valTC) (fenv: funEnv)
                       (ts: list VTyp)
                       (es : list Exp) (vs : list Value) :
  isValueList2T es vs ->
  PrmsTyping ftenv tenv fenv (PS es) (PT ts) ->
  vlsTyping vs ts.
Proof.
  unfold vlsTyping.
  intros.
  inversion H; subst.
  inversion X; subst.
  revert X.
  revert H.
  dependent induction X0 generalizing vs.
  - intros.
    symmetry in x.
    eapply map_eq_nil in x.
    rewrite x.
    constructor.
  - intros.
    simpl in x.
    destruct vs.
    simpl in x.
    inversion x.
    constructor.
    simpl in x.
    inversion x; subst.
    eapply Exp2ValueTyping.
    eassumption.
    simpl in x.
    inversion x; subst.
    specialize (IHX0 vs).
    eapply IHX0.
    reflexivity.
    econstructor.
    auto.
    constructor.
    auto.
Defined.

Lemma matchListsAux02
      (ftenv: funTC) (tenv: valTC) (fenv: funEnv)
                       (ts: list VTyp)
                       (es : list Exp) (vs : list Value) :
  isValueList2 es vs ->
  PrmsTyping ftenv tenv fenv (PS es) (PT ts) ->
  vlsTyping vs ts.
Proof.
  unfold vlsTyping.
  intros.
  inversion H; subst.
  inversion X; subst.
  revert H.
  revert X.
  dependent induction X0 generalizing vs.
  - intros.
    symmetry in x.
    eapply map_eq_nil in x.
    rewrite x.
    constructor.
  - simpl in x.
    destruct vs.
    simpl in x.
    inversion x.
    constructor.
    simpl in x.
    inversion x; subst.
    eapply Exp2ValueTyping.
    eassumption.
    simpl in x.
    inversion x; subst.
    specialize (IHX0 vs).
    eapply IHX0.
    reflexivity.
    econstructor.
    auto.
    constructor.
    auto.
Defined.

Lemma matchListsAux1A
      (ftenv: funTC) (tenv: valTC) (fenv: funEnv) (ts: list VTyp)
                       (es : list Exp) (vs : list Value) :
  isValueList2T es vs ->
  Forall2T (ExpTyping ftenv tenv fenv) es ts ->
  Forall2T (ExpTyping emptyE emptyE emptyE) es ts.
Proof.
  intros.
  revert H.
  revert vs.
  dependent induction X.
  intros.
  inversion H; subst.
  symmetry in H0.
  eapply map_eq_nil in H0; subst.
  constructor.
  intros.
  destruct vs.
  inversion H; subst.
  simpl in H0.
  inversion H0.
  inversion H; subst.
  simpl in H0.
  inversion H0; subst.
  assert (isValueList2T (map Val vs) vs).
  constructor.
  reflexivity.
  eapply IHX in H1.
  constructor.
  eapply Exp2ValueTypingA.
  eassumption.
  assumption.
Defined.

Lemma matchListsAux1
      (ftenv: funTC) (tenv: valTC) (fenv: funEnv) (ts: list VTyp)
                       (es : list Exp) (vs : list Value) :
  isValueList2T es vs ->
  Forall2T (ExpTyping ftenv tenv fenv) es ts ->
  Forall2T ValueTyping vs ts.
Proof.
  intros.
  revert H.
  revert vs.
  dependent induction X.
  intros.
  inversion H; subst.
  symmetry in H0.
  eapply map_eq_nil in H0; subst.
  constructor.
  intros.
  destruct vs.
  inversion H; subst.
  simpl in H0.
  inversion H0.
  inversion H; subst.
  simpl in H0.
  inversion H0; subst.
  assert (isValueList2T (map Val vs) vs).
  constructor.
  reflexivity.
  eapply IHX in H1.
  constructor.
  eapply Exp2ValueTyping.
  eassumption.
  assumption.
Defined.

Lemma prmsAux2 (vls: list Value) (fps: valTC) :
vlsTyping vls (map snd fps) ->
  length fps = length vls.
Proof.
  intros.
  unfold vlsTyping in X.
  eapply sameBehSameLength_T in X.
  rewrite X.
  rewrite map_length.
  auto.
Defined.

Lemma prmsAux3
      (ftenv: funTC) (tenv: valTC) (fenv: funEnv)
                (ls: list Exp) (fps: valTC) :
PrmsTyping ftenv tenv fenv (PS ls) (env2ptyp fps) ->
  length fps = length ls.
Proof.
  intros.
  unfold env2ptyp in X.
  inversion X; subst.
  eapply sameBehSameLength_T in X0.
  rewrite X0 at 1.
  rewrite map_length.
  auto.
Defined.

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

(** lemmas about function typing *)

Lemma funTypingAux1
      (fenv: funEnv) (tenv fps: valTC) (e0 e1: Exp)
                     (x: Id) (i: nat) (t: VTyp) :
      FunTyping (FC fenv tenv e0 e1 x i) (FT fps t) ->
                        tenv = fps.
Proof.
  intros.
  inversion X; subst.
  reflexivity.
  reflexivity.
Defined.

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

(** lemmas about value lists in Prop *)

Lemma isValueList2IsValue (els : list Exp) (vls : list Value) :
  isValueList2 els vls -> isValueList els.
Proof.
  intros.
  inversion H; subst.
  unfold isValueList.
  revert H.
  induction vls.
  simpl.
  constructor.
  constructor.
  econstructor.
  reflexivity.
  eapply IHvls.
  constructor.
  auto.
Defined.

Lemma isValueListT_triv (vls : list Value) :
  isValueListT (map Val vls).
Proof.
  induction vls.
  constructor.
  constructor.
  econstructor.
  reflexivity.
  auto.
Defined.

Lemma isValueList22 (ls : list Exp) : isValueList ls ->
             exists vs, isValueList2 ls vs.
Proof.
  induction ls.
  intros.
  exists nil.
  constructor.
  simpl.
  reflexivity.
  intros.
  assert (isValueList ls).
  inversion H; subst.
  assumption.
  inversion H; subst.
  inversion H3; subst.
  eapply IHls in H0.
  destruct H0.
  rename x into vs1.
  exists (v::vs1).
  constructor.
  inversion H0; subst.
  simpl.
  reflexivity.
Defined.

Lemma mkEnvTyping_aux0 (fps: valTC) (vs: list Value):
  length fps = length vs ->
  vlsTyping vs (map snd fps) ->
    EnvTyping (mkVEnv fps vs) fps.
  intros.
  eapply prmsTypingAux_T.
  auto.
  auto.
Defined.

End Static.


Require Import Coq.Lists.List Program NArith Lia. Import ListNotations.
Require Import SyDPaCC.Support.List SyDPaCC.Support.NList.
From SyDPaCC.Core Require Import Bmf Parallelization Diffusion.
From SyDPaCC.Bsml.Model Require Import Core Pid.
From SyDPaCC.Bsml.DataStructures Require Import DistributedList DistributedVector.
From SyDPaCC.Bsml.Skeletons Require Import StdLib.
Set Implicit Arguments.
Generalizable All Variables.

Module Make(Import Bsml: BSML)
       (Import Pid: Pid.TYPE Bsml.Bsp)
       (Import StdLib: StdLib.TYPE Bsml Pid)
       (Import PL : DistributedList.T Bsml Pid)
       (Import DV : DistributedVector.T Bsml Pid).

  Open Scope N_scope.
  Open Scope sydpacc_scope.

  (** * The [last] Skeleton *)

  Definition seq_last A (l : list A | length l = Bsp.p) : A.
    pose Bsp.p_spec.
    refine (Bmf.last (` l)).
    now apply length_lt_0_NonEmpty.
  Defined.

  Definition par_last A (v:par A) : A := proj v Pid.last.

  #[export] Instance last_corr A: FunCorr (@seq_last A) (@par_last A).
  Proof.
    repeat constructor; intros ap; unfold join, seq_last, last; simpl.
    unfold Bmf.last; rewrite pids_snoc at 1.
    rewrite map_app; simpl; now rewrite list_last_app.
  Qed.

  (** * The [put_right_list] Communication Function *)

  Definition put_right_list A (v:par A) : par(list A) :=
    let destinations := mkpar(fun pid=>Pid.from_succ pid) in
    let messages :=
        parfun2 (fun last=>List.map (fun dst=>(dst,last))) v destinations in
    put_list messages.

  Fact put_right:
    forall A (v:par A) i j (Hlast: j<>Pid.last),
      Pid.le i j ->
      get
        (put
           (parfun (fun (listDstValue : list (pid * A)) (dst : pid) => assoc dst listDstValue)
                   (parfun2 (fun last0 : A => map (fun dst : pid => (dst, last0))) v
                            (mkpar (fun pid : pid => from_succ pid))))) (succ Hlast) i = Some(get v i).
  Proof.
    intros A v i j Hlast Hi.
    autorewrite with bsml.
    apply assoc_in_first. unfold from_succ.
    destruct(pid_dec i Pid.last) as [ Heq | Hneq ].
    - assert(j = Pid.last).
      {
        subst; destruct j as [ j Hj ]; unfold last, le in *; simpl in *; pid.
        apply proj1_sig_inj; simpl; clear Hlast H;
          rewrite N.pred_sub in Hi; pid;
        try(apply N.le_lteq in Hi;
            destruct Hi as [Hi|Hi];
            [ lia | rewrite N.pred_sub; auto ]).
      }
      contradiction.
    - assert(le (succ Hneq) (succ Hlast)) as Hle.
      {
        unfold le, succ in *; simpl in *.
        lia.
      }
      apply from_le in Hle; auto.
      apply In_from_split in Hle.
      destruct Hle as [ H1 [ H2 Hfrom ] ].
      rewrite Hfrom; repeat rewrite map_app; simpl.
      match goal with
      | [ |- in_first ?pair (?l1'++_::?l2') ] =>
        apply in_first_ with (l1:=l1')(l2:=l2')(l:=l1'++pair::l2')
      end.
      + simpl; intros b H.
        apply in_map_iff in H; destruct H as [ k [Hk1 Hk2]].
        inversion Hk1; subst; clear Hk1.
        apply Sig.in_map_in in Hk2; unfold succ in Hk2; simpl in Hk2.
        apply In_seq in Hk2; destruct Hk2 as [ Hk1 Hk2 ].
        pid.
      + reflexivity.
  Qed.

  Lemma put_right_list_first:
    forall A (v:par A),
      get (put_right_list v) first = [ ].
  Proof.
    intros A v.
    unfold put_right_list, put_list; autorewrite with bsml.
    apply filter_map_some_empty.
    intros j Hj. autorewrite with bsml.
    apply assoc_not_in.
    rewrite map_map; simpl; rewrite map_id.
    intro H.
    apply in_map with (f:=@proj1_sig N _) in H; simpl in H.
    unfold from_succ in H.
    destruct(pid_dec j Pid.last) as [ Heq | Hneq ].
    - inversion H.
    - unfold from in H; rewrite Sig.map_proj1_sig in H.
      apply In_seq in H.
      unfold succ in H; simpl in H; lia.
  Qed.

  Lemma put_right_list_succ:
    forall A (v:par A) j (Hlast: j<>Pid.last),
      get (put_right_list v) (succ Hlast) =
      map (get v) (pid_up_to j).
  Proof.
    intros A v j Hlast; unfold put_right_list, put_list; autorewrite with bsml.
    apply map_inj with (f:=Some).
    - intros a a' H0; now inversion H0.
    - rewrite filter_map_some_prop.
      assert(In j (from first)) as Hin
          by (rewrite <- pids_from; apply pids_spec).
      destruct (In_from_split first j Hin) as [ H1 [H2 Hfrom ]].
      rewrite pids_from; unfold from in *.
      erewrite Sig.map_pi
      with (l:=(seq (` first) (Bsp.p - ` first)))
             (l':=(seq (` first) (Bsp.p - ` first))) by solve [ apply proj1_sig_inj | auto ].
      rewrite Hfrom; clear Hfrom Hin.
      repeat rewrite map_app; simpl.
      rewrite put_right by (unfold le; pid).
      match goal with
      | [ |- filter _ ( (map ?f' _) ++ _ :: (map ?f'' _) )  = _ ] =>
        rewrite map_ext_in with (f:=f')(g:=fun i=>Some(get v i));
          try rewrite map_ext_in with (f:=f')(g:=fun i=>None)
      end.
      rewrite filter_app; simpl.
      rewrite filter_true, filter_false, map_map.
      + unfold pid_up_to.
        match goal with
        | [ |- map ?f ?l1 ++ [ Some(get _ ?k) ] = map ?f' ?l2 ] =>
          replace [ Some(get _ k) ] with (map f [ k ]) by auto;
            rewrite <- map_app;
            assert(l1 ++ [ k ] = l2) as Hl
        end.
        {
          replace [ j ] with (Sig.map [` j] (In_pid j))
            by (simpl; f_equal; now apply proj1_sig_inj).
          match goal with
          | [ |- Sig.map ?ll _ ++ _ = _ ] =>
            erewrite Sig.map_pi with (l:=ll)(l':=ll)
              by solve [apply proj1_sig_inj | auto ]
          end.
          erewrite Sig.map_pi with (l:=[` j])(l':=[` j])
            by solve [apply proj1_sig_inj | auto ].
          rewrite <- Sig.map_app by apply proj1_sig_inj.
          match goal with
          | [ |- Sig.map ?l1 _ = Sig.map ?l2 _ ] =>
            assert(l1 = l2) as Hl'
                by (rewrite seq_S_app; repeat f_equal; pid)
          end.
          erewrite Sig.map_pi with (l':=seq 0 (N.succ (` j)))
            by solve [apply proj1_sig_inj | auto ].
          reflexivity.
        }
        rewrite Hl.
        apply map_ext.
        intro; now autorewrite with bsml.
      + intros a Ha; apply in_map_iff in Ha; destruct Ha as [ x [ Hx1 Hx2 ] ]; now subst.
      + intros a Ha; apply in_map_iff in Ha; destruct Ha as [ x [ Hx1 Hx2 ] ]; now subst.
      + intros a Ha; autorewrite with bsml.
        apply assoc_not_in; rewrite map_map, map_id; simpl.
        apply Sig.in_map_in, In_seq in Ha; destruct Ha as [ Ha _ ].
        unfold from_succ; destruct(pid_dec a Pid.last) as [ Heq | Hneq ]; intro Hin.
        * inversion Hin.
        * unfold from in Hin.
           apply Sig.in_map_in, In_seq in Hin; destruct Hin as [ Hin _ ].
           unfold succ in Hin; simpl in Hin; pid.
      + intros a Ha; rewrite put_right; auto.
        apply Sig.in_map_in, In_seq in Ha; destruct Ha as [ _ Ha  ].
        rewrite N.sub_0_r, N.add_0_l in Ha.
        unfold le; pid.
        Unshelve.
        clear; intros a.
        replace [` j] with [0 + ` j] by auto.
        rewrite N.sub_0_r , <- seq_S_app.
        intro Ha; apply In_seq in Ha; destruct j; pid.
  Qed.

  (** * The [scanl1] Skeleton *)

  Definition par_scanl1 A B op (e:B) (v:par A) : par B :=
    parfun (fun l=>List.fold_left op l e) (put_right_list v).

  Definition seq_scanl1 A B (op:B->A->B) (e:B) (l:list A | length l = Bsp.p) :
    { l : list B | length l = Bsp.p }.
    exists(removelast(scanl op e (` l))).
    autorewrite with length; try typeclasses eauto.
    rewrite N.add_1_l, N.pred_succ.
    destruct l ; auto.
  Defined.

  Global Instance scanl1_scanl A B (op:B->A->B) e : FunCorr (seq_scanl1 op e) (par_scanl1 op e).
  Proof.
    constructor; intros ap Ha.
    unfold join, seq_scanl1, par_scanl1; apply list_length_inj; simpl.
    apply  pids_ind ; [ | intros j Hlast IH ].
    - simpl; f_equal; autorewrite with bsml.
      now rewrite put_right_list_first.
    - rewrite pid_up_to_succ.
      repeat rewrite map_app.
      rewrite IH; simpl. rewrite scanl_snoc, removelast_app by (intro;discriminate).
      autorewrite with bsml.
      rewrite put_right_list_succ; simpl; rewrite app_nil_r; symmetry.
      rewrite scanl_scanl_last, scanl_last_fst_scanl at 1.
      do 2 f_equal.
      rewrite scanl_last_snd.
      f_equal; apply map_ext.
      intro; now autorewrite with bsml.
  Qed.

  Lemma scanl1_spec:
    forall A B op (e:B) (v:par A) pid,
      get (par_scanl1 op e v) pid = nth (` pid) (scanl op e (` (join v))) e.
  Proof.
    intros A B op e v pid; unfold par_scanl1.
    autorewrite with bsml.
    destruct(pid_dec pid first) as [ Heq | Hneq ]; subst.
    - rewrite put_right_list_first; simpl.
      now rewrite scanl_cons, nth_equation.
    - apply not_first_succ in Hneq.
      destruct Hneq as [ j [ Hj Heq ] ]; subst.
      rewrite put_right_list_succ.
      rewrite scanl_fold by
          (unfold succ; unfold join; rewrite N.add_1_l; simpl;
           autorewrite with length; repeat rewrite N.add_1_l; simpl;
           destruct j as [j Hj']; clear Hj; pid).
      unfold join; simpl.
      rewrite firstn_map; f_equal; rewrite pid_up_to_firstn by auto.
      apply map_ext; intro; now autorewrite with bsml.
  Qed.

  Lemma scanl1_seq_scanl1: forall A B op (e:A) (ap:par B),
      proj1_sig(join (par_scanl1 op e ap)) = proj1_sig (seq_scanl1 op e (join ap)).
  Proof.
    intros A B op e ap.
    pose (last_corr A) as H; inversion H as [ Hcorr ].
    pose (scanl1_scanl op e) as H'; inversion H' as [ Hcorr' ].
    now rewrite Hcorr'.
  Qed.

  (** * The [scan_last] Skeleton *)

  Definition par_scanl_last A B op1 op2 (e:B) c (v:par(list A)) : par(list B) * B :=
    let partials := parfun (scanl_last' op1 e) v in
    let scanls   := parfun fst partials in
    let lasts    := parfun snd partials in
    let sums     := par_scanl1 op2 c lasts in
    ( parfun2 (fun sum=>map' (op2 sum)) sums scanls,
      par_last (parfun2 op2 sums lasts) ).

  Lemma parfun_seq_scanl_last_up_to:
    forall A B op e `{Monoid A op e} (q:B->A) c ap i,
      let op' := fun s t=>op s (q t) in
      fold_left op (map (proj (parfun snd (parfun (scanl_last op' e) ap))) (pid_up_to i)) c =
      fold_left op (map q (flat_map (proj ap) (pid_up_to i))) c.
  Proof.
    intros A B op e H q c ap i; induction i as [ | i Hneq IH ] using pid_ind.
    - replace (pid_up_to first) with [ first ]
        by (eapply map_inj;
            [ apply proj1_sig_inj |
              unfold pid_up_to; repeat rewrite Sig.map_proj1_sig;
              simpl; now repeat (rewrite seq_equation; simpl) ]).
      simpl.
      rewrite app_nil_r; autorewrite with bsml.
      rewrite scanl_last_snd.
      rewrite fold_left_map_r.
      rewrite <- fold_left_prop by typeclasses eauto.
      now rewrite right_neutral.
    - simpl; rewrite pid_up_to_succ, map_app, flatmap_app, map_app.
      repeat rewrite fold_left_app; simpl; rewrite app_nil_r.
      rewrite IH; autorewrite with bsml.
      rewrite scanl_last_snd.
      repeat rewrite fold_left_map_r with (g:=q).
      rewrite  <- fold_left_prop by typeclasses eauto; f_equal.
      apply right_neutral.
  Qed.

  Fact parfun_seq_scanl_last_pids:
    forall A B op (e:A) `{Monoid A op e} (q:B->A) c ap,
      let op' := fun s t=>op s (q t) in
      fold_left op (map (proj (parfun snd (parfun (scanl_last op' e) ap))) pids) c =
      fold_left op (map q (flat_map (proj ap) pids)) c.
  Proof.
    intros; rewrite pid_up_to_last.
    now apply parfun_seq_scanl_last_up_to.
  Qed.

  #[export] Instance scanl_last_corr A B `{Monoid A op e} (q:B->A) c:
    FunCorr (scanl_last (fun s t=>op s (q t)) c) (par_scanl_last (fun s t=>op s (q t)) op e c).
  Proof.
    repeat constructor; intros ap Ha;  unfold pairing; simpl.
    repeat rewrite parfun_ext with (g:=@scanl_last A B  (fun (s : A) (t : B) => op s (q t)) e)
      by (intro; now rewrite scanl_last_scanl_last').
    rewrite surjective_pairing, scanl_last_fst_scanl, <- last_scanl; f_equal.
    - unfold PL.join. apply pids_ind.
      + simpl; autorewrite with bsml; repeat rewrite app_nil_r.
        rewrite scanl_last_fst_scanl.
        set( op' := fun s t=>op s (q t)).
        specialize (scanl1_seq_scanl1 op c (parfun snd (parfun (scanl_last op' e) ap))) as Heq.
        unfold join, seq_scanl1, last in Heq; simpl in Heq; rewrite pids_cons in Heq;
          simpl in Heq; rewrite scanl_cons in Heq.
        assert(get (par_scanl1 op c (parfun snd (parfun (scanl_last op' e ) ap))) first = c) as HH
          by ( inversion Heq as [ H1 ]; rewrite H1; now autorewrite with bsml in H1 ).
        rewrite map'_map. rewrite HH, <- removelast_map; f_equal.
        unfold op'; now rewrite scanl_map_gen with (c:=c)(e:=e) by typeclasses eauto.
      + intros i Hlast_i IH.
        rewrite pid_up_to_succ, flatmap_app, flatmap_app; simpl;
          repeat rewrite app_nil_r; autorewrite with bsml; rewrite IH; clear IH.
        rewrite scanl1_spec, scanl_fold by
            (unfold succ, join; repeat rewrite N.add_1_l; simpl;
             autorewrite with length; repeat rewrite N.add_1_l;
             clear; destruct i; pid).
        simpl. rewrite firstn_map, <- pid_up_to_firstn by auto.
        rewrite parfun_seq_scanl_last_up_to by auto.
        rewrite <- fold_left_map_r with (g:=q).
        rewrite scanl_last_fst_scanl, <- scanl_last_snd, <- last_scanl.
        rewrite  map'_map,<- removelast_map, <- removelast_app by apply non_emptiness; f_equal.
        unfold Bmf.last; rewrite scanl_hd.
        erewrite scanl_app_gen by typeclasses eauto; f_equal.
        now rewrite list_last_non_empty with (d':=e) by typeclasses eauto.
    - autounfold in *. pose (last_corr A) as Hlc; inversion Hlc as [ Hcorr ].
      autounfold in *. rewrite Hcorr by auto; unfold seq_last, Bmf.last; simpl.
      rewrite pids_snoc, map_app at 1; simpl; rewrite list_last_app.
      autorewrite with bsml in *.
      rewrite scanl1_spec, scanl_fold, scanl_last_snd
        by (unfold succ, join; rewrite N.add_1_l; simpl;
            autorewrite with length; repeat rewrite N.add_1_l; simpl;
            rewrite N.pred_sub; clear; pid).
      pose  last_scanl as HH; unfold Bmf.last in HH; repeat rewrite HH.
      rewrite scanl_last_snd.
      unfold PL.join, join; simpl.
      repeat rewrite fold_left_map_r with (g:=q).
      erewrite <- parfun_seq_scanl_last_pids by typeclasses eauto.
      rewrite pids_snoc at 2; rewrite map_app, fold_left_app; simpl.
      rewrite firstn_map; repeat f_equal.
      + rewrite pids_snoc at 1.
        replace(N.pred Bsp.p) with (length(removelast pids))
          by (autorewrite with length; auto; rewrite pids_cons; typeclasses eauto).
        now rewrite firstn_app1, firstn_length by lia.
      + autorewrite with bsml.
        rewrite scanl_last_snd.
        now rewrite fold_left_map_r with (g:=q).
  Qed.

  Ltac sd :=
    match goal with
    | [ |- context [ SameDistribution ] ] =>
      intros; constructor; autounfold; intros; simpl;
      repeat (try rewrite <- scanl_last_scanl_last';try rewrite map'_map;
              autorewrite with bsml length)
    end.

  #[export] Instance preserves_distribution_fst_par_scanl_last A B op1 op2 (e:B) c:
    EnsuresProp (((id×fst)△(snd∘snd))∘(id △ (par_scanl_last op1 op2 e c)))
                ((prod_curry (@SameDistribution A B)) ∘ fst).
  Proof.
    constructor; intro v; now sd.
  Defined.

  (** * The [fold_left2] Skeleton *)

  Definition par_fold_left2 A B C (op1:C->A*B->C) (op2:C->C->C) (e:C)
             (v1:par(list A)) (v2:par(list B)) : C :=
    let f := proj (parfun2 (fold_left2 op1 e) v1 v2) in
    List.fold_left op2 (map f pids) e.

  #[export] Instance fold_left2_corr A B C (p:A*B->C) `{Monoid C op e} :
    let op' := fun (u:C) (vw:A*B)=>op u (p vw) in
    FunCorr2 (Bmf.fold_left2 op' e) (par_fold_left2 op' op e).
  Proof.
    constructor; intros ap bp H'; unfold par_fold_left2, PL.join; apply pids_ind;
    inversion H' as [ Hsd ]; subst; clear H'.
    - simpl; repeat rewrite app_nil_r; autorewrite with bsml.
      now rewrite left_neutral.
    - intros i Hi IH; rewrite pid_up_to_succ, <- fold_left2_prop1.
      repeat rewrite map_app; repeat rewrite flatmap_app;
        rewrite combine_app
        by(length; repeat rewrite map_map; f_equal; apply map_ext;
           intro; autorewrite with bsml; auto).
      simpl; repeat rewrite app_nil_r; repeat rewrite fold_left_app; simpl;
        autorewrite with bsml; autounfold in *; rewrite IH; repeat rewrite <- fold_left2_prop1.
      repeat rewrite fold_left_map_r with (g:=p).
      rewrite <- fold_left_prop by typeclasses eauto; f_equal.
      apply right_neutral.
  Qed.

  (** * The [accumulate] Skeleton *)

  Open Scope sydpacc_scope.

  #[export] Instance parallelize_accumulate A B C (g:B->C) (p:A*B->C) (q:A->B)
           `{Monoid C oplus e_oplus} `{Monoid B otimes e_otimes} c :
    FunCorr
      (accumulate g p q oplus otimes c)
      ((prod_curry oplus)
         ∘ ( ((prod_curry (par_fold_left2 (fun (u:C) (vw:A*B)=>oplus u (p vw)) oplus e_oplus)) × g)
               ∘ ( ( (id × fst) △ (snd ∘ snd) )
                     ∘ (id △ (par_scanl_last (fun s t=>otimes s (q t)) otimes e_otimes c) ) ) ) )
      (HP:=true_parprop).
  Proof.
    typeclasses eauto.
  Qed.

  Close Scope sydpacc_scope.

  Close Scope N_scope.

End Make.


Require Import Primitives Layer.Core.
Require LayerImplementation.
Import ListNotations.

Set Implicit Arguments.

Section HorizontalComposition.
  Variable O1 O2 : Core.

  Inductive token' :=
  | Token1 : O1.(token) -> token'
  | Token2 : O2.(token) -> token'.

  Definition state' := (O1.(state) * O2.(state))%type.

  Inductive horizontal_composition_prog : Type -> Type :=
  | P1 : forall T, O1.(operation) T -> horizontal_composition_prog T
  | P2 : forall T, O2.(operation) T -> horizontal_composition_prog T.

  Inductive exec': forall T, user -> token' -> state' -> horizontal_composition_prog T -> @Result state' T -> Prop :=
  | ExecP1:
      forall T (p1: O1.(operation) T) u o1 s s1 r,
        O1.(exec) u o1 (fst s) p1 (Finished s1 r) ->
        exec' u (Token1 o1) s (P1 _ p1) (Finished (s1, snd s) r)
  | ExecP2:
      forall T (p2: O2.(operation) T) u o2 s s2 r,
        O2.(exec) u o2 (snd s) p2 (Finished s2 r) ->
        exec' u (Token2 o2) s (P2 _ p2) (Finished (fst s, s2) r)
  | ExecP1Crash:
      forall T (p1: O1.(operation) T) u o1 s s1,
        O1.(exec) u o1 (fst s) p1 (Crashed s1) ->
        exec' u (Token1 o1) s (P1 _ p1) (Crashed (s1, snd s))
  | ExecP2Crash:
      forall T (p2: O2.(operation) T) u o2 s s2,
        O2.(exec) u o2 (snd s) p2 (Crashed s2) ->
        exec' u (Token2 o2) s (P2 _ p2) (Crashed (fst s, s2)).

  Theorem exec_deterministic_wrt_token' :
    forall u o s T (p: horizontal_composition_prog T) ret1 ret2,
      exec' u o s p ret1 ->
      exec' u o s p ret2 ->
      ret1 = ret2.
  Proof.
    intros; destruct p; simpl in *;
    inversion H; inversion H0;
    sigT_eq; clear H H0; cleanup;
    try solve [inversion H11; subst;
               eapply exec_deterministic_wrt_token in H7;
               eauto; cleanup; eauto].
  Qed.

  Hint Constructors exec': core.

  Definition HorizontalComposition :=
    Build_Core
      horizontal_composition_prog exec'
      exec_deterministic_wrt_token'.

Import LayerImplementation.

Fixpoint lift_L1 {L1: Layer O1} {T} (p1 : L1.(prog) T) : prog' HorizontalComposition T :=
  match p1 with
  | Op _ o1 =>
    Op HorizontalComposition (P1 _ o1)
  | Ret v =>
    Ret v
  | Bind px py =>
    Bind (@lift_L1 L1 _ px) (fun x => @lift_L1 L1 _ (py x))
  end.

Fixpoint lift_L2 {L2: Layer O2} {T} (p2 : L2.(prog) T) : prog' HorizontalComposition T :=
  match p2 with
  | Op _ o2 =>
    Op HorizontalComposition (P2 _ o2)
  | Ret v =>
    Ret v
  | Bind px py =>
    Bind (@lift_L2 L2 _ px) (fun x => @lift_L2 L2 _ (py x))
  end.

End HorizontalComposition.

Arguments P1 {O1 O2 T}.
Arguments P2 {O1 O2 T}.

Notation "'<1|'  p >" := (P1 p)(right associativity, at level 60).
Notation "'<2|'  p >" := (P2 p)(right associativity, at level 60).

Section HorizontalCompositionAssociative.
Variable O1 O2 O3 : Core.

Definition HCA_state_1_to_2
(s1: (HorizontalComposition O1 (HorizontalComposition O2 O3)).(state))
: (HorizontalComposition (HorizontalComposition O1 O2) O3).(state) :=
((fst s1, fst (snd s1)), snd (snd s1)).

Definition HCA_state_2_to_1
(s2: (HorizontalComposition (HorizontalComposition O1 O2) O3).(state))
: (HorizontalComposition O1 (HorizontalComposition O2 O3)).(state) :=
(fst (fst s2), (snd (fst s2), snd s2)).

Definition HCA_token_1_to_2
(t1: (HorizontalComposition O1 (HorizontalComposition O2 O3)).(token))
  : (HorizontalComposition (HorizontalComposition O1 O2) O3).(token) :=
  match t1 with
  | Token1 _ _ t =>
    Token1 (HorizontalComposition O1 O2) _ (Token1 _ _ t)
  | Token2 _ _ t =>
    match t with
    | Token1 _ _ t' =>
    Token1 (HorizontalComposition O1 O2) _ (Token2 _ _ t')
    | Token2 _ _ t' =>
    Token2 _ _ t'
    end
  end.

Definition HCA_token_2_to_1
  (t2 : (HorizontalComposition (HorizontalComposition O1 O2) O3).(token))
  : (HorizontalComposition O1 (HorizontalComposition O2 O3)).(token) :=
    match t2 with
    | Token1 _ _ t =>
      match t with
      | Token1 _ _ t' =>
      Token1 _ _ t'
      | Token2 _ _ t' =>
      Token2 _ (HorizontalComposition O2 O3) (Token1 _ _ t')
      end
    | Token2 _ _ t =>
      Token2 _ (HorizontalComposition O2 O3) (Token2 _ _ t)
    end.

Definition HCA_compile_1_to_2 {T}
(o1: (HorizontalComposition O1 (HorizontalComposition O2 O3)).(operation) T)
: (HorizontalComposition (HorizontalComposition O1 O2) O3).(operation) T :=
match o1 with
| P1 p =>
  @P1 (HorizontalComposition O1 O2) _ _ (P1 p)
| P2 p =>
  match p with
  |P1 p =>
  @P1 (HorizontalComposition O1 O2) _ _ (P2 p)
  | P2 p =>
  P2 p
  end
end.

Definition HCA_compile_2_to_1 {T}
  (o2 : (HorizontalComposition (HorizontalComposition O1 O2) O3).(operation) T)
  : (HorizontalComposition O1 (HorizontalComposition O2 O3)).(operation) T :=
match o2 with
| P1 p =>
  match p with
  | P1 p =>
    P1 p
  | P2 p =>
    @P2 _ (HorizontalComposition O2 O3) _ (P1 p)
  end
| P2 p =>
  @P2 _ (HorizontalComposition O2 O3) _ (P2 p)
end.

Lemma HCA_token_1_to_2_to_1 :
forall t,
HCA_token_2_to_1 (HCA_token_1_to_2 t) = t.
Proof.
  intros; destruct t; simpl; eauto.
  destruct t; simpl; eauto.
Qed.

Lemma HCA_token_2_to_1_to_2 :
forall t,
HCA_token_1_to_2 (HCA_token_2_to_1 t) = t.
Proof.
  intros; destruct t; simpl; eauto.
  destruct t; simpl; eauto.
Qed.

Lemma HCA_exec_1_to_2_finished:
forall T u (o1: (HorizontalComposition O1 (HorizontalComposition O2 O3)).(operation) T) t1 s1 s1' r,
Core.exec _ u t1 s1 o1 (Finished s1' r) ->
Core.exec _ u (HCA_token_1_to_2 t1) (HCA_state_1_to_2 s1) (HCA_compile_1_to_2 o1) (Finished (HCA_state_1_to_2 s1') r).
Proof.
  unfold HCA_state_1_to_2; intros.
  inversion H; cleanup.
  destruct s1, s1;
  try destruct s1; simpl in *;
  repeat econstructor; eauto.

  inversion H6; cleanup;
  destruct s1, s1; simpl in *;
  repeat econstructor; eauto.
Qed.

Lemma HCA_exec_2_to_1_finished:
forall T u (o2: (HorizontalComposition (HorizontalComposition O1 O2) O3).(operation) T) t2 s2 s2' r,
Core.exec _ u t2 s2 o2 (Finished s2' r) ->
Core.exec _ u (HCA_token_2_to_1 t2) (HCA_state_2_to_1 s2) (HCA_compile_2_to_1 o2) (Finished (HCA_state_2_to_1 s2') r).
Proof.
  unfold HCA_state_2_to_1; intros.
  inversion H; cleanup.

  inversion H6; cleanup;
  destruct s2, s; simpl in *;
  repeat econstructor; eauto.

  destruct s2, s; simpl in *;
  repeat econstructor; eauto.
Qed.

End HorizontalCompositionAssociative.


Require Export Task.driver_requires.
Import ListNotations.
Import FloatIO.
Import DScopeNotations.
Open Scope D_scope.

(* Inductive type used to name state variables. *)
Inductive stateVar : Set :=
| SvT
| SvX
| SvXD
| SvXDD
| SvT_STOP
| SvDT
| SvDT_MAX
| SvDT_MIN
| SvDT_PRINT
| SvDampingCoefficient
| SvSpringCoefficient
| SvGRAVITY
| SvMass.

Lemma state_var_eq: forall (r1 r2: stateVar), {r1 = r2} + {r1 <> r2}.
Proof. decide equality. Defined.
Global Opaque state_var_eq.

Definition svIndex (sv: stateVar) : positive :=
  match sv with
  | SvT => 1
  | SvX => 2
  | SvXD => 3
  | SvXDD => 4
  | SvT_STOP => 5
  | SvDT => 6
  | SvDT_MAX => 7
  | SvDT_MIN => 8
  | SvDT_PRINT => 9
  | SvDampingCoefficient => 10
  | SvSpringCoefficient => 11
  | SvGRAVITY => 12
  | SvMass => 13
  end.

Definition svStrList :=
  [
    (SvT, "T");
    (SvX, "X");
    (SvXD, "XD");
    (SvXDD, "XDD");
    (SvT_STOP, "T_STOP");
    (SvDT, "DT");
    (SvDT_MAX, "DT_MAX");
    (SvDT_MIN, "DT_MIN");
    (SvDT_PRINT, "DT_PRINT");
    (SvDampingCoefficient, "SvDampingCoefficient");
    (SvSpringCoefficient, "SvSpringCoefficient");
    (SvGRAVITY, "GRAVITY");
    (SvMass, "Mass")
  ].

Definition model_default_values (_: unit) :=
  [
    (SvT,             "0.0"#D);
    (SvX,             "0.0"#D);
    (SvXD,            "0.0"#D);
    (SvXDD,           "0.0"#D);
    (SvT_STOP,        "2.5"#D);
    (SvDT,            "0.01"#D);
    (SvDT_MAX,        "0.005"#D);
    (SvDT_MIN,        "0.001"#D);
    (SvDT_PRINT,      "0.01"#D);
    (SvDampingCoefficient, "8.88"#D);
    (SvSpringCoefficient, "39.47"#D);
    (SvGRAVITY,       "9.88"#D);
    (SvMass,          "1.0"#D)
  ].

Definition modelOutputs : list stateVar := [SvT; SvX; SvXD].

Definition modelPairs : list (stateVar * stateVar) :=
  [(SvX, SvXD); (SvXD, SvXDD)].


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall A B C Aprime : Universe, ((wd_ B Aprime /\ (wd_ B C /\ (wd_ A Aprime /\ (wd_ Aprime C /\ (wd_ B A /\ (col_ A B C /\ col_ Aprime B C)))))) -> col_ B Aprime A)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e384m2e128m2e96p2e32m1_10limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition mul :
  { mul : feBW_loose -> feBW_loose -> feBW_tight
  | forall a b, phiBW_tight (mul a b) = F.mul (phiBW_loose a) (phiBW_loose b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_mul ().
  Show Ltac Profile.
Time Defined.

Print Assumptions mul.


Require Import Setoid Arith List Omega Coq.Program.Tactics decision.
Require Import mlattice id_and_loc language LibTactics tactics.

Module Types (L: Lattice).
  Module Lang := Language L.
  Import Lang L.

  Notation "∘" := LH.L.
  Notation "•" := LH.H.

  Notation "X '≼' Y" := (ProdL.flowsto X Y) (at level 70, no associativity).
  Notation "X '⋎' Y" := (ProdL.join X Y) (at level 40, left associativity).

  Inductive type :=
  | Int: type
  | Array: sectype -> level_proj1 -> type
  with sectype  :=
       | SecType:
           type -> ProdL.T -> sectype.

  Scheme type_mut := Induction for type Sort Prop
                     with sectype_mut := Induction for sectype Sort Prop.

  Definition tenv  := id -> option sectype.
  Definition emptyTenv : tenv := fun _ => None.
  Definition stenv := loc -> option sectype.
  Definition emptyStenv : stenv := fun _ => None.

End Types.