(* by Evelyne Contejean *)

(** * Term algebra defined as functor from a Module Signature and a Module Variable.*)
Require Import List.
From Cyclic_PA.Casteran Require Import more_list.
From Cyclic_PA.Casteran Require Import list_permut.
From Cyclic_PA.Casteran Require Import list_set.
Require Import Arith.

Set Implicit Arguments.

(** * Module Type Signature.
 There are almost no assumptions, except a decidable equality
and an arity function. *)
Module Type Signature.

Parameter symb : Set.
Axiom eq_symbol_dec : forall f1 f2 : symb, {f1 = f2} + {f1 <> f2}.

(** The arity of a symbol contains also the information about built-in theories as in CiME *)
Inductive arity_type : Set :=
  | AC : arity_type
  | C : arity_type
  | Free : nat -> arity_type.

Parameter arity : symb -> arity_type.
End Signature.

(** * Module Type Variables.
 There are almost no assumptions, except a decidable equality. *)
Module Type Variables.

Parameter var : Set.
Axiom eq_variable_dec : forall v1 v2 : var, {v1 = v2} + {v1 <> v2}.

End Variables.

(** * Module Type Term built from a signature and a set of variables. *)
Module Type Term.

Declare Module F : Signature.
Declare Module X : Variables.

Definition symbol := F.symb.
Definition variable := X.var.

Import F.
Import X.

(* Declare Module VSet : list_set.S with Definition DS.A := variable. *)

Ltac destruct_arity f n Af :=
generalize (refl_equal (arity f)); pattern f at 1; destruct (arity f) as [ |  | n]; intro Af.

(** Definition of terms.
Arity is not taken into account, and terms may be hill-formed. *)
Inductive term : Set :=
  | Var : variable -> term
  | Term : symbol -> list term -> term.

Definition direct_subterm t1 t2 : Prop :=
  match t2 with
  | Var _ => False
  | Term _ l => In t1 l
  end.

(** Definition and a few properties of the size of a term.*)
Fixpoint size (t:term) : nat :=
  match t with
  | Var v => 1
  | Term f l => 1 + fold_left (fun size_acc e => size_acc + size e) l 0
  end.

Axiom size_unfold :
 forall t, size t = match t with
                             | Var _ => 1
                             | Term f l => 1 + list_size size l
                           end.

Axiom size_ge_one : forall t, 1 <= size t.

Axiom size_direct_subterm :
 forall t1 t2, direct_subterm t1 t2 -> size t1 < size t2.

(** ** Recursion on terms. *)
Section Recursion.
Variable P : term -> Type.
Variable Pl : list term -> Type.

Axiom term_rec2 : (forall n t, size t <= n -> P t) -> forall t, P t.
Axiom term_rec3 :
  (forall v, P (Var v)) -> (forall f l, (forall t, In t l -> P t) -> P (Term f l)) -> forall t, P t.
Axiom term_rec4 :
  (forall v, P (Var v)) -> (forall f l, Pl l -> P (Term f l)) ->
  (forall l, (forall t, In t l -> P t) -> Pl l) -> forall t, P t.
End Recursion.

(** ** Double recursion on terms. *)
Section DoubleRecursion.
Variable P2 : term -> term -> Type.
Variable Pl2 : list term -> list term -> Type.

Axiom term_rec7 :
  (forall v1 t2, P2 (Var v1) t2) ->
               (forall t1 v2, P2 t1 (Var v2)) ->
               (forall f1 f2 l1 l2, Pl2 l1 l2 -> P2 (Term f1 l1) (Term f2 l2)) ->
               (forall l1 l2, (forall t1 t2, In t1 l1 -> In t2 l2 -> P2 t1 t2) -> Pl2 l1 l2) ->
               forall t1 t2, P2 t1 t2.

Axiom term_rec8 :
  (forall v1 t2, P2 (Var v1) t2) ->
               (forall t1 v2, P2 t1 (Var v2)) ->
               (forall f1 f2 l1 l2, Pl2 l1 l2 -> P2 (Term f1 l1) (Term f2 l2)) ->
               (forall l1 l2, (forall t1 t2, In t1 l1 -> In t2 l2 -> P2 t1 t2) -> Pl2 l1 l2) ->
               forall l1 l2, Pl2 l1 l2.
End DoubleRecursion.

(** ** Equality on terms is decidable. *)
Axiom eq_term_dec :  forall t1 t2:term, {t1 = t2} + {t1 <> t2}.
Declare Module Term_eq_dec : decidable_set.S with Definition A:= term
                                                             with Definition eq_A_dec := eq_term_dec.

(** ** Well-formedness of terms, according to the arity. *)
Fixpoint well_formed (t:term) : Prop :=
  match t with
  | Var _ => True
  | Term f l =>
     let well_formed_list :=
       (fix well_formed_list (l:list term) : Prop :=
       match l with
       | nil => True
       | h :: tl => well_formed h /\ well_formed_list tl
       end) in
       well_formed_list l /\
     (match arity f with
     | Free n => length l = n
     | _ => length l = 2
     end)
  end.

Axiom well_formed_unfold :
 forall t, well_formed t ->
 match t with
 | Var _ => True
 | Term f l =>
    (forall u, In u l -> well_formed u) /\
    (match arity f with
    | Free n => length l = n
    | _ => length l = 2
    end)
 end.

Axiom well_formed_fold :
 forall t,
 match t with
 | Var _ => True
 | Term f l =>
    (forall u, In u l -> well_formed u) /\
    (match arity f with
    | Free n => length l = n
    | _ => length l = 2
    end)
 end -> well_formed t.

Fixpoint well_formed_list (l : list term) : Prop :=
  match l with
  | nil => True
  | h :: tl => well_formed h /\ well_formed_list tl
  end.

(** ** Substitutions. *)
Definition substitution := list (variable * term).

Fixpoint apply_subst (sigma : substitution) (t : term) {struct t} : term :=
  match t with
  | Var v =>
    match find eq_variable_dec v sigma with
    | None => t
    | Some v_sigma => v_sigma
    end
  | Term f l => Term f (map (apply_subst sigma) l)
    end.

Axiom empty_subst_is_id : forall t, apply_subst nil t = t.
Axiom empty_subst_is_id_list : forall l, map (apply_subst nil) l = l.

(** Composition of substitutions. *)
Definition map_subst (f : variable -> term -> term) sigma :=
  map (fun x =>
            match (x : variable * term) with
            | (v, v_sigma) => (v, f v v_sigma)
            end)
            sigma.

Definition subst_comp sigma1 sigma2 :=
  (map_subst (fun _ t => apply_subst sigma1 t) sigma2)
  ++
  (map_subst (fun v t =>
                        match find eq_variable_dec v sigma2 with
                        | None => t
                        | Some v_sigma2 => apply_subst sigma1 v_sigma2
                        end)
                      sigma1).

Axiom subst_comp_is_subst_comp_aux1 :
  forall v sigma f,
  find eq_variable_dec v (map_subst f sigma) =
   match find eq_variable_dec v sigma with
   | None => None
   | Some t => Some (f v t)
  end.

Axiom subst_comp_is_subst_comp :
  forall sigma1 sigma2 t,
   apply_subst (subst_comp sigma1 sigma2) t =
   apply_subst sigma1 (apply_subst sigma2 t).

(** Well-formed substitutions. *)
Definition well_formed_subst sigma :=
  forall v, match find eq_variable_dec v sigma with
            | None => True
            | Some t => well_formed t
            end.

Axiom well_formed_apply_subst :
  forall sigma, well_formed_subst sigma ->
  forall t, well_formed t -> well_formed (apply_subst sigma t).

(** ** Positions in a term.*)
Fixpoint is_a_pos (t : term) (p : list nat) {struct p}: bool :=
  match p with
  | nil => true
  | i :: q =>
    match t with
    | Var _ => false
    | Term _ l =>
         match nth_error l i with
          | Some ti => is_a_pos ti q
          | None => false
          end
     end
  end.

Fixpoint subterm_at_pos (t : term) (p : list nat) {struct p}: option term :=
  match p with
  | nil => Some t
  | i :: q =>
    match t with
    | Var _ => None
    | Term _ l =>
         match nth_error l i with
          | Some ti => subterm_at_pos ti q
          | None => None
          end
    end
  end.

Axiom size_subterm_at_pos :
  forall t i p, match subterm_at_pos t (i :: p) with
	           | Some u => size u < size t
	           | None => True
	           end.

Axiom is_a_pos_exists_subtem :
  forall t p, is_a_pos t p = true -> exists u, subterm_at_pos t p = Some u.

Fixpoint replace_at_pos (t u : term) (p : list nat) {struct p} : term :=
  match p with
  | nil => u
  | i :: q =>
     match t with
     | Var _ => t
     | Term f l =>
        let replace_at_pos_list :=
         (fix replace_at_pos_list j (l : list term) {struct l}: list term :=
            match l with
            | nil => nil
            | h :: tl =>
                 match j with
                 | O => (replace_at_pos h u q) :: tl
                 | S k => h :: (replace_at_pos_list k tl)
                 end
            end) in
    Term f (replace_at_pos_list i l)
    end
  end.

Fixpoint replace_at_pos_list (l : list term) (u : term) (i : nat) (p : list nat)
 {struct l}: list term :=
  match l with
  | nil => nil
  | h :: tl =>
     match i with
     | O => (replace_at_pos h u p) :: tl
     | S j => h :: (replace_at_pos_list tl  u j p)
     end
  end.

Axiom replace_at_pos_unfold :
  forall f l u i q,
   replace_at_pos (Term f l) u (i :: q) = Term f (replace_at_pos_list l u i q).

Axiom replace_at_pos_is_replace_at_pos1 :
  forall t u p, is_a_pos t p = true ->
  subterm_at_pos (replace_at_pos t u p) p = Some u.

Axiom replace_at_pos_is_replace_at_pos2 :
  forall t p u, subterm_at_pos t p = Some u -> replace_at_pos t u p = t.

Axiom subterm_at_pos_apply_subst_apply_subst_subterm_at_pos :
  forall t p sigma,
  match subterm_at_pos t p with
  | Some u =>
        subterm_at_pos (apply_subst sigma t) p = Some (apply_subst sigma u)
  | None => True
end.

Axiom replace_at_pos_list_replace_at_pos_in_subterm :
forall l1 ui l2 u i p, length l1 = i ->
 replace_at_pos_list (l1 ++ ui :: l2) u i p =
 l1 ++ (replace_at_pos ui u p) :: l2.

End Term.

(** * A functor building a Term Module from a Signature and a set of Variables.*)

Module Make (F1 : Signature) (X1 : Variables) <:
     Term with Module F := F1 with Module X := X1.

Module F := F1.
Module X := X1.

Definition symbol := F.symb.
Definition variable := X.var.

Import F.
Import X.

Module DecVar <: decidable_set.S.
Definition A := variable.

Lemma eq_A_dec : forall x y : A, { x = y } + { x <> y }.
Proof.
apply eq_variable_dec.
Qed.

End DecVar.

Module VSet <: list_set.S with Definition DS.A := variable :=
list_set.Make (DecVar).

(** Definition of terms.
Arity is not taken into account, and terms may be ill-formed. *)
Inductive term : Set :=
  | Var : variable -> term
  | Term : symbol -> list term -> term.

Definition direct_subterm t1 t2 : Prop :=
  match t2 with
  | Var _ => False
  | Term _ l => In t1 l
  end.

