Require Import Axioms.

Require Import sepcomp. Import SepComp.
Require Import semantics.
Require Import semantics_lemmas.
Require Import simulations.

Require Import pos.
Require Import stack.
Require Import cast.
Require Import compcert_linking.
Require Import compcert_threads.
Require Import thread_inv.

Require Import ssreflect ssrbool ssrnat ssrfun eqtype seq fintype finfun.
Set Implicit Arguments.

Require Import AST.    (*for typ*)
Require Import Values. (*for val*)
Require Import Globalenvs.
Require Import Memory.
Require Import Integers.

Require Import ZArith.

Module ThreadsSimulate. Section ThreadsSimulate.

Import SM_simulation.

Variables semS semT : Modsem.t.

Variable pS : ThreadPool.t semS.

Variable pT : ThreadPool.t semT.

Import ThreadPool.

Import SM_simulation.

Notation SIM semS semT geS geT := (SM_simulation_inject semS semT geS geT).

Variable sim :
  SIM (Modsem.sem semS) (Modsem.sem semT) (Modsem.ge semS) (Modsem.ge semT).

Variable schedule : nat -> nat.

Variables aggelosS : nat -> PermMap.t.

Lemma threads_safe Z Espec mu c m d tm (z : Z) :
  @ThreadInv.t semS semT c d sim mu m tm ->
  (forall n, safeN (@Concur.semantics semS aggelosS schedule) Espec
               (Modsem.ge semS) n z c m) ->
  (forall n,
   exists aggelosT : nat -> PermMap.t,
     safeN (@Concur.semantics semT aggelosT schedule) Espec
               (Modsem.ge semT) n z d tm).
