Require Import List.
From mathcomp Require Import ssreflect ssrbool ssrnat eqtype seq tuple ssrfun.
From mathcomp Require Import choice path bigop fintype.
Require Import Lib.Base Ipdl.Exp Ipdl.Core String Ipdl.Lems Lib.TupleLems Ipdl.Tacs Lib.Dist Pars Big Lib.Set Lib.OrdLems.
Require Import CFold CoinFlip.

Definition widen_ordS {n} (i : 'I_n) : 'I_(n.+1) := widen_ord (leqnSn n) i.

(* The simulator should work as follows:

   0. get leak from ideal world

   1. sends "committed" from everyone to Adv
   2. once Adv commits message, generate random bits for all honest PIDs, except first honest which is equal to all commits xor leak
   3. Open all to adv
   4. Waits for open from adv, then sends ok to environment
*)

Lemma pars_inline_from_big_shift_index {chan : Type -> Type} {t t'} {n1 n2} (b : chan t') (f : 'I_n1 -> 'I_n2)  (c : n2.-tuple (chan t)) (p : pred 'I_n1) (k : t -> rxn t') (r : 'I_n1 -> rxn t) (i : 'I_n1) rs :
  isDet _ (r i) ->
  p i ->
  pars [::
          Out b (x <-- Read (tnth c (f i)) ;; k x),
          \||_(j < n1 | p j) Out (tnth c (f j)) (r j) & rs] =p
  pars [::
          Out b (x <-- r i ;; k x),
          \||_(j < n1 | p j) Out (tnth c (f j)) (r j) & rs].
  intros.
  focus_tac 1.
  rewrite (bigpar_D1_ord i).
  done.
  done.
  rewrite SeqOps.insert_0.
  swap_tac 0 1.
  rewrite SeqOps.insert_0.
  rewrite par_in_pars; simpl.
  swap_tac 0 2; rewrite SeqOps.insert_0.
  swap_tac 1 2; rewrite SeqOps.insert_0.
  rewrite pars_inline.
  symmetry.
  focus_tac 1.
  rewrite (bigpar_D1_ord i).
  done.
  done.
  rewrite SeqOps.insert_0.
  swap_tac 0 1.
  rewrite SeqOps.insert_0.
  rewrite par_in_pars; simpl.
  swap_tac 0 2; rewrite SeqOps.insert_0.
  apply pars_cons_cong; rewrite //=.
  swap_tac 0 1; rewrite SeqOps.insert_0.
  apply pars_cons_cong; rewrite //=.
  done.
Qed.

   Lemma SimComp_simpl5E_subproof {chan : Type -> Type} (k : nat) {n}
         (commit : (n.+1).-tuple (chan k.-bv))
         (sum_commits : (n.+1).-tuple (chan k.-bv))
         (committed : (n.+2).-tuple (chan unit))
         (sum_committed : (n.+2).-tuple (chan unit))
         (r : rxn k.-bv)
         (c : chan k.-bv) i :
     pars [::
             \||_(i < n.+1) Out (tnth committed (widen_ordS i)) (_ <-- Read (tnth commit i) ;; Ret tt);
             Out (tnth committed ord_max) (Ret tt);
          @cfold chan _ k.-bv k.-bv commit xort id sum_commits;
          read_all committed sum_committed;
          Out c (_ <-- Read (tnth sum_committed ord_max) ;;
                 _ <-- Read (tnth sum_commits i) ;; r)]
     =p
     pars [::
             \||_(i < n.+1) Out (tnth committed (widen_ordS i)) (_ <-- Read (tnth commit i) ;; Ret tt);
             Out (tnth committed ord_max) (Ret tt);
          @cfold chan _ k.-bv k.-bv commit xort id sum_commits;
          read_all committed sum_committed;
          Out c (_ <-- Read (tnth sum_committed ord_max) ;;
                 r)].
     swap_tac 0 4.
     swap_at 0 0 1.
     symmetry; swap_tac 0 4; symmetry.

     move: r.
     induction i using ord_indP; intros.
     swap_tac 1 2.
     rewrite pars_inline_from_big.
     rewrite {1}/cfold_body //=.
     simp_all.
     symmetry.
     swap_tac 1 3.
     rewrite -pars_undep_cfold_input.
     instantiate (1 := ord0).
     swap_tac 1 4.
     have -> : tnth committed ord0 = tnth committed (widen_ordS ord0).
        congr (_ _ _).
        apply/eqP; rewrite eqE //=.
     rewrite pars_inline_from_big_shift_index //=.
     simp_all.
     apply pars_cons_cong; rewrite //=.
     swap_tac 0 1.
     apply pars_cons_cong; rewrite //=.
     swap_tac 0 1.
     apply pars_cons_cong; rewrite //=.
     swap_tac 0 1.
     apply pars_cons_cong; rewrite //=.
     done.
     done.

     intros.
     swap_tac 1 2.
     rewrite pars_inline_from_big.
     rewrite {1}/cfold_body //=.
     simp_at 0.
     swap_at 0 0 1.
     have -> :
        (widen_ord (m:=n.+1) (leqnSn n)
                            (Ordinal (n:=n) (m:=i)
                                     (OrdLems.ltSS (lift_subproof (n:=n.+1) 0 i)))) =
        (widen_ord (leqnSn n) i).
        apply/eqP; rewrite eqE //=.
     swap_at 0 1 2.
     swap_tac 1 2.
     rewrite IHi; clear IHi.

     symmetry.

     swap_tac 1 3.
     rewrite -pars_undep_cfold_input.
     instantiate (1 := (widen_ord (leqnSn n.+1) (lift ord0 i))).
     swap_tac 1 4.
     rewrite pars_inline_from_big_shift_index //=.
     simp_all.
     apply pars_cons_cong.
     apply EqCongReact.
     r_swap 0 1.
     done.
     swap_tac 0 2.
     apply pars_cons_cong; rewrite //=.
     apply pars_cons_cong; rewrite //=.
     swap_tac 0 1.
     apply pars_cons_cong; rewrite //=.
     done.
     done.
Qed.

Ltac print_lhs_size :=
  match goal with
  | [ |- EqProt (pars ?rs) _ ] =>
    let j := eval simpl in (size rs) in idtac j end.

Ltac print_rhs_size :=
  match goal with
  | [ |- EqProt _ (pars ?rs) ] =>
    let j := eval simpl in (size rs) in idtac j end.

Lemma pars_replace {chan} (r2 : @ipdl chan) r1 rs :
  pars [:: r1 & rs] =p pars [:: r2 & rs] ->
  pars [:: r1 & rs] =p pars [:: r2 & rs].
  done.
Qed.

Lemma big_ord_not_maxE {chan : Type -> Type} {n} (f : 'I_(n.+1) -> @ipdl chan) :
  \||_(i < n.+1 | i != ord_max) (f i) =p \||_(i < n) (f (widen_ordS i)).
  rewrite bigpar_mkcond.
  rewrite bigpar_ord_recr.
  rewrite eq_refl //= -eq_0par.
  apply EqProt_big_r; intros.
  rewrite eqE //=.
  have: x < n by destruct x.
  intro h.
  rewrite ltn_neqAle in h.
  move/andP: h; elim; intros.
  rewrite H1.
  done.
Qed.

Section SimDef.
  Context {chan : Type -> Type}.
  Open Scope bool_scope.
  Context (k : nat) {n_ : nat}.
  Let n := nosimpl n_.+2. (* we assume at least 2 players *)
  Context (honest : pred 'I_n).
  Context (H : honest ord_max).
  Context (H0 : ~~ honest ord0).

  Context (leak : (chan k.-bv)).
  Context (ok : chan unit).

  Context (advCommit : n.-tuple (chan k.-bv)).
  Context (advOpen : n.-tuple (chan unit)).

  Context (advCommitted : n.-tuple (n.-tuple (chan unit))).
  Context (advOpened : n.-tuple (n.-tuple (chan k.-bv))).

  Definition Sim_CFRealParty_honest
             (committed : n.-tuple (chan unit)) (opened : n.-tuple (chan k.-bv))
             (commit : chan k.-bv) (open : chan unit)
    :=
      committed_sum <- newvec n @ unit ;;
      opened_sum <- newvec n @ k.-bv ;;
      pars [::
            Out commit (Samp (Unif ));
            read_all committed committed_sum;
            Out open (copy (tnth committed_sum ord_max));

            @cfold chan _ k.-bv k.-bv opened xort id opened_sum
      ].

  Definition Sim_CFRealParty_corr (i : 'I_n)
             (committed : n.-tuple (chan unit))
             (opened : n.-tuple (chan k.-bv))
             (commit : chan k.-bv) (open : chan unit) :=
    pars [::
            Out commit (copy (tnth advCommit i));
            Out open (copy (tnth advOpen i));
            Outvec (tnth advCommitted i) (fun j => copy (tnth committed j));
            Outvec (tnth advOpened i) (fun j => copy (tnth opened j))
    ].

  Definition Sim_CFParty (i : 'I_n)
             (committed : n.-tuple (chan unit)) (opened : n.-tuple (chan k.-bv))
             (commit : chan k.-bv) (open : chan unit) :=
    if honest i then Sim_CFRealParty_honest committed opened commit open
                else Sim_CFRealParty_corr i committed opened commit open.

  Definition Sim_CFParty_last
             (sum_commits : n.-tuple (chan k.-bv))
             (committed_sum : n.-tuple (chan unit))
             (commit : chan k.-bv) (open : chan unit) :=
    pars [::
            Out commit (
                  x <-- Read (tnth sum_commits (inord n_)) ;;
                  y <-- Read leak ;;
                  Ret ((x +t y) : k.-bv));
            Out open (copy (tnth committed_sum ord_max))
                ].

  Definition Sim :=
    commit <- newvec n @ k.-bv ;;
    open <- newvec n @ unit ;;
    committed <- newvec n @ unit ;;
    opened <- newvec n @ k.-bv ;;
    sum_commits <- newvec n @ k.-bv ;;
    sum_committed <- newvec n @ unit ;;
    sum_open <- newvec n @ unit ;;
    sum_opened <- newvec n @ k.-bv ;;

    pars [::
            \||_(i < n | i != ord_max) Sim_CFParty i committed opened (tnth commit i) (tnth open i);
         Sim_CFParty_last
           sum_commits
           sum_committed
           (tnth commit ord_max)
           (tnth open ord_max);

         @cfold chan _ k.-bv k.-bv commit xort id sum_commits;
         read_all committed sum_committed;
         read_all open sum_open;
         @cfold chan _ k.-bv k.-bv opened xort id sum_opened;

         Out (tnth committed ord_max) (Ret tt);
         Out (tnth opened ord_max) (x <-- Read (tnth commit ord_max) ;; _ <-- Read (tnth open ord_max) ;; Ret x);
         \||_(i < n | i != ord_max) FComm k (tnth commit i) (tnth committed i) (tnth open i) (tnth opened i);

         Out ok (_ <-- Read (tnth sum_commits ord_max) ;;
                 _ <-- Read (tnth sum_open ord_max) ;;
                 Ret tt)
         ].
End SimDef.

Section SimComp.
  Context {chan : Type -> Type}.
  Open Scope bool_scope.
  Context (k : nat) {n_ : nat}.
  Let n := nosimpl n_.+2. (* we assume at least 2 players *)
  Context (honest : pred 'I_n).
  Context (H : honest ord_max).
  Context (H0 : ~~ honest ord0).

  Context (advCommit : n.-tuple (chan k.-bv)).
  Context (advOpen : n.-tuple (chan unit)).

  Context (advCommitted : n.-tuple (n.-tuple (chan unit))).
  Context (advOpened : n.-tuple (n.-tuple (chan k.-bv))).

  Definition SimComp (out : n.-tuple (chan k.-bv)) :=
    leakB <- new k.-bv ;;
    ok <- new unit ;;
    pars [::
            Sim k honest leakB ok advCommit advOpen advCommitted advOpened;
            CFIdeal k _ honest leakB ok out
                 ].

  (* out ->
         Out ok (_ <-- Read (tnth sum_commits ord_max) ;;
                 _ <-- Read (tnth sum_open ord_max) ;;
                 x <- Read send ;;
                 Ret x)
  *)

  Definition SimComp_simpl1 (out : n.-tuple (chan k.-bv)) :=
    leak <- new k.-bv ;;
    ok <- new unit ;;
    commit <- newvec n @ k.-bv ;;
    open <- newvec n @ unit ;;
    committed <- newvec n @ unit ;;
    opened <- newvec n @ k.-bv ;;
    sum_commits <- newvec n @ k.-bv ;;
    sum_committed <- newvec n @ unit ;;
    sum_open <- newvec n @ unit ;;
    sum_opened <- newvec n @ k.-bv ;;
    r <- new k.-bv ;;
    send <- new k.-bv ;;

 (pars [:: \||_(i<n | honest i)
             Out (tnth out i)
               (_ <-- Read (tnth sum_commits ord_max);;
                _ <-- Read (tnth sum_open ord_max);;
                copy r);
            Out ok
              (_ <-- Read (tnth sum_commits ord_max);;
               _ <-- Read (tnth sum_open ord_max);;
               Ret tt);
            Sim_CFParty_last
              k
              leak
              sum_commits
              sum_committed
              (tnth commit ord_max)
              (tnth open ord_max);

         @cfold chan _ k.-bv k.-bv commit xort id sum_commits;
         read_all committed sum_committed;
         read_all open sum_open;
         @cfold chan _ k.-bv k.-bv opened xort id sum_opened;

         Out (tnth committed ord_max) (Ret tt);
         Out (tnth opened ord_max) (x <-- Read (tnth commit ord_max) ;; _ <-- Read (tnth open ord_max) ;; Ret x);
         \||_(i < n | i != ord_max) FComm k (tnth commit i) (tnth committed i) (tnth open i) (tnth opened i);
           Out r (Samp (Unif ));
           Out leak (copy r);
           Out send (_ <-- Read ok ;; copy r);

            \||_(i < n | i != ord_max) Sim_CFParty k honest advCommit advOpen advCommitted advOpened i committed opened (tnth commit i) (tnth open i) ] ).

  Lemma SimComp_E1 out : SimComp out =p SimComp_simpl1 out.
    rewrite /SimComp /SimComp_simpl1.
    apply EqCongNew => leak.
    apply EqCongNew => ok.
    rewrite /SimComp.
    rewrite /Sim.
    repeat setoid_rewrite newPars.
    apply EqCongNew_vec => commit .
    apply EqCongNew_vec => open .
    apply EqCongNew_vec => committed .
    apply EqCongNew_vec => opened .
    apply EqCongNew_vec => sum_commits .
    apply EqCongNew_vec => sum_committed .
    apply EqCongNew_vec => sum_open .
    apply EqCongNew_vec => sum_opened .
    rewrite pars_pars.
    swap_tac 0 (@CFIdeal chan).

    rewrite newPars.
    setoid_rewrite pars_pars; simpl.
    etransitivity.
    apply EqCongNew => b .
    rewrite newPars.
    setoid_rewrite pars_pars at 1; simpl.
    apply EqRefl.
    rewrite EqNewExch.

    apply EqCongNew => r .
    apply EqCongNew => send .
    rewrite /CFIdealParty.
    rewrite -bigpar_mkcond.
    swap_tac 0 3.
    swap_tac 1 2.
    etransitivity.
    apply pars_big_replace.
    intros.
    rewrite pars_inline.
    simp_all.
    swap_tac 1 12.
    rewrite pars_inline.
    swap_tac 1 12.
    apply EqRefl.
    done.
    done.
    apply pars_cons_cong.
    apply EqProt_big_r; intros; apply EqCongReact.
    simp_rxn.
    rewrite /copy //=.
    swap_tac 0 (Out ok).
    apply pars_cons_cong; rewrite //=.
    swap_tac 0 2.
    apply pars_cons_cong; rewrite //=.
    swap_tac 0 (@cfold chan _ k.-bv k.-bv commit xort).
    apply pars_cons_cong; rewrite //=.
    swap_tac 0 2.
    apply pars_cons_cong; rewrite //=.
    swap_tac 0 2.
    apply pars_cons_cong; rewrite //=.
    swap_tac 0 2.
    apply pars_cons_cong; rewrite //=.
    swap_tac 0 2.
    apply pars_cons_cong; rewrite //=.
    swap_tac 0 2.
    apply pars_cons_cong; rewrite //=.
    swap_tac 0 2.
    apply pars_cons_cong; rewrite //=.
    swap_tac 0 1.
    apply pars_cons_cong; rewrite //=.
    apply _.
    apply _.
    apply _.
    apply _.
    apply _.
    apply _.
    apply _.
    apply _.
 Qed.

  Definition SimComp_simpl2 (out : n.-tuple (chan k.-bv)) :=
    leak <- new k.-bv ;;
    ok <- new unit ;;
    commit <- newvec n @ k.-bv ;;
    open <- newvec n @ unit ;;
    committed <- newvec n @ unit ;;
    opened <- newvec n @ k.-bv ;;
    sum_commits <- newvec n @ k.-bv ;;
    sum_committed <- newvec n @ unit ;;
    sum_open <- newvec n @ unit ;;
    sum_opened <- newvec n @ k.-bv ;;
    r <- new k.-bv ;;
    send <- new k.-bv ;;

 (pars [:: \||_(i<n | honest i)
             Out (tnth out i)
               (x <-- Read (tnth sum_commits ord_max);;
                _ <-- Read (tnth sum_open ord_max);;
                Ret x);
            Out ok
              (_ <-- Read (tnth sum_commits ord_max);;
               _ <-- Read (tnth sum_open ord_max);;
               Ret tt);

            Sim_CFParty_last
              k
              leak
              sum_commits
              sum_committed
              (tnth commit ord_max)
              (tnth open ord_max);

         @cfold chan _ k.-bv k.-bv commit xort id sum_commits;
         read_all committed sum_committed;
         read_all open sum_open;
         @cfold chan _ k.-bv k.-bv opened xort id sum_opened;

         Out (tnth committed ord_max) (Ret tt);
         Out (tnth opened ord_max) (x <-- Read (tnth commit ord_max) ;; _ <-- Read (tnth open ord_max) ;; Ret x);
         \||_(i < n | i != ord_max) FComm k (tnth commit i) (tnth committed i) (tnth open i) (tnth opened i);

           Out r (Samp (Unif ));
           Out leak (copy r);
           Out send (_ <-- Read ok ;; copy r);

      \||_(i < n | i != ord_max) Sim_CFParty k honest advCommit advOpen advCommitted advOpened i committed opened (tnth commit i) (tnth open i) ] ).

  Lemma SimComp_simpl2E out :
    SimComp_simpl1 out =p SimComp_simpl2 out.

    apply EqCongNew => leak .
    apply EqCongNew => ok .
    rewrite /SimComp_simpl1.
    etransitivity.
    apply EqCongNew_vec => commit .
    apply EqCongNew_vec => open .
    apply EqCongNew_vec => committed .
    apply EqCongNew_vec => opened .
    apply EqCongNew_vec => sum_commits .
    apply EqCongNew_vec => sum_committed .
    apply EqCongNew_vec => sum_open .
    apply EqCongNew_vec => sum_opened .
    apply EqCongNew => r .
    apply EqCongNew => send .
    swap_tac 1 (@cfold chan _ k.-bv k.-bv commit).
    etransitivity.
    apply pars_big_replace; intros.
    rewrite pars_inline_from_big //=; last first.
    rewrite /cfold_body //=.
    focus_tac 0.
      apply EqCongReact.
      simp_rxn.
      apply EqRxnRefl.
    swap_tac 0 (@Sim_CFParty_last).
    rewrite pars_pars //=.
    swap_tac 0 3.
    swap_tac 1 3.

    etransitivity.
    apply pars_big_replace; intros.
    rewrite pars_inline //=.
    apply EqRefl.

    simpl.
    swap_tac 1 (Out leak).
    etransitivity.
    apply pars_big_replace; intros.
    simp_at 0.
    swap_at 0 0 1.
    rewrite pars_inline.
    edit_tac 0.
    rewrite /copy; simp_rxn.
    r_swap 1 4.
    rewrite EqReadSame.
    apply EqRxnRefl.
    apply EqRefl.
    done.
    simpl.
    apply EqRefl.
    symmetry.

    apply EqCongNew_vec => commit .
    apply EqCongNew_vec => open .
    apply EqCongNew_vec => committed .
    apply EqCongNew_vec => opened .
    apply EqCongNew_vec => sum_commits .
    apply EqCongNew_vec => sum_committed .
    apply EqCongNew_vec => sum_open .
    apply EqCongNew_vec => sum_opened .
    apply EqCongNew => r .
    apply EqCongNew => send .

    swap_tac 1 3.
    etransitivity.
    apply pars_big_replace; intros.
    rewrite pars_inline_from_big.
    rewrite {1}/cfold_body //=.
    apply EqRefl.
    done.
    done.
    swap_tac 0 2.
    rewrite pars_pars //=.
    swap_tac 1 (Out leak).
    swap_at 0 0 1.
    rewrite pars_inline //=.
    swap_tac 0 3.
    swap_tac 1 3.
    etransitivity.
    apply pars_big_replace; intros.
    simp_at 0.
    rewrite pars_inline //=.
    simp_at 0.
    edit_tac 0.
    rewrite /copy; simp_rxn.
    have -> :
      (tnth sum_commits (inord n_)) =
      (tnth sum_commits
        (widen_ord (m:=n_.+2) (leqnSn n_.+1)
           (Ordinal (n:=n_.+1) (m:=n_) (OrdLems.ltSS (ltnSn n_.+1))))).
    congr (_ _ _).
    apply/eqP; rewrite eqE //=.
    rewrite inordK //=.
    apply EqBind_r; intro.
    rewrite !EqReadSame.
    apply EqBind_r; intro.
    apply EqBind_r; intro.
    destruct x1; rewrite //= ?negbK //=.
    instantiate (1 := fun _ => Ret x).
    rewrite -xortA xortK xortC xort0 //=.

    simp_at 0.
    apply EqRefl.

    apply pars_cons_cong; rewrite //=.
    apply EqProt_big_r; intros; apply EqCongReact.
    apply EqBind_r; intros.

    have -> :
      (tnth sum_commits (inord n_)) =
      (tnth sum_commits
        (widen_ord (m:=n_.+2) (leqnSn n_.+1)
           (Ordinal (n:=n_.+1) (m:=n_) (OrdLems.ltSS (ltnSn n_.+1))))).
    congr (_ _ _).
    apply/eqP; rewrite eqE //=.
    rewrite inordK //=.
    rewrite EqReadSame.
    apply EqBind_r; intro.
    done.

    symmetry.
    swap_tac 0 (Out (tnth commit ord_max)).
    swap_at 0 0 1.
    swap_tac 1 (Out leak).
    rewrite pars_inline.
    align.
    done.
 Qed.

  (* Eliminate send, leakB and ok channels *)

  Definition SimComp_simpl3 (out : n.-tuple (chan k.-bv)) :=
    commit <- newvec n @ k.-bv ;;
    open <- newvec n @ unit ;;
    committed <- newvec n @ unit ;;
    opened <- newvec n @ k.-bv ;;
    sum_commits <- newvec n @ k.-bv ;;
    sum_committed <- newvec n @ unit ;;
    sum_open <- newvec n @ unit ;;
    sum_opened <- newvec n @ k.-bv ;;
    r <- new k.-bv ;;

[pars [:: \||_(i<n | honest i)
             Out (tnth out i)
               (x <-- Read (tnth sum_commits ord_max);;
                _ <-- Read (tnth sum_open ord_max);;
                Ret x);
      Out (tnth commit ord_max) (x <-- Read (tnth sum_commits (inord n_)) ;;
                                 y <-- Read r ;; Ret ((x +t y)));
      Out (tnth open ord_max) (copy (tnth sum_committed ord_max));

         @cfold chan _ k.-bv k.-bv commit xort id sum_commits;
         read_all committed sum_committed;
         read_all open sum_open;
         @cfold chan _ k.-bv k.-bv opened xort id sum_opened;

         Out (tnth committed ord_max) (Ret tt);
         Out (tnth opened ord_max) (x <-- Read (tnth commit ord_max) ;; _ <-- Read (tnth open ord_max) ;; Ret x);
         \||_(i < n | i != ord_max) FComm k (tnth commit i) (tnth committed i) (tnth open i) (tnth opened i);
         Out r (Samp (Unif));

      \||_(i < n | i != ord_max) Sim_CFParty k honest advCommit advOpen advCommitted advOpened i committed opened (tnth commit i) (tnth open i) ] ].

  Lemma SimComp_simpl3E out :
    SimComp_simpl2 out =p SimComp_simpl3 out.
    rewrite /SimComp_simpl2.

    etransitivity.
    rotate_news.
    rotate_news.
    apply EqRefl.

    rewrite /SimComp_simpl3.

    apply EqCongNew_vec => commit .
    apply EqCongNew_vec => open .
    apply EqCongNew_vec => committed .
    apply EqCongNew_vec => opened .
    apply EqCongNew_vec => sum_commits .
    apply EqCongNew_vec => sum_committed .
    apply EqCongNew_vec => sum_open .
    apply EqCongNew_vec => sum_opened .
    apply EqCongNew => r .

    (* elim c0 *)
    etransitivity.
    rewrite EqNewExch.
    setoid_rewrite EqNewExch at 2.
    apply EqCongNew; intro.
    apply EqCongNew; intro.
    swap_tac 0 12.
    rewrite new_pars_remove; last first.
      intros; repeat set_tac.
    apply EqRefl.

    (* elim c0 *)
    etransitivity.
    apply EqCongNew => c.
    rewrite new_pars_remove //=.
    apply EqRefl.
   (* now elim last *)
   swap_tac 0 9.
   rewrite /Sim_CFParty_last.
   swap_tac 0 9.
   setoid_rewrite pars_pars; simpl.
   etransitivity.
   apply EqCongNew => c.
   swap_at 0 0 1.
   swap_tac 1 (Out c).
   apply EqRefl.
   rewrite pars_fold.
   align.
   apply EqCongReact.
   rewrite /copy; simp_rxn.
   r_swap 0 1.
   done.
 Qed.

  (* Rerandomize r *)

  Definition SimComp_simpl4 (out : n.-tuple (chan k.-bv)) :=
    commit <- newvec n @ k.-bv ;;
    open <- newvec n @ unit ;;
    committed <- newvec n @ unit ;;
    opened <- newvec n @ k.-bv ;;
    sum_commits <- newvec n @ k.-bv ;;
    sum_committed <- newvec n @ unit ;;
    sum_open <- newvec n @ unit ;;
    sum_opened <- newvec n @ k.-bv ;;
    r <- new k.-bv ;;

[pars [:: \||_(i<n | honest i)
             Out (tnth out i)
               (x <-- Read (tnth sum_commits ord_max);;
                _ <-- Read (tnth sum_open ord_max);;
                Ret x);
      Out (tnth commit ord_max) (_ <-- Read (tnth sum_commits (inord n_)) ;;
                                 x <-- Read r ;; Ret x);
      Out (tnth open ord_max) (copy (tnth sum_committed ord_max));

         @cfold chan _ k.-bv k.-bv commit xort id sum_commits;
         read_all committed sum_committed;
         read_all open sum_open;
         @cfold chan _ k.-bv k.-bv opened xort id sum_opened;

         Out (tnth committed ord_max) (Ret tt);
         Out (tnth opened ord_max) (x <-- Read (tnth commit ord_max) ;; _ <-- Read (tnth open ord_max) ;; Ret x);
         \||_(i < n | i != ord_max) FComm k (tnth commit i) (tnth committed i) (tnth open i) (tnth opened i);
        Out r (Samp (Unif));

      \||_(i < n | i != ord_max) Sim_CFParty k honest advCommit advOpen advCommitted advOpened i committed opened (tnth commit i) (tnth open i) ] ].

  Lemma SimComp_simpl4E out :
    SimComp_simpl3 out =p SimComp_simpl4 out.
    apply EqCongNew_vec => commit .
    apply EqCongNew_vec => open .
    apply EqCongNew_vec => committed .
    apply EqCongNew_vec => opened .
    apply EqCongNew_vec => sum_commits .
    apply EqCongNew_vec => sum_committed .
    apply EqCongNew_vec => sum_open .
    apply EqCongNew_vec => sum_opened .
    etransitivity.
    swap_tac 0 10.
    etransitivity.
    apply EqCongNew => r .
    swap_at 1 0 1.
    apply EqRefl.
    swap_tac 0 1.
    rewrite pars_fold.
    edit_tac 0.
    r_swap 0 1.
    apply EqBind_r; intro.
    instantiate (1 := fun _ => (y <-- Samp (Unif) ;; Ret y)).
    simpl.
    rewrite EqBindRet.
    symmetry.
    apply EqSampBijection.
    apply xort_inj_l.
    apply uniform_Unif.
    swap_at 0 0 1.
    rewrite -pars_fold.
    apply EqRefl.
    apply EqCongNew => r.
    swap_at 0 0 1.
    align.
Qed.

  (* Eliminate last commit *)

  Definition SimComp_simpl5 (out : n.-tuple (chan k.-bv)) :=
    open <- newvec n @ unit ;;
    committed <- newvec n @ unit ;;
    opened <- newvec n @ k.-bv ;;
    sum_commits_ <- newvec (n_.+1) @ k.-bv ;;
    sum_commits_last <- new k.-bv;;
    sum_committed <- newvec n @ unit ;;
    sum_open <- newvec n @ unit ;;
    sum_opened <- newvec n @ k.-bv ;;
    r <- new k.-bv ;;
    commit <- newvec (n_.+1) @ k.-bv ;;

[pars [:: \||_(i<n | honest i)
             Out (tnth out i)
               (x <-- Read (tnth [tuple of rcons sum_commits_ sum_commits_last] ord_max);;
                _ <-- Read (tnth sum_open ord_max);;
                Ret x);
      Out r (Samp (Unif ));
      Out (tnth open ord_max) (copy (tnth sum_committed ord_max));

      @cfold chan _ k.-bv k.-bv commit xort id sum_commits_;
      Out sum_commits_last (x <-- Read r ;; y <-- Read (tnth sum_commits_ ord_max) ;; Ret ((x +t y)));
         read_all committed sum_committed;
         read_all open sum_open;
         @cfold chan _ k.-bv k.-bv opened xort id sum_opened;

         Out (tnth committed ord_max) (Ret tt);
         Out (tnth opened ord_max) (x <-- Read r ;; _ <-- Read (tnth open ord_max) ;; Ret x);
         \||_(i < (n_.+1)) FComm k (tnth commit i) (tnth committed (widen_ordS i)) (tnth open (widen_ordS  i)) (tnth opened (widen_ordS i));

      \||_(i < n_.+1) Sim_CFParty k honest advCommit advOpen advCommitted advOpened (widen_ordS i) committed opened (tnth commit i) (tnth open (widen_ordS i)) ] ].

  Lemma SimComp_simpl5E out :
    SimComp_simpl4 out =p SimComp_simpl5 out.
    rewrite /SimComp_simpl4.
    rewrite /SimComp_simpl5.
    etransitivity.
    rotate_news.
    apply EqRefl.

    apply EqCongNew_vec => open .
    apply EqCongNew_vec => committed .
    apply EqCongNew_vec => opened .
    etransitivity.
    rewrite newvecS_r.
    apply EqRefl.
    rewrite -New_newvec.
    apply EqCongNew_vec => sum_commits.
    apply EqCongNew => sum_commits_last .
    apply EqCongNew_vec => sum_committed .
    apply EqCongNew_vec => sum_open .
    apply EqCongNew_vec => sum_opened .
    apply EqCongNew => r .
    etransitivity.
    rewrite newvecS_r.
    done.
    rewrite -New_newvec.
    apply EqCongNew_vec => commit .

    etransitivity.
    (* Now elim y *)
    etransitivity.
    apply EqCongNew => commit_last.
    have -> : tnth [tuple of rcons commit commit_last] ord_max = commit_last.
        rewrite /tnth nth_rcons size_tuple //= ltnn eq_refl //=.
    rewrite cfoldS_r.
    swap_tac 0 3.
    rewrite pars_pars //=.
    inline_tac (Out sum_commits_last) (Out commit_last).
    simp_at 0.
        edit_tac 0.
        r_swap 1 2.
        have -> : (tnth [tuple of rcons sum_commits sum_commits_last] (inord n_))
                  =
                  (tnth sum_commits ord_max).
            rewrite /tnth nth_rcons.
            rewrite size_tuple inordK ltnS.
            rewrite leqnn.
            simpl.
            apply set_nth_default.
            rewrite size_tuple.
            rewrite ltnS leqnn //=.
            rewrite leqnSn //=.

        rewrite EqReadSame.
        r_swap 0 1.
        done.

   inline_tac (Out (tnth opened ord_max)) (Out commit_last).
   simp_at 0.
   apply EqRefl.

   (* remove commit_last from FComm and Sim_CFParty *)
   etransitivity.
   apply EqCongNew => commit_last.
   focus_tac 10.
   rewrite big_ord_not_maxE.
   apply EqProt_big_r; intros.
   have -> : tnth [tuple of rcons commit commit_last] (widen_ordS x) =
             tnth commit x.
       rewrite /tnth nth_rcons //= size_tuple.
       have -> : x < n_.+1 by destruct x.
       apply set_nth_default.
       rewrite size_tuple; destruct x; done.
   apply EqRefl.
   focus_tac 12.
   rewrite big_ord_not_maxE.
   apply EqProt_big_r; intros.
   have -> : tnth [tuple of rcons commit commit_last] (widen_ordS x) =
             tnth commit x.
       rewrite /tnth nth_rcons //= size_tuple.
       have -> : x < n_.+1 by destruct x.
       apply set_nth_default.
       rewrite size_tuple; by destruct x.
   apply EqRefl.

   apply EqRefl.
   swap_tac 0 1.
   rewrite new_pars_remove.
   apply EqRefl.

   (* now the LHS and RHS are the same, except that opened ord_max has a dependency on this sum_commits stuff -- so now we remove it *)
   etransitivity.
   apply (pars_replace
            (Out (tnth opened ord_max) (
                   x <-- Read r ;; _ <-- Read (tnth open ord_max) ;; Ret x))).
   have -> : tnth [tuple of rcons sum_commits sum_commits_last] (inord n_) =
             tnth sum_commits ord_max.
      rewrite /tnth nth_rcons //=.
      rewrite size_tuple inordK //=.
      rewrite ltnSn.
      apply set_nth_default.
      rewrite size_tuple ltnSn //=.

    etransitivity.
    edit_tac 0.
    r_swap 0 2.
    done.
   inline_tac (Out (tnth opened ord_max)) (Out (tnth open ord_max)).
   rewrite /copy.
   simp_at 0.

   symmetry.
    etransitivity.
    edit_tac 0.
    r_swap 0 1.
    done.

   inline_tac (Out (tnth opened ord_max)) (Out (tnth open ord_max)).
   rewrite /copy.
   etransitivity.
   edit_tac 0.
     simp_rxn.
     apply EqRxnRefl.
   apply EqRefl.
   symmetry.
   swap_tac 1 2.
   swap_tac 2 4.
   swap_tac 3 9.
   swap_tac 4 7.
   rewrite (pars_split 5); simpl.

   symmetry.
   swap_tac 1 2.
   swap_tac 2 4.
   swap_tac 3 9.
   swap_tac 4 7.
   rewrite (pars_split 5); simpl.
   symmetry.

   apply EqCong.
   rewrite big_pars2.
   swap_tac 0 3; rewrite pars_pars //=; swap_tac 0 1.
   symmetry; swap_tac 0 3; rewrite pars_pars //=; swap_tac 0 1; symmetry.
   apply pars_cons_cong; rewrite //=.
   swap_tac 1 4.
   swap_tac 2 4.
   swap_tac 3 4.
   rewrite SimComp_simpl5E_subproof.
   align.

   align.

   swap_tac 0 3.
   apply pars_cons_cong; rewrite //=.
   swap_tac 0 (Out r).
   apply pars_cons_cong; rewrite //=.
   align.
   apply EqCongReact.
   apply EqBind_r; intro.
   apply EqBind_r; intro.
   rewrite xortC //=.
Qed.

(* 1. Collapse r into commit
   2. re-fold sum_commits and sum_commits_last, given 1.
   3. depend last committed on last commit, fold last committed, opened into FComm
 *)

  Definition SimComp_simpl6 (out : n.-tuple (chan k.-bv)) :=
    open <- newvec n @ unit ;;
    committed <- newvec n @ unit ;;
    opened <- newvec n @ k.-bv ;;
    sum_commits <- newvec n @ k.-bv ;;
    sum_committed <- newvec n @ unit ;;
    sum_open <- newvec n @ unit ;;
    sum_opened <- newvec n @ k.-bv ;;
    commit <- newvec n @ k.-bv ;;

[pars [:: \||_(i<n | honest i)
             Out (tnth out i)
               (x <-- Read (tnth sum_commits ord_max);;
                _ <-- Read (tnth sum_open ord_max);;
                Ret x);
      Out (tnth commit ord_max) (Samp (Unif ));
      Out (tnth open ord_max) (copy (tnth sum_committed ord_max));

      @cfold chan _ k.-bv k.-bv commit xort id sum_commits;
         read_all committed sum_committed;
         read_all open sum_open;
         @cfold chan _ k.-bv k.-bv opened xort id sum_opened;

         \||_(i < n) FComm k (tnth commit i) (tnth committed i) (tnth open i) (tnth opened i);

      \||_(i < n | i != ord_max) Sim_CFParty k honest advCommit advOpen advCommitted advOpened i committed opened (tnth commit i) (tnth open i) ] ].

Lemma SimComp_simpl6E out :
    SimComp_simpl5 out =p SimComp_simpl6 out.
  rewrite /SimComp_simpl5.
  rewrite /SimComp_simpl6.
  symmetry.

  apply EqCongNew_vec => open .
  apply EqCongNew_vec => committed .
  apply EqCongNew_vec => opened .

  etransitivity.
  rewrite newvecS_r.
  apply EqRefl.
  rewrite New_newvec.
  apply EqCongNew => sum_commits_last .
  apply EqCongNew_vec => sum_commits .
  apply EqCongNew_vec => sum_committed .
  apply EqCongNew_vec => sum_open .
  apply EqCongNew_vec => sum_opened .
  etransitivity.
    rewrite newvecS_r.
  apply EqRefl.
  apply EqCongNew => last_commit .
  apply EqCongNew_vec => commit .
  symmetry.

  swap_tac 0 (Out (tnth committed ord_max)).
  rewrite pars_mkdep //=.
  symmetry.
  swap_tac 0 7.
  rewrite bigpar_ord_recr par_in_pars.
  rewrite pars_pars //=.

  (* just matching things up now *)
  apply pars_cons_cong.
    rewrite tnth_rcons_ord_max; done.
  swap_tac 0 2.
  apply pars_cons_cong.
    rewrite tnth_rcons_ord_max; done.
  swap_tac 0 (Out (tnth open ord_max)).
  apply pars_cons_cong; rewrite //=.
  swap_tac 0 2.
  rewrite cfoldS_r pars_pars //=.
  apply pars_cons_cong; rewrite //=.
  apply pars_cons_cong; rewrite //=.
  apply EqCongReact; apply EqBind_r; intro; apply EqBind_r; intro; rewrite xortC //=.
  swap_tac 0 2.
  apply pars_cons_cong; rewrite //=.
  swap_tac 0 2.
  apply pars_cons_cong; rewrite //=.
  swap_tac 0 2.
  apply pars_cons_cong; rewrite //=.
  swap_tac 0 2.
  apply pars_cons_cong; rewrite //=.
  swap_tac 0 1.
  apply pars_cons_cong; rewrite //=.
  rewrite /copy.
  apply EqCongReact.
  rewrite tnth_rcons_ord_max.
  r_swap 0 1.
  done.
  apply pars_cons_cong; rewrite //=.
  apply EqProt_big_r; intros.
  rewrite tnth_rcons_widen_ord //=.
  apply pars_cons_cong; rewrite //=.
  rewrite big_ord_not_maxE.
  apply EqProt_big_r; intros.
  rewrite tnth_rcons_widen_ord //.
Qed.

(* Restore last party to be like others *)

  Definition SimComp_simpl7 (out : n.-tuple (chan k.-bv)) :=
    open <- newvec n @ unit ;;
    committed <- newvec n @ unit ;;
    opened <- newvec n @ k.-bv ;;
    sum_commits <- newvec n @ k.-bv ;;
    sum_open <- newvec n @ unit ;;
    commit <- newvec n @ k.-bv ;;

[pars [:: \||_(i<n | honest i)
             Out (tnth out i)
               (x <-- Read (tnth sum_commits ord_max);;
                _ <-- Read (tnth sum_open ord_max);;
                Ret x);

      @cfold chan _ k.-bv k.-bv commit xort id sum_commits;
         read_all open sum_open;

         \||_(i < n) FComm k (tnth commit i) (tnth committed i) (tnth open i) (tnth opened i);

      \||_(i < n) Sim_CFParty k honest advCommit advOpen advCommitted advOpened i committed opened (tnth commit i) (tnth open i) ] ].

  Lemma SimComp_simpl7E out :
    SimComp_simpl6 out =p SimComp_simpl7 out.
    rewrite /SimComp_simpl6.
    rewrite /SimComp_simpl7.
    apply EqCongNew_vec => open .
    apply EqCongNew_vec => committed .
    apply EqCongNew_vec => opened .
    apply EqCongNew_vec => sum_commits .
    rotate_news.
    apply EqCongNew_vec => sum_open .
    rotate_news.
    apply EqCongNew_vec => commit .
    symmetry.
    etransitivity.
    swap_tac 0 4.
    rewrite (bigpar_D1_ord ord_max).
    rewrite par_in_pars.
    rewrite /Sim_CFParty H.
    rewrite newPars.
    setoid_rewrite newPars.
    setoid_rewrite pars_pars.
    apply EqRefl.
    apply _.
    done.
    apply EqCongNew_vec => sum_committed .
    apply EqCongNew_vec => sum_opened .
    simpl.
    align.
 Qed.
End SimComp.


Require Import Coq.ZArith.ZArith.
Require Import Coq.Lists.List.
Require Import Crypto.AbstractInterpretation.AbstractInterpretation.
Require Import Crypto.Bedrock.Field.Common.Types.
Require Import Crypto.Language.API.
Require Import Crypto.Util.Option.

Import Language.API.Compilers AbstractInterpretation.Compilers.
Import Types.Notations.
Existing Instances rep.Z rep.listZ_mem.

Section with_parameters.
  Context
    {width BW word mem locals env ext_spec varname_gen error}
   `{parameters_sentinel : @parameters width BW word mem locals env ext_spec varname_gen error}.

  Fixpoint list_lengths_repeat_base (n : nat) t : base_listonly nat t :=
    match t as t0 return base_listonly nat t0 with
    | base.type.prod a b =>
      (list_lengths_repeat_base n a, list_lengths_repeat_base n b)
    | base_listZ => n
    | _ => tt
    end.
  Fixpoint list_lengths_repeat_args (n : nat) t
    : type.for_each_lhs_of_arrow list_lengths t :=
    match t as t0 return type.for_each_lhs_of_arrow list_lengths t0 with
    | type.base b => tt
    | type.arrow (type.base s) d =>
      (list_lengths_repeat_base n s, list_lengths_repeat_args n d)
    | type.arrow s d => (tt, list_lengths_repeat_args n d)
    end.

  (* mostly a duplicate of list_lengths_from_value, just with ZRange interp *)
  Fixpoint list_lengths_from_bounds {t}
    : ZRange.type.base.option.interp t -> option (base_listonly nat t) :=
    match t as t0 return
          ZRange.type.base.option.interp t0 -> option (base_listonly nat t0) with
    | base.type.prod a b =>
      fun x =>
        (x1 <- list_lengths_from_bounds (fst x);
           x2 <- list_lengths_from_bounds (snd x);
           Some (x1, x2))%option
    | base_listZ =>
      fun x : option (list _) => option_map (@List.length _) x
    | _ => fun _ => Some tt
    end.
  Fixpoint list_lengths_from_argbounds {t}
    : type.for_each_lhs_of_arrow ZRange.type.option.interp t ->
      option (type.for_each_lhs_of_arrow list_lengths t) :=
    match t as t0 return
          type.for_each_lhs_of_arrow _ t0 ->
          option (type.for_each_lhs_of_arrow _ t0) with
    | type.base b => fun _ => Some tt
    | type.arrow (type.base a) b =>
      fun x =>
        (x1 <- list_lengths_from_bounds (fst x);
           x2 <- list_lengths_from_argbounds (snd x);
           Some (x1, x2))%option
    | type.arrow a b => fun _ => None
    end.
End with_parameters.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(** This file is obsolete, use Classical.v instead *)

(** Classical Logic for Type *)

Require Export Classical_Prop.
Require Export Classical_Pred_Type.


(* seplog (c) AIST 2005-2013. R. Affeldt, N. Marti, et al. GNU GPLv3. *)
(* seplog (c) AIST 2014-2018. R. Affeldt et al. GNU GPLv3. *)
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq.
Require Import Init_ext ssrZ ZArith_ext seq_ext uniq_tac.
Require Import machine_int multi_int encode_decode integral_type.
Import MachineInt.
Require Import mips_bipl mips_tactics mips_syntax.
Import mips_bipl.expr_m.
Require Import simu.
Import simu.simu_m.
Require Import multi_is_even_u_prg multi_is_even_u_triple.

Local Open Scope machine_int_scope.
Local Open Scope heap_scope.
Local Open Scope assoc_scope.
Local Open Scope uniq_scope.
Local Open Scope asm_cmd_scope.
Local Open Scope asm_expr_scope.
Local Open Scope zarith_ext_scope.

Lemma var_mint_multi_is_even u rk ru s st h a0 :
  uniq(rk, ru, a0, r0) ->
  var_mint u (unsign rk ru) s st (heap_mint (unsign rk ru) st h) ->
  forall st' h',
    Some (st, h) -- multi_is_even_u rk ru a0 ---> Some (st', h')->
  (([var_e u \% nat_e 2 \= nat_e 1 ]b_ s)%pseudo_expr <-> [ beq a0 r0 ]b_ st').
Proof.
move=> Hset u_ru st' h' exec_asm.
case: u_ru => u_ru u_ru' u_ru''.
  move: (multi_is_even_u_triple _ _ _ Hset '|u2Z ([rk ]_ st)| (Z2ints 32 '|u2Z ([rk ]_ st)| ([u ]_ s)%pseudo_expr) ([ru]_st)).
  rewrite size_Z2ints.
  move/(_ refl_equal) => hoare_triple.
  move/mips_seplog.hoare_prop_m.soundness : (hoare_triple).
  rewrite /while.hoare_semantics.
  move/(_ st (heap_mint (unsign rk ru) st h)).
  rewrite Z_of_nat_Zabs_nat; last exact: min_u2Z.
  move/( _ (conj (refl_equal _) (conj (refl_equal _) u_ru''))).
  case=> _.
  have exec_asm':
    ((Some (st, heap_mint (unsign rk ru) st h)) -- multi_is_even_u rk ru a0 ---> Some (st', heap_mint (unsign rk ru) st h')).
    rewrite /heap_mint /heap_cut.
    eapply mips_syntax.triple_exec_proj; last exact: exec_asm.
    apply hoare_triple.
    rewrite /= Z_of_nat_Zabs_nat //; exact: min_u2Z.
  case/(_ _ _ exec_asm') => Hrk [Hru [Hmem [Heven Hodd]]].
split.
- rewrite /= /ZIT.eqb /ZIT.rem => /eqP X.
  rewrite store.get_r0 Z2uK //.
  apply/eqP.
  rewrite Hodd //; last first.
    rewrite lSum_Z2ints_pos //.
    apply not_Zmod_2_Zodd; by rewrite X.
  by rewrite Z2uK.
- rewrite /= /ZIT.eqb /ZIT.rem => /eqP X.
  rewrite store.get_r0 Z2uK // in X.
  apply/eqP.
  rewrite lSum_Z2ints_pos // in Heven.
  rewrite lSum_Z2ints_pos // in Hodd.
  case: (Zeven_odd_dec ([u]_s)%pseudo_expr).
    move/Heven => abs.
    by rewrite abs Z2uK in X.
  by apply Zodd_Zmod_2.
Qed.

Lemma fwd_sim_b_multi_is_even_u u rk ru d a0 : uniq(rk, ru, a0, r0) ->
  disj (mints_regs (assoc.cdom d)) (a0 :: nil) ->
  u \notin assoc.dom d ->
  unsign rk ru \notin assoc.cdom d ->
  fwd_sim_b (state_mint (u |=> unsign rk ru \U+ d ))
  (var_e u \% nat_e 2 \= nat_e 1)%pseudo_expr
  (multi_is_even_u rk ru a0)
  (beq a0 r0).
Proof.
move=> Hregs d_a0 u_d rk_ru_d.
rewrite /fwd_sim_b => s st h s_st_h.
set nk := '|u2Z [rk]_st|.
set U := Z2ints 32 nk ([ u ]_ s)%pseudo_expr.
have Hpre : (var_e ru |--> U)%asm_assert st (heap_mint (unsign rk ru) st h).
  move: (proj1 s_st_h u (unsign rk ru)).
  rewrite assoc.get_union_sing_eq. case/(_ refl_equal) => _ [_]; exact.
move: (multi_is_even_u_triple _ _ _ Hregs nk U [ru]_st).
rewrite /U size_Z2ints.
move/(_ (refl_equal _)) => Htriple.
set code := multi_is_even_u _ _ _.
have [st' Hst'] : exists st', Some (st, h) -- code ---> Some (st', h).
  have [[st' he'] Hst'] : exists st', Some (st, h) -- code ---> Some st'.
    apply constructive_indefinite_description'.
    eapply mips_seplog.hoare_prop_m.termi.
    - apply mips_frame.frame_rule_R with (R := assert_m.TT).
      + exact: Htriple.
      + by Inde.
      + move=> ?; by Inde_mult.
    - move=> s0 h0 /= H.
      apply Epsilon.constructive_indefinite_description.
      by apply mips_syntax.no_while_terminate.
    - exists (heap_mint (unsign rk ru) st h).
      exists (h \D\ iota '|u2Z ([ru ]_ st) / 4| nk).
      split.
        rewrite /= /heap_cut.
        by apply heap.proj_difs_disj, inc_refl.
      split.
        rewrite /= /heap_cut; by apply heap.proj_difs.
      split; last by [].
      split; first by rewrite /nk Z_of_nat_Zabs_nat //; apply min_u2Z.
      split; first by reflexivity.
      exact Hpre.
  exists st'.
  suff : h = he' by move=> X; rewrite -X in Hst'.
  by apply (mips_syntax.no_sw_heap_invariant _ _ _ Hst' refl_equal _ _ _ _ refl_equal refl_equal).
exists st'; split; first by exact Hst'.
move/mips_seplog.soundness : (Htriple).
rewrite /while.hoare_semantics.
move/(_ st (heap_mint (unsign rk ru) st h)).
rewrite {1}/nk Z_of_nat_Zabs_nat; last by apply min_u2Z.
case/(_ (conj (refl_equal _) (conj (refl_equal _) Hpre))) => _ Hpost.
move: {Htriple}(triple_exec_proj _ _ _ Htriple) => Hexec_proj.
rewrite {1}/nk Z_of_nat_Zabs_nat in Hexec_proj; last by apply min_u2Z.
rewrite /heap_mint /heap_cut in Hpre.
move: {Hexec_proj Hpre}(Hexec_proj _ _ _ _ _ (conj refl_equal (conj refl_equal Hpre)) Hst').
move/Hpost => {}Hpost.
case: Hpost => Hrk' [Hru' [Hmem Hret]].
rewrite lSum_Z2ints_pos in Hret; last first.
  move: (proj1 s_st_h u (unsign rk ru)).
  rewrite assoc.get_union_sing_eq.
  move/(_ refl_equal).
  rewrite /var_mint.
  by case=> ? [].
split=> [u_mod_2|].
+ apply/eqP.
  congr (Z<=u _).
  rewrite store.get_r0.
  apply (proj2 Hret).
  rewrite /= in u_mod_2.
  apply not_Zmod_2_Zodd.
  move/eqP : u_mod_2; by rewrite /ZIT.rem => ->.
+ move => u_mod_2.
  apply/eqP => /=.
  move/eqP : u_mod_2.
  rewrite store.get_r0 Z2uK // => Ha0.
  case: (Zeven_odd_dec ([u ]_ s)%pseudo_expr) => Hu.
  by rewrite (proj1 Hret Hu) Z2uK in Ha0.
  by apply Zodd_Zmod_2.
Qed.


Require Import Coq.Program.Basics.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Program.Combinators.
Require Import omega.Omega.
Require Import Setoid.
Require Import ZArith.
Require Import FinProof.Common.
Require Import FinProof.CommonInstances.
Require Import FinProof.StateMonad2.
Require Import FinProof.StateMonadInstances.
Require Import FinProof.ProgrammingWith.
Local Open Scope struct_scope.
Require Import FinProof.CommonProofs.
Require Import depoolContract.ProofEnvironment.
Require Import depoolContract.DePoolClass.
Require Import depoolContract.SolidityNotations.
Require Import depoolContract.DePoolFunc.
Require Import depoolContract.DePoolConsts.

Require Import depoolContract.Lib.CommonModelProofs.
Module CommonModelProofs := CommonModelProofs StateMonadSig.
Import CommonModelProofs.
Require Import depoolContract.Lib.Tactics.
Require Import depoolContract.Lib.ErrorValueProofs.
Import DePoolSpec.LedgerClass.SolidityNotations.
Local Open Scope struct_scope.
Local Open Scope Z_scope.
Local Open Scope solidity_scope.
Require Import Lists.List.
Import ListNotations.
Local Open Scope list_scope.
Set Typeclasses Iterative Deepening.
Set Typeclasses Depth 100.

Module ScenarioCommon  (dc : DePoolConstsTypesSig XTypesSig StateMonadSig).
Module DePoolFuncs := DePoolFuncs XTypesSig StateMonadSig dc.
Import dc.
Import DePoolFuncs.
Import DePoolSpec.
Import LedgerClass.

Record NetParams := NetParamsC {
    NetParams_ι_validatorsElectedFor : Z ;
    NetParams_ι_electionsStartBefore : Z ;
    NetParams_ι_electionsEndBefore : Z ;
    NetParams_ι_stakeHeldFor : Z ;

NetParams_ι_curValidatorData :  TvmCell;
    NetParams_ι_unknown34 : Z ;
    NetParams_ι_utime_since : Z ;
    NetParams_ι_utime_until : Z ;
    NetParams_ι_prevValidatorData : TvmCell ;

NetParams_ι_rawConfigParam_17 : TvmCell ;
    NetParams_ι_unknown17_1 : Z ;
    NetParams_ι_unknown17_2 : Z ;
    NetParams_ι_unknown17_3 : Z ;
    NetParams_ι_maxStakeFactor : Z;

NetParams_ι_rawConfigParam_1 : TvmCell ;
    NetParams_ι_electorRawAddress: Z ;

}.

Definition withNetParams (l : Ledger) (p : NetParams):=
    {$ l With     (VMState_ι_validatorsElectedFor , NetParams_ι_validatorsElectedFor  p) ;
                  (VMState_ι_electionsStartBefore, NetParams_ι_electionsStartBefore p) ;
                  (VMState_ι_electionsEndBefore, NetParams_ι_electionsEndBefore p) ;
                  (VMState_ι_stakeHeldFor, NetParams_ι_stakeHeldFor p) ;

                  (VMState_ι_curValidatorData, NetParams_ι_curValidatorData p);
                  (VMState_ι_unknown34, NetParams_ι_unknown34 p) ;
                  (VMState_ι_utime_since, NetParams_ι_utime_since p) ;
                  (VMState_ι_utime_until, NetParams_ι_utime_until p) ;

(* NetParams_ι_rawConfigParam_32 : C ; *)
                  (VMState_ι_prevValidatorData, NetParams_ι_prevValidatorData p) ;

                  (VMState_ι_rawConfigParam_17, NetParams_ι_rawConfigParam_17 p) ;
                  (VMState_ι_unknown17_1, NetParams_ι_unknown17_1 p) ; (*check the type*)
                  (VMState_ι_unknown17_2, NetParams_ι_unknown17_2 p) ;
                  (VMState_ι_unknown17_3, NetParams_ι_unknown17_3 p) ;
                  (VMState_ι_maxStakeFactor, NetParams_ι_maxStakeFactor p);

                  (VMState_ι_rawConfigParam_1, NetParams_ι_rawConfigParam_1 p) ;
                  (VMState_ι_electorRawAddress, NetParams_ι_electorRawAddress p) $} .

Definition DePoolContract_Ф_addOrdinaryStake'' ( Л_stake : XInteger64 ) : LedgerT ( XErrorValue True XInteger ) :=
           do r ← DePoolContract_Ф_addOrdinaryStake' Л_stake ;
           return! (xErrorMapDefaultF (fun vv => xErrorMapDefaultF xValue vv (fun _ => xError xInt0)) r xError).

Definition DePoolContract_Ф_participateInElections'' ( Л_queryId : XInteger64 )
           ( Л_validatorKey : XInteger256 )
           ( Л_stakeAt : XInteger32 )
           ( Л_maxFactor : XInteger32 )
           ( Л_adnlAddr : XInteger256 )
           ( Л_signature : XList XInteger8 )
            : LedgerT ( XErrorValue True XInteger ) :=
do r ← DePoolContract_Ф_participateInElections' Л_queryId Л_validatorKey Л_stakeAt Л_maxFactor Л_adnlAddr Л_signature;
return! (xErrorMapDefaultF (fun vv => xErrorMapDefaultF xValue vv (fun _ => xError xInt0)) r xError).

Definition DePoolContract_Ф_addVestingOrLock'' ( Л_stake : XInteger64 )
           ( Л_beneficiary : XAddress )
                                 ( Л_withdrawalPeriod : XInteger32 )
                                 ( Л_totalPeriod : XInteger32 )
                                 ( Л_isVesting : XBool ) : LedgerT (XErrorValue True XInteger) :=
do r ← DePoolContract_Ф_addVestingOrLock' Л_stake Л_beneficiary Л_withdrawalPeriod Л_totalPeriod Л_isVesting ;
return! (xErrorMapDefaultF (fun v => xValue v)  r (fun _ => xError xInt0)).

End ScenarioCommon.


(** ** Normalization of types
    This file contains a lot of stuff related to the historical normalization of types performed as a pre-processing phase.
    The current version uses a notion of dynamic types instead and a conversion function [TypToDtyp.typ_to_dtyp].
    The content of this file is however likely to be useful for static analyses in the future.
*)

From Coq Require Import
     List
     String
     Logic.FunctionalExtensionality.

From Vellvm Require Import
     Utils.Util
     Syntax.LLVMAst
     Syntax.AstLib
     Syntax.DynamicTypes.

Require Import Coqlib.

Import ListNotations.
Open Scope list_scope.

Ltac contra :=
  try match goal with
  | [Heq : ?x = ?y, Hneq : ?y <> ?x |- _] => symmetry in Heq
  end; contradiction.

(* Inductive predicate for types in LLVM with a size *)
Inductive sized_typ : list (ident * typ) -> typ -> Prop :=
| sized_typ_I :
    forall (defs : list (ident * typ)) (sz : N),
      sized_typ defs (TYPE_I sz)

| sized_typ_Pointer :
    forall (defs : list (ident * typ)) (t : typ),
      sized_typ defs (TYPE_Pointer t)

| sized_typ_Half :
    forall (defs : list (ident * typ)),
      sized_typ defs TYPE_Half

| sized_typ_Float :
    forall (defs : list (ident * typ)),
      sized_typ defs TYPE_Float

| sized_typ_Double :
    forall (defs : list (ident * typ)),
      sized_typ defs TYPE_Double

| sized_typ_X86_fp80 :
    forall (defs : list (ident * typ)),
      sized_typ defs TYPE_X86_fp80

| sized_typ_Fp128 :
    forall (defs : list (ident * typ)),
      sized_typ defs TYPE_Fp128

| sized_typ_Ppc_fp128 :
    forall (defs : list (ident * typ)),
      sized_typ defs TYPE_Ppc_fp128

| sized_typ_Metadata :
    forall (defs : list (ident * typ)),
      sized_typ defs TYPE_Metadata

| sized_typ_X86_mmx :
    forall (defs : list (ident * typ)),
      sized_typ defs TYPE_X86_mmx

| sized_typ_Array :
    forall (defs : list (ident * typ)) (sz : N) (t : typ),
      sized_typ defs t -> sized_typ defs (TYPE_Array sz t)

| sized_typ_Struct :
    forall (defs : list (ident * typ)) (fields : list typ),
      (forall (f : typ), In f fields -> sized_typ defs f) -> sized_typ defs (TYPE_Struct fields)

| sized_typ_Packed_struct :
    forall (defs : list (ident * typ)) (fields : list typ),
      (forall (f : typ), In f fields -> sized_typ defs f) -> sized_typ defs (TYPE_Packed_struct fields)

| sized_typ_Vector :
    forall (defs : list (ident * typ)) (sz : N) (t : typ),
      sized_typ defs t -> sized_typ defs (TYPE_Vector sz t)

| sized_typ_Identified :
    forall (defs : list (ident * typ)) (id : ident),
      (exists (t : typ), In (id, t) defs -> sized_typ defs t) -> sized_typ defs (TYPE_Identified id)
.

(* Inductive predicate for types in LLVM that can be elements of vectors.

   "elementtype" may be any integer, floating-point or pointer type.

   https://llvm.org/docs/LangRef.html#vector-type *)
Inductive element_typ : typ -> Prop :=
| element_typ_Pointer : forall (t : typ), element_typ (TYPE_Pointer t)
| element_typ_I : forall (sz : N), element_typ (TYPE_I sz)
| element_typ_Half : element_typ TYPE_Half
| element_typ_Float : element_typ TYPE_Float
| element_typ_Double : element_typ TYPE_Double
| element_typ_X86_fp80 : element_typ TYPE_X86_fp80
| element_typ_Fp128 : element_typ TYPE_Fp128
| element_typ_Ppc_fp128 : element_typ TYPE_Ppc_fp128
.

(* Predicate to ensure that an ident is guarded by a pointer everywhere in a type in an environment *)
Inductive guarded_typ : ident -> list (ident * typ) -> typ -> Prop :=
| guarded_typ_I :
    forall (id : ident) (env : list (ident * typ)) (sz : N),
      guarded_typ id env (TYPE_I sz)

| guarded_typ_Pointer :
    forall (id : ident) (env : list (ident * typ)) (t : typ),
      guarded_typ id env (TYPE_Pointer t)

| guarded_typ_Void :
    forall (id : ident) (env : list (ident * typ)),
      guarded_typ id env TYPE_Void

| guarded_typ_Half :
    forall (id : ident) (env : list (ident * typ)),
      guarded_typ id env TYPE_Half

| guarded_typ_Float :
    forall (id : ident) (env : list (ident * typ)),
      guarded_typ id env TYPE_Float

| guarded_typ_Double :
    forall (id : ident) (env : list (ident * typ)),
      guarded_typ id env TYPE_Double

| guarded_typ_X86_fp80 :
    forall (id : ident) (env : list (ident * typ)),
      guarded_typ id env TYPE_X86_fp80

| guarded_typ_Fp128 :
    forall (id : ident) (env : list (ident * typ)),
      guarded_typ id env TYPE_Fp128

| guarded_typ_Ppc_fp128 :
    forall (id : ident) (env : list (ident * typ)),
      guarded_typ id env TYPE_Ppc_fp128

| guarded_typ_Metadata :
    forall (id : ident) (env : list (ident * typ)),
      guarded_typ id env TYPE_Metadata

| guarded_typ_X86_mmx :
    forall (id : ident) (env : list (ident * typ)),
      guarded_typ id env TYPE_X86_mmx

| guarded_typ_Function :
    forall (id : ident) (env : list (ident * typ)) (ret : typ) (args : list typ),
      guarded_typ id env ret ->
      (forall a, In a args -> guarded_typ id env a) ->
      guarded_typ id env (TYPE_Function ret args)

| guarded_typ_Array :
    forall (id : ident) (env : list (ident * typ)) (sz : N) (t : typ),
      guarded_typ id env t -> guarded_typ id env (TYPE_Array sz t)

| guarded_typ_Struct :
    forall (id : ident) (env : list (ident * typ)) (t : typ) (fields : list typ),
      (forall f, In f fields -> guarded_typ id env f) ->
      guarded_typ id env (TYPE_Struct fields)

| guarded_typ_Packed_struct :
    forall (id : ident) (env : list (ident * typ)) (t : typ) (fields : list typ),
      (forall f, In f fields -> guarded_typ id env f) ->
      guarded_typ id env (TYPE_Packed_struct fields)

| guarded_typ_Opaque :
    forall (id : ident) (env : list (ident * typ)),
      guarded_typ id env TYPE_Opaque

| guarded_typ_Vector :
    forall (id : ident) (env : list (ident * typ)) (sz : N) (t : typ),
      guarded_typ id env (TYPE_Vector sz t)

| guarded_typ_Identified_Some :
    forall (id : ident) (env : list (ident * typ)) (id' : ident) (t : typ),
      id <> id' ->
      Some (id', t) = find (fun a => Ident.eq_dec id' (fst a)) env ->
      guarded_typ id env t ->
      guarded_typ id' env t ->
      guarded_typ id env (TYPE_Identified id')

| guarded_typ_Identified_None :
    forall (id : ident) (env : list (ident * typ)) (id' : ident),
      id <> id' ->
      None = find (fun a => Ident.eq_dec id' (fst a)) env ->
      guarded_typ id env (TYPE_Identified id')
.

Inductive first_class_typ : typ -> Prop :=
| first_class_I : forall sz, first_class_typ (TYPE_I sz)
| first_class_Pointer : forall t, first_class_typ (TYPE_Pointer t)
| first_class_Void : first_class_typ TYPE_Void
| first_class_Half : first_class_typ TYPE_Half
| first_class_Float : first_class_typ TYPE_Float
| first_class_Double : first_class_typ TYPE_Double
| first_class_X86_fp80 : first_class_typ TYPE_X86_fp80
| first_class_Fp128 : first_class_typ TYPE_Fp128
| first_class_Ppc_fp128 : first_class_typ TYPE_Ppc_fp128
| first_class_Metadata : first_class_typ TYPE_Metadata
| first_class_X86_mmx : first_class_typ TYPE_X86_mmx
| first_class_Array : forall sz t, first_class_typ (TYPE_Array sz t)
| first_class_Struct : forall fields, first_class_typ (TYPE_Struct fields)
| first_class_Packed_struct : forall fields, first_class_typ (TYPE_Packed_struct fields)
| first_class_Opaque : first_class_typ TYPE_Opaque
| first_class_Vector : forall sz t, first_class_typ (TYPE_Vector sz t)
| first_class_Identified : forall id, first_class_typ (TYPE_Identified id)
.

Definition function_ret_typ (t : typ) : Prop :=
  first_class_typ t /\ t <> TYPE_Metadata.

(* Inductive predicate for well-formed LLVM types.

   wf_typ env t

   means that 't' is a well-formed type in the environment 'env'. The
   environment just associates identifiers to types, so this contains
   things like user-defined structure types.

   well-formed LLVM types should cover every valid type in LLVM.

   Examples of invalid types:

   - Vectors of size 0
   - Arrays with unsized elements
   - Recursive structures (must be guarded by a pointer) *)

Inductive wf_typ : list (ident * typ) -> typ -> Prop :=
| wf_typ_Pointer:
    forall (defs : list (ident * typ)) (t : typ),
      wf_typ defs t -> wf_typ defs (TYPE_Pointer t)

| wf_typ_I :
    forall (defs : list (ident * typ)) (sz : N),
      (sz > 0)%N -> wf_typ defs (TYPE_I sz)

| wf_typ_Void :
    forall (defs : list (ident * typ)),
      wf_typ defs TYPE_Void

| wf_typ_Half :
    forall (defs : list (ident * typ)),
      wf_typ defs TYPE_Half

| wf_typ_Float :
    forall (defs : list (ident * typ)),
      wf_typ defs TYPE_Float

| wf_typ_Double :
    forall (defs : list (ident * typ)),
      wf_typ defs TYPE_Double

| wf_typ_X86_fp80 :
    forall (defs : list (ident * typ)),
      wf_typ defs TYPE_X86_fp80

| wf_typ_Fp128 :
    forall (defs : list (ident * typ)),
      wf_typ defs TYPE_Fp128

| wf_typ_Ppc_fp128 :
    forall (defs : list (ident * typ)),
      wf_typ defs TYPE_Ppc_fp128

| wf_typ_Metadata :
    forall (defs : list (ident * typ)),
      wf_typ defs TYPE_Metadata

| wf_typ_X86_mmx :
    forall (defs : list (ident * typ)),
      wf_typ defs TYPE_X86_mmx

| wf_typ_Function :
    forall (defs : list (ident * typ)) (ret : typ) (args : list typ),
      function_ret_typ ret ->
      wf_typ defs ret ->
      (forall (a : typ), In a args -> sized_typ defs a) ->
      (forall (a : typ), In a args -> wf_typ defs a) ->
      wf_typ defs (TYPE_Function ret args)

(* Arrays are only well formed if the size is >= 0, and the element type is sized. *)
| wf_typ_Array :
    forall (defs : list (ident * typ)) (sz : N) (t : typ),
      (sz >= 0)%N -> sized_typ defs t -> wf_typ defs t -> wf_typ defs (TYPE_Array sz t)

(* Vectors of size 0 are not allowed, and elements must be of element_typ. *)
| wf_typ_Vector :
    forall (defs : list (ident * typ)) (sz : N) (t : typ),
      (sz > 0)%N -> element_typ t -> wf_typ defs t -> wf_typ defs (TYPE_Vector sz t)

(* Any type identifier must exist in the environment.

   Additionally the identifier must not occur anywhere in the type
   that it refers to *unless* it is guarded by a pointer. *)
| wf_typ_Identified :
    forall (defs : list (ident * typ)) (id : ident),
      (exists t, In (id, t) defs) ->
      (forall (t : typ), In (id, t) defs -> guarded_typ id defs t) ->
      (forall (t : typ), In (id, t) defs -> wf_typ defs t) ->
      wf_typ defs (TYPE_Identified id)

(* Fields of structure must be sized types *)
| wf_typ_Struct :
    forall (defs : list (ident * typ)) (fields : list typ),
      (forall (f : typ), In f fields -> sized_typ defs f) ->
      (forall (f : typ), In f fields -> wf_typ defs f) ->
      wf_typ defs (TYPE_Struct fields)

| wf_typ_Packed_struct :
    forall (defs : list (ident * typ)) (fields : list typ),
      (forall (f : typ), In f fields -> sized_typ defs f) ->
      (forall (f : typ), In f fields -> wf_typ defs f) ->
      wf_typ defs (TYPE_Packed_struct fields)

| wf_typ_Opaque :
    forall (defs : list (ident * typ)),
      wf_typ defs TYPE_Opaque
.

Hint Constructors wf_typ.

Definition wf_env (env : list (ident * typ)) : Prop :=
  NoDup (map fst env) /\ Forall (wf_typ env) (map snd env).

Inductive guarded_wf_typ : list (ident * typ) -> typ -> Prop :=
| guarded_wf_typ_Pointer:
    forall (defs : list (ident * typ)) (t : typ),
      guarded_wf_typ defs (TYPE_Pointer t)

| guarded_wf_typ_I :
    forall (defs : list (ident * typ)) (sz : N),
      (sz > 0)%N -> guarded_wf_typ defs (TYPE_I sz)

| guarded_wf_typ_Void :
    forall (defs : list (ident * typ)),
      guarded_wf_typ defs TYPE_Void

| guarded_wf_typ_Half :
    forall (defs : list (ident * typ)),
      guarded_wf_typ defs TYPE_Half

| guarded_wf_typ_Float :
    forall (defs : list (ident * typ)),
      guarded_wf_typ defs TYPE_Float

| guarded_wf_typ_Double :
    forall (defs : list (ident * typ)),
      guarded_wf_typ defs TYPE_Double

| guarded_wf_typ_X86_fp80 :
    forall (defs : list (ident * typ)),
      guarded_wf_typ defs TYPE_X86_fp80

| guarded_wf_typ_Fp128 :
    forall (defs : list (ident * typ)),
      guarded_wf_typ defs TYPE_Fp128

| guarded_wf_typ_Ppc_fp128 :
    forall (defs : list (ident * typ)),
      guarded_wf_typ defs TYPE_Ppc_fp128

| guarded_wf_typ_Metadata :
    forall (defs : list (ident * typ)),
      guarded_wf_typ defs TYPE_Metadata

| guarded_wf_typ_X86_mmx :
    forall (defs : list (ident * typ)),
      guarded_wf_typ defs TYPE_X86_mmx

| guarded_wf_typ_Function :
    forall (defs : list (ident * typ)) (ret : typ) (args : list typ),
      function_ret_typ ret ->
      guarded_wf_typ defs ret ->
      (forall (a : typ), In a args -> sized_typ defs a) ->
      (forall (a : typ), In a args -> guarded_wf_typ defs a) ->
      guarded_wf_typ defs (TYPE_Function ret args)

(* Arrays are only well formed if the size is >= 0, and the element type is sized. *)
| guarded_wf_typ_Array :
    forall (defs : list (ident * typ)) (sz : N) (t : typ),
      (sz >= 0)%N -> sized_typ defs t -> guarded_wf_typ defs t -> guarded_wf_typ defs (TYPE_Array sz t)

(* Vectors of size 0 are not allowed, and elemnts must be of element_typ. *)
| guarded_wf_typ_Vector :
    forall (defs : list (ident * typ)) (sz : N) (t : typ),
      (sz > 0)%N -> element_typ t -> guarded_wf_typ defs t -> guarded_wf_typ defs (TYPE_Vector sz t)

(* Identifier must be in the typing environment.

   Additionally the identifier must not occur anywhere in the type
   that it refers to *unless* it is guarded by a pointer. *)
| guarded_wf_typ_Identified :
    forall (defs : list (ident * typ)) (id : ident),
      (exists t, In (id, t) defs) ->
      (forall (t : typ), In (id, t) defs -> guarded_typ id defs t) ->
      (forall (t : typ), In (id, t) defs -> guarded_wf_typ defs t) ->
      guarded_wf_typ defs (TYPE_Identified id)

(* Fields of structure must be sized types *)
| guarded_wf_typ_Struct :
    forall (defs : list (ident * typ)) (fields : list typ),
      (forall (f : typ), In f fields -> sized_typ defs f) ->
      (forall (f : typ), In f fields -> guarded_wf_typ defs f) ->
      guarded_wf_typ defs (TYPE_Struct fields)

| guarded_wf_typ_Packed_struct :
    forall (defs : list (ident * typ)) (fields : list typ),
      (forall (f : typ), In f fields -> sized_typ defs f) ->
      (forall (f : typ), In f fields -> guarded_wf_typ defs f) ->
      guarded_wf_typ defs (TYPE_Packed_struct fields)

| guarded_wf_typ_Opaque :
    forall (defs : list (ident * typ)),
      guarded_wf_typ defs TYPE_Opaque
.

Hint Constructors guarded_wf_typ.

Theorem wf_typ_is_guarded_wf_typ :
  forall env t,
    wf_typ env t ->
    guarded_wf_typ env t.
Proof.
  induction 1; auto.
Qed.

(* An unrolled type is an LLVM type that contains no identifiers,
   unless the identifier is behind a pointer.

 *)

Inductive unrolled_typ : typ -> Prop :=
| unrolled_typ_I :
    forall (sz : N),
      unrolled_typ (TYPE_I sz)

| unrolled_typ_Pointer :
    forall (t : typ),
      unrolled_typ (TYPE_Pointer t)

| unrolled_typ_Void :
    unrolled_typ TYPE_Void

| unrolled_typ_Half :
    unrolled_typ TYPE_Half

| unrolled_typ_Float :
    unrolled_typ TYPE_Float

| unrolled_typ_Double :
    unrolled_typ TYPE_Double

| unrolled_typ_X86_fp80 :
    unrolled_typ TYPE_X86_fp80

| unrolled_typ_Fp128 :
    unrolled_typ TYPE_Fp128

| unrolled_typ_Ppc_fp128 :
    unrolled_typ TYPE_Ppc_fp128

| unrolled_typ_Metadata :
    unrolled_typ TYPE_Metadata

| unrolled_typ_X86_mmx :
    unrolled_typ TYPE_X86_mmx

| unrolled_typ_Array :
    forall (sz : N) (t : typ),
      unrolled_typ t ->
      unrolled_typ (TYPE_Array sz t)

| unrolled_typ_Function :
    forall (ret : typ) (args : list typ),
      unrolled_typ ret ->
      Forall unrolled_typ args ->
      unrolled_typ (TYPE_Function ret args)

| unrolled_typ_Struct :
    forall (fields : list typ),
      Forall (unrolled_typ) fields ->
      unrolled_typ (TYPE_Struct fields)

| unrolled_typ_Packed_struct :
    forall (fields : list typ),
      Forall (unrolled_typ) fields ->
      unrolled_typ (TYPE_Packed_struct fields)

| unrolled_typ_Opaque :
    unrolled_typ TYPE_Opaque

| unrolled_typ_Vector :
    forall (sz : N) (t : typ), unrolled_typ (TYPE_Vector sz t)
.

Inductive typ_order : typ -> typ -> Prop :=
| typ_order_Pointer : forall (t : typ), typ_order t (TYPE_Pointer t)
| typ_order_Array : forall (sz : N) (t : typ), typ_order t (TYPE_Array sz t)
| typ_order_Vector : forall (sz : N) (t : typ), typ_order t (TYPE_Vector sz t)
| typ_order_Struct : forall (fields : list typ),
    forall f, In f fields -> typ_order f (TYPE_Struct fields)
| typ_order_Packed_struct : forall (fields : list typ),
    forall f, In f fields -> typ_order f (TYPE_Packed_struct fields)
| typ_order_Function_args : forall (ret : typ) (args : list typ),
    forall a, In a args -> typ_order a (TYPE_Function ret args)
| typ_order_Function_ret : forall (ret : typ) (args : list typ),
    typ_order ret (TYPE_Function ret args)
.

Hint Constructors typ_order.

Theorem wf_typ_order :
    well_founded typ_order.
Proof.
  unfold well_founded.
  induction a; constructor; intros y H'; inversion H'; subst; auto.
Qed.

Theorem wf_lt_typ_order :
  well_founded (lex_ord lt typ_order).
Proof.
  apply wf_lex_ord.
  apply lt_wf. apply wf_typ_order.
Qed.

Hint Resolve wf_lt_typ_order.
Hint Constructors lex_ord.

Definition length_order {A : Type} (l1 l2 : list A) :=
  (List.length l1 < List.length l2)%nat.

(* Lemma lengthOrder_wf' : forall A len, forall ls, (List.length ls <= len)%nat -> Acc (@length_order A) ls. *)
(*   unfold length_order; induction len; *)
(*     intros ls H; inversion H; subst; constructor; firstorder. *)
(* Defined. *)

(* Theorem lengthOrder_wf : forall A, well_founded (@length_order A). *)
(*   red; intros A a; eapply lengthOrder_wf'; eauto. *)
(* Defined. *)

(* Theorem wf_length_typ_order : *)
(*   forall A, *)
(*     well_founded (lex_ord (@length_order A) typ_order). *)
(* Proof. *)
(*   intros. *)
(*   apply wf_lex_ord. apply lengthOrder_wf. apply wf_typ_order. *)
(* Defined. *)

Lemma map_In {A B : Type} (l : list A) (f : forall (x : A), In x l -> B) : list B.
Proof.
  induction l.
  - exact [].
  - refine (f a _ :: IHl _).
    + simpl. auto.
    + intros x H. apply (f x). simpl. auto.
Defined.

Fixpoint remove_key {A B : Type} (eq_dec : (forall (x y : A), {x = y} + {x <> y})) (a : A) (l : list (A * B)) : list (A * B) :=
  match l with
  | nil => nil
  | cons (h, b) t =>
    match eq_dec a h with
    | left _ => t
    | right _ => (h, b) :: remove_key eq_dec a t
    end
  end.

Fixpoint remove_keys {A B : Type} (eq_dec : (forall (x y : A), {x = y} + {x <> y})) (keys : list A) (l : list (A * B)) : list (A * B) :=
  match keys with
  | nil => l
  | key :: rest_of_keys => remove_keys eq_dec rest_of_keys (remove_key eq_dec key l)
  end.

Ltac destruct_prod :=
  match goal with
  | [ |- context[let (_, _) := ?p in _]] => destruct p
  | [ p: ?A * ?B |- _ ] => destruct p
  end.

Ltac destruct_eq_dec :=
  match goal with
  | [ eq: forall x y : ?A , {x = y} + {x <> y} |- context[eq ?a ?b] ] => destruct (eq a b) eqn:?; simpl
  | [ |- context[Ident.eq_dec ?a ?b] ] => destruct (Ident.eq_dec a b) eqn:?; simpl
  end.

Lemma remove_key_in :
  forall (A B : Type) (a : A)  (b : B) eq_dec l,
    In (a, b) l ->
    (List.length (remove_key eq_dec a l) < List.length l)%nat.
Proof.
  induction l.
  - intros H. inversion H.
  - intros H.
    destruct_prod.
    simpl. destruct_eq_dec.
    + apply Nat.lt_succ_diag_r.
    + simpl. apply lt_n_S. apply IHl.
      destruct H.
      * inversion H. subst. contradiction.
      * assumption.
Qed.

Lemma remove_key_not_in :
  forall (A B : Type) (a : A) eq_dec (l : list (A * B)),
    ~ In a (map fst l) ->
    remove_key eq_dec a l = l.
Proof.
  induction l; intros H.
  - reflexivity.
  - simpl in *. destruct_prod; destruct_eq_dec.
    + intuition.
    + rewrite IHl; intuition.
Qed.

Ltac solve_eq_dec_if :=
  match goal with
  | [ eq: forall x y : ?A , {x = y} + {x <> y},
        Heq : ?eq ?a ?b = ?c |- context[if ?eq ?a ?b then _ else _] ] => rewrite Heq
  | [ Heq : Ident.eq_dec ?a ?b = ?c |- context[if Ident.eq_dec ?a ?b then _ else _] ] => rewrite Heq
  | [ eq: forall x y : ?A , {x = y} + {x <> y},
        Heq : ?eq ?a ?b = ?c |- context[if proj_sumbool (?eq ?a ?b) then _ else _] ] => rewrite Heq
  | [ Heq : Ident.eq_dec ?a ?b = ?c |- context[if proj_sumbool (Ident.eq_dec ?a ?b) then _ else _] ] => rewrite Heq

  end.

Ltac subst_eq :=
  match goal with
  | [ eq: forall x y : ?A , {x = y} + {x <> y}, Heq: eq ?a ?b = ?c |- _ ] => rewrite Heq
  | [ Heq : Ident.eq_dec ?a ?b = ?c |- _ ] => rewrite Heq
  end.

Ltac solve_eq_dec :=
  repeat destruct_prod; simpl in *;
  repeat (destruct_eq_dec; simpl in *; subst; simpl; try contra; auto; repeat (solve_eq_dec_if; simpl); auto);
  intuition; try congruence.

Lemma remove_key_commutes :
  forall (A B : Type) (k1 k2 : A) eq_dec (l : list (A * B)),
    remove_key eq_dec k1 (remove_key eq_dec k2 l) = remove_key eq_dec k2 (remove_key eq_dec k1 l).
Proof.
  induction l; solve_eq_dec.
Qed.

Lemma remove_key_keys :
  forall (A B : Type) (keys : list A) eq_dec (key : A) (l : list (A * B)),
    remove_key eq_dec key (remove_keys eq_dec keys l) = remove_keys eq_dec (key :: keys) l.
Proof.
  intros A B keys.
  induction keys as [| k keys' IHkeys]; intros eq_dec key l; auto.
  simpl in *.
  rewrite IHkeys.
  apply f_equal; apply remove_key_commutes.
Qed.

Lemma remove_keys_key :
  forall (A B : Type) (keys : list A) eq_dec (key : A) (l : list (A * B)),
    remove_keys eq_dec keys (remove_key eq_dec key l) = remove_keys eq_dec (key :: keys) l.
Proof.
  intros A B keys.
  induction keys; intros eq_dec key l; auto.
Qed.

Program Fixpoint normalize_type (env : list (ident * typ)) (t : typ) {measure (List.length env, t) (lex_ord lt typ_order)} : typ :=
  match t with
  | TYPE_Array sz t =>
    let nt := normalize_type env t in
    TYPE_Array sz nt

  | TYPE_Function ret args =>
    let nret := (normalize_type env ret) in
    let nargs := map_In args (fun t _ => normalize_type env t) in
    TYPE_Function nret nargs

  | TYPE_Struct fields =>
    let nfields := map_In fields (fun t _ => normalize_type env t) in
    TYPE_Struct nfields

  | TYPE_Packed_struct fields =>
    let nfields := map_In fields (fun t _ => normalize_type env t) in
    TYPE_Packed_struct nfields

  | TYPE_Vector sz t =>
    let nt := normalize_type env t in
    TYPE_Vector sz nt

  | TYPE_Identified id =>
    match find (fun a => Ident.eq_dec id (fst a)) env with
    | None => TYPE_Identified id
    | Some (_, t) => normalize_type (remove_key Ident.eq_dec id env) t
    end

  | TYPE_I sz => t
  | TYPE_Pointer t' => t
  | TYPE_Void => t
  | TYPE_Half => t
  | TYPE_Float => t
  | TYPE_Double => t
  | TYPE_X86_fp80 => t
  | TYPE_Fp128 => t
  | TYPE_Ppc_fp128 => t
  | TYPE_Metadata => t
  | TYPE_X86_mmx => t
  | TYPE_Opaque => t
  end.
Next Obligation.
  left.
  symmetry in Heq_anonymous. apply find_some in Heq_anonymous. destruct Heq_anonymous as [Hin Heqb_ident].
  simpl in Heqb_ident.
  destruct (Ident.eq_dec id wildcard'). subst. eapply remove_key_in. apply Hin.
  inversion Heqb_ident.
Defined.

Lemma normalize_type_equation : forall env t,
    normalize_type env t =
    match t with
  | TYPE_Array sz t =>
    let nt := normalize_type env t in
    TYPE_Array sz nt

  | TYPE_Function ret args =>
    let nret := (normalize_type env ret) in
    let nargs := map_In args (fun t _ => normalize_type env t) in
    TYPE_Function nret nargs

  | TYPE_Struct fields =>
    let nfields := map_In fields (fun t _ => normalize_type env t) in
    TYPE_Struct nfields

  | TYPE_Packed_struct fields =>
    let nfields := map_In fields (fun t _ => normalize_type env t) in
    TYPE_Packed_struct nfields

  | TYPE_Vector sz t =>
    let nt := normalize_type env t in
    TYPE_Vector sz nt

  | TYPE_Identified id =>
    let opt := find (fun a => Ident.eq_dec id (fst a)) env in
    match opt with
    | None => TYPE_Identified id   (* TODO: should this be None? *)
    | Some (_, t) => normalize_type (remove_key Ident.eq_dec id env) t
    end

  | TYPE_I sz => TYPE_I sz
  | TYPE_Pointer t' => TYPE_Pointer t'
  | TYPE_Void => TYPE_Void
  | TYPE_Half => TYPE_Half
  | TYPE_Float => TYPE_Float
  | TYPE_Double => TYPE_Double
  | TYPE_X86_fp80 => TYPE_X86_fp80
  | TYPE_Fp128 => TYPE_Fp128
  | TYPE_Ppc_fp128 => TYPE_Ppc_fp128
  | TYPE_Metadata => TYPE_Metadata
  | TYPE_X86_mmx => TYPE_X86_mmx
  | TYPE_Opaque => TYPE_Opaque
  end.
Proof.
  intros env t.
  unfold normalize_type.
  unfold normalize_type_func at 1.
  rewrite Wf.WfExtensionality.fix_sub_eq_ext.
  destruct t; try reflexivity. simpl.
  destruct (find (fun a : ident * typ => Ident.eq_dec id (fst a)) env).
  destruct p; simpl; eauto.
  reflexivity.
Defined.

Hint Constructors unrolled_typ.

Lemma find_in_wf_env :
  forall env id t,
    NoDup (map fst env) ->
    In (id, t) env ->
    find (fun a : ident * typ => Ident.eq_dec id (fst a)) env = Some (id, t).
Proof.
  intros env id t Hdup Hin.
  induction env as [| [id' t'] env IHenv].
  - contradiction.
  - destruct Hin as [Hin | Hin]; try inversion Hin; subst.
    + simpl. destruct_eq_dec; intuition.
    + simpl. destruct_eq_dec.
      * inversion Hdup. subst. apply in_map with (f:=fst) in Hin. simpl in *.
        contradiction.
      * simpl. inversion Hdup. auto.
Qed.

Lemma guarded_typ_id_same :
  forall env id,
    guarded_typ id env (TYPE_Identified id) -> False.
Proof.
  intros env id H.
  inversion H; contradiction.
Qed.

Lemma find_different_key_from_removed :
  forall env id id',
    id <> id' ->
    find (fun a : ident * typ => Ident.eq_dec id' (fst a)) env = find (fun a : ident * typ => Ident.eq_dec id' (fst a)) (remove_key Ident.eq_dec id env).
Proof.
  intros env id id' H.
  induction env; solve_eq_dec.
Qed.

Lemma remove_keys_find :
  forall env id ids,
    ~ In id ids ->
    find (fun a : ident * typ => Ident.eq_dec id (fst a)) env = find (fun a : ident * typ => Ident.eq_dec id (fst a)) (remove_keys Ident.eq_dec ids env).
Proof.
  intros env id ids H.
  induction ids.
  - reflexivity.
  - rewrite <- remove_key_keys.
    rewrite <- find_different_key_from_removed with (id:=a); intuition; subst; intuition.
Qed.

Ltac solve_some :=
  match goal with
  | [ H: (?i1, ?t1) = (?i2, ?t2) |- ?F (?i1, ?t1) = ?F (?i2, ?t2) ] => inversion H; reflexivity
  | [ Hdup : NoDup (?i :: map fst ?env),
      Hin : In (?i, ?t) ?env |- ?F (?i, ?t1) = ?F (?i, ?t2) ] =>
    let Hnin := fresh in
    let Hdup' := fresh in
    inversion Hdup as [| ? ? Hnin Hdup']; subst;
    exfalso; apply Hnin;
    replace i with (fst (i, t)) by reflexivity;
    apply in_map; auto
  | [ Hin : In (?i, ?t1) ((?i, ?t2) :: ?env) |- ?F (?i, ?t1) = ?F (?i, ?t2) ] => symmetry; solve_some
  | [ Hin : In (?i, ?t2) ((?i, ?t1) :: ?env) |- ?F (?i, ?t1) = ?F (?i, ?t2) ] => inversion Hin; solve_some
  end.

Ltac solve_in :=
  match goal with
  | [ Hin: In (?id, ?t) ((?i, ?t0) :: ?env),
      Hneq: ?id <> ?i |- In (?id, ?t) ?env ] =>
    let Htup := fresh in
    inversion Hin as [Htup | ?]; [> inversion Htup; contra | auto]

  | [ H: find (fun a => (proj_sumbool (?eq ?id (fst a)))) ?env = Some (?i, ?t)
      |- In (?id, ?t) ?env ] =>
    let Hfind := fresh in
    apply find_some in H as [? Hfind];
    simpl in Hfind;
    destruct (Ident.eq_dec id i) eqn:?; subst; intuition
  end.

Lemma find_some_id :
  forall env id p t,
    NoDup (map fst env) ->
    In (id, t) env ->
    find (fun a : ident * typ => Ident.eq_dec id (fst a)) env = Some p ->
    find (fun a : ident * typ => Ident.eq_dec id (fst a)) env = Some (id, t).
Proof.
  intros env id p t Hdup Hin H.
  induction env.
  - inversion H.
  - destruct a. simpl.
    destruct_eq_dec.
    + subst. simpl in Hdup. solve_some.
    + simpl. apply IHenv.
      * inversion Hdup; auto.
      * solve_in.
      * simpl in *. rewrite Heqs in H. simpl in *.
        assumption.
Qed.

Hint Constructors sized_typ.
Hint Constructors guarded_typ.

(* Types with no identifiers *)
Inductive simple_typ : typ -> Prop :=
| simple_typ_I : forall sz, simple_typ (TYPE_I sz)
| simple_typ_Pointer : forall t, simple_typ t -> simple_typ (TYPE_Pointer t)
| simple_typ_Void : simple_typ (TYPE_Void)
| simple_typ_Half : simple_typ (TYPE_Half)
| simple_typ_Float : simple_typ (TYPE_Float)
| simple_typ_Double : simple_typ (TYPE_Double)
| simple_typ_X86_fp80 : simple_typ (TYPE_X86_fp80)
| simple_typ_Fp128 : simple_typ (TYPE_Fp128)
| simple_typ_Ppc_fp128 : simple_typ (TYPE_Ppc_fp128)
| simple_typ_Metadata : simple_typ (TYPE_Metadata)
| simple_typ_X86_mmx : simple_typ (TYPE_X86_mmx)
| simple_typ_Array : forall sz t, simple_typ t -> simple_typ (TYPE_Array sz t)
| simple_typ_Function :
    forall ret args,
      simple_typ ret ->
      (forall a, In a args -> simple_typ a) ->
      simple_typ (TYPE_Function ret args)
| simple_typ_Struct :
    forall fields,
      (forall f, In f fields -> simple_typ f) ->
      simple_typ (TYPE_Struct fields)
| simple_typ_Packed_struct :
    forall fields,
      (forall f, In f fields -> simple_typ f) ->
      simple_typ (TYPE_Packed_struct fields)
| simple_typ_Opaque : simple_typ (TYPE_Opaque)
| simple_typ_Vector : forall sz t, simple_typ t -> simple_typ (TYPE_Vector sz t)
.

Hint Constructors simple_typ.

Theorem map_in_id :
  forall {A : Type} (l : list A) (f : forall x : A, In x l -> A),
    (forall a (Hin : In a l), f a Hin = a) ->
    map_In l f = l.
Proof.
  intros A l f H.
  induction l; auto.
  simpl. rewrite H. rewrite IHl; auto.
Qed.

Theorem simple_normalizes_to_self :
  forall env t,
    simple_typ t ->
    normalize_type env t = t.
Proof.
  intros env t H.
  induction H; rewrite normalize_type_equation; simpl;
    repeat
      match goal with
      | [H : normalize_type env _ = _ |- context[normalize_type _ _]] => rewrite H
      | [|- context[(map_In _ (fun (t : typ) (_ : In t _) => normalize_type env t))]] => rewrite map_in_id; auto
      end; auto.
Qed.

Theorem simple_unrolled :
  forall t,
    simple_typ t -> unrolled_typ t.
Proof.
  intros t H.
  induction H; constructor;
    try match goal with
        | [|- Forall _ _] => apply Forall_forall
        end; auto.
Qed.

Theorem in_map_in :
  forall {A : Type} (x : A) (l : list A) f,
    In x (map_In l (fun t (_ : In t l) => f t)) ->
    exists t, In t l /\ f t = x.
Proof.
  intros A x l f H.
  induction l.
  - inversion H.
  - simpl in *. destruct H.
    + exists a. split; auto.
    + apply IHl in H as [t [Hin Hftx]].
      exists t. intuition.
Qed.

Theorem map_rewrite :
  forall {A B : Type} (x : A) (l : list A) (f g : A -> B),
    (forall x, In x l -> f x = g x) ->
    map_In l (fun t (_ : In t l) => f t) = map_In l (fun t (_ : In t l) => g t).
Proof.
  intros A B x l f g H.
  induction l as [| a l IHl]; simpl; auto.
  pose proof (H a) as Ha.
  rewrite Ha; intuition.
  rewrite IHl; intuition.
Qed.

Ltac simpl_remove_keys :=
  match goal with
  | [ |- context[remove_key ?eq ?id (remove_keys ?eq ?ids ?assoc_list)] ] =>
    replace (remove_key eq id (remove_keys eq ids assoc_list)) with
        (remove_keys eq (id :: ids) assoc_list) by auto using remove_key_keys

  | [ |- context[remove_keys ?eq ?ids (remove_key ?eq ?id ?assoc_list)] ] =>
    replace (remove_keys eq ids (remove_key eq id assoc_list)) with
        (remove_keys eq (id :: ids) assoc_list) by auto using remove_keys_key

  | [ |- context[remove_key ?eq ?id ?assoc_list] ] =>
    replace (remove_key eq id assoc_list) with
        (remove_keys eq [id] assoc_list) by auto
  end.

Ltac subst_find_some :=
  match goal with
  | [ H1: ?F ?filter ?defs = ?G (?i1, ?t1),
      H2: ?X = ?F ?filter ?defs |- _ ] => rewrite H1 in H2; inversion H2
  end.

Ltac solve_guard :=
  match goal with
  | [ H: element_typ ?x |- guarded_typ ?id ?defs ?x ] =>
        match goal with
        | [H : element_typ _ |- _] => inversion H
        end; auto

  | [ Hguard: forall i, In i ?ids -> guarded_typ i ?env ?t |- ~(In ?id ?ids) ] =>
    let Hguard' := fresh in
    let Hin := fresh in
    unfold not; intros Hin;
    pose proof Hguard id Hin as Hguard';
    inversion Hguard'; auto

  | [ Hguard: forall t, In (?i, t) ?defs -> guarded_typ ?i ?defs t,
        Hin: In ?id [?i] |- _ ] =>
    intros; inversion Hin; subst; try contradiction; auto

  | [ Hguard: forall i, In ?id [i] -> guarded_typ ?i ?env ?t |- ~(In ?id ?ids) ] =>
    let Hguard' := fresh in
    let Hin := fresh in
    unfold not; intros Hin;
    pose proof Hguard id Hin as Hguard';
    inversion Hguard'; subst; try contra; auto

  | [ Hguard: forall i, In i ?ids -> guarded_typ i ?env ?t,
        Hin: In ?id [?one] |- guarded_typ ?id ?defs ?x ] =>
    inversion Hin; subst; auto; contra

  | [ Hguard: forall i, In i ?ids -> guarded_typ i ?env ?t,
      Hin: In ?id ?ids |- guarded_typ ?id ?defs ?x ] =>
    let Hguard' := fresh in
    pose proof Hguard _ Hin as Hguard'; inversion Hguard'; auto; subst; subst_find_some; subst; auto

  | [ |- forall id, In id ?ids -> guarded_typ id ?defs ?x ] =>
    intros; solve_guard
  end.

Theorem guarded_id_normalize_same :
  forall t env,
    NoDup (map fst env) ->
    guarded_wf_typ env t ->
    (forall ids,
        (forall id, In id ids -> guarded_typ id env t) ->
        normalize_type (remove_keys Ident.eq_dec ids env) t = normalize_type env t).
Proof.
  intros t env Hdup Hwf.
  induction Hwf; intros ids Hguard;
    rewrite normalize_type_equation; symmetry; rewrite normalize_type_equation; simpl; auto;
      try rewrite IHHwf; auto;
        try match goal with
            | [H : element_typ _ |- _] => inversion H
            end;
        try (rewrite map_rewrite with (f:=normalize_type (remove_keys _ _ _)) (g:=normalize_type defs);
             try exact (TYPE_Void);
             auto; intros;
             match goal with
             | [ H: _ |- _ ] => apply H
             end;
             auto);
        try (intros id Hidin; solve_guard).

  (* Identifiers *)
  repeat simpl_remove_keys.

  (* If id is in ids, this means that guarded_typ id defs
     (TYPE_Identified id), which is a contradiction. *)
  assert (~ In id ids) as Hnotin by solve_guard.

  replace (find (fun a : ident * typ => Ident.eq_dec id (fst a)) (remove_keys Ident.eq_dec ids defs)) with
      (find (fun a : ident * typ => Ident.eq_dec id (fst a)) defs) by (auto using remove_keys_find).

  destruct (find (fun a : ident * typ => Ident.eq_dec id (fst a)) defs) eqn:Hfind; auto.
  destruct_prod. simpl.

  assert (In (id, t) defs).
  apply find_some in Hfind as [Hin Hfind].
  simpl in Hfind.

  destruct (Ident.eq_dec id i) eqn:Hidi; subst; intuition.

  repeat (simpl_remove_keys;
          repeat match goal with
                 | [ H: _ |- _ ] => rewrite H
                 end; auto); intros id0 [Hidid0 | Hin']; subst; auto.

  - inversion Hin'.
  - pose proof (Hguard id0 Hin') as Hguard'. inversion Hguard'; subst_find_some; subst; auto.
Qed.

Theorem double_map_In :
  forall A B C (l : list A) (f : A -> B) (g : B -> C),
    (map_In (map_In l (fun x (_ : In x l) => f x)) (fun x (_ : In x (map_In l (fun x (_ : In x l) => f x))) => g x)) = map_In l (fun x (_ : In x l) => g (f x)).
Proof.
  intros A B C l f g.
  induction l; simpl; auto using f_equal.
Qed.

Ltac solve_map_in :=
  repeat
    match goal with
    | [  |- context[map_In (map_In _ _)] ] => rewrite double_map_In
    | [ defs : list (ident * typ) |- _ ] =>
      try (rewrite map_rewrite with (f:=fun x => normalize_type defs (normalize_type defs x)) (g:=normalize_type defs); [> eauto | exact TYPE_Void | eauto]);
      try solve [intros;
                 match goal with
                 | [ H: _ |- _ ] => apply H
                 end; auto; solve_guard]

  end.

Ltac solve_match_find :=
  match goal with
  | [ |- context[match ?Find with _ => _ end = _] ] =>
    let i := fresh in
    let t := fresh in
    let Hfind := fresh in
    destruct Find as [[i t] |] eqn:Hfind;
    match goal with
    | [ Hf: context[find (fun a => proj_sumbool (?eq ?id (fst a))) ?defs],
            defs : list (ident * typ) |- _ ] =>
      try (assert (In (id, t) defs) by solve_in;
           symmetry; simpl_remove_keys;
           rewrite guarded_id_normalize_same; auto using wf_typ_is_guarded_wf_typ; try solve_guard;

           try (match goal with
                | [ H: _ |- _ ] => apply H
                end; auto; solve_guard));
      try (rewrite normalize_type_equation; simpl; rewrite Hfind; reflexivity)
    end
  end.

Theorem guarded_normalize_same :
  forall t env,
    NoDup (map fst env) ->
    guarded_wf_typ env t ->
    (forall ids,
        (forall id, In id ids -> guarded_typ id env t) ->
        normalize_type env (normalize_type env t) = normalize_type env t).
Proof.
  intros t env Hdup Hwf ids Hguard_all.
  induction Hwf;
    try solve [rewrite normalize_type_equation; symmetry; rewrite normalize_type_equation;
               simpl; auto;
               try rewrite IHHwf; auto; try solve_guard; solve_map_in].

  symmetry; rewrite normalize_type_equation; simpl.
  solve_match_find.
Qed.

Lemma wf_typ_guarded_normalize_twice :
  forall env t,
    NoDup (map fst env) ->
    wf_typ env t ->
    (forall ids,
        (forall id, In id ids -> guarded_typ id env t) ->
        normalize_type env (normalize_type env t) = normalize_type env t).
Proof.
  eauto using wf_typ_is_guarded_wf_typ, guarded_normalize_same.
Qed.

Theorem double_normalize_type :
  forall env t,
    wf_env env ->
    wf_typ env t ->
    normalize_type env (normalize_type env t) = normalize_type env t.
Proof.
  intros env t [Hdup Henv] Hwf.
  induction Hwf;
    try solve [rewrite normalize_type_equation; symmetry; rewrite normalize_type_equation;
               simpl; auto;
               try rewrite IHHwf; auto; try solve_guard; solve_map_in].

  symmetry; rewrite normalize_type_equation; simpl.
  solve_match_find.
Qed.

Theorem guarded_normalize_type_unrolls:
  forall env t,
    NoDup (map fst env) ->
    guarded_wf_typ env t ->
    (forall ids,
        (forall id, In id ids -> guarded_typ id env t) ->
        unrolled_typ (normalize_type env t)).
Proof.
  intros env t Hdup Hwf ids Hguard_all.
  induction Hwf; rewrite normalize_type_equation; simpl; auto;
    try constructor;
    try (apply IHHwf; auto; solve_guard);
    try (rewrite Forall_forall; intros;
         match goal with
         | [ H: In ?x (map_In _ _) |- _ ] =>  apply in_map_in in H as [t [Hin Hnorm]]
         end;

         rewrite <- Hnorm;

         match goal with
         | [ H: _ |- _ ] => apply H
         end; auto; solve_guard).
  - destruct (find (fun a : ident * typ => Ident.eq_dec id (fst a)) defs) as [[i t] |] eqn:Hfind.
    + pose proof Hfind as Hfind'.
      apply find_some in Hfind' as [Hin Heq].
      simpl in *. destruct (Ident.eq_dec id i) as [He | He]; inversion Heq.

      rewrite He.
      simpl_remove_keys.
      rewrite guarded_id_normalize_same; auto;
        try match goal with
            | [ H: _ |- _ ] => apply H
            end;
        subst; auto; solve_guard.
    + destruct H as [t Hin].
      eapply find_none in Hfind; eauto.
      simpl in Hfind. destruct (Ident.eq_dec id id).
      inversion Hfind. contradiction.
Qed.

Theorem normalize_type_unrolls:
  forall env t,
    wf_env env ->
    wf_typ env t ->
    unrolled_typ (normalize_type env t).
Proof.
  intros env t [Hdup Henv] Hwf.
  induction Hwf; rewrite normalize_type_equation; simpl; auto;
    try constructor;
    try (apply IHHwf; auto);
    try (rewrite Forall_forall; intros;
         match goal with
         | [ H: In ?x (map_In _ _) |- _ ] =>  apply in_map_in in H as [t [Hin Hnorm]]
         end;

         rewrite <- Hnorm;

         match goal with
         | [ H: _ |- _ ] => apply H
         end; auto; solve_guard).
  - destruct (find (fun a : ident * typ => Ident.eq_dec id (fst a)) defs) as [[i t] |] eqn:Hfind.
    +
      apply find_some in Hfind as [Hin Heq].
      simpl in *. destruct (Ident.eq_dec id i); inversion Heq; subst.

      simpl_remove_keys.

      rewrite guarded_id_normalize_same; auto using wf_typ_is_guarded_wf_typ; solve_guard.
    + destruct H as [t Hin].
      eapply find_none in Hfind; eauto.
      simpl in Hfind. destruct (Ident.eq_dec id id).
      inversion Hfind. contradiction.
Qed.


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

Require Import Coq.Arith.Arith Coq.Vectors.Vector.
Require Import Cava.Arrow.ArrowExport.

Require Import Aes.Pkg Aes.MixSingleColumn.

Import VectorNotations.
Import KappaNotation.
Open Scope kind_scope.

(* module aes_mix_columns (
  input  aes_pkg::ciph_op_e    op_i,
  input  logic [3:0][3:0][7:0] data_i,
  output logic [3:0][3:0][7:0] data_o
); *)
Definition aes_mix_columns
  :
    <<Bit, Vector (Vector (Vector Bit 8) 4) 4, Unit>> ~>
      Vector (Vector (Vector Bit 8) 4) 4 :=
      (* // Transpose to operate on columns
      logic [3:0][3:0][7:0] data_i_transposed;
      logic [3:0][3:0][7:0] data_o_transposed;

      assign data_i_transposed = aes_transpose(data_i);

      // Individually mix columns
      for (genvar i = 0; i < 4; i++) begin : gen_mix_column
        aes_mix_single_column aes_mix_column_i (
          .op_i   ( op_i                 ),
          .data_i ( data_i_transposed[i] ),
          .data_o ( data_o_transposed[i] )
        );
      end

      assign data_o = aes_transpose(data_o_transposed); *)
  <[\op_i data_i =>
    let transposed = !aes_transpose data_i in
    let ouput_transposed = !(map2 aes_mix_single_column) (!replicate op_i) transposed in
    !aes_transpose ouput_transposed
  ]>.