(** Definition and a few properties of the size of a term.*)
Fixpoint size (t:term) : nat :=
  match t with
  | Var v => 1
  | Term f l => 1 + fold_left (fun size_acc e => size_acc + size e) l 0
  end.

Lemma size_unfold :
 forall t,
 size t = match t with
          | Var _ => 1
          | Term f l => 1 + list_size size l
          end.
Proof.
intro t; destruct t as [x | f l]; trivial.
simpl; rewrite list_size_fold; trivial.
Qed.

Lemma size_ge_one : forall t, 1 <= size t.
Proof.
destruct t as [ x | f l ]; trivial.
rewrite size_unfold; auto with arith.
Qed.

Lemma size_direct_subterm :
 forall t1 t2, direct_subterm t1 t2 -> size t1 < size t2.
Proof.
intros t1 t2; unfold direct_subterm; destruct t2 as [ x | f l ].
contradiction.
rewrite (size_unfold (Term f l)).
induction l as [ | t l]; simpl; intuition.
subst; auto with arith.
apply lt_le_trans with (1 + list_size size l); trivial;
simpl; auto with arith.
Qed.

(** ** Recursion on terms. *)
Section Recursion.
Variable P : term -> Type.
Variable Pl : list term -> Type.

Definition term_rec2 : (forall n t, size t <= n -> P t) -> forall t, P t.
Proof.
intros H t; apply (H (size t) t); apply le_n.
Qed.

Definition term_rec3 :
  (forall v, P (Var v)) -> (forall f l, (forall t, In t l -> P t) -> P (Term f l)) -> forall t, P t.
Proof.
intros Hvar Hterm; apply term_rec2; induction n; intros t Size_t.
absurd (1 <= 0); auto with arith;
apply le_trans with (size t); trivial; apply size_ge_one.
destruct t as [ x | f l ]; trivial;
apply Hterm; intros; apply IHn;
apply lt_n_Sm_le;
apply lt_le_trans with (size (Term f l)); trivial;
apply size_direct_subterm; trivial.
Qed.

Definition term_rec4 :
  (forall v, P (Var v)) -> (forall f l, Pl l -> P (Term f l)) ->
  (forall l, (forall t, In t l -> P t) -> Pl l) -> forall t, P t.
Proof.
intros Hvar Hterm Hlist; apply term_rec2;
induction n; intros t Size_t.
absurd (1<=0); auto with arith;
apply le_trans with (size t); trivial; apply size_ge_one.
destruct t as [ x | f l ]; trivial;
apply Hterm; apply Hlist; intros t In_t; apply IHn;
apply lt_n_Sm_le;
apply lt_le_trans with (size (Term f l)); trivial;
apply size_direct_subterm; trivial.
Qed.
End Recursion.

(** ** Double recursion on terms. *)
Section DoubleRecursion.
Variable P2 : term -> term -> Type.
Variable Pl2 : list term -> list term -> Type.

Definition term_rec7 :
  (forall v1 t2, P2 (Var v1) t2) ->
               (forall t1 v2, P2 t1 (Var v2)) ->
               (forall f1 f2 l1 l2, Pl2 l1 l2 -> P2 (Term f1 l1) (Term f2 l2)) ->
               (forall l1 l2, (forall t1 t2, In t1 l1 -> In t2 l2 -> P2 t1 t2) -> Pl2 l1 l2) ->
               forall t1 t2, P2 t1 t2.
Proof.
intros Hvt Htv Hterm Hlist.
intro t1; pattern t1; apply term_rec2; induction n; clear t1;
intros t1 Size_t1.
absurd (1<=0); auto with arith;
apply le_trans with (size t1); trivial; apply size_ge_one.
destruct t1 as [ x1 | f1 l1 ]; trivial.
destruct t2 as [ x2 | f2 l2 ]; trivial.
apply Hterm; apply Hlist; intros t1 t2 In_t1 In_t2; apply IHn;
apply lt_n_Sm_le;
apply lt_le_trans with (size (Term f1 l1)); trivial;
apply size_direct_subterm; trivial.
Qed.

Definition term_rec8 :
  (forall v1 t2, P2 (Var v1) t2) ->
               (forall t1 v2, P2 t1 (Var v2)) ->
               (forall f1 f2 l1 l2, Pl2 l1 l2 -> P2 (Term f1 l1) (Term f2 l2)) ->
               (forall l1 l2, (forall t1 t2, In t1 l1 -> In t2 l2 -> P2 t1 t2) -> Pl2 l1 l2) ->
               forall l1 l2, Pl2 l1 l2.
Proof.
intros Hvt Htv Hterm Hlist l1 l2;
apply Hlist;
intros; apply term_rec7; trivial.
Defined.
End DoubleRecursion.

(** ** Equality on terms is decidable. *)
Theorem eq_term_dec :
  forall t1 t2:term, {t1 = t2} + {t1 <> t2}.
Proof.
intro t1; pattern t1; apply term_rec3.
intro x1; destruct t2 as [ x2 | f2 l2].
destruct (eq_variable_dec x1 x2) as  [x1_eq_x2 | x1_diff_x2].
left; subst; trivial.
right; intro H; apply x1_diff_x2; inversion H; trivial.
right; discriminate.
intros f1 l1 Hrec t2; destruct t2 as [x2 | f2 l2].
right; discriminate.
destruct (eq_symbol_dec f1 f2) as  [f1_eq_f2 | f1_diff_f2].

subst; assert (Hrec_list : forall l2, {l1 = l2} + {l1 <> l2}).
clear f2 l2; induction l1 as [ | a1 l1].
intro l2; destruct l2 as [ | a2 l2]; [left; trivial | right; discriminate].
intro l2; destruct l2 as [ | a2 l2].
right; discriminate.
assert (In_a1 : In a1 (a1 :: l1)). left; trivial.
destruct (Hrec a1 In_a1 a2) as  [a1_eq_a2 | a1_diff_a2].
assert (Hrec_l1 : forall t, In t l1 -> forall t2, {t = t2} + {t <> t2}).
intros; apply Hrec; right; trivial.
subst; destruct (IHl1 Hrec_l1 l2) as  [l1_eq_l2 | l1_diff_l2];
[ left; subst
| right; intro H; apply l1_diff_l2; inversion H] ; trivial.
right; intro H; apply a1_diff_a2; inversion H; trivial.

destruct (Hrec_list l2) as  [l1_eq_l2 | l1_diff_l2];
[ left; subst
| right; intro H; apply l1_diff_l2; inversion H] ; trivial.
right; intro H; apply f1_diff_f2; inversion H; trivial.
Qed.

Module Term_eq_dec : decidable_set.S with Definition A:= term
                                                             with Definition eq_A_dec := eq_term_dec.
Definition A := term.
Definition eq_A_dec := eq_term_dec.
End Term_eq_dec.

(** ** Well-formedness of terms, according to the arity. *)
Fixpoint well_formed (t:term) : Prop :=
  match t with
  | Var _ => True
  | Term f l =>
     let well_formed_list :=
       (fix well_formed_list (l:list term) : Prop :=
       match l with
       | nil => True
       | h :: tl => well_formed h /\ well_formed_list tl
       end) in
       well_formed_list l /\
     (match arity f with
     | Free n => length l = n
     | _ => length l = 2
     end)
  end.

Lemma well_formed_unfold :
 forall t, well_formed t ->
 match t with
 | Var _ => True
 | Term f l =>
    (forall u, In u l -> well_formed u) /\
    (match arity f with
    | Free n => length l = n
    | _ => length l = 2
    end)
 end.
Proof.
intros t; destruct t as [ x | f l ]; trivial.
intros [Wl A]; split; trivial.
clear A; induction l as [ | t l].
contradiction.
generalize Wl; clear Wl; intros [Wa Wl] u [Eq_u_a | In_u].
subst u; trivial.
apply IHl; trivial.
Qed.

Lemma well_formed_fold :
 forall t,
 match t with
 | Var _ => True
 | Term f l =>
    (forall u, In u l -> well_formed u) /\
    (match arity f with
    | Free n => length l = n
    | _ => length l = 2
    end)
 end -> well_formed t.
Proof.
intros t; destruct t as [ x | f l ]; trivial.
intros [Wl A]; split ; trivial; clear A; induction l as [ | t l]; trivial; split.
apply Wl; left; trivial.
apply IHl; intros; apply Wl; right; trivial.
Qed.

Fixpoint well_formed_list (l : list term) : Prop :=
  match l with
  | nil => True
  | h :: tl => well_formed h /\ well_formed_list tl
  end.

(** ** Substitutions. *)
Definition substitution := list (variable * term).

Fixpoint apply_subst (sigma : substitution) (t : term) {struct t} : term :=
  match t with
  | Var v =>
    match find eq_variable_dec v sigma with
    | None => t
    | Some v_sigma => v_sigma
    end
  | Term f l => Term f (map (apply_subst sigma) l)
    end.

Lemma empty_subst_is_id : forall t, apply_subst nil t = t.
Proof.
intro t; pattern t; apply term_rec3; clear t; trivial.
intros f l IH; simpl; apply (f_equal (fun l => Term f l));
induction l as [ | t l]; trivial; simpl; rewrite (IH t).
rewrite IHl; trivial.
intros; apply IH; right; trivial.
left; trivial.
Qed.

Lemma empty_subst_is_id_list : forall l, map (apply_subst nil) l = l.
Proof.
intro l; induction l as [ | t l]; simpl;
[idtac | rewrite empty_subst_is_id; rewrite IHl];
trivial.
Qed.

(** Composition of substitutions. *)
Definition map_subst (f : variable -> term -> term) sigma :=
  map (fun x =>
            match (x : variable * term) with
            | (v, v_sigma) => (v, f v v_sigma)
            end)
            sigma.

Definition subst_comp sigma1 sigma2 :=
  (map_subst (fun _ t => apply_subst sigma1 t) sigma2)
  ++
  (map_subst (fun v t =>
                        match find eq_variable_dec v sigma2 with
                        | None => t
                        | Some v_sigma2 => apply_subst sigma1 v_sigma2
                        end)
                      sigma1).

Lemma subst_comp_is_subst_comp_aux1 :
  forall v sigma f,
  find eq_variable_dec v (map_subst f sigma) =
   match find eq_variable_dec v sigma with
   | None => None
   | Some t => Some (f v t)
  end.
Proof.
intros v sigma f; induction sigma as [ | [v1 a1] sigma ].
simpl; trivial.
simpl; elim (eq_variable_dec v v1); intro v_eq_v1; trivial;
subst v; trivial.
Qed.

Lemma subst_comp_is_subst_comp_aux2 :
  forall v sigma1 sigma2,
  find (B:= term) eq_variable_dec v (sigma1 ++ sigma2)  =
  match find eq_variable_dec v sigma1 with
  | Some _ => find eq_variable_dec v sigma1
  | None => find eq_variable_dec v sigma2
  end.
Proof.
intros v sigma1 sigma2;
induction sigma1 as [ | [v1 a1] sigma1] ; trivial.
simpl; elim (eq_variable_dec v v1); intro v_eq_v1; trivial.
Qed.

Theorem subst_comp_is_subst_comp :
  forall sigma1 sigma2 t,
   apply_subst (subst_comp sigma1 sigma2) t =
   apply_subst sigma1 (apply_subst sigma2 t).