Proof.
move=> INV SAFE n; move: mu c m d tm z INV SAFE; elim: n.
{ by move=> /= ??????; exists (fun _ => aggelosS 0).
}
{ move=> n IH mu c m d tm z INV SAFE /=.
  move: (SAFE)=> SAFE0.
  move: (SAFE (S n))=> /=.
  case atS : (Concur.at_external _ c)=> [[[ef sg] argsS]|].
  { admit. (*TODO*) }
  { have ->: Concur.at_external schedule d = None.
    { admit. }
    case=> c' []m' []STEP SAFE'.
    inversion STEP; subst.
    { (*step0*)
      move: H0=> step0; move: H=> getS.
      have [U estep0]:
        exists U, effstepN (Modsem.sem semS) (Modsem.ge semS) n0.+1 U
                           c0 m c'0 m'.
      { admit. }
      case: (ThreadInv.krun_inv INV (Ordinal tid0_lt_pf) getS).
      move=> d0 []getT []cd MATCH.
      have [d'0 [tm' [n1 [T [mu' [tstep0 [tcant MATCH']]]]]]]:
        exists d'0 tm' n1 T mu',
          effstepN (Modsem.sem semT) (Modsem.ge semT) n1.+1 T
                   d0 tm d'0 tm'
          /\ cant_step (Modsem.sem semT) d'0
          /\ match_state sim cd mu' c'0 m' d'0 tm'.
      { admit. }
      set (c' := updThread c
                 (Ordinal (n:=num_threads c) (m:=schedule (counter c)) tid0_lt_pf)
                 (Krun c'0)).
      have tid0_lt_pf' : schedule (counter d) < num_threads d.
      { admit. }
      set (d' := updThread d
                 (Ordinal (n:=num_threads d) (m:=schedule (counter d)) tid0_lt_pf')
                 (Krun d'0)).
      have INV': ThreadInv.t c' d' sim mu' m' tm'.
      { admit. }
      have SAFE0': forall n : nat,
        safeN (Concur.semantics aggelosS schedule) Espec (Modsem.ge semS) n z c' m'.
      { admit. }
      case: (IH mu' c' m' d' tm' z INV' SAFE0')=> aggelosT TSAFE.
      exists aggelosT, d', tm'; split; last by [].
      apply Concur.step_congr with d0 n1=> //.
      { admit. (*dependent types*) }
      { by apply: effstepN_corestepN. }
    }
    {
      set (c' := schedNext (updThread c
                  (Ordinal (n:=num_threads c) (m:=schedule (counter c))
                     tid0_lt_pf) (Kstage ef args c0))) in *.
      case: (ThreadInv.krun_inv INV _ H)=> d0 []H' []cd MATCH.
      case: (core_at_external sim cd mu _ _ _ _ MATCH H0)=> inj []args2.
      case=> hfor []at2 H2.
      have tid1_lt_pf: schedule (counter d) < num_threads d.
      { admit. }
      set (d' := schedNext (updThread d
                  (Ordinal (n:=num_threads d) (m:=schedule (counter d))
                     tid1_lt_pf) (Kstage ef args2 d0))) in *.
      set (pubSrc' :=
             (fun b : block =>
                locBlocksSrc mu b && REACH m' (exportedSrc mu args) b)) in *.
      set (pubTgt' :=
             (fun b : block =>
                   locBlocksTgt mu b && REACH tm (exportedTgt mu args2) b)) in *.
      set (nu := replace_locals mu pubSrc' pubTgt').
      case: (H2 pubSrc' pubTgt' erefl erefl nu erefl)=> MATCH' INJ'.
      have INV': ThreadInv.t c' d' sim nu m' tm.
      { admit. }
      have SAFE'': (forall n0 : nat,
                      safeN (Concur.semantics aggelosS schedule) Espec
                            (Modsem.ge semS) n0 z c' m').
      { admit. }
      case: (IH _ _ _ _ _ _ INV' SAFE'')=> aggelosT TSAFE.
      exists aggelosT, d', tm; split=> //.
      apply: Concur.step_stage=> //.
      move: H'. admit. (*dependent type stuff*)
    }
    {
      set (c' := updThread c
                  (Ordinal (n:=num_threads c) (m:=schedule (counter c))
                     tid0_lt_pf) (Krun c'0)) in *.
      case: (ThreadInv.kstage_inv INV _ H)=> d0 []argsT []H' []vinj []at2 []cd MATCH.
      have [b' [delta [inj vinj']]]:
        exists b' delta,
          as_inj mu b = Some (b', delta)
          /\ argsT = [:: Vptr b' (Int.add ofs (Int.repr delta))].
      { admit. }
      rewrite vinj' in H'; move {vinj vinj' argsT}.
      have tid0'_lt_pf: schedule (counter d) < num_threads d.
      { admit. }
      have [d'0 H2']:
        exists d'0,
          after_external (Modsem.sem semT) (Some (Vint Int.zero)) d0 = Some d'0.
      { admit. }
      set (d' := updThread d
                   (Ordinal (n:=num_threads d) (m:=schedule (counter d))
                      tid0'_lt_pf) (Krun d'0)) in *.
      have H0':
        Mem.load Mint32 tm b' (Int.intval (Int.add ofs (Int.repr delta)))
          = Some (Vint Int.one).
      { admit. }
      have [tm'' H1']:
        exists tm'',
          Mem.store Mint32 tm b' (Int.intval (Int.add ofs (Int.repr delta))) (Vint Int.zero)
            = Some tm''.
      { admit. }
      set (pubSrc' :=
             (fun b : block =>
                locBlocksSrc mu b && REACH m' (exportedSrc mu [:: Vptr b ofs]) b)) in *.
      set (pubTgt' :=
             (fun b : block =>
                locBlocksTgt mu b
                && REACH tm
                   (exportedTgt mu [:: Vptr b' (Int.add ofs (Int.repr delta))]) b)) in *.
      set (nu := replace_locals mu pubSrc' pubTgt').
      have [mu' [tm' [pm [H3' inj']]]]:
        exists mu' tm' pm,
          updPermMap tm'' pm = Some tm'
          /\ Mem.inject (as_inj mu') m' tm'.
      { admit. }
      have INV': ThreadInv.t c' d' sim mu' m' tm'.
      { admit. }
      have SAFE'': (forall n0 : nat,
                      safeN (Concur.semantics aggelosS schedule) Espec
                            (Modsem.ge semS) n0 z c' m').
      { admit. }
      case: (IH _ _ _ _ _ _ INV' SAFE'')=> aggelosT TSAFE'.
      set (aggelosT' := fun n => if eq_nat_dec n (counter d) then pm else aggelosT n).
      exists aggelosT', d', tm'; split=> //.
      eapply Concur.step_lock; eauto.
      { admit. (*dependent types stuff*) }
      { by rewrite /aggelosT'; case: (eq_nat_dec _ _). }
      { clear - TSAFE'; rewrite /aggelosT'.
        admit. (*by [counter d' = counter d.+1] and an aux. lemma about
                 safety in concurrent machine, namely:
                  if two angels [x] and [y] are equal at positions [counter d']
                  and greater, then [d'] is safe in [x] iff safe in [y]. *) }
    }
    { admit. (*UNLOCK, symmetric (?)*) }
    { set (c' :=
        schedNext
          (addThread
             (updThread c
                (Ordinal (n:=num_threads c)
                         (m:= schedule (counter c)) tid0_lt_pf)
                (Krun c'0)) (Krun c_new))) in *.
      case: (ThreadInv.kstage_inv INV _ H)=> d0 []argsT []H' []vinj []at2 []cd MATCH.
      have [vf' [arg' [inj [vinj' vinj'']]]]:
        exists vf' arg',
          argsT = (vf' :: arg' :: nil)
          /\ val_inject (as_inj mu) vf vf'
          /\ val_inject (as_inj mu) arg arg'.
      { admit. }
      rewrite inj in H'; move {inj vinj}.
      have tid0'_lt_pf: schedule (counter d) < num_threads d.
      { admit. }
      have [d'0 H2']:
        exists d'0,
          after_external (Modsem.sem semT) (Some (Vint Int.zero)) d0 = Some d'0.
      { admit. }
      have [d_new H0']:
        exists d_new,
          initial_core (Modsem.sem semT) (Modsem.ge semT) vf' [:: arg']
          = Some d_new.
      { admit. }
      set (d' :=
        schedNext
          (addThread
             (updThread d
                (Ordinal (n:=num_threads d)
                         (m:= schedule (counter d)) tid0'_lt_pf)
                (Krun d'0)) (Krun d_new))) in *.
      have INV': ThreadInv.t c' d' sim mu m' tm.
      { admit. }
      have SAFE'': (forall n0 : nat,
                      safeN (Concur.semantics aggelosS schedule) Espec
                            (Modsem.ge semS) n0 z c' m').
      { admit. }
      case: (IH _ _ _ _ _ _ INV' SAFE'')=> aggelosT TSAFE'.
      exists aggelosT, d', tm; split=> //.
      eapply Concur.step_create; eauto.
      { admit. (*dependent types stuff*) }
    }
  }
}
Qed.

End ThreadsSimulate. End ThreadsSimulate.


Require Import ZArith Int63.
Open Scope uint63.
Require Import coqutil.Map.Interface.
Require Import Tries.Canonical.
Import PTree.

Require Utils.ArrayList Utils.TrieMap.
(*
(* positives consed when they should be appended*)
Fixpoint trie_fold' {B A} (f : A -> positive -> B -> A) (acc : A) (m : PTree.tree' B)
         (*TODO: find a better way*)
         (num : positive -> positive) : A :=
  match m with
  | Node001 r => trie_fold' f acc r (fun a => num (xI a))
  | Node010 y => f acc (num xH) y
  | Node011 y r =>
      let acc := f acc (num xH) y in
      trie_fold' f acc r (fun a => num (xI a))
  | Node100 l => trie_fold' f acc l (fun a => num (xO a))
  | Node101 l r =>
      let acc := trie_fold' f acc r (fun a => num (xI a)) in
      trie_fold' f acc l (fun a => num (xO a))
  | Node110 l y =>
      let acc := f acc (num xH) y in
      trie_fold' f acc l (fun a => num (xO a))
  | Node111 l y r =>
      let acc := f acc (num xH) y in
      let acc := trie_fold' f acc r (fun a => num (xI a)) in
      trie_fold' f acc l (fun a => num (xO a))
end.

Definition trie_fold {B A} (f : A -> positive -> B -> A) (acc : A) (m : PTree.t B) : A :=
  match m with
  | Empty => acc
  | Nodes m' => trie_fold' f acc m' id
  end.

 *)

(** PTree operations reimplemented for i63.
    Note that we can't differentiate between 0 and 000 by default,
    so we trim all leading 0s to avoid making each access have depth 64.
 *)

(* Note: this can be expensive for large numbers, should only be called on small ones.
   Invariant: this file only calls it on numbers <= digits
 *)
Local Definition int_to_nat (i : int) := Z.to_nat (Uint63.to_Z i).

Fixpoint get' {A} (p: int) (m: tree' A) (msb : nat) : option A :=
  let q := lsr p 1 in
  match msb, m, is_zero (Int63.land p 1) with
  | O, Node001 _, _ => None
  | O, Node010 x, _ => Some x
  | O, Node011 x _, _ => Some x
  | O, Node100 _, _ => None
  | O, Node101 _ _, _ => None
  | O, Node110 _ x, _ => Some x
  | O, Node111 _ x _, _ => Some x
  | S msb, Node001 _, true => None
  | S msb, Node010 _, true => None
  | S msb, Node011 _ _, true => None
  | S msb, Node100 m', true => get' q m' msb
  | S msb, Node101 m' _, true => get' q m' msb
  | S msb, Node110 m' _, true => get' q m' msb
  | S msb, Node111 m' _ _, true => get' q m' msb
  | S msb, Node001 m', false => get' q m' msb
  | S msb, Node010 _, false => None
  | S msb, Node011 _ m', false => get' q m' msb
  | S msb, Node100 m', false => None
  | S msb, Node101 _ m', false => get' q m' msb
  | S msb, Node110 _ _, false => None
  | S msb, Node111 _ _ m', false => get' q m' msb
  end.

(* TODO: we always use int_to_nat (msb p). Should we implement that directly?
   It would probably be faster.
 *)
Definition msb i := sub digits (head0 i).

Definition get {A} (m : tree A) (p: int) : option A :=
  match m with
  | Empty => None
  | Nodes m' => get' p m' (int_to_nat (msb p))
  end.

Fixpoint set0 {A} (p: int) (x: A) (msb : nat) : tree' A :=
  let q := lsr p 1 in
  match msb, is_zero (Int63.land p 1) with
  | O, _ => Node010 x
  | S msb, true => Node100 (set0 q x msb)
  | S msb, false => Node001 (set0 q x msb)
  end.

Fixpoint set' {A} (p: int) (x: A) (m: tree' A) (msb : nat) : tree' A :=
  let q := lsr p 1 in
match msb, m, is_zero (Int63.land p 1) with
| O, Node001 r, _ => Node011 x r
| O, Node010 _, _ => Node010 x
| O, Node011 _ r, _ => Node011 x r
| O, Node100 l, _ => Node110 l x
| O, Node101 l r, _ => Node111 l x r
| O, Node110 l _, _ => Node110 l x
| O, Node111 l _ r, _ => Node111 l x r
| S msb, Node001 r, true => Node101 (set0 q x msb) r
| S msb, Node010 y, true => Node110 (set0 q x msb) y
| S msb, Node011 y r, true => Node111 (set0 q x msb) y r
| S msb, Node100 l, true => Node100 (set' q x l msb)
| S msb, Node101 l r, true => Node101 (set' q x l msb) r
| S msb, Node110 l y, true => Node110 (set' q x l msb) y
| S msb, Node111 l y r, true => Node111 (set' q x l msb) y r
| S msb, Node001 r, false => Node001 (set' q x r msb)
| S msb, Node010 y, false => Node011 y (set0 q x msb)
| S msb, Node011 y r, false => Node011 y (set' q x r msb)
| S msb, Node100 l, false => Node101 l (set0 q x msb)
| S msb, Node101 l r, false => Node101 l (set' q x r msb)
| S msb, Node110 l y, false => Node111 l y (set0 q x msb)
| S msb, Node111 l y r, false => Node111 l y (set' q x r msb)
end.

Definition set {A} (m: tree A) (p: int) (x: A) : tree A :=
match m with
| Empty => Nodes (set0 p x (int_to_nat (msb p)))
| Nodes m' => Nodes (set' p x m' (int_to_nat (msb p)))
end.

Fixpoint rem' {A} (p: int) (m: tree' A) (msb : nat) : tree A :=
  let q := lsr p 1 in
  match msb, m, is_zero (Int63.land p 1) with
  | O, Node001 r,_ => Nodes m
  | O, Node010 _,_ => Empty
  | O, Node011 _ r,_ => Nodes (Node001 r)
  | O, Node100 l,_ => Nodes m
  | O, Node101 l r,_ => Nodes m
  | O, Node110 l _,_ => Nodes (Node100 l)
  | O, Node111 l _ r,_ => Nodes (Node101 l r)
  | S msb, Node001 r, true => Nodes m
  | S msb, Node010 y, true => Nodes m
  | S msb, Node011 y r, true => Nodes m
  | S msb, Node100 l, true => Node (rem' q l msb) None Empty
  | S msb, Node101 l r, true => Node (rem' q l msb) None (Nodes r)
  | S msb, Node110 l y, true => Node (rem' q l msb) (Some y) Empty
  | S msb, Node111 l y r, true => Node (rem' q l msb) (Some y) (Nodes r)
  | S msb, Node001 r, false => Node Empty None (rem' q r msb)
  | S msb, Node010 y, false => Nodes m
  | S msb, Node011 y r, false => Node Empty (Some y) (rem' q r msb)
  | S msb, Node100 l, false => Nodes m
  | S msb, Node101 l r, false => Node (Nodes l) None (rem' q r msb)
  | S msb, Node110 l y, false => Nodes m
  | S msb, Node111 l y r, false => Node (Nodes l) (Some y) (rem' q r msb)
  end.

(** This use of [Node] causes some run-time overhead, which we eliminate
    by asking Coq to unfold the definition of [Node] in [rem'],
    then simplify the definition.  This is a form of partial evaluation. *)

Definition remove' := Eval cbv [rem' Node] in @rem'.

Definition remove {A} (m: tree A)  (p: int) : tree A :=
match m with
| Empty => Empty
| Nodes m' => remove' _ p m' (int_to_nat (msb p))
end.

(*
Fixpoint msb' (fuel : nat) (i : int) : nat * int :=
  match fuel with
  (* Should never happen? *)
  | 0 => (O, 0)
  | S fuel =>
      let i' := i >> 1 in
      if is_zero i'
      then (O,0)
      else
        let (n,i) := msb' fuel i' in
        (S n, i + 1)
  end.

Definition msb := msb' size.

(* Note: this should not be used outside this module.
   It does not represent an principled transformation.
 (* Note: assumes the input is nonnegative, in which case the function is bijective *)
 *)
Local Definition to_pos (i:int) : positive :=
  (*adding 1 to make sure that 0 gets mapped to a positive. *)
  match to_Z (i + 1) with
  | Zpos p => p
  (*should never happen*)
  | _ => xH
  end.
(*
  TODO: this is a very poor implementation of fold, improve
 *)*)

Section __.

  Context (value : Type).

  Section Fold.
    Context {R : Type} (f : R -> int -> value -> R).

    Fixpoint fold' (acc : R) (m : tree' value) (i : int) : R :=
      (*0 bit ~> left
        1 bit ~> right
       *)
      let i'_l := lsr i 1 in
      let i'_r := Int63.lor i'_l 1 in
      match m with
      | Node001 r => fold' acc r i'_r
      | Node010 v => f acc i v
      | Node011 v r => fold' (f acc i v) r i'_r
      | Node100 l => fold' acc l i'_l
      | Node101 l r => fold' (fold' acc r i'_r) l i'_l
      | Node110 l v => fold' (f acc i v) l i'_l
      | Node111 l v r => fold' (fold' (f acc i v) r i'_r) l i'_l
      end.

    Definition fold (acc : R) (m : tree value) : R :=
      match m with
      | Empty => acc
      | Nodes m' => fold' acc m' 0
      end.

  End Fold.

  Instance map : map.map int value :=
    {|
      map.rep := PTree.t value;
      map.empty := PTree.empty value;
      map.get := get;
      map.put := set;
      map.remove := remove;
      map.fold := @fold;
    |}.

  (* TODO: prove map.ok *)
End __.


(*

  Copyright 2014 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

  VPrl is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  VPrl is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with VPrl.  If not, see <http://www.gnu.org/licenses/>.

  Website: http://nuprl.org/html/verification/
  Authors: Abhishek Anand & Vincent Rahli

*)

Require Export type_sys_useful.
Require Import dest_close.

Lemma close_type_system_isect {p} :
  forall lib (ts : cts(p))
         T T'
         (eq : per)
         A A' v v' B B' eqa eqb,
    type_system lib ts
    -> defines_only_universes lib ts
    -> computes_to_valc lib T (mkc_isect A v B)
    -> computes_to_valc lib T' (mkc_isect A' v' B')
    -> close lib ts A A' eqa
    -> (forall (a a' : CTerm) (e : eqa a a'),
          close lib ts (substc a v B) (substc a' v' B') (eqb a a' e))
    -> (forall (a a' : CTerm) (e : eqa a a'),
          type_system lib ts ->
          defines_only_universes lib ts ->
          type_sys_props lib (close lib ts) (substc a v B) (substc a' v' B')
                         (eqb a a' e))
    -> (forall t t' : CTerm,
          eq t t' <=> (forall (a a' : CTerm) (e : eqa a a'), eqb a a' e t t'))
    -> per_isect lib (close lib ts) T T' eq
    -> type_sys_props lib (close lib ts) A A' eqa
    -> type_sys_props lib (close lib ts) T T' eq.
Proof.
  introv X X0 c1 c2 X1 clb recb eqiff per IHX1.

  rw @type_sys_props_iff_type_sys_props3.
  prove_type_sys_props3 SCase; intros.

  + SCase "uniquely_valued".
    dclose_lr.

    SSCase "CL_isect".
    allunfold @per_isect; exrepd.
    generalize (eq_term_equals_type_family lib T T3 eqa0 eqa eqb0 eqb (close lib ts) A v B A' v' B' mkc_isect); intro i.
    repeat (autodimp i hyp; try (complete (introv e; eqconstr e; sp))); repnd.

    unfold eq_term_equals; sp.
    rw t0; rw eqiff; split; sp.

    duplicate e as e'; rw <- i0 in e.
    generalize (i1 a a' e' e); intro k.
    rw k; sp.

    duplicate e as e'; rw i0 in e.
    generalize (i1 a a' e e'); intro k.
    rw <- k; sp.

  + SCase "type_symmetric"; repdors; subst; dclose_lr;
    apply CL_isect;
    clear per;
    allunfold @per_isect; exrepd;
    unfold per_isect;
    exists eqa0 eqb0; sp;
    allrw <-; sp.

  + SCase "type_value_respecting"; repdors; subst;
    apply CL_isect; unfold per_isect; exists eqa eqb; sp.

    duplicate c1 as ct.
    apply @cequivc_mkc_isect with (T' := T3) in ct; sp.

    apply @type_family_cequivc
          with
          (A1 := A)
          (v1 := v)
          (B1 := B)
          (A2 := A'0)
          (v2 := v'0)
          (B2 := B'0)
          (A := A')
          (v := v')
          (B := B'); sp.

    duplicate c2 as ct.
    apply @cequivc_mkc_isect with (T' := T3) in ct; sp.

    apply @type_family_cequivc2
          with
          (A1 := A')
          (v1 := v')
          (B1 := B')
          (A2 := A'0)
          (v2 := v'0)
          (B2 := B'0)
          (A := A)
          (v := v)
          (B := B); sp.

  + SCase "term_symmetric".
    unfold term_equality_symmetric; sp.
    onedtsp e pp p0 p1 c t t0 t3 tygs tygt dum.
    apply eqiff; sp.
    assert (eqa a a) as eqaa by (apply t0 with (t2 := a'); auto).
    assert (eqa a' a) as e' by auto.
    assert (eq t1 t2) as eq12 by auto.
    apply eqiff with (a := a') (a' := a) (e := e') in eq12; auto.

    generalize (eq_term_equals_sym_tsp lib (close lib ts) eqa eqb a a' eqaa e0 e'
                                       v B v' B'); intro i.
    autodimp i h; repnd.

    (* Now we prove the equality between the applies *)
    unfold eq_term_equals in i.
    apply i in eq12.
    generalize (recb a a' e0); sp.
    onedtsp X5 X6 X7 X8 X9 X10 X11 X4 tygs1 tygt1 dum1; sp.

  + SCase "term_transitive".
    unfold term_equality_transitive; sp.
    apply eqiff; sp.
    assert (eq t1 t2) as eq12 by auto.
    assert (eq t2 t3) as eq23 by auto.
    apply eqiff with (a := a) (a' := a') (e := e) in eq12; auto.
    apply eqiff with (a := a) (a' := a') (e := e) in eq23; auto.

    onedtsp IHX0 IHX2 IHX3 IHX4 IHX5 IHX6 IHX7 IHX8 tygs tygt dum.

    generalize (recb a a' e); intro tsp.
    unfold type_sys_props in tsp; sp.
    apply tsp6 with (t2 := t2); auto.

  + SCase "term_value_respecting".
    unfold term_equality_respecting; sp.
    apply eqiff; sp.
    assert (eq t t) as eqtt by auto.
    apply eqiff with (a := a) (a' := a') (e := e) in eqtt; auto.

    generalize (recb a a' e); sp.
    onedtsp X5 X6 X7 X8 X9 X10 X11 X4 tygs1 tygt1 dum1; sp.

  + SCase "type_gsymmetric"; repdors; subst; split; sp; dclose_lr;
    apply CL_isect;
    clear per;
    allunfold @per_isect; exrepd.

    (* 1 *)
    generalize (eq_term_equals_type_family
                  lib T T3 eqa0 eqa eqb0 eqb (close lib ts)
                  A v B A' v' B' mkc_isect); intro i.
    repeat (autodimp i hyp; try (complete (introv e; eqconstr e; sp))).
    repnd.

    unfold per_isect.
    exists eqa eqb; sp.

    rw t0; split; intro k; sp.

    duplicate e as e'.
    rw i0 in e.
    generalize (k a a' e); intro j.
    generalize (i1 a a' e e'); intro eqt.
    rw eqt in j; sp.

    duplicate e as e'.
    rw <- i0 in e.
    generalize (k a a' e); intro j.
    generalize (i1 a a' e' e); intro eqt.
    rw <- eqt in j; sp.

    (* 2 *)
    generalize (eq_term_equals_type_family2
                  lib T3 T eqa0 eqa eqb0 eqb (close lib ts)
                  A v B A' v' B' mkc_isect); intro i;
    repeat (autodimp i hyp; try (complete (introv e; eqconstr e; sp)));
    repnd.

    unfold per_isect.
    exists eqa eqb; sp.

    rw t0; split; intro k; sp.

    duplicate e as e'.
    rw i0 in e.
    generalize (k a a' e); intro j.
    generalize (i1 a a' e e'); intro eqt.
    rw eqt in j; sp.

    duplicate e as e'.
    rw <- i0 in e.
    generalize (k a a' e); intro j.
    generalize (i1 a a' e' e); intro eqt.
    rw <- eqt in j; sp.

  + SCase "type_gtransitive"; sp.

  + SCase "type_mtransitive".
    repdors; subst; dclose_lr;
    try (move_term_to_top (per_isect lib (close lib ts) T T4 eq2));
    try (move_term_to_top (per_isect lib (close lib ts) T' T4 eq2)).

    (* 1 *)
    clear per.
    allunfold @per_isect; exrepd.

    generalize (eq_term_equals_type_family2
                  lib T3 T eqa1 eqa eqb1 eqb (close lib ts)
                  A v B A' v' B' mkc_isect); intro i.
    repeat (autodimp i hyp; try (complete (introv e; eqconstr e; sp))).
    repnd.

    generalize (type_family_trans2
                  lib mkc_isect (close lib ts) T3 T T4 eqa eqb eqa0 eqb0 A v B A' v' B'); intro j.
    repeat (autodimp j hyp; try (complete (introv e; eqconstr e; sp))).
    repnd.

    dands; apply CL_isect; unfold per_isect; exists eqa eqb; sp; allrw.

    split; intro pp; sp.

    assert (eqa1 a a') as e' by (rw <- i0; auto).
    generalize (pp a a' e'); intro k.
    generalize (i1 a a' e' e); intro l.
    rw <- l; sp.

    assert (eqa a a') as e' by (rw i0; auto).
    generalize (pp a a' e'); intro k.
    generalize (i1 a a' e e'); intro l.
    rw l; sp.

    split; intro pp; sp.

    assert (eqa0 a a') as e' by (rw <- j0; auto).
    generalize (pp a a' e'); intro k.
    generalize (j1 a a' e e'); intro l.
    rw l; sp.

    assert (eqa a a') as e' by (rw j0; auto).
    generalize (pp a a' e'); intro k.
    generalize (j1 a a' e' e); intro l.
    rw <- l; sp.

    (* 2 *)
    clear per.
    allunfold @per_isect; exrepd.

    generalize (eq_term_equals_type_family2
                  lib T3 T' eqa1 eqa eqb1 eqb (close lib ts)
                  A' v' B' A v B mkc_isect); intro i.
    repeat (autodimp i hyp;
            try (complete (introv e; eqconstr e; sp));
            try (complete (apply type_sys_props_sym; sp))).
    onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt dum.
    intros.
    apply type_sys_props_sym.
    apply type_sys_props_eqb_comm; sp.
    apply tet with (t2 := a'); sp.
    apply tet with (t2 := a); sp.
    repnd.

    generalize (type_family_trans2
                  lib mkc_isect (close lib ts) T3 T' T4 eqa eqb eqa0 eqb0 A' v' B' A v B); intro j.
    repeat (autodimp j hyp;
            try (complete (introv e; eqconstr e; sp));
            try (complete (apply type_sys_props_sym; sp))).
    onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt dum.
    intros.
    apply type_sys_props_sym.
    apply type_sys_props_eqb_comm; sp.
    apply tet with (t2 := a'); sp.
    apply tet with (t2 := a); sp.
    repnd.

    dands; apply CL_isect; unfold per_isect; exists eqa eqb; sp; allrw.

    split; intro pp; sp.

    assert (eqa1 a a') as e' by (rw <- i0; auto).
    generalize (pp a a' e'); intro k.
    generalize (i1 a a' e' e); intro l.
    rw <- l; sp.

    assert (eqa a a') as e' by (rw i0; auto).
    generalize (pp a a' e'); intro k.
    generalize (i1 a a' e e'); intro l.
    rw l; sp.

    split; intro pp; sp.

    assert (eqa0 a a') as e' by (rw <- j0; auto).
    generalize (pp a a' e'); intro k.
    generalize (j1 a a' e e'); intro l.
    rw l; sp.

    assert (eqa a a') as e' by (rw j0; auto).
    generalize (pp a a' e'); intro k.
    generalize (j1 a a' e' e); intro l.
    rw <- l; sp.
Qed.


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

(***
Modulus : 2^384 - 317
Base: 21 + 1/3
***)

Definition curve : CurveParameters :=
  {|
    sz := 18%nat;
    base := 21 + 1/3;
    bitwidth := 32;
    s := 2^384;
    c := [(1, 317)];
    carry_chains := Some [seq 0 (pred 18); [0; 1]]%nat;

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

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

    mul_code := None;

    square_code := None;

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

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


From Coq Require Import Arith ZArith.
From mathcomp Require Import ssreflect ssrbool ssrnat seq eqtype div.
From Common Require Import Tactics Arch Types SsrOrdered Bits Lists FSets Bools Nats ZAriths Var Store.
From mQhasm Require Import zDSL bvDSL.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Notation wordsize := AMD64.wordsize.

Opaque wordsize.

(** Convert instructions and programs. *)

Definition bv2z_atomic (a : atomic) : zDSL.exp :=
  match a with
  | bvVar v => zDSL.zVar v
  | bvConst c => zConst (toPosZ c)
  end.

Definition bv2z_instr (i : instr) : seq zDSL.instr :=
  match i with
  | bvAssign v a => [:: zAssign v (bv2z_atomic a)]
(*  | bvNeg v a => [:: zAssign v (zUnop zNeg (bv2z_atomic a))] *)
  | bvAdd v a1 a2 => [:: zAssign v (zadd (bv2z_atomic a1) (bv2z_atomic a2))]
  | bvAddC c v a1 a2 =>
    [:: zSplit c v (zadd (bv2z_atomic a1) (bv2z_atomic a2)) wordsize]
  | bvAdc v a1 a2 y =>
    [:: zAssign v (zadd (zadd (bv2z_atomic a1) (bv2z_atomic a2)) (zVar y))]
  | bvAdcC c v a1 a2 y =>
    [:: zSplit c v (zadd (zadd (bv2z_atomic a1) (bv2z_atomic a2)) (zVar y)) wordsize]
  | bvSub v a1 a2 => [:: zAssign v (zsub (bv2z_atomic a1) (bv2z_atomic a2))]
  | bvSubC c v a1 a2 =>
    [:: zSplit c v
        (zsub (bv2z_atomic a1) (bv2z_atomic a2)) wordsize;
       zAssign c (zneg (zVar c))]
  | bvSbb v a1 a2 y =>
    [:: zAssign v (zsub (zsub (bv2z_atomic a1) (bv2z_atomic a2)) (zVar y))]
  | bvSbbC c v a1 a2 y =>
    [:: zSplit c v
        (zsub (zsub (bv2z_atomic a1) (bv2z_atomic a2)) (zVar y)) wordsize;
       zAssign c (zneg (zVar c))]
  | bvMul v a1 a2 => [:: zAssign v (zmul (bv2z_atomic a1) (bv2z_atomic a2))]
  | bvMulf vh vl a1 a2 =>
    [:: zSplit vh vl (zmul (bv2z_atomic a1) (bv2z_atomic a2)) wordsize]
  | bvShl v a n => [:: zAssign v (zmul2p (bv2z_atomic a) (toNat n))]
  | bvSplit vh vl a n => [:: zSplit vh vl (bv2z_atomic a) (toNat n)]
  | bvConcatShl vh vl a1 a2 n =>
    [:: zSplit vh vl
        (zadd (zmul2p (bv2z_atomic a1) wordsize) (bv2z_atomic a2))
        (wordsize - (toNat n))]
  end.

Fixpoint bv2z_program (p : program) : zDSL.program :=
  match p with
  | [::] => [::]
  | hd::tl => (bv2z_instr hd) ++ (bv2z_program tl)
  end.

Definition addB_safe w (bv1 bv2 : BITS w) : bool :=
  ~~ carry_addB bv1 bv2.

Definition adcB_safe w (bv1 bv2 c : BITS w) : bool :=
  ~~ carry_addB bv1 bv2 && ~~ carry_addB (addB bv1 bv2) c.

Definition subB_safe w (bv1 bv2 : BITS w) : bool :=
  ~~ carry_subB bv1 bv2.

Definition sbbB_safe w (bv1 bv2 c : BITS w) : bool :=
  ~~ carry_subB bv1 bv2 && ~~ carry_subB (subB bv1 bv2) c.

Definition mulB_safe w (bv1 bv2 : BITS w) : bool :=
  high w (fullmulB bv1 bv2) == fromNat 0.

Definition shlBn_safe w (bv : BITS w) n : bool :=
  ltB bv (shlBn (@fromNat w 1) (w - n)).

Definition concatshl_safe w (bv : BITS w) n : bool :=
  (n <= w) && ltB bv (shlBn (@fromNat w 1) (w - n)).

Definition bv2z_instr_safe_at (i : instr) (s : bv64DSL.State.t) : bool :=
  match i with
  | bvAssign _ _ => true
(*  | bvNeg _ _ => true *)
  | bvAdd _ a1 a2 => addB_safe (eval_atomic a1 s) (eval_atomic a2 s)
  | bvAddC _ _ _ _ => true
  | bvAdc _ a1 a2 c => adcB_safe (eval_atomic a1 s) (eval_atomic a2 s)
                                 (bv64DSL.State.acc c s)
  | bvAdcC _ _ _ _ _ => true
  | bvSub _ a1 a2 => subB_safe (eval_atomic a1 s) (eval_atomic a2 s)
  | bvSubC _ _ _ _ => true
  | bvSbb _ a1 a2 y => sbbB_safe (eval_atomic a1 s) (eval_atomic a2 s)
                                 (bv64DSL.State.acc y s)
  | bvSbbC _ _ _ _ _ => true
  | bvMul _ a1 a2 => mulB_safe (eval_atomic a1 s) (eval_atomic a2 s)
  | bvMulf _ _ _ _ => true
  | bvShl _ a n => shlBn_safe (eval_atomic a s) (toNat n)
  | bvSplit _ _ _ _ => true
  | bvConcatShl _ _ a1 a2 n => concatshl_safe (eval_atomic a1 s) (toNat n)
  end.

Fixpoint bv2z_program_safe_at p s : bool :=
  match p with
  | [::] => true
  | hd::tl => bv2z_instr_safe_at hd s && bv2z_program_safe_at tl (eval_instr s hd)
  end.

Definition bv2z_program_safe p : Prop :=
  forall s, bv2z_program_safe_at p s.

(** State equivalence. *)

Definition bvz_eq (sb : State.t) (sz : zDSL.State.t) : Prop :=
  forall x, toPosZ (State.acc x sb) = zDSL.State.acc x sz.

Lemma bvz_eq_upd v bv zv sb sz :
  bvz_eq sb sz ->
  toPosZ bv = zv ->
  bvz_eq (State.upd v bv sb) (zDSL.State.upd v zv sz).
Proof.
  move=> Heq Hbv x.
  case Hxv: (x == v).
  - rewrite (State.acc_upd_eq _ _ Hxv) (zDSL.State.acc_upd_eq _ _ Hxv).
    exact: Hbv.
  - move/idP/negP: Hxv => Hxv.
    rewrite (State.acc_upd_neq _ _ Hxv) (zDSL.State.acc_upd_neq _ _ Hxv).
    exact: Heq.
Qed.

Lemma bvz_eq_upd2 vh vl bvh bvl zvh zvl sb sz :
  bvz_eq sb sz ->
  toPosZ bvh = zvh ->
  toPosZ bvl = zvl ->
  bvz_eq (State.upd2 vh bvh vl bvl sb) (zDSL.State.upd2 vh zvh vl zvl sz).
Proof.
  move=> Heq Hbvh Hbvl x.
  case Hxvl: (x == vl).
  - rewrite (State.acc_upd_eq _ _ Hxvl) (zDSL.State.acc_upd_eq _ _ Hxvl).
    exact: Hbvl.
  - move/idP/negP: Hxvl => Hxvl.
    rewrite (State.acc_upd_neq _ _ Hxvl) (zDSL.State.acc_upd_neq _ _ Hxvl).
    case Hxvh: (x == vh).
    + rewrite (State.acc_upd_eq _ _ Hxvh) (zDSL.State.acc_upd_eq _ _ Hxvh).
      exact: Hbvh.
    + move/idP/negP: Hxvh => Hxvh.
      rewrite (State.acc_upd_neq _ _ Hxvh) (zDSL.State.acc_upd_neq _ _ Hxvh).
      exact: Heq.
Qed.

Lemma bvz_eq_upd2_aux c v bvc bvv zvc zvv zvt sb sz :
  bvz_eq sb sz ->
  toPosZ bvc = zvc ->
  toPosZ bvv = zvv ->
  bvz_eq (State.upd2 v bvv c bvc sb)
         (zDSL.State.upd c
                         zvc
                         (zDSL.State.upd2 v zvv c zvt sz)).
Proof.
  move=> Heq Hc Hv x.
  case Hxc: (x == c).
  - rewrite (zDSL.State.acc_upd_eq _ _ Hxc) (State.acc_upd2_eq2 _ _ _ _ Hxc).
    exact: Hc.
  - move/idP/negP: Hxc => Hxc. rewrite (zDSL.State.acc_upd_neq _ _ Hxc).
    case Hxv: (x == v).
    + rewrite (State.acc_upd2_eq1 _ _ _ Hxv Hxc).
      rewrite (zDSL.State.acc_upd2_eq1 _ _ _ Hxv Hxc). exact: Hv.
    + move/idP/negP: Hxv => Hxv.
      rewrite (State.acc_upd2_neq _ _ _ Hxv Hxc).
      rewrite (zDSL.State.acc_upd2_neq _ _ _ Hxv Hxc).
      exact: (Heq x).
Qed.

(** Properties of program conversion. *)

Lemma bvz_eq_eval_atomic a sb sz :
  bvz_eq sb sz ->
  toPosZ (eval_atomic a sb) = (zDSL.eval_exp (bv2z_atomic a) sz).
Proof.
  move=> Heq; case: a => /=.
  - move=> x.
    exact: Heq.
  - reflexivity.
Qed.

Lemma bvz_eq_eval_instr i sb sz :
  bvz_eq sb sz ->
  bv2z_instr_safe_at i sb ->
  bvz_eq (eval_instr sb i) (zDSL.eval_program sz (bv2z_instr i)).
Proof.
  move=> Heq; case: i => /=.
  - (* bvAssign *)
    move=> v a _ x. apply: (bvz_eq_upd _ Heq). exact: bvz_eq_eval_atomic.
  - (* bvAdd *)
    move=> v a1 a2 Hsafe. apply: (bvz_eq_upd _ Heq).
    rewrite -(bvz_eq_eval_atomic a1 Heq) -(bvz_eq_eval_atomic a2 Heq).
    exact: toPosZ_addB_bounded.
  - (* bvAddC *)
    move=> vh vl a1 a2 _ x.
    rewrite -(bvz_eq_eval_atomic a1 Heq) -(bvz_eq_eval_atomic a2 Heq).
    sethave tmp
            (Z.div_eucl (toPosZ (eval_atomic a1 sb) + toPosZ (eval_atomic a2 sb))
                 (2 ^ Z.of_nat wordsize)).
    destruct tmp as [q r] => Hqr.
    apply: (bvz_eq_upd2 _ _ Heq).
    + exact: (toPosZ_addB_zeroExtend_low Hqr).
    + exact: (toPosZ_addB_zeroExtend_high Hqr).
  - (* bvAdc *)
    move=> v a1 a2 c Hsafe. apply: (bvz_eq_upd _ Heq).
    rewrite -(bvz_eq_eval_atomic a1 Heq) -(bvz_eq_eval_atomic a2 Heq) -(Heq c).
    move: Hsafe => /andP [Hsafe1 Hsafe2].
    exact: toPosZ_addB3_bounded.
  - (* bvAdcC *)
    move=> c v a1 a2 a _.
    rewrite -(bvz_eq_eval_atomic a1 Heq) -(bvz_eq_eval_atomic a2 Heq) -(Heq a).
    sethave tmp
            (Z.div_eucl
               (toPosZ (eval_atomic a1 sb) + toPosZ (eval_atomic a2 sb) +
                toPosZ (State.acc a sb)) (2 ^ Z.of_nat wordsize)).
    destruct tmp as [q r] => Hqr.
    apply: (bvz_eq_upd2 _ _ Heq).
    + exact: (toPosZ_addB3_zeroExtend_low Hqr).
    + exact: (toPosZ_addB3_zeroExtend_high Hqr).
  - (* bvSub *)
    move=> v a1 a2 Hsafe.
    apply: (bvz_eq_upd _ Heq).
    rewrite -(bvz_eq_eval_atomic a1 Heq) -(bvz_eq_eval_atomic a2 Heq).
    exact: toPosZ_subB_bounded.
  - (* bvSubC *)
    move=> c v a1 a2 _.
    rewrite -(bvz_eq_eval_atomic a1 Heq) -(bvz_eq_eval_atomic a2 Heq).
    sethave temp (Z.div_eucl
                    (toPosZ (eval_atomic a1 sb) - toPosZ (eval_atomic a2 sb))
                    (2 ^ Z.of_nat wordsize)).
    destruct temp as [q r] => Hqr.
    apply: (bvz_eq_upd2_aux _ _ _ Heq).
    + rewrite (zDSL.State.acc_upd2_eq2 _ _ _ _ (eqxx c)).
      exact: (toPosZ_subB_zeroExtend_high Hqr).
    + exact: (toPosZ_subB_zeroExtend_low Hqr).
  - (* bvSbb *)
    move=> v a1 a2 y Hsafe. apply: (bvz_eq_upd _ Heq).
    rewrite -(bvz_eq_eval_atomic a1 Heq) -(bvz_eq_eval_atomic a2 Heq)
            -(Heq y).
    move: Hsafe => /andP [Hsafe1 Hsafe2].
    exact: toPosZ_subB3_bounded.
  - (* bvSbbC *)
    move=> c v a1 a2 y _.
    rewrite -(bvz_eq_eval_atomic a1 Heq) -(bvz_eq_eval_atomic a2 Heq)
            -(Heq y).
    sethave temp (Z.div_eucl
                    (toPosZ (eval_atomic a1 sb) - toPosZ (eval_atomic a2 sb) -
                     toPosZ (State.acc y sb)) (2 ^ Z.of_nat wordsize)).
    destruct temp as [q r] => Hqr.
    apply: (bvz_eq_upd2_aux _ _ _ Heq).
    + rewrite (zDSL.State.acc_upd2_eq2 _ _ _ _ (eqxx c)).
      exact: (toPosZ_subB3_zeroExtend_high Hqr).
    + exact: (toPosZ_subB3_zeroExtend_low Hqr).
  - (* bvMul *)
    move=> v a1 a2 Hsafe x. apply: (bvz_eq_upd _ Heq).
    rewrite -(bvz_eq_eval_atomic a1 Heq) -(bvz_eq_eval_atomic a2 Heq).
    apply: toPosZ_mulB_bounded. rewrite -fromNat0. apply/eqP.
    exact: Hsafe.
  - (* bvMulf *)
    move=> vh vl a1 a2 _ x.
    rewrite -(bvz_eq_eval_atomic a1 Heq) -(bvz_eq_eval_atomic a2 Heq).
    sethave tmp
            (Z.div_eucl (toPosZ (eval_atomic a1 sb) * toPosZ (eval_atomic a2 sb))
                        (2 ^ Z.of_nat wordsize)).
    destruct tmp as [q r] => Hqr. apply: (bvz_eq_upd2 _ _ Heq).
    + exact: (toPosZ_fullmulB_low Hqr).
    + exact: (toPosZ_fullmulB_high Hqr).
  - (* bvShl *)
    move=> v a n Hsafe. apply: (bvz_eq_upd _ Heq).
    rewrite -(bvz_eq_eval_atomic a Heq). exact: toPosZ_shlBn_bounded.
  - (* bvSplit *)
    move=> vh vl a n _ x. rewrite -(bvz_eq_eval_atomic a Heq).
    sethave tmp (Z.div_eucl (toPosZ (eval_atomic a sb)) (2 ^ Z.of_nat (toNat n))).
    destruct tmp as [q r] => Hqr. apply: (bvz_eq_upd2 _ _ Heq).
    + exact: (toPosZ_shrBn_low Hqr).
    + exact: (toPosZ_shrBn_high Hqr).
  - (* bvConcatShl *)
    move=> vh vl a1 a2 n Hsafe x.
    rewrite -(bvz_eq_eval_atomic a1 Heq) -(bvz_eq_eval_atomic a2 Heq).
    sethave tmp
            (Z.div_eucl
               (toPosZ (eval_atomic a1 sb) *
                2 ^ Z.of_nat wordsize +
                    toPosZ (eval_atomic a2 sb))
               (2 ^ Z.of_nat (wordsize - (toNat n)))).
    destruct tmp as [q r] => Hqr. move/andP: Hsafe => [Hle Hsafe].
    apply: (bvz_eq_upd2 _ _ Heq).
    + exact: (toPosZ_catB_shlBn_low_shrBn Hle Hsafe Hqr).
    + exact: (toPosZ_catB_shlBn_high Hle Hsafe Hqr).
Qed.

Lemma bvz_eq_eval_program p sb sz :
  bvz_eq sb sz ->
  bv2z_program_safe_at p sb ->
  bvz_eq (eval_program sb p) (zDSL.eval_program sz (bv2z_program p)).
Proof.
  elim: p sb sz => /=.
  - move=> sb sz Heq _; exact: Heq.
  - move=> hd tl IH sb sz Heq /andP [Hhd Htl].
    rewrite zDSL.eval_program_concat_step.
    apply: (IH _ _ _ Htl).
    exact: bvz_eq_eval_instr.
Qed.

(** Convert specifications. *)

Definition bv2z_unop (op : unop) : zDSL.unop :=
  match op with
  | bvNegOp => zDSL.zNeg
  end.

Definition bv2z_binop (op : binop) : zDSL.binop :=
  match op with
  | bvAddOp => zDSL.zAdd
  | bvSubOp => zDSL.zSub
  | bvMulOp => zDSL.zMul
  end.

Fixpoint bv2z_eexp (e : eexp) : zDSL.exp :=
  match e with
  | bveVar v => zVar v
  | bveConst c => zConst c
  | bveUnop op e => zUnop (bv2z_unop op) (bv2z_eexp e)
  | bveBinop op e1 e2 => zBinop (bv2z_binop op) (bv2z_eexp e1) (bv2z_eexp e2)
  end.

Fixpoint bv2z_ebexp e : zDSL.bexp :=
  match e with
  | bveTrue => zDSL.zTrue
  | bveEq e1 e2 => zDSL.zEq (bv2z_eexp e1) (bv2z_eexp e2)
  | bveEqMod e1 e2 p => zDSL.zEqMod (bv2z_eexp e1) (bv2z_eexp e2) (bv2z_eexp p)
  | bveAnd e1 e2 => zDSL.zAnd (bv2z_ebexp e1) (bv2z_ebexp e2)
  end.

Definition bv2z_spec_rng s : rspec :=
  {| rspre := rng_bexp (spre s);
     rsprog := sprog s;
     rspost := rng_bexp (spost s) |}.

Definition bv2z_spec_eqn s : zDSL.spec :=
  {| zDSL.spre := bv2z_ebexp (eqn_bexp (spre s));
     zDSL.sprog := bv2z_program (sprog s);
     zDSL.spost := bv2z_ebexp (eqn_bexp (spost s)) |}.

Definition bv2z_spec_safe sp :=
  forall s, eval_rbexp (rng_bexp (spre sp)) s ->
            bv2z_program_safe_at (sprog sp) s.

(** Properties of specification conversion. *)

Lemma bvz_eq_eval_eunop op (v : Z) :
  eval_eunop op v =
  zDSL.eval_unop (bv2z_unop op) v.
Proof.
  case: op; reflexivity.
Qed.

Lemma bvz_eq_eval_ebinop op (v1 v2 : Z) :
  eval_ebinop op v1 v2 =
  zDSL.eval_binop (bv2z_binop op) v1 v2.
Proof.
  case: op; reflexivity.
Qed.

Lemma bvz_eq_eval_eexp (e : eexp) bs zs :
  bvz_eq bs zs ->
  eval_eexp e bs = zDSL.eval_exp (bv2z_eexp e) zs.
Proof.
  elim: e => /=.
  - move=> a Heq. exact: Heq.
  - reflexivity.
  - move=> op e IH Heq. rewrite -(IH Heq). exact: bvz_eq_eval_eunop.
  - move=> op e1 IH1 e2 IH2 Heq. rewrite -(IH1 Heq) -(IH2 Heq).
    exact: bvz_eq_eval_ebinop.
Qed.

Lemma bvz_eq_eval_ebexp1 e bs zs :
  bvz_eq bs zs ->
  eval_ebexp e bs ->
  zDSL.eval_bexp (bv2z_ebexp e) zs.
Proof.
  elim: e => /=.
  - done.
  - move=> e1 e2 Heq Heval.
    rewrite -(bvz_eq_eval_eexp e1 Heq) -(bvz_eq_eval_eexp e2 Heq). exact: Heval.
  - move=> e1 e2 p Heq Heval.
    rewrite -(bvz_eq_eval_eexp e1 Heq) -(bvz_eq_eval_eexp e2 Heq)
            -(bvz_eq_eval_eexp p Heq). exact: Heval.
  - move=> e1 IH1 e2 IH2 Heq [Heval1 Heval2].
    split; [exact: (IH1 Heq Heval1) | exact: (IH2 Heq Heval2)].
Qed.

Lemma bvz_eq_eval_ebexp2 e bs zs :
  bvz_eq bs zs ->
  zDSL.eval_bexp (bv2z_ebexp e) zs ->
  eval_ebexp e bs.
Proof.
  elim: e => /=.
  - done.
  - move=> e1 e2 Heq Heval.
    rewrite (bvz_eq_eval_eexp e1 Heq) (bvz_eq_eval_eexp e2 Heq). exact: Heval.
  - move=> e1 e2 p Heq Heval.
    rewrite (bvz_eq_eval_eexp e1 Heq) (bvz_eq_eval_eexp e2 Heq)
            (bvz_eq_eval_eexp p Heq). exact: Heval.
  - move=> e1 IH1 e2 IH2 Heq [Heval1 Heval2].
    split; [exact: (IH1 Heq Heval1) | exact: (IH2 Heq Heval2)].
Qed.

Lemma eval_bexp_combine e bs zs :
  bvz_eq bs zs ->
  eval_rbexp (rng_bexp e) bs ->
  zDSL.eval_bexp (bv2z_ebexp (eqn_bexp e)) zs ->
  eval_bexp e bs.
Proof.
  move=> Heq Her Hee. split.
  - exact: (bvz_eq_eval_ebexp2 Heq Hee).
  - exact: Her.
Qed.

(** Convert bvState to zState. *)

Definition bv2z_state bs : zDSL.State.t :=
  fun v => toPosZ (State.acc v bs).

Lemma bv2z_state_eq bs :
  bvz_eq bs (bv2z_state bs).
Proof.
  move=> x; reflexivity.
Qed.

(** Well-formedness *)

Lemma lvs_bv2z_instr i :
  VS.Equal (zDSL.lvs_program (bv2z_instr i)) (lvs_instr i).
Proof.
  case: i => /=; intros;
  (let rec tac :=
       match goal with
       | |- context f [VS.union _ VS.empty] =>
         rewrite zDSL.VSLemmas.union_emptyr; tac
       | |- VS.Equal ?s ?s => reflexivity
       | |- VS.Equal
              (VS.union
                 (VS.add ?v1 (VS.singleton ?v2))
                 (VS.singleton ?v1))
              (VS.add ?v1 (VS.singleton ?v2)) =>
         rewrite VSLemmas.union_add1 zDSL.VSLemmas.OP.P.union_sym
                 -VSLemmas.union_add1
                 (VSLemmas.add_equal
                    (VSLemmas.mem_singleton2 (eqxx v1)))
                 -VSLemmas.OP.P.add_union_singleton;
         reflexivity
       | |- _ => idtac
       end in
   tac).
Qed.

Lemma bv2z_atomic_vars a :
  VS.Equal (zDSL.vars_exp (bv2z_atomic a)) (vars_atomic a).
Proof.
  case: a => /=; reflexivity.
Qed.

Lemma bv2z_eexp_vars (e : eexp) : VS.Equal (zDSL.vars_exp (bv2z_eexp e)) (vars_eexp e).
Proof.
  elim: e => /=.
  - reflexivity.
  - reflexivity.
  - move=> _ e IH. exact: IH.
  - move=> _ e1 IH1 e2 IH2. rewrite IH1 IH2. reflexivity.
Qed.

(* Convert (vars_* (bv2z_* _)) to (vars_* _). *)
Ltac vars_to_bvdsl :=
  match goal with
  | |- context f [VS.union _ VS.empty] =>
    rewrite VSLemmas.union_emptyr; vars_to_bvdsl
  | |- context f [vars_exp (bv2z_atomic _)] =>
    rewrite !bv2z_atomic_vars; vars_to_bvdsl
  | |- context f [vars_exp (bv2z_eexp _)] =>
    rewrite !bv2z_eexp_vars; vars_to_bvdsl
  | |- _ => idtac
  end.

Lemma vars_bv2z_instr i :
  VS.Equal (zDSL.vars_program (bv2z_instr i)) (vars_instr i).
Proof.
  case: i => /=; intros; vars_to_bvdsl; VSLemmas.dp_Equal.
Qed.

Lemma vars_bv2z_program p :
  VS.Equal (zDSL.vars_program (bv2z_program p)) (vars_program p).
Proof.
  elim: p => /=.
  - reflexivity.
  - move=> hd tl IH. rewrite (zDSL.vars_program_concat) IH vars_bv2z_instr.
    reflexivity.
Qed.

Lemma eqn_bexp_vars_subset f :
  VS.subset (zDSL.vars_bexp (bv2z_ebexp (eqn_bexp f))) (vars_bexp f).
Proof.
  case: f => e r /=. apply: VSLemmas.subset_union1 => /= {r}.
  elim: e => /=; intros; vars_to_bvdsl; VSLemmas.dp_subset.
Qed.

Lemma bv2z_instr_well_formed vs i :
  well_formed_instr vs i ->
  zDSL.well_formed_program vs (bv2z_instr i).
Proof.
  case: i => /=; intros;
  (let rec tac :=
       match goal with
       | |- is_true true => done
       | |- is_true (_ && _) => apply/andP; split; tac
       | H : is_true (_ && _) |- _ =>
         let H1 := fresh in
         let H2 := fresh in
         move/andP: H => [H1 H2]; tac
       | H : is_true (?x != ?y) |- is_true (?x != ?y) => exact: H
       | |- is_true (VS.subset _ _) => vars_to_bvdsl; VSLemmas.dp_subset
       | |- _ => idtac
       end in
   tac).
Qed.

Lemma bv2z_program_well_formed vs p :
  well_formed_program vs p ->
  zDSL.well_formed_program vs (bv2z_program p).
Proof.
  elim: p vs => /=.
  - done.
  - move=> hd tl IH vs /andP [Hwellhd Hwelltl].
    rewrite zDSL.well_formed_program_concat.
    rewrite (bv2z_instr_well_formed Hwellhd) /=.
    apply: (@zDSL.well_formed_program_replace (VS.union vs (lvs_instr hd))).
  - exact: (IH _ Hwelltl).
  - rewrite lvs_bv2z_instr. reflexivity.
Qed.

Lemma bv2z_spec_rng_well_formed vs sp :
  well_formed_spec vs sp ->
  well_formed_spec vs (bv2z_spec_rng sp).
Proof.
  destruct sp as [f p g]. move=> /andP /= [/andP [Hf Hp] Hg].
  rewrite /well_formed_spec /=. rewrite /vars_bexp /=.
  rewrite 2!VSLemmas.union_emptyl Hp.
  rewrite (VSLemmas.subset_trans (vars_rbexp_subset f) Hf).
  rewrite (VSLemmas.subset_trans (vars_rbexp_subset g) Hg).
  done.
Qed.

Lemma bv2z_spec_eqn_well_formed vs sp :
  well_formed_spec vs sp ->
  zDSL.well_formed_spec vs (bv2z_spec_eqn sp).
Proof.
  destruct sp as [f p g].
  move=> /andP /= [/andP [Hf Hp] Hg].
  apply/andP => /=; split; first (apply/andP; split).
  - apply: (@VSLemmas.subset_trans _ (vars_bexp f) _ _ Hf).
    exact: eqn_bexp_vars_subset.
  - exact: bv2z_program_well_formed.
  - apply: (VSLemmas.subset_trans (eqn_bexp_vars_subset g)).
    rewrite vars_bv2z_program. assumption.
Qed.

(** Soundness *)

Theorem bv2z_spec_sound sp :
  bv2z_spec_safe sp ->
  valid_rspec (bv2z_spec_rng sp) ->
  zDSL.valid_spec (bv2z_spec_eqn sp) ->
  valid_spec sp.
Proof.
  destruct sp as [f p g] => /=.
  move=> Hsafe Hrng Heqn bs1 bs2 /= Hbf Hbp.
  move: (Hrng bs1 bs2 (eval_bexp_rng Hbf) Hbp) => {Hrng} /= Hrng.
  set zs1 := bv2z_state bs1.
  set zs2 := zDSL.eval_program zs1 (bv2z_program p).
  move: (Heqn zs1 zs2
              (bvz_eq_eval_ebexp1 (bv2z_state_eq bs1) (eval_bexp_eqn Hbf))
              (Logic.eq_refl zs2)) => {Heqn} /= Heqn.
  apply: (@eval_bexp_combine g bs2 zs2 _ Hrng Heqn). rewrite -Hbp.
  exact: (bvz_eq_eval_program (bv2z_state_eq bs1) (Hsafe _ (eval_bexp_rng Hbf))).
Qed.


(** PRF Example

  Inspired by "State Separation for Code-Based Game-Playing Proofs"
  by Brzuska et al.

  Appendix A.

  "Given a pseudorandom function (PRF) we construct a symmetric encryption
  scheme that is indistinguishable under chosen plaintext attacks (IND-CPA)."

*)

From Relational Require Import OrderEnrichedCategory GenericRulesSimple.

Set Warnings "-notation-overridden,-ambiguous-paths".
From mathcomp Require Import all_ssreflect all_algebra reals distr realsum
  ssrnat ssreflect ssrfun ssrbool ssrnum eqtype choice seq.
Set Warnings "notation-overridden,ambiguous-paths".

From Mon Require Import SPropBase.
From Crypt Require Import Axioms ChoiceAsOrd SubDistr Couplings
  UniformDistrLemmas FreeProbProg Theta_dens RulesStateProb
  pkg_core_definition chUniverse pkg_composition pkg_rhl Package Prelude.

From Coq Require Import Utf8.
From extructures Require Import ord fset fmap.

Import SPropNotations.

Import PackageNotation.

From Equations Require Import Equations.
Require Equations.Prop.DepElim.

Set Equations With UIP.

Set Bullet Behavior "Strict Subproofs".
Set Default Goal Selector "!".
Set Primitive Projections.

Import Num.Def.
Import Num.Theory.
Import Order.POrderTheory.

Section PRF_example.

  Context (n : nat).

  Definition Words_N : nat := 2^n.
  Definition Words_N_pos : Positive Words_N := _.
  Definition Words : chUniverse := chFin (mkpos Words_N).
  Definition Key_N : nat := 2^n.
  Definition Key_N_pos : Positive Key_N := _.
  Definition Key : chUniverse := chFin (mkpos Key_N).

  (* TW: Is this normal that this definition is so big? *)
  #[program] Definition plus : Words → Key → Words :=
    λ w k,
      @Ordinal _ (BinNat.N.to_nat (BinNat.N.lxor (BinNat.N.of_nat (nat_of_ord w)) (BinNat.N.of_nat (nat_of_ord k)))) _.
  Next Obligation.
    destruct w as [w Hw], k as [k Hk].
    destruct w as [|Pw], k as [|Pk].
    1:{ simpl. assumption. }
    1:{
      simpl.
      rewrite Pnat.SuccNat2Pos.id_succ.
      assumption.
    }
    1:{
      simpl.
      rewrite Pnat.SuccNat2Pos.id_succ.
      assumption.
    }
    remember (succn Pw) as w.
    remember (succn Pk) as k.
    assert (
      ∀ m,
        (2 ^ m)%nat = BinNat.N.to_nat (BinNat.N.pow (BinNums.Npos (BinNums.xO 1%AC)) (BinNat.N.of_nat m))
    ) as H.
    { induction m.
      - reflexivity.
      - rewrite expnSr.
        rewrite Nnat.Nat2N.inj_succ.
        rewrite BinNat.N.pow_succ_r'.
        rewrite Nnat.N2Nat.inj_mul.
        rewrite PeanoNat.Nat.mul_comm.
        apply f_equal2.
        + apply IHm.
        + reflexivity.
    }
    unfold Words_N, Key_N in *.
    move: (BinNat.N.log2_lxor (BinNat.N.of_nat w) (BinNat.N.of_nat k)) => Hbound.
    assert (
      BinNat.N.lt (BinNat.N.log2 (BinNat.N.of_nat w)) (BinNat.N.of_nat n)
    ) as H1.
    { rewrite -BinNat.N.log2_lt_pow2.
      2:{
        rewrite Heqw. rewrite Nnat.Nat2N.inj_succ.
        apply BinNat.N.lt_0_succ.
      }
      unfold BinNat.N.lt.
      rewrite Nnat.N2Nat.inj_compare.
      rewrite PeanoNat.Nat.compare_lt_iff.
      rewrite Nnat.Nat2N.id.
      rewrite -H.
      apply /ltP.
      apply Hw.
    }
    assert (
      BinNat.N.lt (BinNat.N.log2 (BinNat.N.of_nat k)) (BinNat.N.of_nat n)
    ) as H2.
    { rewrite -BinNat.N.log2_lt_pow2.
      2:{
        rewrite Heqk. rewrite Nnat.Nat2N.inj_succ.
        apply BinNat.N.lt_0_succ.
      }
      unfold BinNat.N.lt.
      rewrite Nnat.N2Nat.inj_compare.
      rewrite PeanoNat.Nat.compare_lt_iff.
      rewrite Nnat.Nat2N.id.
      rewrite -H.
      apply /ltP.
      apply Hk.
    }
    move: (BinNat.N.max_lub_lt _ _ _ H1 H2) => Hm.
    destruct ((BinNat.N.lxor (BinNat.N.of_nat w) (BinNat.N.of_nat k)) == BinNat.N0) eqn:H0.
    1:{
      simpl. move: H0. move /eqP => H0. rewrite H0. simpl.
      rewrite expn_gt0. apply /orP. left. auto.
    }
    move: (BinNat.N.le_lt_trans _ _ _ Hbound Hm).
    rewrite -BinNat.N.log2_lt_pow2.
    2:{
      apply BinNat.N.neq_0_lt_0.
      move: H0. move /eqP. auto.
    }
    unfold BinNat.N.lt.
    rewrite Nnat.N2Nat.inj_compare.
    rewrite PeanoNat.Nat.compare_lt_iff.
    move => Hlt.
    apply /ltP.
    simpl in *.
    rewrite H.
    assumption.
  Qed.

  Notation "m ⊕ k" := (plus m k) (at level 70).

  Lemma plus_involutive :
    ∀ m k, (m ⊕ k) ⊕ k = m.
  Proof.
    intros m k.
    move: ord_inj => Hordinj.
    unfold injective in Hordinj.
    apply Hordinj.
    destruct m. cbn.
    rewrite Nnat.N2Nat.id.
    rewrite BinNat.N.lxor_assoc.
    rewrite BinNat.N.lxor_nilpotent.
    rewrite BinNat.N.lxor_0_r.
    rewrite Nnat.Nat2N.id.
    reflexivity.
  Qed.

  #[local] Open Scope package_scope.

  Definition key_location : Location := ('option Key ; 0).
  Definition plain_location : Location := (Words ; 1).
  Definition cipher_location : Location := (Words ; 2).
  Definition i0 : nat := 3.
  Definition i1 : nat := 4.
  Definition i2 : nat := 5.
  Definition salt_location : Location := ('nat ; 6).
  Definition table_location : Location :=
    (chMap 'nat ('fin (2^n)%N) ; 7).

  Definition rel_loc : {fset Location} :=
    fset [:: key_location ; table_location ].

  Context (PRF : Words → Key → Key).

  Notation " 'word " := ('fin (2^n)%N) (in custom pack_type at level 2).
  Notation " 'key " := ('fin (2^n)%N) (in custom pack_type at level 2).
  Definition i_key : nat := 2^n.
  Definition i_words : nat := 2^n.

  Definition enc {L : { fset Location }} (m : Words) (k : Key) :
    code L [interface] ('fin (2^n) × 'fin (2^n)) :=
      {code
        r ← sample uniform i_words ;;
        let pad := PRF r k in
        let c := m ⊕ pad in
        ret (r, c)
      }.

  Definition kgen : code fset0 [interface] 'fin (2^n) :=
    {code
      k ← sample uniform i_key ;;
      ret k
    }.

  Definition dec (c : Words) (k : Key) :
    code
      (fset [:: key_location; table_location])
      [interface]
      ('fin (2^n) × 'fin (2^n)) :=
    enc k c.

  Definition EVAL_location_tt := (fset [:: key_location]).
  Definition EVAL_location_ff := (fset [:: table_location]).

  Definition EVAL_pkg_tt :
    package EVAL_location_tt [interface]
      [interface val #[i0] : 'word → 'key ] :=
    [package
      def #[i0] (r : 'word) : 'key
      {
        k_init ← get key_location ;;
        match k_init with
        | None =>
            k ← sample uniform i_key ;;
            put key_location := Some k ;;
            ret (PRF r k)
        | Some k_val =>
            ret (PRF r k_val)
        end
      }
    ].

  Definition EVAL_pkg_ff :
    package EVAL_location_ff [interface]
      [interface val #[i0] : 'word → 'key ] :=
    [package
      def #[i0] (r : 'word) : 'key
      {
        T ← get table_location ;;
        match getm T r with
        | None =>
            T_key ← sample uniform i_key ;;
            put table_location := (setm T r T_key) ;;
            ret T_key
        | Some T_key => ret T_key
        end
      }
    ].

  (* TODO Not the most satisfying, it would be nice to think of something else
    This might come with more automation to deal with the GamePair type.
  *)
  Definition EVAL : loc_GamePair [interface val #[i0] : 'word → 'key ] :=
    λ b, if b then {locpackage EVAL_pkg_tt } else {locpackage EVAL_pkg_ff }.

  Definition MOD_CPA_location : {fset Location} := fset0.

  Definition MOD_CPA_tt_pkg :
    package MOD_CPA_location [interface val #[i0] : 'word → 'key ]
      [interface val #[i1] : 'word → 'word × 'word ] :=
    [package
      def #[i1] (m : 'word) : 'word × 'word
      {
        #import {sig #[i0] : 'word → 'key } as eval ;;
        r ← sample uniform i_words ;;
        pad ← eval r ;;
        let c := m ⊕ pad in
        ret (r, c)
      }
    ].

  Definition MOD_CPA_ff_pkg :
    package MOD_CPA_location [interface val #[i0] : 'word → 'key]
      [interface val #[i1] : 'word → 'word × 'word ]:=
    [package
      def #[i1] (m : 'word) : 'word × 'word
      {
        #import {sig #[i0] : 'word → 'key } as eval ;;
        r ← sample uniform i_words ;;
        m' ← sample uniform i_words ;;
        pad ← eval r ;;
        let c := (m' ⊕ pad) in
        ret (r, c)
      }
    ].

  Definition IND_CPA_location : {fset Location} := fset [:: key_location].

  Definition IND_CPA_pkg_tt :
    package IND_CPA_location
      [interface]
      [interface val #[i1] : 'word → 'word × 'word ] :=
    [package
      def #[i1] (m : 'word) : 'word × 'word
      {
        k ← get key_location ;;
        match k with
        | None =>
          k_val ← sample uniform i_key ;;
          put key_location := Some k_val ;;
          enc m k_val
        | Some k_val =>
          enc m k_val
        end
      }
   ].

  Definition IND_CPA_pkg_ff :
    package IND_CPA_location
      [interface]
      [interface val #[i1] : 'word → 'word × 'word ] :=
    [package
      def #[i1] (m : 'word) : 'word × 'word
      {
        k ← get key_location ;;
        match k with
        | None =>
          k_val ← sample uniform i_key ;;
          put key_location := Some k_val ;;
          m' ← sample uniform i_words ;;
          enc m' k_val
        | Some k_val =>
          m' ← sample uniform i_words ;;
          enc m' k_val
        end
      }
    ].

  Definition IND_CPA :
    loc_GamePair [interface val #[i1] : 'word → 'word × 'word ] :=
    λ b,
      if b then {locpackage IND_CPA_pkg_tt } else {locpackage IND_CPA_pkg_ff }.

  Local Open Scope ring_scope.

  Definition prf_epsilon A := Advantage EVAL A.

  Definition statistical_gap :=
    AdvantageE (MOD_CPA_ff_pkg ∘ EVAL false) (MOD_CPA_tt_pkg ∘ EVAL false).

  Lemma IND_CPA_equiv_false :
    IND_CPA false ≈₀ MOD_CPA_ff_pkg ∘ (EVAL true).
  Proof.
    (* We go to the relation logic using equality as invariant. *)
    eapply eq_rel_perf_ind_eq.
    simplify_eq_rel m.
    simplify_linking.
    (* We now conduct the proof in relational logic. *)
    ssprove_swap_rhs 1%N.
    ssprove_swap_rhs 0%N.
    ssprove_sync_eq. cbn. intros [k|].
    - cbn. ssprove_swap_rhs 0%N.
      eapply rpost_weaken_rule.
      1: eapply rreflexivity_rule.
      cbn. intros [? ?] [? ?] e. inversion e. intuition auto.
    - cbn.
      ssprove_swap_rhs 0%N.
      ssprove_swap_rhs 1%N.
      ssprove_swap_rhs 0%N.
      ssprove_swap_rhs 2%N.
      ssprove_swap_rhs 1%N.
      eapply rpost_weaken_rule. 1: eapply rreflexivity_rule.
      cbn. intros [? ?] [? ?] e. inversion e. intuition auto.
  Qed.

  Lemma IND_CPA_equiv_true :
    MOD_CPA_tt_pkg ∘ (EVAL true) ≈₀ IND_CPA true.
  Proof.
    (* We go to the relation logic using equality as invariant. *)
    eapply eq_rel_perf_ind_eq.
    simplify_eq_rel m.
    simplify_linking.
    (* We now conduct the proof in relational logic. *)
    ssprove_swap_lhs 0%N.
    ssprove_sync_eq. cbn. intros [k|].
    - cbn. eapply rpost_weaken_rule. 1: eapply rreflexivity_rule.
      cbn. intros [? ?] [? ?] e. inversion e. intuition auto.
    - cbn.
      ssprove_swap_rhs 1%N.
      ssprove_swap_rhs 0%N.
      eapply rpost_weaken_rule. 1: eapply rreflexivity_rule.
      cbn. intros [? ?] [? ?] e. inversion e. intuition auto.
  Qed.

  (** Security of PRF

    The bound is given by using the triangle inequality several times,
    using the following chain:
    IND_CPA false ≈ MOD_CPA_ff_pkg ∘ EVAL true
                  ≈ MOD_CPA_ff_pkg ∘ EVAL false
                  ≈ MOD_CPA_tt_pkg ∘ EVAL false
                  ≈ MOD_CPA_tt_pkg ∘ EVAL true
                  ≈ IND_CPA true

  *)
  Theorem security_based_on_prf :
    ∀ LA A,
      ValidPackage LA
        [interface val #[i1] : 'word → 'word × 'word ] A_export A →
      fdisjoint LA (IND_CPA false).(locs) →
      fdisjoint LA (IND_CPA true).(locs) →
      Advantage IND_CPA A <=
      prf_epsilon (A ∘ MOD_CPA_ff_pkg) +
      statistical_gap A +
      prf_epsilon (A ∘ MOD_CPA_tt_pkg).
  Proof.
    intros LA A vA hd₀ hd₁. unfold prf_epsilon, statistical_gap.
    rewrite !Advantage_E.
    ssprove triangle (IND_CPA false) [::
      MOD_CPA_ff_pkg ∘ EVAL true ;
      MOD_CPA_ff_pkg ∘ EVAL false ;
      MOD_CPA_tt_pkg ∘ EVAL false ;
      MOD_CPA_tt_pkg ∘ EVAL true
    ] (IND_CPA true) A
    as ineq.
    eapply le_trans. 1: exact ineq.
    clear ineq.
    erewrite IND_CPA_equiv_false. all: eauto.
    2:{ simpl. unfold MOD_CPA_location. rewrite fset0U. auto. }
    erewrite IND_CPA_equiv_true. all: eauto.
    2:{ simpl. unfold MOD_CPA_location. rewrite fset0U. auto. }
    rewrite GRing.add0r GRing.addr0.
    rewrite !Advantage_link. rewrite Advantage_sym. auto.
  Qed.

End PRF_example.


Require Import Min.

Require Import msl.msl_standard.
Require Import Maps.
Require Import FuncListMachine.

Open Scope pred.

(* Various utility lemmas *)

Lemma later_level : forall k1 k2,
  laterR k1 k2 ->
  level k2 < level k1.
Proof.
  intros k1 k2 H; induction H.
  do 2 rewrite K.knot_level.
  hnf in H.
  rewrite K.knot_age1 in H.
  destruct (K.unsquash x).
  destruct n; try discriminate.
  inv H.
  rewrite K.unsquash_squash; simpl.
  auto with arith.
  apply lt_trans with (level y); auto.
Qed.

Lemma nec_level : forall k1 k2,
  necR k1 k2 ->
  level k2 <= level k1.
Proof.
  intros k1 k2 H; induction H.
  do 2 rewrite K.knot_level.
  hnf in H.
  rewrite K.knot_age1 in H.
  destruct (K.unsquash x).
  destruct n; try discriminate.
  inv H.
  rewrite K.unsquash_squash; simpl.
  auto with arith. auto.
  apply le_trans with (level y); auto.
Qed.

Lemma age1_level : forall p1 p2,
  age1 p1 = Some p2 ->
  level p1 = S (level p2).
Proof.
  intros.
  do 2 rewrite K.knot_level.
  rewrite K.knot_age1 in H.
  remember (K.unsquash p1).
  icase p.
  icase n.
  inv H.
  rewrite K.unsquash_squash.
  simpl.
  trivial.
Qed.

Fixpoint ageN (n : nat) (p1 p2 : prog) : Prop :=
  match n with
   | 0 => p1 = p2
   | S n' => exists p', age p1 p' /\ ageN n' p' p2
  end.

Lemma ageN_det: forall n p1 p2 p2',
  ageN n p1 p2 ->
  ageN n p1 p2' ->
  p2 = p2'.
Proof.
  induction n; intros.
  compute in *. congruence.
  destruct H as [px [? ?]]. destruct H0 as [px' [? ?]].
  red in H, H0.
  rewrite H in H0.
  inv H0.
  eapply IHn; eauto.
Qed.
Implicit Arguments ageN_det.

Lemma ageN_necR: forall p1 p2,
  (exists n, ageN n p1 p2) = necR p1 p2.
Proof.
  intros. apply prop_ext. split; intro.
  destruct H. revert p1 H.
  induction x; intros.
  compute in H. subst. auto.
  destruct H as [? [? ?]].
  apply rt_trans with x0. apply rt_step. trivial.
  eapply IHx; eauto.
  induction H.
  exists 1. exists y. intuition.
  exists 0. red. auto.
  destruct IHclos_refl_trans1 as [n1 ?].
  destruct IHclos_refl_trans2 as [n2 ?].
  exists (n1 + n2).
  clear H H0. revert x y z n2 H1 H2.
  induction n1; intros.
  inv H1.
  apply H2.
  simpl in *.
  destruct H1 as [px [? ?]].
  exists px.
  split. trivial.
  eapply IHn1; eauto.
Qed.

Lemma ageN_level: forall n p1 p2,
  ageN n p1 p2 ->
  level p1 = level p2 + n.
Proof.
  unfold prog. induction n; intros.
  inv H. auto.
  inv H. destruct H0.
  apply age1_level in H.
  spec IHn x p2 H0. omega.
Qed.

Let closedR (w1 w2:world) := fst w1 = fst w2.
Program Definition closedM : @modality world _ := exist _ closedR _.
Next Obligation.
  split; repeat intro; unfold closedR in *;
    destruct x as [? ?]; destruct y as [? ?];
      destruct z as [? ?]; simpl in *; intuition subst.
  hnf in H; simpl in H.
  exists  (p,s1); simpl; auto.
  hnf; simpl.
  destruct (@age1 _ K.ageable_knot p0).
  inv H. auto. discriminate.
  hnf in H0; simpl in H0.
  exists (p1,s); simpl; auto.
  hnf; simpl in *.
  destruct (@age1 _ K.ageable_knot p1).
  inv H0. auto. discriminate.
Qed.
Definition closed := box closedM.

Inductive setR v x : relation world :=
  intro_setR : forall p r r',
    r' = r#v <- x ->
    setR v x (p,r) (p,r').

Program Definition setM v x : @modality world _ := setR v x.
Next Obligation.
  split; hnf; intros.
  inv H0.
  hnf in H; simpl in H.
  case_eq (age1 p); intros; unfold prog in *;
    rewrite H0 in H; try discriminate.
  inv H.
  exists (p0,r).
  constructor; auto.
  hnf. simpl. rewrite H0. auto.
  inv H.
  destruct z.
  hnf in H0; simpl in H0.
  case_eq (age1 p0); unfold prog in *; intros;
    rewrite H in H0.
  inv H0.
  exists (p0,(r#v <- x)).
  hnf. simpl. rewrite H. auto.
  constructor; auto.
  discriminate.
Qed.

Program Definition world_op (Pp : pred prog) (Pr : store -> Prop) : pred world :=
  fun pr => let (p,r) := pr in Pp p /\ Pr r.
Next Obligation.
  unfold hereditary; intros.
  destruct a as [p r].
  destruct a' as [p' r'].
  hnf in H.
  simpl in H.
  rewrite K.knot_age1 in H.
  case_eq (K.unsquash p); intros; rewrite H1 in H.
  destruct n; try discriminate.
  inv H.
  intuition.
  destruct Pp as [Pp HPp].
  simpl.
  simpl in H.
  eapply HPp.
  2: apply H.
  hnf.
  rewrite K.knot_age1.
  rewrite H1; auto.
Qed.

Definition store_op (Pr : store -> Prop) := world_op TT Pr.
Definition prog_op (X:pred prog) :=  world_op X (fun _ => True).

Lemma worldNec_unfold : forall p r p' r',
  @necR world _ (p,r) (p',r') <->
  necR p p' /\ r = r'.
Proof.
  intros; split; intro H.
  remember (p,r) as w1.
  remember (p',r') as w2.
  revert p r p' r' Heqw1 Heqw2.
  induction H; simpl; intros; subst.
  hnf in H; simpl in H.
  unfold prog in *.
  case_eq (age1 p); intros; rewrite H0 in H.
  inv H. intuition.
  discriminate.
  inv Heqw2. intuition.
  destruct y as [p2 r2].
  assert (necR p p2 /\ r = r2). auto.
  assert (necR p2 p' /\ r2 = r'). auto.
  intuition; try congruence.
  eapply rt_trans; eauto.
  intuition; subst. induction H0.
  apply rt_step; hnf; simpl. hnf in H.
  unfold prog in *. rewrite H; auto.
  apply rt_refl.
  eapply rt_trans; eauto.
Qed.

Lemma worldLater_unfold : forall p r p' r',
  @laterR world _ (p,r) (p',r') <->
  laterR p p' /\ r = r'.
Proof.
  intros; split; intro H.
  remember (p,r) as w1.
  remember (p',r') as w2.
  revert p r p' r' Heqw1 Heqw2.
  induction H; simpl; intros; subst.
  hnf in H; simpl in H.
  unfold prog in *.
  case_eq (age1 p); intros; rewrite H0 in H.
  inv H. intuition.
  apply t_step; auto.
  discriminate.
  destruct y as [p2 r2].
  assert (laterR p p2 /\ r = r2). auto.
  assert (laterR p2 p' /\ r2 = r'). auto.
  intuition; try congruence.
  eapply t_trans; eauto.
  intuition; subst.
  induction H0. apply t_step.
  hnf; simpl. hnf in H. unfold prog in *. rewrite H. auto.
  eapply t_trans; eauto.
Qed.

Definition instr_approx_rel (n:nat) (i1 i2:instruction) : Prop :=
  fmap_instr (K.approx n) i1 = fmap_instr (K.approx n) i2.

Lemma intro_instr_approx_rel : forall m n i,
  m >= n ->
  instr_approx_rel n i (fmap_instr (K.approx m) i).
Proof.
  intros; hnf.
  induction i; simpl; auto.
  replace (K.approx n (K.approx m x))
    with (K.approx n x); auto.
  change (K.approx n x = (K.approx n oo K.approx m) x).
  replace m with ((m-n)+n) by omega.
  rewrite <- K.approx_approx1; auto.
  rewrite <- IHi1.
  rewrite <- IHi2.
  auto.
  rewrite <- IHi1.
  rewrite <- IHi2.
  auto.
Qed.

Lemma collapse_instr_approx : forall n m i,
  fmap_instr (K.approx n) (fmap_instr (K.approx m) i) =
  fmap_instr (K.approx (min n m)) i.
Proof.
  intros. induction i; simpl; auto.
  destruct (le_gt_dec n m).
  rewrite min_l; auto.
  assert ((m-n)+n = m) by omega.
  rewrite <- H.
  pattern (K.approx n) at 2.
  rewrite (K.approx_approx1 (m-n) n).
  unfold compose. rewrite H. auto.
  rewrite min_r.
  assert ((n-m)+m = n) by omega.
  rewrite <- H.
  pattern (K.approx m) at 2.
  rewrite (K.approx_approx2 (n-m) m).
  unfold compose. rewrite H. auto.
  omega.
  rewrite IHi1. rewrite IHi2. auto.
  rewrite IHi1. rewrite IHi2. auto.
Qed.

Lemma collapse_instr_approx_same : forall n  i,
  fmap_instr (K.approx n) (fmap_instr (K.approx n) i) =
  fmap_instr (K.approx n) i.
Proof.
  intros.
  rewrite collapse_instr_approx.
  apply min_case; auto.
Qed.

Inductive stack_approx_rel (n:nat) : stack -> stack -> Prop :=
  | stack_approx_nil : stack_approx_rel n nil nil
  | stack_approx_cons : forall i i' stk stk',
     instr_approx_rel n i i' ->
     stack_approx_rel n stk stk' ->
     stack_approx_rel n (i::stk) (i'::stk').

Lemma stack_approx_rel_refl : forall n stk,
  stack_approx_rel n stk stk.
Proof.
  induction stk; constructor; auto.
  hnf; auto.
Qed.

Lemma stack_approx_downward : forall n m s1 s2,
  n <= m ->
  stack_approx_rel m s1 s2 ->
  stack_approx_rel n s1 s2.
Proof.
  do 3 intro.
  revert n m.
  induction s1; intros.
  inversion H0.
  constructor.
  inversion H0.
  subst.
  constructor.
  replace n with (min n m).
  red.
  do 2 rewrite <- collapse_instr_approx.
  rewrite H3.
  trivial.
  apply min_l; trivial.
  apply IHs1 with m; trivial.
Qed.

Lemma nec_prog_lookup : forall p p' l i,
  necR p p' ->
  prog_lookup p l = Some i ->
  prog_lookup p' l = Some (fmap_instr (K.approx (level p')) i).
Proof.
  unfold prog_lookup; intros.
  revert l i H0. induction H; simpl; intros; auto.
  hnf in H.
  rewrite K.knot_age1 in H.
  destruct (K.unsquash x). destruct n; try discriminate.
  simpl in *.
  rewrite K.knot_level.
  inv H.
  rewrite K.unsquash_squash. simpl.
  unfold KnotInput.fmap.
  erewrite fmap_eqn; eauto.
  rewrite H0. f_equal.
  rewrite K.knot_level.
  case_eq (K.unsquash x); intros.
  rewrite H in H0. simpl in H0.
  apply K.unsquash_approx in H.
  generalize H0; intro.
  rewrite H in H0.
  unfold KnotInput.fmap in H0.
  erewrite fmap_eqn in H0; eauto.
  simpl; congruence.
  replace (fmap_instr (K.approx (level z)) i)
    with (fmap_instr (K.approx (level z))
          (fmap_instr (K.approx (level y)) i)).
  apply IHclos_refl_trans2.
  apply IHclos_refl_trans1. auto.
  rewrite collapse_instr_approx.
  rewrite min_l; auto.
  apply nec_level; auto.
Qed.

Lemma step_prog: forall p1 p2 r1 s1 r2 s2,
  step p1 p2 r1 s1 r2 s2 ->
  p1 = p2 \/ age p1 p2.
Proof.
  intros.
  inv H; auto.
Qed.

Lemma step_prog_levels : forall p p' r s r' s',
  step p p' r s r' s' ->
  level p' <= level p.
Proof.
  intros.
  apply step_prog in H. destruct H.
  subst p'. trivial.
  do 2 rewrite K.knot_level.
  hnf in H; simpl in H.
  rewrite K.knot_age1 in H.
  destruct (K.unsquash p).
  icase n.
  inv H.
  rewrite K.unsquash_squash; simpl.
  auto.
Qed.

Lemma step_approxprog: forall n p1 p2 p1' p2' r1 s1 s1' r2 s2,
  step p1 p2 r1 s1 r2 s2 ->
  ageN n p1 p1' ->
  ageN n p2 p2' ->
  stack_approx_rel (S (level p1')) s1 s1' ->
  exists s2',
    step p1' p2' r1 s1' r2 s2' /\
    stack_approx_rel (S (level p2')) s2 s2'.
Proof.
  unfold prog.
  intros.
  inversion H; subst.
(* assert *)
  generalize (ageN_det _ _ _ _ H0 H1). intro. subst p2'.
  inversion H2; subst.
  icase i'. icase i'1.
  exists (i'2 :: stk').
  inversion H2. subst.
  red in H9. simpl in H9. inv H9.
  split.
  constructor.
  assert (K.approx (S (level p1')) P (p1', r2)).
    rewrite K.approx_spec. simpl.
    rewrite <- (nec_useless P) in H3. spec H3 (p1', r2).
    spec H3. simpl. rewrite worldNec_unfold. split; trivial.
    rewrite <- ageN_necR. exists n. trivial.
    split; trivial. omega.
  rewrite H5 in H4.
  rewrite K.approx_spec in H4. destruct H4. trivial.
  apply stack_approx_downward with (S (level p1')). omega.
  constructor; trivial.
(* getlab *)
  generalize (ageN_det _ _ _ _ H0 H1). intro. subst p2'.
  inversion H2; subst.
  icase i'. icase i'1.
  exists (i'2 :: stk').
  inversion H5; subst.
  split. constructor; trivial.
  apply stack_approx_downward with (S (level p1')). omega.
  constructor; trivial.
(* fetch1 *)
  generalize (ageN_det _ _ _ _ H0 H1). intro. subst p2'.
  inversion H2; subst.
  icase i'. icase i'1.
  exists (i'2 :: stk').
  inversion H6; subst.
  split. econstructor; eauto.
  apply stack_approx_downward with (S (level p1')). omega.
  constructor; trivial.
(* fetch2 *)
  generalize (ageN_det _ _ _ _ H0 H1). intro. subst p2'.
  inversion H2; subst.
  icase i'. icase i'1.
  exists (i'2 :: stk').
  inversion H6; subst.
  split. econstructor; eauto.
  apply stack_approx_downward with (S (level p1')). omega.
  constructor; trivial.
(* cons *)
  generalize (ageN_det _ _ _ _ H0 H1). intro. subst p2'.
  inversion H2; subst.
  icase i'. icase i'1.
  exists (i'2 :: stk').
  inversion H7; subst.
  split. constructor; trivial.
  apply stack_approx_downward with (S (level p1')). omega.
  constructor; trivial.
(* seq *)
  generalize (ageN_det _ _ _ _ H0 H1). intro. subst p2'.
  inversion H2; subst.
  icase i'. icase i'1.
  exists ((i'1_1 ;; (i'1_2 ;; i'2)) :: stk').
  inversion H5; subst.
  split. econstructor; eauto.
  apply stack_approx_downward with (S (level p1')). omega.
  constructor; trivial.
  red. simpl. congruence.
(* if1 *)
  generalize (ageN_det _ _ _ _ H0 H1). intro. subst p2'.
  inversion H2; subst.
  icase i'. icase i'1.
  exists ((i'1_1 ;; i'2) :: stk').
  inversion H6; subst.
  split. econstructor; eauto.
  apply stack_approx_downward with (S (level p1')). omega.
  constructor; trivial.
  red. simpl. congruence.
(* if2 *)
  generalize (ageN_det _ _ _ _ H0 H1). intro. subst p2'.
  inversion H2; subst.
  icase i'. icase i'1.
  exists ((i'1_2 ;; i'2) :: stk').
  inversion H6; subst.
  split. econstructor; eauto.
  apply stack_approx_downward with (S (level p1')). omega.
  constructor; trivial.
  red. simpl. congruence.
(* call *)
  assert (age p1' p2').
    clear - H5 H0 H1. revert p1 p1' p2 p2' H0 H1 H5.
    induction n; intros; simpl in H0, H1.
    subst p1' p2'. trivial.
    destruct H0 as [px [? ?]]. destruct H1 as [px' [? ?]]. unfold prog in *.
    red in H, H5. rewrite H in H5. inv H5.
    eapply IHn; eauto.
  unfold prog in *.
  icase s1'. inversion H2.
  icase i0; inversion H2; disc. subst.
  icase i0_1.
  inversion H10. subst v0.
  exists ( ((fmap_instr (K.approx (level p1')) i') ;; instr_assert FF) :: i0_2 :: s1').
  split. econstructor; eauto.
  apply (nec_prog_lookup p1 p1' l i'); trivial.
  rewrite <- ageN_necR. exists n. trivial.
  apply age_level in H6.
  constructor.
  red. simpl.
  rewrite collapse_instr_approx. rewrite min_l. trivial. omega.
  apply stack_approx_downward with (S (level p1')). omega.
  constructor; trivial.
(* return *)
  generalize (ageN_det _ _ _ _ H0 H1). intro. subst p2'.
  inversion H2; subst.
  icase i'. icase i'1.
  exists stk'.
  inversion H5; subst.
  split. constructor; eauto.
  apply stack_approx_downward with (S (level p1')). omega.
  trivial.
Qed.

Lemma stepstar_prog_levels : forall p p' r s r' s',
  stepstar p p' r s r' s' ->
  level p' <= level p.
Proof.
  intros; induction H; auto.
  apply le_trans with (level p'); auto.
  eapply step_prog_levels; eauto.
Qed.

Lemma stepstar_approxprog: forall n p1 p2 p1' p2' r1 s1 s1' r2 s2,
  stepstar p1 p2 r1 s1 r2 s2 ->
  ageN n p1 p1' ->
  ageN n p2 p2' ->
  stack_approx_rel (S (level p1')) s1 s1' ->
  exists s2',
    stepstar p1' p2' r1 s1' r2 s2' /\
    stack_approx_rel (S (level p2')) s2 s2'.
Proof.
  do 11 intro.
  apply stepstar_stepN in H.
  destruct H as [m ?].
  revert n p1 p2 p1' p2' r1 s1 s1' r2 s2 H.
  induction m; intros.
  inversion H; subst.
  exists s1'.
  generalize (ageN_det _ _ _ _ H0 H1). intro. subst p2'.
  split. constructor.
  apply stack_approx_downward with (S (level p1')). omega.
  trivial.
  inversion H; subst.
  assert (exists p'2, ageN n p' p'2).
    apply step_prog in H4.
    destruct H4.
    subst p'. exists p1'. trivial.
    apply stepN_stepstar in H5.
    apply stepN_stepstar in H.
    apply stepstar_prog_levels in H.
    apply stepstar_prog_levels in H5.
    apply ageN_level in H1.
    apply ageN_level in H0.
    apply age_level in H3.
    assert (level p' >= n) by (unfold prog in *; omega).
    clear -H4. revert p' H4.
    induction n; intros.
    exists p'. red. trivial.
    rewrite K.knot_level in H4.
    remember (K.unsquash p'). destruct p. simpl in H4.
    destruct n0. omegac.
    spec IHn (K.squash (n0, f)). spec IHn.
    rewrite K.knot_level. rewrite K.unsquash_squash.
    simpl. omega.
    destruct IHn as [px ?].
    exists px. exists (K.squash (n0,f)).
    split; trivial.
    red. rewrite K.knot_age1.
    rewrite <- Heqp. trivial.
  destruct H3 as [p'2 ?].
  destruct (step_approxprog _ _ _ _ _ _ _ _ _ _ H4 H0 H3 H2) as [sx [? ?]].
  spec IHm n p' p2 p'2 p2'.
  spec IHm s' i' sx r2 s2.
  spec IHm H5 H3 H1 H7.
  destruct IHm as [sx' [? ?]].
  exists sx'.
  split; trivial.
  econstructor 2; eauto.
Qed.

Program Definition agedfrom {A} `{ageable A} (x:A) : pred A := necR x.
Next Obligation.
  unfold hereditary; intros.
  apply rt_trans with a; auto.
  apply rt_step; auto.
Qed.

(* The next two also maybe can be combined *)
(*
Lemma safe_approx : forall p n r s s',
  level p < n ->
  stack_approx_rel n s s' ->
  safe p r s ->
  safe p r s'.
Proof.
  repeat intro.
  apply stepstar_stepN in H2.
  destruct H2 as [x H2].
  revert p n r s s' H H0 H1 p' s'0 k' H2.
  induction x; intros.
  inv H2.
  cut (step_or_halt p' s'0 s).
  intros.
  inv H2.
  cut (level p'0 < n); intros.
  generalize H3; intros.
  eapply step_approx in H3; eauto.
  destruct H3 as [s'' [? ?]].
  econstructor; eauto.
  apply le_lt_trans with (level p'); auto.
  eapply step_prog_levels; eauto.
  inv H0.
  constructor.
  apply H1; constructor.

  inv H2.
  cut (step_or_halt p r s).
  intros.
  inv H2.
  cut (level p'1 < n); intros.
  generalize H3; intros.
  eapply step_approx with (n:=n) in H3; eauto.
  destruct H3 as [s'' [? ?]].
  assert (s'1 = r' /\ i' = s'' /\ p'0 = p'1).
  eapply step_deterministic; eauto.
  decompose [and] H8; subst; clear H8.
  revert H5; eapply IHx; eauto.
  repeat intro.
  eapply H1.
  econstructor; eauto.
  apply le_lt_trans with (level p); auto.
  eapply step_prog_levels; eauto.
  inv H0.
  inv H4.
  apply H1.
  constructor.
Qed.

Lemma ev_halts_approx : forall p n r s s',
  level p < n ->
  stack_approx_rel n s s' ->

  eventually_halts p r s ->
  eventually_halts p r s'.
Proof.
  repeat intro.
  destruct H1 as [pz [rz ?]].
  destruct (stepstar_approx _ _ _ _ _ _ _ _  H H0 H1)
    as [z [? ?]].
  exists pz. exists rz.
  inv H3.
  auto.
Qed.

Lemma step_approx :
  forall n p1 p2 s1 s1' s2 r1 r2,
    level p2 < n ->
    stack_approx_rel n s1 s2 ->
    step p1 p2 r1 s1 r2 s1' ->
    exists s2',
      step p1 p2 r1 s2 r2 s2' /\
      stack_approx_rel n s1' s2'.
Proof.
  intros. inv H1; inv H0.

  (* step assert *)
  hnf in H4.
  destruct i'; inv H4.
  destruct i'1; inv H1.
  exists (i'2::stk'); split.
  apply step_assert.
  assert ((K.approx n a) (p2,r2)).
  rewrite <- H4.
  rewrite K.approx_spec.
  simpl; intuition.
  rewrite K.approx_spec in H0.
  simpl in H2; intuition.
  constructor; auto.

  (* step getlabel *)
  hnf in H3; destruct i'; inv H3.
  destruct i'1; inv H1.
  exists (i'2 :: stk'); split;
    econstructor; eauto.

  (* step fetch field 0 *)
  hnf in H4; destruct i'; inv H4.
  destruct i'1; inv H1.
  exists (i'2 :: stk'); split;
    econstructor; eauto.

  (* step fetch field 1 *)
  hnf in H4; destruct i'; inv H4.
  destruct i'1; inv H1.
  exists (i'2 :: stk'); split;
    econstructor; eauto.

  (* step cons *)
  hnf in H5; destruct i'; inv H5.
  destruct i'1; inv H1.
  exists (i'2 :: stk'); split;
    econstructor; eauto.

  (* step seq *)
  hnf in H3; destruct i'; inv H3.
  destruct i'1; inv H1.
  exists ((i'1_1 ;; i'1_2 ;; i'2) :: stk'); split.
  econstructor; eauto.
  constructor; auto.
  hnf; simpl.
  f_equal; auto.
  f_equal; auto.

  (* step if nil 1 *)
  hnf in H4; destruct i'; inv H4.
  destruct i'1; inv H1.
  exists ((i'1_1 ;; i'2) :: stk'); split;
    econstructor; eauto.
  hnf; simpl; f_equal; auto.

  (* step if nil 2 *)
  hnf in H4; destruct i'; inv H4.
  destruct i'1; inv H1.
  exists ((i'1_2 ;; i'2) :: stk'); split;
    econstructor; eauto.
  hnf; simpl; f_equal; auto.

  (* step call *)
  hnf in H6; destruct i'0; inv H6.
  destruct i'0_1; inv H1.
  exists ((i' ;; instr_assert FF):: i'0_2 :: stk'); split;
    econstructor; eauto.
  constructor; auto.
  constructor; auto.

  (* step return *)
  hnf in H3; destruct i'; inv H3.
  destruct i'1; inv H1.
  exists stk'; split.
  econstructor.
  auto.
Qed.
*)
(* end nagging suspicion *)
(*
Lemma stepstar_approx :
  forall n p1 p2 s1 s1' s2 r1 r2,
    level p1 < n ->
    stack_approx_rel n s1 s2 ->
    stepstar p1 p2 r1 s1 r2 s1' ->
    exists s2',
      stepstar p1 p2 r1 s2 r2 s2' /\
      stack_approx_rel n s1' s2'.
Proof.
  intros.
  apply stepstar_stepN in H1.
  destruct H1 as [x H1].
  revert n p1 p2 s1 s1' s2 r1 r2 H H0 H1.
  induction x; intros; inv H1.
  exists s2; split; auto.
  constructor.
  assert (level p' < n).
  apply le_lt_trans with (level p1); auto.
  eapply step_prog_levels; eauto.
  destruct (step_approx _ _ _ _ _ _ _ _ H1 H0 H3)
    as [z [? ?]].
  destruct (IHx _ _ _ _ _ _ _ _ H1 H5 H4)
    as [z' [? ?]].
  exists z'; split; auto.
  eapply stepstar_S; eauto.
Qed.
*)


Require Import Coq.Strings.String Coq.Classes.RelationClasses.
Require Import Crypto.Reflection.Syntax.
Require Import Crypto.Reflection.Wf.
Require Import Crypto.Reflection.Relations.
Require Import Crypto.Util.Tuple.
Require Import Crypto.Util.Sigma.
Require Import Crypto.Util.Prod.
Require Import Crypto.Util.Tactics.
Require Import Crypto.Util.Notations.
Local Open Scope ctype_scope.
Local Open Scope expr_scope.

Section language.
  Context {base_type_code : Type}
          {interp_base_type1 interp_base_type2 : base_type_code -> Type}
          {op : flat_type base_type_code -> flat_type base_type_code -> Type}
          (interp_op1 : forall src dst, op src dst -> interp_flat_type interp_base_type1 src -> interp_flat_type interp_base_type1 dst)
          (interp_op2 : forall src dst, op src dst -> interp_flat_type interp_base_type2 src -> interp_flat_type interp_base_type2 dst)
          {R : forall t, interp_base_type1 t -> interp_base_type2 t -> Prop}
          (Rop : forall src dst op sv1 sv2, interp_flat_type_rel_pointwise R sv1 sv2
                                            -> interp_flat_type_rel_pointwise
                                                 R (interp_op1 src dst op sv1) (interp_op2 src dst op sv2)).

  Local Notation exprf1 := (@exprf base_type_code op interp_base_type1).
  Local Notation exprf2 := (@exprf base_type_code op interp_base_type2).
  Local Notation expr1 := (@expr base_type_code op interp_base_type1).
  Local Notation expr2 := (@expr base_type_code op interp_base_type2).
  Local Notation Expr := (@Expr base_type_code op).
  Local Notation interpf1 := (@interpf base_type_code interp_base_type1 op interp_op1).
  Local Notation interpf2 := (@interpf base_type_code interp_base_type2 op interp_op2).
  Local Notation interp1 := (@interp base_type_code interp_base_type1 op interp_op1).
  Local Notation interp2 := (@interp base_type_code interp_base_type2 op interp_op2).
  Local Notation Interp1 := (@Interp base_type_code interp_base_type1 op interp_op1).
  Local Notation Interp2 := (@Interp base_type_code interp_base_type2 op interp_op2).

  Lemma interp_flat_type_rel_pointwise_flatten_binding_list
        {t x x' T e1 e2}
        (Hpointwise : interp_flat_type_rel_pointwise R e1 e2)
        (HIn : List.In (existT (fun t : base_type_code => (interp_base_type1 t * interp_base_type2 t)%type) t (x, x')%core)
                       (flatten_binding_list (t:=T) e1 e2))
    : R t x x'.
  Proof.
    induction T; simpl in *; try tauto; [ | rewrite List.in_app_iff in HIn ];
      repeat first [ progress destruct_head or
                   | progress destruct_head False
                   | progress destruct_head and
                   | progress inversion_sigma
                   | progress inversion_prod
                   | progress subst
                   | solve [ eauto ] ].
  Qed.

  Local Hint Resolve List.in_app_or List.in_or_app interp_flat_type_rel_pointwise_flatten_binding_list.

  Section wf.
    Lemma interpf_wff
             {t} {e1 : exprf1 t} {e2 : exprf2 t}
             {G}
             (HG : forall t x x',
                 List.In (existT (fun t : base_type_code => (interp_base_type1 t * interp_base_type2 t)%type) t (x, x')%core) G
                 -> R t x x')
             (Rwf : wff G e1 e2)
    : interp_flat_type_rel_pointwise R (interpf1 e1) (interpf2 e2).
    Proof.
      induction Rwf; simpl; auto.
      repeat match goal with
             | [ H : context[List.In _ (_ ++ _)] |- _ ]
               => setoid_rewrite List.in_app_iff in H
             end.
      match goal with
      | [ H : _ |- _ ]
        => apply H; intros; destruct_head' or; solve [ eauto ]
      end.
    Qed.

    Local Hint Resolve interpf_wff.

    Lemma interp_wf
             {t} {e1 : expr1 t} {e2 : expr2 t}
             (Rwf : wf e1 e2)
    : interp_type_rel_pointwise R (interp1 e1) (interp2 e2).
    Proof.
      destruct Rwf; simpl; repeat intro; eauto.
    Qed.

    Lemma InterpWf
             {t} {e : Expr t}
             (Rwf : Wf e)
    : interp_type_rel_pointwise R (Interp1 e) (Interp2 e).
    Proof.
      unfold Interp, Wf in *; apply interp_wf; simpl; intuition.
    Qed.
  End wf.
End language.


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

From Undecidability.Shared.Libs.DLW.Utils
  Require Import utils.

Set Implicit Arguments.

Reserved Notation " e '⇢' x " (at level 58).
Reserved Notation " e [ v / x ] " (at level 57, v at level 0, x at level 0,
                                   left associativity, format "e [ v / x ]").
Reserved Notation " e ⦃  x '⇠' v ⦄ " (at level 57, v at level 0, x at level 0, left associativity).

Section env.

  Variable (X Y : Type) (X_eq_dec : eqdec X) (Y_default : Y).

  Definition env := X -> Y.

  Implicit Type e : env.

  Definition get_env e x := e x.

  Definition set_env e x v : env := fun y => if X_eq_dec x y then v else e y.

  Definition nil_env : env := fun _ => Y_default.

  Fact get_set_env_eq e v p q : p = q -> get_env (set_env e p v) q = v.
  Proof. intros []; unfold set_env, get_env; destruct (X_eq_dec p p) as [ | [] ]; auto. Qed.

  Fact get_set_env_neq e v p q : p <> q -> get_env (set_env e p v) q = get_env e q.
  Proof. simpl; intros H; unfold set_env, get_env; destruct (X_eq_dec p q); auto; destruct H; auto. Qed.

End env.

Arguments nil_env {X}.

Opaque get_env.
Opaque set_env.

Local Notation " e ⇢ x " := (@get_env _ _ e x).
Local Notation " e ⦃  x ⇠ v ⦄ " := (@set_env _ _ _ e x v).

(* find the value of x inside the environment t *)

Ltac find_val x t :=
  match t with
    | ?s⦃x⇠?v⦄ => v
    | ?s⦃_⇠_⦄ => find_val x s
  end.

Tactic Notation "rew" "env" :=
  repeat once lazymatch goal with
    |              |- context[ _⦃ ?x⇠_⦄⇢?x ] => rewrite get_set_env_eq  with (1 := eq_refl x)
    | _ : ?x = ?y  |- context[ _⦃ ?x⇠_⦄⇢?y ] => rewrite get_set_env_eq  with (p := x) (q := y)
    | _ : ?y = ?x  |- context[ _⦃ ?x⇠_⦄⇢?y ] => rewrite get_set_env_eq  with (p := x) (q := y)
    | _ : ?x <> ?y |- context[ _⦃ ?x⇠_⦄⇢?y ] => rewrite get_set_env_neq with (p := x) (q := y)
    | _ : ?y <> ?x |- context[ _⦃ ?x⇠_⦄⇢?y ] => rewrite get_set_env_neq with (p := x) (q := y)
    |              |- context[ _⦃ ?x⇠_⦄⇢?y ] => rewrite get_set_env_neq with (p := x) (q := y);
                                                  [ | discriminate ]
  end; auto.

(*
Tactic Notation "rew" "envi" :=
  repeat once lazymatch goal with
    | |- context f[ _[_/?l]#>?l ] => rewrite get_set_env_eq with (x := l)
    | _ : ?l <> ?m |- context f[ _[_/?l]#>?m ] => rewrite get_set_env_neq with (x := l) (y := m)
    | _ : ?m <> ?l |- context f[ _[_/?l]#>?m ] => rewrite get_set_env_neq with (x := l) (y := m)
    | |- context f[ _[_/?l]#>?m ] => rewrite get_set_env_neq with (x := l) (y := m); [ | discriminate ]
  end; auto.
*)

Tactic Notation "rew" "env" "in" hyp(H) := revert H; rew env; intros H.


Require Import Common
        ADTNotation.BuildADT ADTRefinement.Core
        ADTRefinement.SetoidMorphisms.

(* A notation-friendly version of the setoid morphisms
   infrastructure for ADT refinement. *)

Theorem refineADT_BuildADT_Rep consSigs methSigs oldRep newRep
      (AbsR : oldRep -> newRep -> Prop)
: @respectful_heteroT _ _ _ _
      (fun oldCons newCons =>
         forall consIdx,
           @refineConstructor oldRep newRep AbsR
                          _
                          (getConsDef oldCons consIdx)
                          (getConsDef newCons consIdx))
      (fun x y => @respectful_heteroT _ _ _ _
                    (fun oldMeth newMeth =>
                       forall methIdx,
                         @refineMethod oldRep newRep AbsR _ _
                                         (getMethDef oldMeth methIdx)
                                         (getMethDef newMeth methIdx))
                    (fun m m' => refineADT))
     (@BuildADT oldRep consSigs methSigs)
     (@BuildADT newRep consSigs methSigs).
 Proof.
   unfold Proper, respectful_heteroT; intros.
   let A := match goal with |- refineADT ?A ?B => constr:(A) end in
   let B := match goal with |- refineADT ?A ?B => constr:(B) end in
   eapply (@refinesADT _ A B AbsR);
     unfold id, pointwise_relation in *; simpl in *; intros; eauto.
 Qed.

Lemma refineADT_BuildADT_Both
      rep consigs methSigs
: forall oldCons newCons,
    (forall consIdx, @refineConstructor _ _ eq _
                                   (getConsDef oldCons consIdx)
                                   (getConsDef newCons consIdx))
    -> forall oldMeth newMeth,
         (forall methIdx, @refineMethod _ _ eq _ _
                                         (getMethDef oldMeth methIdx)
                                         (getMethDef newMeth methIdx))
         -> refineADT (@BuildADT rep consigs methSigs oldCons oldMeth)
                      (@BuildADT rep consigs methSigs newCons newMeth).
  intros; eapply refineADT_BuildADT_Rep; eauto; reflexivity.
Qed.

(*Add Parametric Morphism rep consigs methSigs
: (@BuildADT rep consigs methSigs)
    with signature
    (fun oldCons newCons =>
       forall consIdx, @refineConsator _ _ eq _
                                  (getConsDef oldCons consIdx)
                                  (getConsDef newCons consIdx))
      ==> (fun oldMeth newMeth =>
             forall methIdx, @refineMetherver _ _ eq _ _
                                         (getMethDef oldMeth methIdx)
                                         (getMethDef newMeth methIdx))
      ==> refineADT
      as refineADT_BuildADT_Both.
Proof.
  intros; apply refineADT_BuildADT_Both'.
Qed.*)