Proof.
intros sigma1 sigma2 t; pattern t; apply term_rec3; clear t.
intro v; unfold subst_comp;
simpl; rewrite subst_comp_is_subst_comp_aux2;
do 2 rewrite subst_comp_is_subst_comp_aux1;
destruct (find eq_variable_dec v sigma2); trivial; simpl;
destruct (find eq_variable_dec v sigma1); trivial.
intros f l IH; simpl; apply (f_equal (fun l => Term f l));
induction l as [ | a l]; trivial.
simpl; rewrite (IH a).
rewrite IHl; trivial.
intros; apply IH; right; trivial.
left; trivial.
Qed.

(** Well-formed substitutions. *)
Definition well_formed_subst sigma :=
  forall v, match find eq_variable_dec v sigma with
            | None => True
            | Some t => well_formed t
            end.

Theorem well_formed_apply_subst :
  forall sigma, well_formed_subst sigma ->
  forall t, well_formed t -> well_formed (apply_subst sigma t).
Proof.
intros sigma W_sigma t; pattern t;
apply term_rec3.
intros v _; simpl; generalize (W_sigma v);
destruct (find eq_variable_dec v sigma); trivial.
intros f l Hrec [Wl A]; split.
clear A; induction l as [ | a l]; simpl; trivial;
inversion_clear Wl as [Wa Wl']; split.
apply Hrec; trivial; left; trivial.
apply IHl; trivial; intros; apply Hrec; trivial; right; trivial.
rewrite length_map; trivial.
Qed.

(** ** Positions in a term.*)
Fixpoint is_a_pos (t : term) (p : list nat) {struct p}: bool :=
  match p with
  | nil => true
  | i :: q =>
    match t with
    | Var _ => false
    | Term _ l =>
         match nth_error l i with
          | Some ti => is_a_pos ti q
          | None => false
          end
     end
  end.

Fixpoint subterm_at_pos (t : term) (p : list nat) {struct p}: option term :=
  match p with
  | nil => Some t
  | i :: q =>
    match t with
    | Var _ => None
    | Term _ l =>
         match nth_error l i with
          | Some ti => subterm_at_pos ti q
          | None => None
          end
    end
  end.

Lemma size_subterm_at_pos :
  forall t i p, match subterm_at_pos t (i :: p) with
	           | Some u => size u < size t
	           | None => True
	           end.
Proof.
intros t i p; generalize t i; clear t i; induction p as [ | j p].
intros [ v | f l ] j; simpl subterm_at_pos; cbv iota beta; trivial.
generalize (nth_error_ok_in j l); destruct (nth_error l j) as [tj | ]; [idtac | trivial].
intro H; apply size_direct_subterm; simpl; apply H; trivial.
intros [ v | f l ] i; simpl subterm_at_pos; cbv iota beta; trivial.
generalize (nth_error_ok_in i l); destruct (nth_error l i) as [ti | ]; [idtac | trivial].
intro ti_in_l; generalize (IHp ti j); simpl subterm_at_pos;
destruct ti as [vi | fi li]; trivial.
generalize (nth_error_ok_in j li); destruct (nth_error li j) as [tij | ]; [idtac | trivial].
intro tij_in_li; destruct (subterm_at_pos tij p) as [ u | ]; trivial.
intro H; apply lt_trans with (size (Term fi li)); trivial.
apply size_direct_subterm; simpl; apply ti_in_l; trivial.
Qed.

Lemma is_a_pos_exists_subtem :
  forall t p, is_a_pos t p = true -> exists u, subterm_at_pos t p = Some u.
Proof.
intros t p; generalize t; clear t; induction p as [ | i q ].
intros t _; exists t; trivial.
intros t; destruct t as [ x | f l ]; simpl.
intros; discriminate.
destruct (nth_error l i) as [ ti | ].
intro; apply IHq; trivial.
intros; discriminate.
Qed.

Fixpoint replace_at_pos (t u : term) (p : list nat) {struct p} : term :=
  match p with
  | nil => u
  | i :: q =>
     match t with
     | Var _ => t
     | Term f l =>
        let replace_at_pos_list :=
         (fix replace_at_pos_list j (l : list term) {struct l}: list term :=
            match l with
            | nil => nil
            | h :: tl =>
                 match j with
                 | O => (replace_at_pos h u q) :: tl
                 | S k => h :: (replace_at_pos_list k tl)
                 end
            end) in
    Term f (replace_at_pos_list i l)
    end
  end.

Fixpoint replace_at_pos_list (l : list term) (u : term) (i : nat) (p : list nat)
 {struct l}: list term :=
  match l with
  | nil => nil
  | h :: tl =>
     match i with
     | O => (replace_at_pos h u p) :: tl
     | S j => h :: (replace_at_pos_list tl  u j p)
     end
  end.

Lemma replace_at_pos_unfold :
  forall f l u i q,
   replace_at_pos (Term f l) u (i :: q) = Term f (replace_at_pos_list l u i q).
Proof.
intros f l u i q; simpl; apply (f_equal (fun l => Term f l));
generalize u i q; clear u i q;
induction l as [| t l]; intros u i q; trivial.
simpl; destruct i as [ | i ]; trivial.
rewrite <- IHl; trivial.
Qed.

Lemma replace_at_pos_is_replace_at_pos1 :
  forall t u p, is_a_pos t p = true ->
  subterm_at_pos (replace_at_pos t u p) p = Some u.
Proof.
intro t; pattern t; apply term_rec3; clear t.
intros x u p; destruct p as [ | i q ]; trivial;
intros; discriminate.
intros f l IHl u p; destruct p as [ | i q ]; trivial.
rewrite replace_at_pos_unfold; simpl; generalize i q; clear i q;
induction l as [ | t l ]; intros i q.
destruct i as [ | i ]; simpl; intros; discriminate.
destruct i as [ | i ]; simpl.
intros; apply (IHl t); trivial; left; trivial.
intros; apply IHl0; intros; trivial; apply IHl; trivial; right; trivial.
Qed.

Lemma replace_at_pos_is_replace_at_pos2 :
  forall t p u, subterm_at_pos t p = Some u -> replace_at_pos t u p = t.
Proof.
intro t; pattern t; apply term_rec3; clear t.
intros v p u; destruct p as [ | i q ]; intro H; inversion_clear H; trivial.
intros f l IHl p; destruct p as [ | i q ].
intros u H; inversion_clear H; trivial.
intros u H; rewrite replace_at_pos_unfold;
apply (f_equal (fun l => Term f l)); generalize i q u H; clear i q u H;
induction l as [ | t l ]; intros i q u H.
destruct i as [ | i ]; simpl; intros; discriminate.
destruct i as [ | i ]; simpl.
rewrite IHl; trivial; left; trivial.
rewrite IHl0; trivial; intros; apply IHl; trivial; right; trivial.
Qed.

Lemma subterm_at_pos_apply_subst_apply_subst_subterm_at_pos :
  forall t p sigma,
  match subterm_at_pos t p with
  | Some u =>
        subterm_at_pos (apply_subst sigma t) p = Some (apply_subst sigma u)
  | None => True
end.
Proof.
intro t; pattern t; apply term_rec3; clear t.
intros v p; destruct p as [ | i q ]; simpl; trivial.
intros f l IHl p; destruct p as [ | i q ]; simpl; trivial.
assert (H : forall (l : list term) i,
                     match nth_error l i with
                                | Some li => In li l
                                | None => True end).
clear IHl l i; intro l;
induction l as [ | t l ]; intro i; destruct i as [ | i ]; simpl; trivial.
left; trivial.
generalize (IHl i); destruct (nth_error l i); trivial; intros; right; trivial.
generalize i; clear i; induction l as [ | l ll ];
intros i; destruct i as [ | i ]; simpl; trivial.
intros; apply IHl; left; trivial.
intro sigma; apply IHll; intros; apply IHl; right; trivial.
Qed.

Lemma replace_at_pos_list_replace_at_pos_in_subterm :
forall l1 ui l2 u i p, length l1 = i ->
 replace_at_pos_list (l1 ++ ui :: l2) u i p =
 l1 ++ (replace_at_pos ui u p) :: l2.
Proof.
intros l1; induction l1 as [ | u1 l1 ]; intros ui l2 u i p L; simpl in L.
subst i; trivial.
destruct i as [ | i ].
discriminate.
simpl; rewrite IHl1; trivial.
inversion L; trivial.
Qed.

End Make.


(* The PRP PRF switching lemma.  This proof uses the outdated state-related definitions.  We need to update this proof to use the definitions and theory in Procedure.v *)

Set Implicit Arguments.

Require Import Crypto.
Require Import Permutation.
Require Import ConstructedFunc.
Require Import State.

Local Open Scope list_scope.
Local Open Scope array_scope.

(* We start by extending the theory of constructed permutations with a notion of "bad" permutations.  A permutation is "bad" if, at some point in the past, it attempted to choose a new value for its range, and on the first attempt it produced a value that is already in its range. *)
Section PRP_PRF.
  Variable n : nat. (* bit vector length *)

  Hint Resolve getUnusedR_wf : wftac.
  Hint Resolve well_formed_perm_1 : wftac.

  Definition getUnusedBvector := @getUnusedR (Bvector n) _ _ (Rnd n).
  Definition well_formed_Bvector_perm := @well_formed_perm (Bvector n) _ _ _ (Rnd n).
  Definition randomPerm_Bvector := @randomPerm (Bvector n) _ _ _ (Rnd n).

  Lemma getUnusedBvector_wf_h : forall ls r,
       inRange _ ls r = false ->
       well_formed_comp (getUnusedBvector ls).

    intuition.
    eapply getUnusedR_wf; wftac.
    simpl.
    eapply in_getAllBvectors.
  Qed.

  Theorem getUnusedBvector_wf : forall ls d,
       well_formed_Bvector_perm ls ->
       ls # d = None ->
       well_formed_comp (getUnusedBvector ls).

    intuition.
    eapply well_formed_perm_1 in H.
    destruct H.
    intuition.
    unfold getUnusedBvector.
    eapply getUnusedR_wf; wftac.
    eauto.
  Qed.
  Hint Resolve getUnusedBvector_wf : wftac.

  (* A random permutation in which the loop that gets an unused value from the range is unrolled one step.  This is useful when comparing to a random function. *)
  Definition randomPerm_unroll(p : (list (Bvector n * Bvector n)) * Bvector n) : Comp (list (Bvector n * Bvector n) * Bvector n) :=
    let (f, d) := p in
    match f#d with
      | None => (r <-$ (r0 <-$ {0, 1}^n; if (negb (inRange _ f r0)) then ret r0 else getUnusedBvector f) ; ret ((d, r) :: f, r))
      | Some r => ret (f, r)
    end.

   Lemma randomPerm_unroll_wf : forall ls b0,
    (forall x, ls#x = None -> exists r, inRange _ ls r = false) ->
    well_formed_comp (randomPerm_unroll (ls, b0)).

    intuition.
    unfold randomPerm_unroll.
    case_eq (ls#b0); intuition; wftac.
    edestruct H; eauto.
    eapply getUnusedBvector_wf_h.
    eauto.
  Qed.

  (* A random permutation in which the loop that gets an unused value form the range is unrolled one step and the permutation keeps track of whether the first attempt located a value that is already in the range.  This is useful when comparing to a random function. *)
  Definition randomPerm_bad(p : (list (Bvector n * Bvector n)) *  Bvector n) : Comp (list (Bvector n * Bvector n) * Bvector n) :=
    let (f, d) := p in
    match f#d with
      | None =>
        r0 <-$ {0,1} ^ n;
        r <-$ if (negb (inRange _ f r0)) then ret r0 else getUnusedBvector f;
          ret (if (inRange _ f r0) then ((d, r) :: (d, r0) :: f) else ((d, r) :: f), r)
      | Some r => ret (f, r)
    end.

  Fixpoint checkBad(f : list (Bvector n * Bvector n)) : bool :=
    match f with
      | nil => false
      | (d, r) :: f' =>
        orb (inRange _ f' r) (checkBad f')
    end.

  Lemma randomPerm_bad_wf : forall ls d,
    well_formed_Bvector_perm ls ->
    well_formed_comp (randomPerm_bad (ls, d)).

    intuition.
    unfold randomPerm_bad.
    case_eq (ls#d); intuition.
    wftac.
    wftac.
  Qed.
  Hint Resolve randomPerm_bad_wf : wftac.

  Lemma randomPerm_eq_unroll : forall s d x,
    well_formed_Bvector_perm s ->
    evalDist (randomPerm_Bvector (s, d)) x ==
    evalDist (randomPerm_unroll (s, d)) x.

    intuition.
    unfold randomPerm_Bvector, randomPerm, randomPerm_unroll.
    case_eq (s#d); intuition.
    unfold getUnusedR.
    comp_skip.
    eapply repeat_unroll_eq; wftac.
    eapply well_formed_perm_1 in H; eauto.
    destruct H.
    exists x0.
    eapply filter_In; intuition.
    destruct (inRange _ s x0); intuition.
  Qed.

  Lemma randomPerm_unroll_preserves_wf : forall ls d ls' r,
    well_formed_Bvector_perm ls ->
    In (ls', r) (getSupport (randomPerm_unroll (ls, d))) ->
    well_formed_Bvector_perm ls'.

    intuition.
    unfold randomPerm_unroll in *.
    case_eq (ls#d); intuition.
    rewrite H1 in H0.
    simpl in *.
    intuition.
    inversion H2; clear H2; subst.
    trivial.

    rewrite H1 in H0.
    apply getSupport_Bind_In in H0.
    destruct H0.
    intuition.
    apply getSupport_Bind_In in H2.
    destruct H2.
    intuition.
    simpl in H3.
    intuition.
    inversion H0; clear H0; subst.
    case_eq (inRange _ ls x0); intuition;
    rewrite H0 in H4.
    simpl in *.
    apply filter_In in H4.
    intuition.
    eapply well_formed_perm_cons; eauto.
    destruct (inRange _ ls r); intuition.
    simpl in *.
    intuition. subst.
    eapply well_formed_perm_cons; eauto.

  Qed.

  Lemma randomPerm_unroll_preserves_wf_pair : forall ls d p,
    well_formed_Bvector_perm ls ->
    In p (getSupport (randomPerm_unroll (ls, d))) ->
    well_formed_Bvector_perm (fst p).

    intuition.
    destruct p.
    eapply randomPerm_unroll_preserves_wf; eauto.
  Qed.

  Lemma randomPerm_bad_preserves_wf : forall ls d ls' r,
    well_formed_Bvector_perm ls ->
    In (ls', r) (getSupport (randomPerm_bad (ls, d))) ->
    well_formed_Bvector_perm ls'.

    intuition.
    unfold randomPerm_bad in *.
    case_eq (ls#d); intuition;
    rewrite H1 in H0.
    simp_in_support.
    trivial.

    simp_in_support.
    case_eq (inRange _ ls x); intuition;
    rewrite H0 in H3.
    simp_in_support.
    simpl in *.
    intuition.
    inversion H3; clear H3; subst.
    apply filter_In in H4.
    intuition.
    unfold well_formed_Bvector_perm, well_formed_perm in *.
    intuition.
    destruct (in_dec (EqDec_dec _) d lsd).
    specialize (H6 d).
    intuition.
    simpl in *.
    rewrite eqbBvector_complete in H7.
    discriminate.
    edestruct (H (d :: lsd)).
    econstructor; trivial.
    intuition.
    simpl in H7.
    intuition. subst.
    trivial.
    specialize (H6 d0).
    intuition.
    simpl in H7.
    destruct (eqbBvector d0 d).
    discriminate.
    trivial.

    intuition.
    destruct (in_dec (EqDec_dec _) r x0).
    exists (removeFirst (EqDec_dec _) x0 r).
    intuition.
    simpl.
    case_eq (eqbBvector r0 r); intuition.
    apply eqbBvector_sound in H11.
    subst.
    exfalso.
    eapply removeFirst_NoDup_not_in; eauto.

    case_eq (eqbBvector r0 x); intuition.
    apply eqbBvector_sound in H12.
    subst.
    assert (inRange  _ ls x = false).
    eapply H8.
    eapply removeFirst_in_iff.
    eauto.
    congruence.
    eapply H8.
    eapply removeFirst_in_iff.
    eauto.
    simpl.
    eapply in_getAllBvectors.
    eapply removeFirst_NoDup.
    trivial.
    eapply eq_add_S.
    simpl in H10.
    rewrite H10.
    symmetry.
    eapply removeFirst_length.
    trivial.

    destruct x0.
    simpl in *.
    omega.
    exists x0.
    intuition.
    simpl.
    simpl in n1.
    intuition.
    case_eq (eqbBvector r0 r); intuition.
    apply eqbBvector_sound in H13.
    subst.
    intuition.
    case_eq (eqbBvector r0 x); intuition.
    apply eqbBvector_sound in H14.
    subst.
    assert (inRange _ ls x = false).
    eapply H8.
    simpl.
    right.
    trivial.
    congruence.
    eapply H8.
    simpl.
    intuition.
    simpl.
    eapply in_getAllBvectors.
    inversion H7; clear H7; subst.
    trivial.

    repeat simp_in_support.
    eapply well_formed_perm_cons; trivial.

    simpl in *.
    discriminate.
  Qed.

  Lemma randomPerm_bad_preserves_wf_pair : forall ls d p,
    well_formed_Bvector_perm ls ->
    In p (getSupport (randomPerm_bad (ls, d))) ->
    well_formed_Bvector_perm (fst p).

    intuition.
    destruct p.
    eapply randomPerm_bad_preserves_wf; eauto.
  Qed.

  Definition Bvector_perms_eq := @perms_eq (Bvector n) _ _ _ (Rnd n).

  Lemma randomPerm_unroll_bad_inv :
    comp_spec
    (fun p1 p2 => (snd p1) = (snd p2) /\ Bvector_perms_eq (fst p1) (fst p2))
    (fun p1 p2 => (snd p1) = (snd p2) /\ Bvector_perms_eq (fst p1) (fst p2))
    randomPerm_unroll randomPerm_bad.

    unfold comp_spec.

    intuition.
    simpl in H1.
    subst.
    unfold randomPerm_unroll, randomPerm_bad.
    unfold Bvector_perms_eq, perms_eq, funcs_eq in *.
    intuition.
    destruct d2.
    unfold snd.
    simpl in H3.

    rewrite H3.
    case_eq (l # b); intuition.

    comp_simp.
    eapply H0; intuition.

    unfold randomPerm_unroll.
    simpl.
    rewrite H3.
    rewrite H4.
    simpl.
    intuition.

    unfold randomPerm_bad.
    rewrite H4.
    simpl.
    intuition.

    inline_first.
    comp_skip.
    inline_first.

    unfold fst, snd in H5.
    rewrite H5.
    case_eq (inRange _ l r2); intuition; unfold negb.
    comp_skip.
    eapply getUnusedR_eq; intuition.

    comp_simp.
    eapply H0; intuition; unfold fst.
    eapply well_formed_perm_cons; trivial.
    rewrite H3.
    trivial.
    eapply getUnusedR_not_inRange.
    rewrite H3.
    eauto.
    eauto.

    eapply well_formed_perm_cons_2; intuition.
    simpl.
    destruct (eqbBvector d b); intuition.
    simpl.
    case_eq (eqbBvector r r0); intuition.
    case_eq (eqbBvector r r2); intuition.
    apply eqbBvector_sound in H12.
    subst.
    rewrite H5.
    trivial.

    unfold snd.

    eapply getSupport_In_evalDist.
    intuition.
    eapply getSupport_In_evalDist.
    eapply (@inSupportRandomPerm (Bvector n) (Bvector n)).
    eauto.
    rewrite H3.
    eauto.
    rewrite randomPerm_eq_unroll.
    trivial.
    simpl in H1.
    trivial.

    Theorem inSupportRandomPerm_bad :
      forall a b r1 r2,
        In r1 (getSupport (getUnusedBvector a)) ->
        inRange _ a r2  = true ->
        a # b = None ->
        In ((b, r1) :: (b, r2) :: a, r1) (getSupport (randomPerm_bad (a, b))).

      intuition.
      unfold randomPerm_bad.
      rewrite H1.
      eapply getSupport_In_Seq.
      simpl.
      eapply (in_getAllBvectors r2).
      eapply getSupport_In_Seq.
      rewrite H0.
      unfold negb.
      eauto.
      rewrite H0.
      simpl.
      intuition.
    Qed.

    eapply inSupportRandomPerm_bad; eauto.

    comp_simp.

    eapply H0; intuition; unfold fst.
    eapply well_formed_perm_cons; intuition.
    rewrite H3.
    trivial.
    rewrite H5.
    trivial.
    eapply well_formed_perm_cons; eauto.
    simpl.
    rewrite H3.
    trivial.
    simpl.
    rewrite H5.
    trivial.

    unfold snd.
    eapply getSupport_In_evalDist.
    intuition.
    eapply getSupport_In_evalDist.
    eapply (@inSupportRandomPerm (Bvector n) (Bvector n)).

    simpl.
    eapply filter_In.
    split.
    eapply H8.

    instantiate (1:=a).
    rewrite H5.
    rewrite H6.
    trivial.
    rewrite H3.
    eauto.

    rewrite randomPerm_eq_unroll.
    trivial.
    simpl in H1.
    trivial.

     Theorem inSupportRandomPerm_bad_1 :
      forall a b r1,
        In r1 (getSupport (getUnusedBvector a)) ->
        a # b = None ->
        In ((b, r1) :: a, r1) (getSupport (randomPerm_bad (a, b))).

      intuition.
      unfold randomPerm_bad.
      rewrite H0.
      eapply getSupport_In_Seq.
      simpl.
      eapply (in_getAllBvectors r1).
      eapply getSupport_In_Seq.
      erewrite getUnusedR_not_inRange.
      simpl.
      intuition.
      eauto.
      eauto.
      erewrite getUnusedR_not_inRange.
      simpl.
      intuition.
      eauto.
      eauto.
    Qed.

     eapply inSupportRandomPerm_bad_1; eauto.
     simpl.
     eapply filter_In.
     split.
     eapply in_getAllBvectors.
     rewrite H6.
     trivial.

  Qed.

  Lemma filter_eq : forall (A : Set)(ls : list A)(P1 P2 : A -> bool),
    (forall a, In a ls -> P1 a = P2 a) ->
    filter P1 ls = filter P2 ls.

    induction ls; intuition; simpl in *.
    rewrite (H a); intuition.
    destruct (P2 a).
    f_equal.
    eapply IHls; intuition.
    eapply IHls; intuition.
  Qed.

  Lemma randomPerm_bad_preserves_bad : forall ls ls' v r,
    checkBad ls = true ->
    In (ls', r) (getSupport (randomPerm_bad (ls, v))) ->
    checkBad ls' = true.

    intuition.
    unfold randomPerm_bad in *.
    case_eq (ls # v); intuition;
      rewrite H1 in H0.
    simp_in_support.
    trivial.
    repeat simp_in_support.
    simpl.
    rewrite H.
    eapply orb_true_r.
    case_eq (inRange _ ls x); intuition.
    simpl.
    rewrite H.
    rewrite orb_true_r.
    eapply orb_true_r.
    simpl.
    rewrite H.
    eapply orb_true_r.

  Qed.

  Definition randomFunc_Bvector := @randomFunc (Bvector n) _ _ _ (Rnd n).

  Lemma randomFunc_preserves_bad : forall ls ls' v r,
    checkBad ls = true ->
    In (ls', r) (getSupport (randomFunc_Bvector (ls, v))) ->
    checkBad ls' = true.

    intuition.
    unfold randomFunc_Bvector, randomFunc in *.
    case_eq (ls # v); intuition;
      rewrite H1 in H0.
    simp_in_support.
    trivial.

    repeat simp_in_support.
    simpl.
    rewrite H.
    eapply orb_true_r.

  Qed.

  Lemma perm_func_bad_spec :
    comp_spec
      (fun p1 p2 => checkBad (fst p1) = true /\ checkBad (fst p2) = true /\ well_formed_Bvector_perm (fst p2))
      (fun p1 p2 => checkBad (fst p1) = true /\ checkBad (fst p2) = true /\ well_formed_Bvector_perm (fst p2))
      (randomFunc_Bvector)
      randomPerm_bad.

    intuition.
    unfold comp_spec.
    intuition.

    unfold randomFunc_Bvector, randomFunc, randomPerm_bad.
    destruct d2.
    case_eq (a # b); intuition; case_eq (l # b0); intuition.

    comp_simp.
    eapply H2; intuition.
    unfold randomFunc_Bvector, randomFunc.
    rewrite H4.
    simpl.
    intuition.
    unfold randomPerm_bad.
    rewrite H5.
    simpl.
    intuition.

    inline_first.
    comp_irr_r; wftac.
    inline_first.
    case_eq (inRange _ l x); intuition; unfold negb.
    comp_irr_r; wftac.
    comp_simp.
    eapply H2; intuition.

    simpl.
    destruct (eqbBvector x0 x); intuition.
    unfold fst.
    eapply well_formed_perm_cons_2; intuition.

    unfold randomFunc_Bvector, randomFunc.
    rewrite H4.
    simpl.
    intuition.

    eapply inSupportRandomPerm_bad; eauto.

    comp_simp.
    eapply H2; intuition.
    unfold fst.
    simpl.
    simpl in H0.
    rewrite H0.
    eapply orb_true_r.
    unfold fst in *.
    eapply well_formed_perm_cons; intuition.

    unfold randomFunc_Bvector, randomFunc.
    rewrite H4.
    simpl.
    intuition.
    eapply inSupportRandomPerm_bad_1; eauto.
    simpl.
    eapply filter_In.
    intuition.
    rewrite H7.
    trivial.

    comp_simp.
    inline_first.
    comp_irr_l.
    wftac.
    eapply H2; intuition.
    simpl in *.
    rewrite H1.
    eapply orb_true_r.

    eapply inSupportRandomFunc;
    trivial.

    unfold randomPerm_bad.
    rewrite H5.
    simpl.
    intuition.

    inline_first.
    comp_skip.
    inline_first.
    case_eq (inRange _ l r2); intuition; unfold negb.
    comp_irr_r; wftac.
    comp_simp.
    eapply H2; intuition.
    simpl in *.
    rewrite H1.
    eapply orb_true_r.

    simpl.
    destruct (eqbBvector x r2); intuition.
    simpl.
    eapply well_formed_perm_cons_2; intuition.

    eapply inSupportRandomFunc; trivial.
    eapply inSupportRandomPerm_bad; trivial.

    comp_simp.
    eapply H2; intuition.
    simpl in *.
    rewrite H1.
    eapply orb_true_r.
    simpl in *.
    rewrite H0.
    eapply orb_true_r.
    eapply well_formed_perm_cons; intuition.

    eapply inSupportRandomFunc; trivial.
    eapply inSupportRandomPerm_bad_1; trivial.
    simpl.
    eapply filter_In; intuition.
    rewrite H6.
    trivial.

  Qed.

  Lemma perm_func_not_bad_spec :
    let s1 := (fun p1 p2 => checkBad (fst p1) = false /\ checkBad (fst p2) = false /\ snd p1 = snd p2 /\ (forall v, (fst p1) # v = ((fst p2) # v)) /\ (forall r, inRange  _ (fst p1) r = inRange _ (fst p2) r) /\ well_formed_Bvector_perm (fst p2)) in
    comp_spec
    s1
    (fun p1 p2 => s1 p1 p2 \/ (checkBad (fst p1) = true /\ checkBad (fst p2) = true /\ well_formed_Bvector_perm (fst p2)))
    (randomFunc_Bvector)
    randomPerm_bad.

    unfold comp_spec; intuition.

    unfold randomFunc_Bvector, randomFunc, randomPerm_bad.
    simpl in H2.
    subst.
    destruct d2.
    unfold snd.
    simpl in H3.
    rewrite H3.
    case_eq (l # b); intuition.
    comp_simp.
    eapply H5; intuition.

    simpl.
    rewrite H3.
    rewrite H2.
    simpl.
    intuition.

    simpl.
    rewrite H2.
    simpl.
    intuition.

    inline_first.
    comp_skip.
    inline_first.
    case_eq (inRange _ l r2); intuition; unfold negb.
    comp_irr_r; wftac.
    comp_simp.
    eapply H5; intuition.
    right.
    intuition.
    simpl.
    simpl in H4.
    rewrite H4.
    rewrite H7.
    eapply orb_true_l.
    simpl.
    case_eq (eqbBvector x r2); intuition.
    eapply well_formed_perm_cons_2; intuition.

    eapply inSupportRandomFunc; trivial.
    simpl.
    rewrite H3.
    trivial.

    eapply inSupportRandomPerm_bad; trivial.

    comp_simp.
    eapply H5; intuition.
    left; intuition.

    simpl in *.
    rewrite H4.
    rewrite H7.
    rewrite H1.
    trivial.
    simpl in *.

    rewrite H7.
    rewrite H0.
    trivial.

    simpl.
    rewrite H3.
    trivial.

    simpl.
    rewrite H4.
    trivial.

    unfold fst.
    eapply well_formed_perm_cons; intuition.

    eapply inSupportRandomFunc; trivial.
    simpl.
    rewrite H3.
    trivial.

    eapply inSupportRandomPerm_bad_1; trivial.
    simpl.
    eapply filter_In.
    intuition.
    rewrite H7.
    trivial.
  Qed.

  Definition randomFunc_eager(p: (list (Bvector n * Bvector n)) * Bvector n) : Comp (list (Bvector n * Bvector n) * Bvector n) :=
    let (f, d) := p in
    r <-$ {0, 1}^n;
    f' <- f ++ (d, r) :: nil;
    match f # d with
      | None => ret (f', r)
      | Some r => ret (f', r)
    end.

  Lemma checkBad_permutation : forall ls1 ls2,
    Permutation ls1 ls2 ->
    checkBad ls1 = checkBad ls2.

    induction 1; intuition; simpl in *.
    rewrite IHPermutation.
    erewrite inRange_permutation.
    eauto.
    trivial.

    case_eq (eqbBvector b0 b); intuition.
    apply eqbBvector_sound in H. subst.
    rewrite eqbBvector_complete.
    simpl.
    trivial.
    case_eq (eqbBvector b b0); intuition.
    apply eqbBvector_sound in H0.
    subst.
    rewrite eqbBvector_complete in H.
    discriminate.
    destruct (inRange _ l b0).
    destruct (inRange _ l b).
    simpl.
    trivial.
    simpl.
    trivial.

    simpl.
    trivial.
    eauto.
  Qed.

  Lemma checkBad_app_cons : forall ls d r,
    checkBad (ls ++ (d, r) :: nil) = checkBad ((d , r) :: ls).

    intuition.
    symmetry.
    eapply checkBad_permutation.
    eapply Permutation_cons_append.
  Qed.

  Lemma checkBad_app : forall ls ls',
    checkBad ls = true ->
    checkBad (ls ++ ls') = true.

    induction ls; intuition; simpl in *.
    apply orb_true_iff in H.
    intuition.
    rewrite inRange_app.
    simpl.
    trivial.
    trivial.
  Qed.

  Lemma randomFunc_eager_spec :
    stateful_comp_spec
      (fun s1 s2 => (checkBad s1 = true -> checkBad s2 = true) /\ (forall d, s1 # d = (s2 # d)) /\ forall r, inRange _ s1 r = true -> inRange _ s2 r = true)
      (fun p1 p2 => snd p1 = snd p2) (fun p1 p2  => snd p1 = snd p2)
      (randomFunc_Bvector)
      randomFunc_eager.

    intuition.
    unfold stateful_comp_spec, comp_spec.
    intuition.

    unfold randomFunc_Bvector, randomFunc, randomFunc_eager.
    simpl in H1.
    subst.
    destruct d2.
    simpl in H2.
    unfold snd.
    rewrite H2.

    inline_first.

    case_eq (l # b); intuition.
    comp_simp.
    inline_first.
    comp_irr_r; wftac.
    comp_simp.
    eapply H3; intuition.

    simpl in *.
    eapply checkBad_app; trivial.
    simpl.
    erewrite arrayLookup_app_some; eauto.
    simpl in *.
    rewrite inRange_app_cons.
    simpl.
    case_eq (eqbBvector r x); intuition.

    simpl.
    rewrite H2.
    rewrite H1.
    simpl.
    intuition.

    Theorem inSupportRandomFunc_eager_Some :
      forall l a r b,
        l # a = Some b ->
        In (l ++ (a, r) :: nil, b) (getSupport (randomFunc_eager (l, a))).

      intuition.
      unfold randomFunc_eager.
      eapply getSupport_In_Seq.
      simpl.
      eapply in_getAllBvectors.
      rewrite H.
      unfold setLet.
      simpl.
      intuition.
    Qed.

    Theorem inSupportRandomFunc_eager_None :
      forall l a r,
        l # a = None ->
        In (l ++ (a, r) :: nil, r) (getSupport (randomFunc_eager (l, a))).

      intuition.
      unfold randomFunc_eager.
      eapply getSupport_In_Seq.
      simpl.
      eapply in_getAllBvectors.
      rewrite H.
      unfold setLet.
      simpl.
      intuition.
    Qed.

    eapply inSupportRandomFunc_eager_Some.
    trivial.

    inline_first.
    comp_skip.

    comp_simp.
    eapply H3; intuition.
    simpl in *.
    rewrite checkBad_app_cons.
    simpl.
    apply orb_true_iff in H5.
    intuition.

    simpl.
    case_eq (eqbBvector d b); intuition.
    apply eqbBvector_sound in H5.
    subst.
    rewrite arrayLookup_app_some_eq; trivial.

    rewrite arrayLookup_app_none; trivial.
    simpl.
    rewrite H5.
    intuition.

    simpl in *.
    case_eq (eqbBvector r r2); intuition.
    rewrite H8 in H5.
    apply eqbBvector_sound in H8.
    subst.
    rewrite inRange_app_cons.
    simpl.
    rewrite eqbBvector_complete.
    trivial.
    eapply inRange_app.
    rewrite H8 in H5.
    intuition.

    eapply inSupportRandomFunc; trivial.
    simpl.
    rewrite H2.
    trivial.

    eapply inSupportRandomFunc_eager_None; trivial.

  Qed.

  Lemma randomFunc_eager_bad_eq :
    stateful_comp_spec
      (fun s1 s2 => (checkBad s1 = checkBad s2) /\ (forall r, inRange _ s1 r = inRange _ s2 r))
      (fun p1 p2 => True) (fun p1 p2 => True)
      randomFunc_eager
      randomFunc_eager.

    intuition.
    unfold stateful_comp_spec, comp_spec.
    intuition.

    unfold randomFunc_eager.
    comp_simp.
    inline_first.
    comp_skip.
    case_eq (a # b); intuition;
    case_eq (l # b0); intuition;
    comp_simp;
    eapply H2; intuition;

    try match goal with
        | [|- _ = _ ] => simpl in *; repeat rewrite checkBad_app_cons;
                                          repeat rewrite inRange_app_cons; simpl;
                                          repeat rewrite H3; repeat rewrite H0; intuition
        | [|- In (?a ++ (?b, ?r) :: nil, ?r) (getSupport (randomFunc_eager (?a, ?b))) ] =>
          eapply inSupportRandomFunc_eager_None; trivial
        | [|- In (?a ++ (?b, ?r) :: nil, _) (getSupport (randomFunc_eager (?a, ?b))) ] =>
          eapply inSupportRandomFunc_eager_Some; trivial
        end.

  Qed.

  Lemma filter_NoDup_perm : forall (A : Set)(eqd: eq_dec A) u ls,
    NoDup ls ->
    NoDup u ->
    (forall a, In a ls -> In a u) ->
    Permutation (filter (fun a => if (in_dec eqd a ls) then true else false) u) ls.

    induction u; intuition; simpl in *.
    destruct ls.
    econstructor.
    specialize (H1 a); simpl in *.
    intuition.

    inversion H0; clear H0; subst.
    destruct (in_dec eqd a ls).
    symmetry.
    eapply perm_trans.
    eapply (removeFirst_permutation eqd).
    eauto.
    eapply perm_skip.
    eapply Permutation_sym.
    erewrite filter_eq.
    eapply IHu; intuition.
    eapply removeFirst_NoDup.
    trivial.
    specialize (H1 a0).
    intuition.
    edestruct H1.
    eapply removeFirst_in_iff.
    eauto.
    subst.
    exfalso.
    eapply removeFirst_NoDup_not_in.
    eapply H.
    eauto.
    trivial.
    intuition.
    destruct (in_dec eqd a0 ls).
    destruct (in_dec eqd a0 (removeFirst eqd ls a)).
    trivial.
    exfalso.
    destruct (eqd a a0); subst.
    intuition.
    eapply n0.
    eapply removeFirst_in; eauto.
    destruct (in_dec eqd a0 (removeFirst eqd ls a)).
    exfalso.
    eapply removeFirst_not_in; eauto.
    trivial.

    eapply IHu; intuition.
    specialize (H1 a0); intuition.
    subst.
    intuition.
  Qed.

  Lemma randomFunc_eager_wf : forall ls d,
    well_formed_comp (randomFunc_eager (ls, d)).

    intuition.
    unfold randomFunc_eager.
    wftac.
    intuition.
    destruct (ls # d); wftac.

  Qed.

  Lemma randomFunc_eager_preserves_bad : forall ls d ls' r,
    In (ls', r) (getSupport (randomFunc_eager (ls, d))) ->
    checkBad ls = true ->
    checkBad ls' = true.

    intuition.
    unfold randomFunc_eager in *.
    simp_in_support.
    case_eq (ls # d); intuition;
    rewrite H in H2;
    simp_in_support.
    rewrite checkBad_app_cons; simpl.
    rewrite H0.
    eapply orb_true_r.
    rewrite checkBad_app_cons; simpl.
    rewrite H0.
    eapply orb_true_r.

  Qed.

  (*************************************************************************************)
  (*----------------------  PRP-PRF Switching Lemma Proof Begins Here -----------------*)
  (*************************************************************************************)

  Variable q : nat. (* number of queries *)
  Variable A : AdversaryWithOracle unit bool (Bvector n) (Bvector n) (list (Bvector n * Bvector n)).

  Definition PRF_G :=
    s_O <- (@nil (Bvector n * Bvector n));
    p <-$ (A queries (randomFunc_Bvector) ) q s_O tt;
    ret fst p.

  Definition PRP_G :=
    s_O <- (@nil (Bvector n * Bvector n));
    p <-$ (A queries (randomPerm_Bvector)) q s_O tt;
    ret fst p.

  Definition PRP_PRF_Advantage :=
    | Pr[PRP_G] - Pr[PRF_G] |.

  Definition PRP_S1 :=
    s_O <- (@nil (Bvector n * Bvector n));
    p <-$ (A queries randomPerm_bad) q s_O tt;
    ret fst p.

  Definition PRP_S0 :=
    s_O <- (@nil (Bvector n * Bvector n));
    p <-$ (A queries randomPerm_unroll) q s_O tt;
    ret fst p.

  Theorem well_formed_Bvector_perm_nil : well_formed_Bvector_perm nil.

    unfold well_formed_Bvector_perm, well_formed_perm.
    intuition.
    econstructor.
    intuition.
    simpl.
    eapply in_getAllBvectors.
    trivial.

  Qed.

  Theorem Bvector_perms_eq_nil : Bvector_perms_eq nil nil.

    unfold Bvector_perms_eq, perms_eq.
    intuition.
    eapply well_formed_Bvector_perm_nil.
    eapply well_formed_Bvector_perm_nil.
    unfold funcs_eq.
    intuition.
  Qed.

  Lemma PRP_G_eq_S0 :
    Pr[PRP_G] == Pr[PRP_S0].

    unfold PRP_G, PRP_S0.

    eapply (A_query_inv _ _ _ _ well_formed_Bvector_perm); intuition.
    eapply well_formed_Bvector_perm_nil.
    eapply randomPerm_preserves_wf_pair; eauto.
    eapply randomPerm_unroll_preserves_wf_pair; eauto.
    eapply randomPerm_eq_unroll.
    trivial.
  Qed.

  Lemma PRP_S0_eq_S1 :
    Pr[PRP_S0] == Pr[PRP_S1].

    unfold PRP_S0, PRP_S1.

    eapply (A_query_spec_eq _ _ randomPerm_unroll_bad_inv); intuition.
    eapply Bvector_perms_eq_nil.

    subst.
    simpl.
    intuition.
  Qed.

  Definition PRF_G_bad :=
    s_O <- nil;
    p <-$ (A queries (randomFunc_Bvector)) q s_O tt;
    ret (checkBad (snd p)).

  Definition PRP_S1_bad :=
    s_O <- nil;
    p <-$ (A queries randomPerm_bad) q s_O tt;
    ret (checkBad (snd p)).

  Lemma badness_same :
    Pr[PRF_G_bad] == Pr[PRP_S1_bad].

    intuition.
    unfold PRF_G_bad, PRP_S1_bad.

    eapply (A_query_spec_2_eq _ _ _ _ perm_func_not_bad_spec perm_func_bad_spec); intros; intuition.

    unfold fst.
    eapply well_formed_Bvector_perm_nil.

    simpl in *.
    rewrite H.
    rewrite H0.
    intuition.

    simpl in *.
    rewrite H.
    rewrite H0.
    intuition.

  Qed.

  Definition PRF_G_both :=
    s_O <- nil;
    p <-$ (A queries (randomFunc_Bvector)) q s_O tt;
    ret (fst p, checkBad (snd p)).

  Definition PRP_S1_both :=
    s_O <- nil;
    p <-$ (A queries randomPerm_bad) q s_O tt;
    ret (fst p, checkBad (snd p)).

  Lemma func_perm_eq_when_good : forall x,
    evalDist PRF_G_both (x, false) ==
    evalDist PRP_S1_both (x, false).

    intuition.
    eapply (A_query_spec_2_eq _ _ _ _ perm_func_not_bad_spec perm_func_bad_spec); intros; intuition.
    simpl.
    eapply well_formed_Bvector_perm_nil.
    unfold fst, snd.
    unfold fst in H0, H.
    rewrite H0.
    rewrite H.
    intuition.
    simpl in *.
    rewrite H0.
    rewrite H.
    destruct (EqDec_dec (pair_EqDec bool_EqDec bool_EqDec) (s_A1', true) (x, false)); destruct (EqDec_dec (pair_EqDec bool_EqDec bool_EqDec) (s_A2', true) (x, false)); intuition; pairInv.
  Qed.

  Lemma func_perm_close : forall x,
    | evalDist PRF_G x - evalDist PRP_S1 x | <= Pr[PRF_G_bad].

    intuition.
    eapply fundamental_lemma.
    eapply pair_EqDec.
    eapply bool_EqDec.
    eapply list_EqDec.
    eapply pair_EqDec;
    eapply Bvector_EqDec.
    eapply badness_same.

    eapply func_perm_eq_when_good.
  Qed.

  Definition PRF_eager_G_bad :=
    s_O <- nil;
    p <-$ (A queries randomFunc_eager) q s_O tt;
    ret checkBad (snd p).

  Lemma randomFunc_bad_le_eager :
    Pr [PRF_G_bad] <= Pr [PRF_eager_G_bad].

    unfold PRF_G_bad, PRF_eager_G_bad.

    eapply (A_query_spec _ _ _ randomFunc_eager_spec); intuition.
    simpl.

    destruct (checkBad o1).
    rewrite H1.
    intuition.
    trivial.

    destruct (EqDec_dec bool_EqDec false true); try discriminate.
    eapply rat0_le_all.

  Qed.

  Definition randomFunc_eager_loop :=
    s <-$ compLoop _ randomFunc_eager q nil (oneVector n);
    ret checkBad s.

  Lemma randomFunc_G_eq_loop :
    Pr[PRF_eager_G_bad] == Pr[randomFunc_eager_loop].

    intuition.
    unfold PRF_eager_G_bad, randomFunc_eager_loop.
    eapply (runA_eq_compLoop _ _ randomFunc_eager_bad_eq); intuition.

    simpl.
    rewrite H0.
    intuition.
  Qed.

  Lemma checkBad_NoDup : forall ls,
    checkBad ls = false ->
    NoDup (map (@snd (Bvector n) (Bvector n)) ls).

    induction ls; intuition; simpl in *.
    econstructor.
    destruct a.
    apply orb_false_elim in H.
    intuition.
    econstructor.
    intuition.
    simpl in *.
    rewrite inRange_in_dec in H0.
    destruct (in_dec (EqDec_dec (Bvector_EqDec n)) b0 (map (snd (B:=Bvector n)) ls)).
    discriminate.
    intuition.
    trivial.

  Qed.

  Lemma compLoop_randomFunc_eager_le_bound: forall count s_O d,
    checkBad s_O = false ->
    Pr [p <-$ compLoop _ randomFunc_eager count s_O d; ret (checkBad p)] <=
    if (checkBad s_O) then 1 else
    ((count / 1) * (length s_O/ expnat 2 n) + (count * count / expnat 2 n)).

    induction count; intuition.

    unfold compLoop.
    comp_simp.
    comp_ute.
    eapply rat0_le_all.

    unfold compLoop.

    unfold randomFunc_eager.
    fold randomFunc_eager.
    inline_first.

    eapply trans.
    eapply (@evalDist_bind_case_split leRat _ (inRange _ s_O)
    (length s_O / expnat 2 n)
    1
    (count / 1 * (S (length s_O) / expnat 2 n) + count * count / expnat 2 n)
    bool (Rnd n)); intuition.
    wftac.

    simpl.
    rewrite sumList_factor_constant_l.
    (* there are (length ls) distinct elements in the list, so this must be true *)
    assert (sumList (getAllBvectors n)
     (fun a : Bvector n =>
      if EqDec_dec bool_EqDec (inRange _ s_O a) true then 1 else 0) == (length s_O / 1)).
    rewrite (sumList_filter_partition (inRange _ s_O)).
    eapply eqRat_trans.
    eapply ratAdd_eqRat_compat.
    eapply sumList_body_eq.
    intuition.
    apply filter_In in H0.
    intuition.
    destruct (EqDec_dec bool_EqDec (inRange _ s_O a) true).
    eapply eqRat_refl.
    congruence.
    eapply sumList_0.
    intuition.
    apply filter_In in H0.
    intuition.
    destruct (EqDec_dec bool_EqDec (inRange _ s_O a) true); intuition.
    rewrite e in H2.
    simpl in *.
    discriminate.

    rewrite sumList_body_const.
    rewrite ratMult_1_l.
    rewrite <- ratAdd_0_r.
    eapply eqRat_terms.

    erewrite filter_eq.
    Focus 2.
    intros.
    eapply inRange_in_dec.

    apply checkBad_NoDup in H.
    erewrite <- (map_length _ s_O).

    eapply Permutation_length.
    eapply filter_NoDup_perm; intuition.
    eapply getAllBvectors_NoDup.
    eapply in_getAllBvectors.
    trivial.

    rewrite H0.
    rewrite <- ratMult_num_den.
    eapply eqRat_terms.
    omega.
    unfold posnatMult, natToPosnat, posnatToNat.
    omega.

    case_eq (s_O # d); intuition.

    comp_simp.
    comp_irr_l.

    specialize (compLoop_wf _ randomFunc_eager); intuition.
    eapply H2; intuition.
    eapply randomFunc_eager_wf.

    assert (checkBad x = true).
    eapply (@compLoop_inv _ _ _ _ _ (fun x => checkBad x = true)); intuition.
    eapply randomFunc_eager_preserves_bad.
    eauto.
    trivial.
    Focus 2.
    eauto.
    rewrite checkBad_app_cons.
    simpl.
    rewrite H0.
    trivial.
    simpl.
    destruct (EqDec_dec bool_EqDec (checkBad x) true); try congruence.
    intuition.

    comp_simp.
    comp_irr_l.
    specialize (compLoop_wf _ randomFunc_eager); intuition.
    eapply H2; intuition.
    eapply randomFunc_eager_wf.

    assert (checkBad x = true).
    eapply (@compLoop_inv _ _ _ _ _ (fun x => checkBad x = true)); intuition.
    eapply randomFunc_eager_preserves_bad.
    eauto.
    trivial.
    Focus 2.
    eauto.
    rewrite checkBad_app_cons.
    simpl.
    rewrite H0.
    trivial.
    simpl.
    destruct (EqDec_dec bool_EqDec (checkBad x) true); try congruence.
    intuition.

    case_eq (s_O # d); intuition.
    comp_simp.

    eapply trans.
    eapply IHcount.
    rewrite checkBad_app_cons.
    simpl; intuition.

    rewrite checkBad_app_cons.
    simpl.
    rewrite H0.
    rewrite H.
    simpl.
    rewrite app_length.
    simpl.
    rewrite plus_comm.
    simpl.
    intuition.

    comp_simp.
    eapply trans.
    eapply IHcount.
    rewrite checkBad_app_cons.
    simpl; intuition.
    rewrite checkBad_app_cons.
    simpl.
    rewrite H0.
    rewrite H.
    simpl.

    rewrite app_length.
    simpl.
    rewrite plus_comm.
    simpl.
    intuition.

    rewrite ratMult_1_r.
    eapply leRat_trans.
    eapply ratAdd_leRat_compat.
    eapply leRat_refl.
    eapply ratMult_leRat_compat.
    eapply ratSubtract_le.
    eapply leRat_refl.
    eapply leRat_refl.
    rewrite ratMult_1_l.
    repeat rewrite <- ratMult_num_den.
    assert (RatIntro (count * S (length s_O)) (posnatMult (pos 1) (pos expnat 2 n)) == count * S (length s_O) / expnat 2 n).
    eapply eqRat_terms.
    trivial.
    simpl.
    omega.
    rewrite H0.
    rewrite <- ratAdd_num.
    rewrite <- ratAdd_num.
    assert (RatIntro (S count * length s_O) (posnatMult (pos 1) (pos expnat 2 n)) == S count * length s_O / expnat 2 n).
    eapply eqRat_terms.
    trivial.
    simpl.
    omega.
    rewrite H.
    rewrite H1.
    eapply leRat_trans.
    Focus 2.
    eapply eqRat_impl_leRat.
    rewrite <- ratAdd_num.
    eapply eqRat_refl.
    eapply leRat_num.
    simpl.
    rewrite mult_comm.
    simpl.
    rewrite (mult_comm count  (S count)).
    simpl.
    repeat rewrite plus_assoc.
    rewrite (mult_comm count (length s_O)).
    omega.

  Qed.

  Lemma randomFunc_eager_loop_le_bound :
    Pr[randomFunc_eager_loop] <= q * q / expnat 2 n.

    eapply leRat_trans.
    eapply compLoop_randomFunc_eager_le_bound.
    trivial.

    simpl.
    rewrite <- ratMult_num_den.
    rewrite mult_0_r.
    rewrite rat_num_0.
    rewrite <- ratAdd_0_l.
    intuition.

  Qed.

  (* note: bounds could be better *)
  Theorem PRP_PRF_Switching : PRP_PRF_Advantage <= (q * q / expnat 2 n).

    intuition.
    unfold PRP_PRF_Advantage.
    rewrite PRP_G_eq_S0.
    rewrite PRP_S0_eq_S1.
    rewrite ratDistance_comm.
    rewrite func_perm_close.
    rewrite randomFunc_bad_le_eager.
    rewrite randomFunc_G_eq_loop.
    eapply randomFunc_eager_loop_le_bound.
  Qed.

  Print Assumptions PRP_PRF_Switching.

End PRP_PRF.

(*
Section PRP_Cipher.

  Variable n : nat.
  Variable k1 k2 : Bvector n.

  Local Open Scope vector_scope.
  Fixpoint eagerPerm_h(z : nat)(range : list (Bvector n)) : Comp (list (Bvector z * Bvector n)):=
    match z with
      | O => v <- Repeat ({0, 1}^n) (fun v => if (in_dec (@Bvector_eq_dec n) v range) then false else true);
        ret ((Vector.nil bool, v) :: nil)%list
      | S z' =>
        ls1 <- eagerPerm_h z' range;
        ls2 <- eagerPerm_h z' (range ++ (map (fun p => snd p) ls1));
        ls1' <-! (map (fun (p : Bvector z' * Bvector n) => (Vector.cons bool false z' (fst p), snd p)) ls1);
        ls2' <-! (map (fun (p : Bvector z' * Bvector n) => (Vector.cons bool true z' (fst p), snd p)) ls2);
        ret (ls1' ++ ls2')
    end.

  Definition eagerPerm :=
    eagerPerm_h n nil.

    match v with
      | Vector.nil => ret nil
      | b :: v' =>
        ls1 <- eagerPerm_h v';
        ls2 <- eagerPerm_h v';

    end.

  Definition perm := (@randomPerm n).

  Definition encrypt(s_perm : list (Bvector n * Bvector n))(m : Bvector n) :=
    p <- perm (s_perm, (BVxor n k1 m));
    ret (fst p, (BVxor n k2 (snd p))).

  (* We need the inverse permutation for this -- we can build it out of the one we have by swapping the order of the pairs in the list.  It might be easier to sample the entire permutation up front. *)

End PRP_Cipher.
*)


From stdpp Require Import gmap.
From iris.bi Require Import interface.
From iris.proofmode Require Import tactics.

(** This file constructs a simple non step-indexed linear separation logic as
predicates over heaps (modeled as maps from integer locations to integer values).
It shows that Iris's [bi] canonical structure can be inhabited, and the Iris
proof mode can be used to prove lemmas in this separation logic. *)
Definition loc := Z.
Definition val := Z.

Record heapProp := HeapProp {
  heapProp_holds :> gmap loc val → Prop;
}.
Global Arguments heapProp_holds : simpl never.
Add Printing Constructor heapProp.

Section ofe.
  Inductive heapProp_equiv' (P Q : heapProp) : Prop :=
    { heapProp_in_equiv : ∀ σ, P σ ↔ Q σ }.
  Local Instance heapProp_equiv : Equiv heapProp := heapProp_equiv'.
  Local Instance heapProp_equivalence : Equivalence (≡@{heapProp}).
  Proof. split; repeat destruct 1; constructor; naive_solver. Qed.
  Canonical Structure heapPropO := discreteO heapProp.
End ofe.

(** logical entailement *)
Inductive heapProp_entails (P Q : heapProp) : Prop :=
  { heapProp_in_entails : ∀ σ, P σ → Q σ }.

(** logical connectives *)
Definition heapProp_emp_def : heapProp :=
  {| heapProp_holds σ := σ = ∅ |}.
Definition heapProp_emp_aux : seal (@heapProp_emp_def). Proof. by eexists. Qed.
Definition heapProp_emp := unseal heapProp_emp_aux.
Definition heapProp_emp_eq :
  @heapProp_emp = @heapProp_emp_def := seal_eq heapProp_emp_aux.

Definition heapProp_pure_def (φ : Prop) : heapProp :=
  {| heapProp_holds _ := φ |}.
Definition heapProp_pure_aux : seal (@heapProp_pure_def). Proof. by eexists. Qed.
Definition heapProp_pure := unseal heapProp_pure_aux.
Definition heapProp_pure_eq :
  @heapProp_pure = @heapProp_pure_def := seal_eq heapProp_pure_aux.

Definition heapProp_and_def (P Q : heapProp) : heapProp :=
  {| heapProp_holds σ := P σ ∧ Q σ |}.
Definition heapProp_and_aux : seal (@heapProp_and_def). Proof. by eexists. Qed.
Definition heapProp_and := unseal heapProp_and_aux.
Definition heapProp_and_eq:
  @heapProp_and = @heapProp_and_def := seal_eq heapProp_and_aux.

Definition heapProp_or_def (P Q : heapProp) : heapProp :=
  {| heapProp_holds σ := P σ ∨ Q σ |}.
Definition heapProp_or_aux : seal (@heapProp_or_def). Proof. by eexists. Qed.
Definition heapProp_or := unseal heapProp_or_aux.
Definition heapProp_or_eq:
  @heapProp_or = @heapProp_or_def := seal_eq heapProp_or_aux.

Definition heapProp_impl_def (P Q : heapProp) : heapProp :=
  {| heapProp_holds σ := P σ → Q σ |}.
Definition heapProp_impl_aux : seal (@heapProp_impl_def). Proof. by eexists. Qed.
Definition heapProp_impl := unseal heapProp_impl_aux.
Definition heapProp_impl_eq :
  @heapProp_impl = @heapProp_impl_def := seal_eq heapProp_impl_aux.

Definition heapProp_forall_def {A} (Ψ : A → heapProp) : heapProp :=
  {| heapProp_holds σ := ∀ a, Ψ a σ |}.
Definition heapProp_forall_aux : seal (@heapProp_forall_def). Proof. by eexists. Qed.
Definition heapProp_forall {A} := unseal heapProp_forall_aux A.
Definition heapProp_forall_eq :
  @heapProp_forall = @heapProp_forall_def := seal_eq heapProp_forall_aux.

Definition heapProp_exist_def {A} (Ψ : A → heapProp) : heapProp :=
  {| heapProp_holds σ := ∃ a, Ψ a σ |}.
Definition heapProp_exist_aux : seal (@heapProp_exist_def). Proof. by eexists. Qed.
Definition heapProp_exist {A} := unseal heapProp_exist_aux A.
Definition heapProp_exist_eq :
  @heapProp_exist = @heapProp_exist_def := seal_eq heapProp_exist_aux.

Definition heapProp_sep_def (P Q : heapProp) : heapProp :=
  {| heapProp_holds σ := ∃ σ1 σ2, σ = σ1 ∪ σ2 ∧ σ1 ##ₘ σ2 ∧ P σ1 ∧ Q σ2 |}.
Definition heapProp_sep_aux : seal (@heapProp_sep_def). Proof. by eexists. Qed.
Definition heapProp_sep := unseal heapProp_sep_aux.
Definition heapProp_sep_eq:
  @heapProp_sep = @heapProp_sep_def := seal_eq heapProp_sep_aux.

Definition heapProp_wand_def (P Q : heapProp) : heapProp :=
  {| heapProp_holds σ := ∀ σ', σ ##ₘ σ' → P σ' → Q (σ ∪ σ') |}.
Definition heapProp_wand_aux : seal (@heapProp_wand_def). Proof. by eexists. Qed.
Definition heapProp_wand := unseal heapProp_wand_aux.
Definition heapProp_wand_eq:
  @heapProp_wand = @heapProp_wand_def := seal_eq heapProp_wand_aux.

Definition heapProp_persistently_def (P : heapProp) : heapProp :=
  {| heapProp_holds σ := P ∅ |}.
Definition heapProp_persistently_aux : seal (@heapProp_persistently_def).
Proof. by eexists. Qed.
Definition heapProp_persistently := unseal heapProp_persistently_aux.
Definition heapProp_persistently_eq:
  @heapProp_persistently = @heapProp_persistently_def := seal_eq heapProp_persistently_aux.

(** Iris's [bi] class requires the presence of a later modality, but for non
step-indexed logics, it can be defined as the identity. *)
Definition heapProp_later (P : heapProp) : heapProp := P.

Definition unseal_eqs :=
  (heapProp_emp_eq, heapProp_pure_eq, heapProp_and_eq, heapProp_or_eq,
   heapProp_impl_eq, heapProp_forall_eq, heapProp_exist_eq,
   heapProp_sep_eq, heapProp_wand_eq, heapProp_persistently_eq).
Ltac unseal := rewrite !unseal_eqs /=.

Section mixins.
  (** Enable [simpl] locally, which is useful for proofs in the model. *)
  Local Arguments heapProp_holds !_ _ /.

  Lemma heapProp_bi_mixin :
    BiMixin
      heapProp_entails heapProp_emp heapProp_pure heapProp_and heapProp_or
      heapProp_impl (@heapProp_forall) (@heapProp_exist)
      heapProp_sep heapProp_wand heapProp_persistently.
  Proof.
    split.
    - (* [PreOrder heapProp_entails] *)
      split; repeat destruct 1; constructor; naive_solver.
    - (* [P ≡ Q ↔ (P ⊢ Q) ∧ (Q ⊢ P)] *)
      intros P Q; split.
      + intros [HPQ]; split; split; naive_solver.
      + intros [[HPQ] [HQP]]; split; naive_solver.
    - (* [Proper (iff ==> dist n) bi_pure] *)
      unseal=> n φ1 φ2 Hφ; split; naive_solver.
    - (* [NonExpansive2 bi_and] *)
      unseal=> n P1 P2 [HP] Q1 Q2 [HQ]; split; naive_solver.
    - (* [NonExpansive2 bi_or] *)
      unseal=> n P1 P2 [HP] Q1 Q2 [HQ]; split; naive_solver.
    - (* [NonExpansive2 bi_impl] *)
      unseal=> n P1 P2 [HP] Q1 Q2 [HQ]; split; naive_solver.
    - (* [Proper (pointwise_relation _ (dist n) ==> dist n) (bi_forall A)] *)
      unseal=> A n Φ1 Φ2 HΦ; split=> σ /=; split=> ? x; by apply HΦ.
    - (* [Proper (pointwise_relation _ (dist n) ==> dist n) (bi_exist A)] *)
      unseal=> A n Φ1 Φ2 HΦ; split=> σ /=; split=> -[x ?]; exists x; by apply HΦ.
    - (* [NonExpansive2 bi_sep] *)
      unseal=> n P1 P2 [HP] Q1 Q2 [HQ]; split; naive_solver.
    - (* [NonExpansive2 bi_wand] *)
      unseal=> n P1 P2 [HP] Q1 Q2 [HQ]; split; naive_solver.
    - (* [NonExpansive2 bi_persistently] *)
      unseal=> n P1 P2 [HP]; split; naive_solver.
    - (* [φ → P ⊢ ⌜ φ ⌝] *)
      unseal=> φ P ?; by split.
    - (* [(φ → True ⊢ P) → ⌜ φ ⌝ ⊢ P] *)
      unseal=> φ P HP; split=> σ ?. by apply HP.
    - (* [P ∧ Q ⊢ P] *)
      unseal=> P Q; split=> σ [??]; done.
    - (* [P ∧ Q ⊢ Q] *)
      unseal=> P Q; split=> σ [??]; done.
    - (* [(P ⊢ Q) → (P ⊢ R) → P ⊢ Q ∧ R] *)
      unseal=> P Q R [HPQ] [HPR]; split=> σ; split; auto.
    - (* [P ⊢ P ∨ Q] *)
      unseal=> P Q; split=> σ; by left.
    - (* [Q ⊢ P ∨ Q] *)
      unseal=> P Q; split=> σ; by right.
    - (* [(P ⊢ R) → (Q ⊢ R) → P ∨ Q ⊢ R] *)
      unseal=> P Q R [HPQ] [HQR]; split=> σ [?|?]; auto.
    - (* [(P ∧ Q ⊢ R) → P ⊢ Q → R] *)
      unseal=> P Q R HPQR; split=> σ ??. by apply HPQR.
    - (* [(P ⊢ Q → R) → P ∧ Q ⊢ R] *)
      unseal=> P Q R HPQR; split=> σ [??]. by apply HPQR.
    - (* [(∀ a, P ⊢ Ψ a) → P ⊢ ∀ a, Ψ a] *)
      unseal=> A P Ψ HPΨ; split=> σ ? a. by apply HPΨ.
    - (* [(∀ a, Ψ a) ⊢ Ψ a] *)
      unseal=> A Ψ a; split=> σ ?; done.
    - (* [Ψ a ⊢ ∃ a, Ψ a] *)
      unseal=> A Ψ a; split=> σ ?. by exists a.
    - (* [(∀ a, Φ a ⊢ Q) → (∃ a, Φ a) ⊢ Q] *)
      unseal=> A Φ Q HΦQ; split=> σ [a ?]. by apply (HΦQ a).
    - (* [(P ⊢ Q) → (P' ⊢ Q') → P ∗ P' ⊢ Q ∗ Q'] *)
      unseal=> P P' Q Q' [HPQ] [HP'Q']; split; naive_solver.
    - (* [P ⊢ emp ∗ P] *)
      unseal=> P; split=> σ ? /=. eexists ∅, σ. rewrite left_id_L.
      split_and!; done || apply map_disjoint_empty_l.
    - (* [emp ∗ P ⊢ P] *)
      unseal=> P; split; intros ? (?&σ&->&?&->&?). by rewrite left_id_L.
    - (* [P ∗ Q ⊢ Q ∗ P] *)
      unseal=> P Q; split; intros ? (σ1&σ2&->&?&?&?).
      exists σ2, σ1. by rewrite map_union_comm.
    - (* [(P ∗ Q) ∗ R ⊢ P ∗ (Q ∗ R)] *)
      unseal=> P Q R; split; intros ? (?&σ3&->&?&(σ1&σ2&->&?&?&?)&?).
      exists σ1, (σ2 ∪ σ3). split_and!; [by rewrite assoc_L|solve_map_disjoint|done|].
      exists σ2, σ3; split_and!; [done|solve_map_disjoint|done..].
    - (* [(P ∗ Q ⊢ R) → P ⊢ Q -∗ R] *)
      unseal=> P Q R [HPQR]; split=> σ1 ? σ2 ??. apply HPQR. by exists σ1, σ2.
    - (* [(P ⊢ Q -∗ R) → P ∗ Q ⊢ R] *)
      unseal=> P Q R [HPQR]; split; intros ? (σ1&σ2&->&?&?&?). by apply HPQR.
    - (* [(P ⊢ Q) → <pers> P ⊢ <pers> Q] *)
      unseal=> P Q [HPQ]; split=> σ. apply HPQ.
    - (* [<pers> P ⊢ <pers> <pers> P] *)
      unseal=> P; split=> σ; done.
    - (* [emp ⊢ <pers> emp] *)
      unseal; split=> σ; done.
    - (* [(∀ a, <pers> (Ψ a)) ⊢ <pers> (∀ a, Ψ a)] *)
      unseal=> A Ψ; split=> σ; done.
    - (* [<pers> (∃ a, Ψ a) ⊢ ∃ a, <pers> (Ψ a)] *)
      unseal=> A Ψ; split=> σ; done.
    - (* [<pers> P ∗ Q ⊢ <pers> P] *)
      unseal=> P Q; split; intros ? (σ1&σ2&->&?&?&?); done.
    - (* [<pers> P ∧ Q ⊢ P ∗ Q] *)
      unseal=> P Q; split=> σ [??]. eexists ∅, σ. rewrite left_id_L.
      split_and!; done || apply map_disjoint_empty_l.
  Qed.

  Lemma heapProp_bi_later_mixin :
    BiLaterMixin
      heapProp_entails heapProp_pure heapProp_or heapProp_impl
      (@heapProp_forall) (@heapProp_exist)
      heapProp_sep heapProp_persistently heapProp_later.
  Proof. eapply bi_later_mixin_id; [done|apply heapProp_bi_mixin]. Qed.
End mixins.

Canonical Structure heapPropI : bi :=
  {| bi_ofe_mixin := ofe_mixin_of heapProp;
     bi_bi_mixin := heapProp_bi_mixin; bi_bi_later_mixin := heapProp_bi_later_mixin |}.

Global Instance heapProp_pure_forall : BiPureForall heapPropI.
Proof. intros A φ. rewrite /bi_forall /bi_pure /=. unseal. by split. Qed.

Lemma heapProp_proofmode_test {A} (P Q R : heapProp) (Φ Ψ : A → heapProp) :
  P ∗ Q -∗
  □ R -∗
  □ (R -∗ ∃ x, Φ x) -∗
  ∃ x, Φ x ∗ Φ x ∗ P ∗ Q.
Proof.
  iIntros "[HP HQ] #HR #HRΦ".
  iDestruct ("HRΦ" with "HR") as (x) "#HΦ".
  iExists x. iFrame. by iSplitL.
Qed.