(* Use of this source code is governed by the license described	*
 * in the LICENSE file at the root of the source tree.		*)
(* 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 Broken.ConstructedFunc.
Require Import State.
Require Import FCF.

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 *.
    lia.
    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.
    lia.
    unfold posnatMult, natToPosnat, posnatToNat.
    lia.

    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.
    lia.
    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.
    lia.
    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)).
    lia.

  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.
*)


(* This file is extracted from the TLC library.
   http://github.com/charguer/tlc
   DO NOT EDIT. *)

(**************************************************************************
* Product of Data Structures                                              *
**************************************************************************)

Set Implicit Arguments.
From SLF Require Import LibTactics LibLogic LibReflect.

(* ********************************************************************** *)
(* ################################################################# *)
(** * Unit type *)

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Definition *)

(** From the Prelude.

  Inductive unit : Type :=
    | tt : unit.

  Add Printing If bool.
  Delimit Scope bool_scope with bool.

*)

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Inhabited *)

Instance Inhab_unit : Inhab unit.
Proof using. intros. apply (Inhab_of_val tt). Qed.

(* ********************************************************************** *)
(* ################################################################# *)
(** * Properties *)

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Uniqueness *)

Lemma unit_eq : forall (tt1 tt2 : unit),
  tt1 = tt2.
Proof using. intros. destruct tt1. destruct~ tt2. Qed.

(* 2021-01-25 13:22 *)


(* Copyright (c) 2008, Harvard University
 * All rights reserved.
 *
 * Author: Adam Chlipala
 *
 * Redistribution and use in source and binary forms, with or without
 * modification, are permitted provided that the following conditions are met:
 *
 * - Redistributions of source code must retain the above copyright notice,
 *   this list of conditions and the following disclaimer.
 * - Redistributions in binary form must reproduce the above copyright notice,
 *   this list of conditions and the following disclaimer in the documentation
 *   and/or other materials provided with the distribution.
 * - The names of contributors may not be used to endorse or promote products
 *   derived from this software without specific prior written permission.
 *
 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
 * POSSIBILITY OF SUCH DAMAGE.
 *)

(** remove printing * *)

(** %\chapter{Mutable Stacks}% *)

(** Our next example demonstrates one of the simplest imperative data structures that really deserves the name: polymorphic mutable stacks. *)

Require Import List.
Require Import Ynot.
Set Implicit Arguments.
Open Local Scope hprop_scope.

Module Type STACK.
  Parameter t : Set -> Set.
  Parameter rep : forall T, t T -> list T -> hprop.

  (** Compared to the [COUNTER] example, our new type [t] differs in being polymorphic in the type of data that we store.  The representation predicate is parameterized similarly, and we set the convention that the functional model of a [T] stack is a [T] list.

     The first three stack methods don't involve any new concepts. *)

  Parameter new : forall T : Set,
    Cmd __ (fun s : t T => rep s nil).
  Parameter free : forall (T : Set) (s : t T),
    Cmd (rep s nil) (fun _ : unit => __).

  Parameter push : forall (T : Set) (s : t T) (x : T) (ls : [list T]),
    Cmd (ls ~~ rep s ls) (fun _ : unit => ls ~~ rep s (x :: ls)).

  (** The type of the [pop] method demonstrates two important patterns.  First, we can use arbitrary Coq computation in calculating a precondition or postcondition.  Our [pop] method returns an [option T], which will be [None] when the stack is empty.  We use Coq's standard [match] expression form to case-analyze this return value, returning a different assertion for each case.  The [Some] case uses an [hprop] version of the standard existential quantifier. *)

  Parameter pop : forall (T : Set) (s : t T) (ls : [list T]),
    Cmd (ls ~~ rep s ls)
    (fun xo : option T => ls ~~ match xo with
                                  | None => [ls = nil] * rep s ls
                                  | Some x => Exists ls' :@ list T, [ls = x :: ls']
                                              * rep s ls'
                                end).
End STACK.

Module Stack : STACK.

  (** We use Coq's section mechanism to scope the type variable [T] over all of our definitions. *)

  Section Stack.
    Variable T : Set.

    (* We will represent stacks as singly-linked lists.  A node of a linked list consists of a data value and an optional pointer to the next node.  We use [option] types rather than baking in a concept of "null pointers." *)

    Record node : Set := Node {
      data : T;
      next : option ptr
    }.

    (** We can use a recursive [hprop]-valued function to define what it means for a particular list to be represented in the heap, starting from a particular head pointer. *)

    Fixpoint listRep (ls : list T) (hd : option ptr) {struct ls} : hprop :=
      match ls with
        | nil => [hd = None]
        | h :: t => match hd with
                      | None => [False]
                      | Some hd => Exists p :@ option ptr, hd --> Node h p * listRep t p
                    end
      end.

    (** As in the [Counter] example, we represent a stack as an untyped pointer, and we rely on the [rep] predicate to enforce proper typing of associated heap cells. *)

    Definition stack := ptr.
    Definition rep q ls := Exists po :@ option ptr, q --> po * listRep ls po.

    (** We define a tactic that will be useful for domain-specific goal simplification.  In larger examples, such a tactic definition would probably be significantly longer.  Here, we only need to ask Coq to try solving goals by showing that they are contradictory, because two equated values of a datatype are built from different constructors. *)

    Ltac simplr := try discriminate.

    (** A key component of effective Ynot automation is the choice of appropriate domain-specific %\emph{%#<i>#unfolding lemmas#</i>#%}%.  Such a lemma characterizes how an application of a representation predicate may be decomposed, when something is known about the structure of the arguments.  Our first simple unfolding lemma says that any functional list represented by a null pointer must be nil.  [sep] can complete the proof after we begin with a case analysis on the list. *)

    Theorem listRep_None : forall ls, listRep ls None ==> [ls = nil].
      destruct ls; sep fail idtac.
    Qed.

    (** A slightly more complicated lemma characterizes the shape of a list represented by a non-null pointer.  Here we put our [simplr] tactic to use as the second argument to [sep].  In general, the tactic given as that second argument is tried throughout proof search, in attempts to discharge goals that the separation logic simplifier can't prove alone. *)

    Theorem listRep_Some : forall ls hd,
      listRep ls (Some hd) ==> Exists h :@ T, Exists t :@ list T, Exists p :@ option ptr,
        [ls = h :: t] * hd --> Node h p * listRep t p.
      destruct ls; sep fail simplr.
    Qed.

    (** With these lemmas available, we are ready to define a tactic that will be passed as the first argument to [sep].  The tactic in that position is used to simplify the goal before beginning the main proof search.  The tactic [simp_prem] will perform that function for us. *)

    Ltac simp_prem :=
      simpl_IfNull;
      simpl_prem ltac:(apply listRep_None || apply listRep_Some).

    (** The [simpl_IfNull] tactic comes from the Ynot library.  It simplifies goal patterns that arise from a syntax extension that we will see shortly.  The more interesting part of [simp_prem] is the call to [simpl_prem], another tactic from the library.  [simpl_prem t] looks for premises (sub-formulas on the left of implications) that can be simplified by the tactic [t].  Here, we try to simplify by applying either of our unfolding lemmas.

       With these pieces in place, we define a final [t] solver tactic by dropping our two parameters into the version that we used for [Counter]. *)

    Ltac t := unfold rep; sep simp_prem simplr.

    Open Scope stsepi_scope.

    (** The first three method definitions are quite simple and use no new concepts. *)

    Definition new : Cmd __ (fun s => rep s nil).
      refine {{New (@None ptr)}}; t.
    Qed.

    Definition free : forall s, Cmd (rep s nil) (fun _ : unit => __).
      intros; refine {{Free s}}; t.
    Qed.

    Definition push : forall s x ls, Cmd (ls ~~ rep s ls) (fun _ : unit => ls ~~ rep s (x :: ls)).
      intros; refine (hd <- !s;
        nd <- New (Node x hd);
        {{s ::= Some nd}}
      ); t.
    Qed.

    (** The definition of [pop] introduces the [IfNull] syntax extension.  An expression [IfNull x Then e1 Else e2] expands to a test on whether the variable [x] of some [option] type is null.  If [x] is [None], then the result is [e1].  If [x] is [Some y], then the result is [e2], with all occurrences of [x] replaced by [y]. *)

    Definition pop : forall s ls,
      Cmd (ls ~~ rep s ls)
      (fun xo => ls ~~ match xo with
                         | None => [ls = nil] * rep s ls
                         | Some x => Exists ls' :@ list T, [ls = x :: ls']
                                     * rep s ls'
                       end).
      intros; refine (hd <- !s;

        IfNull hd Then
          {{Return None}}
        Else
          nd <- !hd;
          Free hd;;
          s ::= next nd;;
          {{Return (Some (data nd))}}); t.
    Qed.
  End Stack.

  (** Finally, since the signature makes the type [t] polymorphic, we define a trivial wrapper that discards the type paramter. *)

  Definition t (_ : Set) := stack.
End Stack.


(*|
==========================
Operational Game Semantics
==========================

.. coq:: none
|*)
From Coq Require Import JMeq Program.Equality EqdepFacts.
From OGS Require Import Utils Ctx CatD EventD ITreeD RecD AngelicD EqD.
From ExtLib.Data Require Import Nat Fin List Unit.
From Paco Require Import paco.
Set Primitive Projections.
Set Implicit Arguments.
Set Equations Transparent.

(*|
An uniform event is one where the set of answers for a given query is
of the form ``list kon`` for some type ``kon``. We argue that the gist
of an OGS is the ability for the opponent to remember all the
continuations that have been offered, and continue not only on the continuations
that have been offered at the last event, but also on all the previous ones.

Hence the OGS of an uniform event will be indexed by an additional
``ks : list kon`` representing the list of currently available continuations
and the set of responses will be the choice of a continuation in the concatenation
of the new continuations available and the ones present in the context.
|*)
Definition ogs {I J} (U : uniform_event I J)
           : event (I * list (kon U)) (J * list (kon U)) :=
  Event (fun '(j , ks) => u_qry U j)
        (fun '(j , ks) q => { i : _ & k_rsp U ((u_rsp U q ++ ks) .[i]) })
        (fun '(j , ks) q r => (k_nxt U (projT2 r) , u_rsp U q ++ ks)).

(*|
An OGS configuration ``c : ogs_conf X ks`` is a heterogeneous list
of ``X``'s for each continuation of the list.
|*)
Definition ogs_conf {I} {U : uniform_event I I}
             (X : I -> Type) (ks : list (kon U)) : Type :=
  dvec (fun k => forall r : k_rsp U k, X (k_nxt U r)) ks.

(*|
Given an OGS configuration containing itrees (eg a forest of itrees
explaining how to continue for every continuation in scope), and an
itree over ``U``, we can generate an itree over ``ogs U``.
|*)
Definition ogs_emb {I} {U : uniform_event I I} {X : I -> Type}
           : forall {i ks},
             ogs_conf (itree U X) ks
           -> itree U X i
           -> itree (ogs U) (X ∘ fst) (i , ks) :=
  cofix _ogs_emb i ks c x := match (observe x) with
    | RetF x => Ret (x : X (fst (i , ks)))
    | TauF t => Tau (_ogs_emb i ks c t)
    | VisF e k => Vis (e : qry (ogs U) (i , ks)) (fun r =>
                   let c' := d_concat _ _ c (curry2' k) in
                   _ogs_emb _ _ c' (uncurry2' (d_get _ c') r))
    end.

(*|
Here is a short lemma injecting a query for ``U`` into a query for ``ogs U``.
|*)
Definition ogs_inj_rsp {I} {U : uniform_event I I} {i ks} {q : qry U i}
          (r : rsp U q) : rsp (ogs U) (q : qry (ogs U) (i , ks)) :=
  fin_inj' _ ,& eq_rect _ (k_rsp U) (projT2 r) _ (fin_inj_get (projT1 r)).

(*|
Next is a definition of eutt lifted to our type of forests: two forests are eutt
if they are pointwise eutt.
|*)
Definition eutt_conf {I} {U : uniform_event I I} {X ks}
           : ogs_conf (itree U X) ks -> ogs_conf (itree U X) ks -> Prop :=
  fun c0 c1 => forall i (r : k_rsp U (ks .[i])), d_get ks c0 i r ≈ d_get ks c1 i r.

(*|
The soundness theorem: if the OGS embedding of two itrees are eutt, then the
trees are themselves eutt. The proof is very direct: by coinduction we pattern
match on the proof, destructing and discriminating everything to expose the forced
constructors (like the kind of clause-based dependent induction that coq-equation
does). The case for Vis is currently not finished, there are still some dependent
equality rewriting shenanigans.
|*)
Theorem ogs_sound {I} {U : uniform_event I I} {X i ks}
        {c0 c1 : ogs_conf (itree U X) ks} {a b : itree U X i}
        (H : ogs_emb c0 a ≈ ogs_emb c1 b) : a ≈ b.
  revert i ks c0 c1 a b H.
  pcofix CIH.
  intros i ks c0 c1 a b H.
  pstep. punfold H.
  red in H |- *.
  remember (observe (ogs_emb c0 a)) as x.
  remember (observe (ogs_emb c1 b)) as y.
  hinduction H before r;
    pclearbot;
    intros CIH c0 c1 a b Ha Hb;
    cbv [ observe ogs_emb ] in Ha, Hb |- *; cbn [ rsp ogs ] in Ha, Hb;
    change (Tau (_ i ks ?c ?t)) with (Tau (ogs_emb c t)) in Ha, Hb;
    change (_ (k_nxt U (projT2 _)) (ks +▶ u_rsp U _)%ctx ?c ?r)
      with (ogs_emb c r) in Ha, Hb.
  + destruct (_observe a); try discriminate Ha.
    destruct (_observe b); try discriminate Hb.
    econstructor.
    injection Ha as <-; injection Hb as <-; auto.
  + destruct (_observe a); try discriminate Ha.
    destruct (_observe b); try discriminate Hb.
    econstructor; right.
    apply (CIH i ks c0 c1).
    cbn [_observe] in Ha, Hb.
    injection Ha as <-; injection Hb as <-; auto.
  + destruct (_observe a); try discriminate Ha.
    destruct (_observe b); try discriminate Hb.
    cbn [_observe] in Ha, Hb.
    injection Ha as <- Ha; injection Hb as <- Hb.
    econstructor; intros v; right.
    apply (CIH _ _ (d_concat ks _ c0 (fun a b => k (a ,& b)))
               (d_concat ks _ c1 (fun a b => k0 (a ,& b)))).
    dependent induction Ha.
    dependent induction Hb.
    apply (fun f => f (ogs_inj_rsp v)) in REL.
    cbn [projT1 projT2 ogs_inj_rsp] in REL.
    admit.
  + destruct (_observe a); try discriminate Ha.
    econstructor; auto.
    enough (Hcut : _) by apply (IHeqitF CIH c0 c1 t b Hcut Hb).
    f_equal; injection Ha as Ha; exact Ha.
  + destruct (_observe b); try discriminate Hb.
    econstructor; auto.
    enough (Hcut : _) by apply (IHeqitF CIH c0 c1 a t Ha Hcut).
    f_equal; injection Hb as Hb; exact Hb.
Admitted.

(*|
The completeness result: given two eutt trees and two pointwise eutt forests,
the OGS embedding are eutt. Again this is a direct proof by coinduction and
pattern matching on the proofs.
|*)
Theorem ogs_complete {I} {U : uniform_event I I} {X i ks}
        (c0 c1 : ogs_conf (itree U X) ks) (a b : itree U X i)
        : (a ≈ b) -> eutt_conf c0 c1 -> ogs_emb c0 a ≈ ogs_emb c1 b.
  revert i ks c0 c1 a b.
  pcofix CIH.
  intros i ks c0 c1 a b H0 H1.
  pstep; punfold H0.
  red in H0, H1 |- *.
  cbv [ observe ] in H0.
  cbv [ ogs_emb observe ]; cbn.
  remember (_observe a) as x.
  remember (_observe b) as y.
  hinduction H0 before r; intros CIH ks c0 c1 a b Ha Hb H1.
  + econstructor; eauto.
  + econstructor. right.
    destruct (_observe a); try discriminate Ha.
    destruct (_observe b); try discriminate Hb.
    enough (Hcut : _) by apply (CIH i ks c0 c1 m1 m2 Hcut H1).
    destruct REL; [eauto | destruct H ].
  + econstructor; intros [ci cr]; right.
    destruct (_observe a); try discriminate Ha.
    destruct (_observe b); try discriminate Hb.
    pose (c0' :=  (d_concat ks (u_rsp U e) c0 (fun a0 b0 => k1 (a0,& b0)))).
    pose (c1' :=  (d_concat ks (u_rsp U e) c1 (fun a0 b0 => k2 (a0,& b0)))).
    enough (Hcut : eutt_conf c0' c1')
      by apply (CIH _ _ c0' c1' _ _ (Hcut ci cr) Hcut).
    clear ci cr.
    injection Ha as <- Ha.
    injection Hb as <- Hb.
    unfold eutt_conf.
    enough (Hcut : _)
      by eapply (d_concat_lem (fun _ (f0 : forall r, _) (f1 : forall r, _) => forall r, f0 r ≈ f1 r)
                  ks (u_rsp U e) c0 c1
                  (fun a0 b0 => k1 (a0 ,& b0)) (fun a0 b0 => k2 (a0 ,& b0))
                  H1 Hcut).
    intros ci cr.
    destruct (REL (ci ,& cr)); [ auto | destruct H ].
  + econstructor; auto.
    destruct (_observe a); try discriminate Ha.
    enough (Hcut : _) by apply (IHeqitF CIH ks c0 c1 t b Hcut Hb H1).
    injection Ha as ->; auto.
  + econstructor; auto.
    destruct (_observe b); try discriminate Hb.
    enough (Hcut : _) by apply (IHeqitF CIH ks c0 c1 a t Ha Hcut H1).
    injection Hb as ->; auto.
Qed.


Set Warnings "-notation-overridden,-parsing".
Require Import Tweetnacl_verif.init_tweetnacl.
Require Import Tweetnacl.Low.Sel25519.
Require Import Tweetnacl.Low.Binary_select.

(*
sv sel25519(gf p,gf q,int b)
{
  i64 t,i,c=~(b-1);
  FOR(i,16) {
    t= c&(p[i]^q[i]);
    p[i]^=t;
    q[i]^=t;
  }
}
*)

Open Scope Z.

Import Low.

Definition sel25519_spec :=
 DECLARE _sel25519
  WITH p: val, q: val, sh : share, contents_p : list Z, contents_q : list Z, b:Z
  PRE [ _p OF (tptr tlg), _q OF (tptr tlg), _b OF tint]
        PROP  (writable_share sh;
                Zlength contents_p = 16;
                Zlength contents_q = 16;
                b = 0 \/ b = 1)
        LOCAL (temp _p p; temp _q q; temp _b (Vint (Int.repr b)))
        SEP   ( sh [{ p }] <<(lg16)-- mVI64 contents_p;
                sh [{ q }] <<(lg16)-- mVI64 contents_q)
  POST [ tvoid ]
        PROP ()
        LOCAL()
        SEP  (sh [{ p }] <<(lg16)-- mVI64 (Sel25519 b contents_p contents_q);
              sh [{ q }] <<(lg16)-- mVI64 (Sel25519 b contents_q contents_p)).

Definition sel25519_Inv sh p q b c contents_p contents_q :=
  EX i : Z,
    PROP  (writable_share sh;
            Zlength contents_p = 16;
            Zlength contents_q = 16;
            b = 0 \/ b = 1;
            c = set_xor b)
    LOCAL (temp _c (Vlong (Int64.repr c)); temp _p p; temp _q q; temp _b (Vint (Int.repr b)))
    SEP   ( sh [{ p }] <<(lg16)-- mVI64 (list.take (nat_of_Z i) (Sel25519 b contents_p contents_q) ++ list.drop (nat_of_Z i) contents_p);
            sh [{ q }] <<(lg16)-- mVI64 (list.take (nat_of_Z i) (Sel25519 b contents_q contents_p) ++ list.drop (nat_of_Z i) contents_q)).

Close Scope Z.


Require Export List.
Require Export Bool.
Require Export Arith.
Require Export Peano_dec.
Require Export Coq.Arith.PeanoNat.
Require Import CpdtTactics.
Require Export Coq.Program.Wf.
Require Export Coq.Program.Tactics.
Require Export Coq.Logic.FunctionalExtensionality.
Require Export Recdef.
Require Import wyv_common.
Require Import rhs_mat_tree.
Set Implicit Arguments.

Import WfExtensionality.

Lemma subtype_rfn_top_rfn_top_reduce :
  forall T1 Ts1, T1 = (t_rfn_top Ts1) ->
            forall T2 Ts2, T2 = (t_rfn_top Ts2) ->
                      subtype T1 T2 = subtype Ts1 Ts2.
Proof.
  intros.

  remember (subtype T1 T2) as sub_fn; subst T1 T2.

  unfold subtype, subtype_func in Heqsub_fn;
    simpl in Heqsub_fn;
    rewrite fix_sub_eq_ext in Heqsub_fn;
    simpl in Heqsub_fn;
    fold subtype_func in Heqsub_fn;
    auto.
Qed.

Lemma subtype_rfn_top_sel_low_reduce :
  forall T1 Ts, T1 = (t_rfn_top Ts) ->
           forall T2 x L T, T2 = (t_sel_low x L T) ->
                       subtype T1 T2 = subtype T1 T.
Proof.
  intros.

  remember (subtype T1 T2) as sub_fn; subst T1 T2.

  unfold subtype, subtype_func in Heqsub_fn;
    simpl in Heqsub_fn;
    rewrite fix_sub_eq_ext in Heqsub_fn;
    simpl in Heqsub_fn;
    fold subtype_func in Heqsub_fn;
    auto.
Qed.

Lemma subtype_rfn_top_sel_equ_reduce :
  forall T1 Ts, T1 = (t_rfn_top Ts) ->
             forall T2 x L T, T2 = (t_sel_equ x L T) ->
                         subtype T1 T2 = subtype T1 T.
Proof.
  intros.

  remember (subtype T1 T2) as sub_fn; subst T1 T2.

  unfold subtype, subtype_func in Heqsub_fn;
    simpl in Heqsub_fn;
    rewrite fix_sub_eq_ext in Heqsub_fn;
    simpl in Heqsub_fn;
    fold subtype_func in Heqsub_fn;
    auto.
Qed.

Lemma subtype_rfn_top_other_reduce :
  forall T1 Ts1, T1 = (t_rfn_top Ts1) ->
             forall T2, (T2 <> t_top) ->
                   (forall Ts2, T2 <> (t_rfn_top Ts2)) ->
                   (forall x L T, T2 <> (t_sel_low x L T)) ->
                   (forall x L T, T2 <> (t_sel_equ x L T)) ->
                   subtype T1 T2 = false.
Proof.
  intros.

  remember (subtype T1 T2) as sub_fn; subst T1.

  unfold subtype, subtype_func in Heqsub_fn;
    simpl in Heqsub_fn;
    rewrite fix_sub_eq_ext in Heqsub_fn;
    simpl in Heqsub_fn;
    fold subtype_func in Heqsub_fn;
    auto.

  destruct T2; auto;
    [contradiction H0; auto
    |contradiction (H2 v l T2); auto
    |contradiction (H3 v l T2); auto
    |contradiction (H1 T2); auto].

Qed.

Lemma subtype_rfn_top_reduce :
  forall T1 Ts1, T1 = (t_rfn_top Ts1) ->
            forall T2, subtype T1 T2 = match T2 with
                                  | t_top => true
                                  | t_sel_low x L T => subtype T1 T
                                  | t_sel_equ x L T => subtype T1 T
                                  | t_rfn_top Ts2 => subtype Ts1 Ts2
                                  | _ => false
                                  end.
Proof.
  intros; subst; destruct T2;
    try solve [eapply subtype_rfn_top_other_reduce; crush].

  apply subtype_top; crush.

  eapply subtype_rfn_top_sel_low_reduce; crush.

  eapply subtype_rfn_top_sel_equ_reduce; crush.

  eapply subtype_rfn_top_rfn_top_reduce; crush.
Qed.


From Categories Require Import Essentials.Notations.
From Categories Require Import Essentials.Types.
From Categories Require Import Essentials.Facts_Tactics.
From Categories Require Import Category.Main.
From Categories Require Import Functor.Functor Functor.Functor_Ops
        Functor.Representable.Hom_Func.
From Categories Require Import Functor.Functor_Extender.
From Categories Require Import NatTrans.NatTrans NatTrans.Operations
        NatTrans.Func_Cat NatTrans.NatIso.
From Categories Require Import Ext_Cons.Prod_Cat.Prod_Cat Ext_Cons.Prod_Cat.Operations
        Ext_Cons.Prod_Cat.Nat_Facts.
From Categories Require Import KanExt.Local
        KanExt.LocalFacts.HomToCones
        KanExt.LocalFacts.ConesToHom.

Local Open Scope functor_scope.

(** This module contains facts about local kan extensions involving natural
    isomorphism. *)

(** Any two naturally isomorphic functors have the same kan extensions –
stated with hom functor definition of local kan extensions. *)
Section Hom_Local_Right_KanExt_Iso.
  Context {C C' : Category} {p : C –≻ C'}
          {D : Category} {F F' : C –≻ D}
          (N : (F' ≃ F)%natiso)
          (hlrke : Hom_Local_Right_KanExt p F).

  Definition Hom_Local_Right_KanExt_Iso : Hom_Local_Right_KanExt p F' :=
    {|
      HLRKE := hlrke;
      HLRKE_Iso :=
        (
          (HLRKE_Iso hlrke)
            ∘ (
              (Fix_Bi_Func_2_object_NatIso (Hom_Func (Func_Cat C D)) N)
               ∘_h (NatTrans_id_Iso (Left_Functor_Extender p D)^op)
            )
        )%isomorphism%natiso

    |}.

End Hom_Local_Right_KanExt_Iso.

(** Any two naturally isomorphic functors have the same kan extensions –
stated with cones definition of local kan extensions. *)
Section Local_Right_KanExt_Iso.
  Context {C C' : Category}
          {p : C –≻ C'}
          {D : Category}
          {F F' : C –≻ D}
          (N : (F' ≃ F)%natiso)
          (hlrke : Local_Right_KanExt p F).

  Definition Local_Right_KanExt_Iso : Local_Right_KanExt p F' :=
    Hom_Local_Right_KanExt_to_Local_Right_KanExt
      (Hom_Local_Right_KanExt_Iso
         N
         (Local_Right_KanExt_to_Hom_Local_Right_KanExt hlrke)
      ).

End Local_Right_KanExt_Iso.

(** If a functor is naturally isomorphic to the local right kan extension then
it also is local right kan extensions *)
Section Iso_Hom_Local_Right_KanExt.
  Context {C C' : Category}
          {p : C –≻ C'}
          {D : Category}
          {F : C –≻ D}
          {hlrke hlrke' : C' –≻ D}
          (N : (hlrke ≃ hlrke')%natiso)
          (ihlrke : Hom_Local_Right_KanExt_Isomorphism p F hlrke).

  Definition Iso_Hom_Local_Right_KanExt : Hom_Local_Right_KanExt p F :=
    {|
      HLRKE := hlrke';
      HLRKE_Iso :=
        ((Fix_Bi_Func_2_object_NatIso (Hom_Func (Func_Cat C' D)) N)
           ∘ ihlrke)%isomorphism
    |}.

End Iso_Hom_Local_Right_KanExt.

(** If a functor is naturally isomorphic to the local left kan extension then
it also is local left kan extensions – proven using duality. *)
Section Iso_Local_Right_KanExt.
  Context {C C' : Category}
          {p : C –≻ C'}
          {D : Category}
          {F : C –≻ D}
          {hlrke hlrke' : C' –≻ D}
          (N : (hlrke ≃ hlrke')%natiso)
          (ihlrke : is_Local_Right_KanExt p F hlrke).

  Definition  Iso_Local_Right_KanExt : is_Local_Right_KanExt p F hlrke' :=
    Local_Right_KanExt_is_Local_Right_KanExt
      _
      _
      (
        Hom_Local_Right_KanExt_to_Local_Right_KanExt
          (Iso_Hom_Local_Right_KanExt
             N
             (HLRKE_Iso
                (Local_Right_KanExt_to_Hom_Local_Right_KanExt
                   (is_Local_Right_KanExt_Local_Right_KanExt _ _ ihlrke)
                )
             )
          )
      ).

End Iso_Local_Right_KanExt.

(** Kan extension along any two naturally isomorphic functors is the same –
stated with hom functor definition of local kan extensions. *)
Section Hom_Local_Right_KanExt_Iso_along.
  Context {C C' : Category} {p p' : C –≻ C'}
          (N : (p' ≃ p )%natiso)
          {D : Category} {F : C –≻ D}
          (hlrke : Hom_Local_Right_KanExt p F).

  Program Definition Hom_Local_Right_KanExt_Iso_along
    : Hom_Local_Right_KanExt p' F :=
    {|
      HLRKE := hlrke;
      HLRKE_Iso :=
        (
          (HLRKE_Iso hlrke)
            ∘ (
              (NatTrans_id_Iso
                 (@Fix_Bi_Func_2
                    _ (Func_Cat C D) _ F (Hom_Func (Func_Cat C D))))
                ∘_h ((Left_Functor_Extender_Iso N D)^op)
            )
        )%isomorphism%natiso
    |}.

End Hom_Local_Right_KanExt_Iso_along.

(** Any two naturally isomorphic functors have the same kan extensions –
stated with cones definition of local kan extensions. *)
Section Local_Right_KanExt_Iso_along.
  Context {C C' : Category} {p p' : C –≻ C'}
          (N : (p' ≃ p)%natiso)
          {D : Category} {F : C –≻ D}
          (hlrke : Local_Right_KanExt p F).

  Definition Local_Right_KanExt_Iso_along : Local_Right_KanExt p' F :=
    Hom_Local_Right_KanExt_to_Local_Right_KanExt
      (Hom_Local_Right_KanExt_Iso_along
         N
         (Local_Right_KanExt_to_Hom_Local_Right_KanExt hlrke)
      ).

End Local_Right_KanExt_Iso_along.


Require Export ProjectiveGeometry.Dev.desargues_2D_lemmasV2.

(*****************************************************************************)
(** Proof of 2D lemmas V3 about Desargues **)

Section s_desargues2DLemmasV3.

Context `{RPSOH : RankProjectiveSpaceOrHigher}.
Context `{EP : EqDecidability Point}.

Lemma beta_ok' : forall
(A' : Point)
(B' : Point)
(C' : Point)
(A : Point)
(B : Point)
(C : Point)
(O : Point)
(rABC : rk (triple A B C) = 3)
(rA'B'C' : rk (triple A' B' C') = 3)
(rABCA'B'C'O : rk
                (union (triple A B C) (union (triple A' B' C') (singleton O))) =
              3)
(rABO : rk (triple A B O) = 3)
(rACO : rk (triple A C O) = 3)
(rBCO : rk (triple B C O) = 3)
(rA'B'O' : rk (triple A' B' O) = 3)
(rA'C'O' : rk (triple A' C' O) = 3)
(rB'C'O' : rk (triple B' C' O) = 3)
(rAA'O : rk (triple A A' O) = 2)
(rBB'O : rk (triple B B' O) = 2)
(rCC'O : rk (triple C C' O) = 2)
(rAA' : rk (couple A A') = 2)
(rBB' : rk (couple B B') = 2)
(rCC' : rk (couple C C') = 2)
(P : Point)
(rABOP : rk (add P (triple A B O)) >= 4)
(rOP : rk (couple O P) = 2)
(o : Point)
(rko1 : rk (triple o O P) = 2)
(rko2 : rk (couple O o) = 2)
(rko3 : rk (couple P o) = 2)
(alpha : Point)
(beta : Point)
(gamma : Point)
(rABgamma : rk (triple A B gamma) = 2)
(rA'B'gamma : rk (triple A' B' gamma) = 2)
(rACbeta : rk (triple A C beta) = 2)
(rA'C'beta : rk (triple A' C' beta) = 2)
(rBCalpha : rk (triple B C alpha) = 2)
(rB'C'alpha : rk (triple B' C' alpha) = 2)
(a : Point)

(Ha2 : rk (triple o A a) = 2)
(Ha2' : rk (triple P A' a) = 2)
(b : Point)
(Hb2 : rk (triple o B b) = 2)
(Hb2' : rk (triple P B' b) = 2)
(c : Point)
(Hc2 : rk (triple o C c) = 2)
(Hc2' : rk (triple P C' c) = 2)
(rabc3 : rk (triple a b c) = 3),
rk (triple a c beta) = 2.
Proof.
intros.
assert (rk(union (triple a c A) (couple C beta))=3).
assert (rk(add c (triple A C a)) = 3).
apply le_antisym.
assert(rk(union (triple A C a) (couple c o))<=3).
generalize (matroid3 (triple o A a) (triple o C c)).
setoid_replace (union (triple o A a) (triple o C c)) with (union (triple A C a) (couple c o)) by (unfold Equal; split;(clear_all;fsetdecide)).
assert (rk (inter (triple o A a) (triple o C c)) >= rk(singleton o)).
apply matroid2;(clear_all;fsetdecide).
rewrite rk_singleton in H0.
omega.
assert (rk (add c (triple A C a))<=rk (union (triple A C a) (couple c o))).
apply matroid2;(clear_all;fsetdecide).
omega.
generalize (matroid3 (add c (triple A C a)) (triple P A' a)).
assert (rk(union (add c (triple A C a)) (triple P A' a))>=rk(add P (triple A A' C))).
apply matroid2;(clear_all;fsetdecide).
assert (rk(add P (triple A A' C))>=4).
setoid_replace (triple A A' C)  with (triple A C A') by (clear_all;fsetdecide).
apply (l2rABMP_scheme  A' C' B' A C B O).
setoid_replace (triple A C B) with (triple A B C) by (clear_all;fsetdecide); assumption.
setoid_replace (triple A C B) with (triple A B C) by (clear_all;fsetdecide).
setoid_replace (triple A' C' B') with (triple A' B' C') by (clear_all;fsetdecide); assumption.
assumption.
assumption.
assumption.
eapply rAO;eassumption.
eapply rCO; eassumption.
assumption.
assumption.
eapply rACOP with (B0:=B) (A'0:=A') (B'0:=B') (C'0:=C'); try eassumption.
solve [intuition].
assert (rk (inter (add c (triple A C a)) (triple P A' a)) >= rk(singleton a)).
apply matroid2;(clear_all;fsetdecide).
rewrite rk_singleton in H2.
omega.
apply le_antisym.
generalize (matroid3 (add c (triple A C a)) (triple A C beta)).
assert (rk(inter (add c (triple A C a)) (triple A C beta))>=rk(couple A C)).
apply matroid2;(clear_all;fsetdecide).
setoid_replace (union (add c (triple A C a)) (triple A C beta)) with (union (triple a c A) (couple C beta)) by (unfold Equal; split;(clear_all;fsetdecide)).
assert (rk(couple A C)=2).
apply (rk_triple_ABC_couple_AC A B C rABC).
omega.
assert (rk (add c (triple A C a)) <=rk (union (triple a c A) (couple C beta))).
apply matroid2;(clear_all;fsetdecide).
omega.

assert(rk(union (triple a c A') (couple C' beta))=3).
assert (rk(add c (triple A' C' a)) = 3).
apply le_antisym.
assert(rk(union (triple A' C' a) (couple c P))<=3).
generalize (matroid3 (triple P A' a) (triple P C' c)).
setoid_replace (union (triple P A' a) (triple P C' c)) with (union (triple A' C' a) (couple c P)) by (unfold Equal; split;(clear_all;fsetdecide)).
assert (rk (inter (triple P A' a) (triple P C' c)) >= rk(singleton P)).
apply matroid2;(clear_all;fsetdecide).
rewrite rk_singleton in H1.
omega.
assert (rk (add c (triple A' C' a))<=rk (union (triple A' C' a) (couple c P)) ).
apply matroid2;(clear_all;fsetdecide).
omega.
generalize (matroid3 (add c (triple A' C' a)) (triple o A a)).
assert (rk(union (add c (triple A' C' a)) (triple o A a))>=rk(add o (triple A' A C'))).
apply matroid2; (clear_all;fsetdecide).
assert (rk(add o (triple A' A C'))>=4).
setoid_replace (triple A' A C')  with  (triple A' C' A) by (clear_all;fsetdecide).
eapply (rA'C'Mo A' B' C' A B C);try eassumption || intuition.
assert (rk (inter (add c (triple A' C' a)) (triple o A a)) >= rk(singleton a)).
apply matroid2; (clear_all;fsetdecide).
rewrite rk_singleton in H3.
omega.
apply le_antisym.
generalize (matroid3 (add c (triple A' C' a)) (triple A' C' beta)).
assert (rk(inter (add c (triple A' C' a)) (triple A' C' beta))>=rk(couple A' C')).
apply matroid2; (clear_all;fsetdecide).
setoid_replace (union (add c (triple A' C' a)) (triple A' C' beta)) with (union (triple a c A') (couple C' beta)) by (unfold Equal; split; (clear_all;fsetdecide)).
assert (rk(couple A' C')=2).
apply (rk_triple_ABC_couple_AC A' B' C' rA'B'C').
omega.
assert (rk (add c (triple A' C' a)) <=rk (union (triple a c A') (couple C' beta))).
apply matroid2; (clear_all;fsetdecide).
omega.

generalize (matroid3 (union (triple a c A)(couple  C beta)) (union (triple a c A')  (couple C' beta))).
assert (rk (inter (union (triple a c A) (couple C beta)) (union (triple a c A') (couple C' beta)))>=rk(triple a c beta)).
apply matroid2; (clear_all;fsetdecide).
assert (rk
  (union (union (triple a c A) (couple C beta))
     (union (triple a c A') (couple C' beta)))>=4).
assert (rk(add a (triple A A' C))>=4).
generalize (rABCa A' B' C' A B C O rABC rA'B'C' rABCA'B'C'O
            rABO rACO rBCO rA'B'O' rA'C'O' rB'C'O' rAA'O rBB'O rCC'O rAA'
            rBB' rCC' P rABOP rOP o rko1 rko2  rko3 a Ha2 Ha2'); intros rABCa'.
setoid_replace (triple A A' C) with (triple A' A C) by (clear_all;fsetdecide).
apply (rk3_4 B A C A' a).
apply le_antisym.
rewrite <- rABCA'B'C'O.
apply matroid2;(clear_all;fsetdecide).
rewrite <- rABC.
apply matroid2;(clear_all;fsetdecide).
apply le_antisym.
rewrite <- rABCA'B'C'O.
apply matroid2;(clear_all;fsetdecide).
generalize (matroid3 (triple A A' O) (triple A C A')).
assert (rk (union (triple A A' O) (triple A C A'))>=rk(triple A C O)).
apply matroid2;(clear_all;fsetdecide).
assert (rk (inter (triple A A' O) (triple A C A')) >= rk (couple A A')).
apply matroid2;(clear_all;fsetdecide).
omega.
setoid_replace (triple B A C) with  (triple A B C) by (clear_all;fsetdecide); assumption.
assert (rk
  (union (union (triple a c A) (couple C beta))
     (union (triple a c A') (couple C' beta)))>=rk(add a (triple A A' C))).
apply matroid2;(clear_all;fsetdecide).
intros;omega.
assert (rk(couple a c)=2).
eapply rk_triple_ABC_couple_AC; eassumption.
assert (rk(triple a c beta)>=rk(couple a c)).
apply matroid2;(clear_all;fsetdecide).
omega.
Qed.

End s_desargues2DLemmasV3.


(** * Convertion from values back to expressions through the environment substitution *)
Require Import List Bool Relations Morphisms ssrbool PeanoNat.
Require Import MetaCoq.Template.utils.

From ConCert.Embedding Require Import EvalE Ast CustomTactics Misc MyEnv.

(** ** Substitution for the nameless representation *)
Module NamelessSubst.

  Definition expr_to_ty (e : expr) : option type :=
    match e with
    | eTy ty => Some ty
    | _ => None
    end.

  Definition lookup_ty (ρ : env expr) (i : nat) : option type :=
     match lookup_i ρ i with
     | Some e => expr_to_ty e
     | None => None
     end.

  Fixpoint subst_env_i_ty (k : nat) (ρ : env expr) (ty : type) : type :=
      match ty with
      | tyInd x => ty
      | tyForall x ty => tyForall x (subst_env_i_ty (1+k) ρ ty)
      | tyApp ty1 ty2 =>
        let ty2' := subst_env_i_ty k ρ ty2 in
        let ty1' := subst_env_i_ty k ρ ty1 in
        tyApp ty1' ty2'
      | tyVar nm => ty
      | tyRel i => if Nat.leb k i then
                    from_option (lookup_ty ρ (i-k)) (tyRel i) else tyRel i
      | tyArr ty1 ty2 =>
        let ty2' := subst_env_i_ty k ρ ty2 in
        let ty1' := subst_env_i_ty k ρ ty1 in
        tyArr ty1' ty2'
      end.

   (** NOTE: assumes, that expression in [ρ] are closed! *)
  Fixpoint subst_env_i_aux (k : nat) (ρ : env expr) (e : expr) : expr :=
    match e with
    | eRel i => if Nat.leb k i then
                 from_option (lookup_i ρ (i-k)) (eRel i) else eRel i
    | eVar nm  => eVar nm
    | eLambda nm ty b => eLambda nm (subst_env_i_ty k ρ ty) (subst_env_i_aux (1+k) ρ b)
    | eTyLam nm b => eTyLam nm (subst_env_i_aux (1+k) ρ b)
    | eLetIn nm e1 ty e2 => eLetIn nm (subst_env_i_aux k ρ e1) (subst_env_i_ty k ρ ty)
                                  (subst_env_i_aux (1+k) ρ e2)
    | eApp e1 e2 => eApp (subst_env_i_aux k ρ e1) (subst_env_i_aux k ρ e2)
    | eConstr t i as e' => e'
    | eConst nm => eConst nm
    | eCase nm_i ty e bs =>
      let (nm, tys) := nm_i in
      eCase (nm,map (subst_env_i_ty k ρ) tys) (subst_env_i_ty k ρ ty) (subst_env_i_aux k ρ e)
            (map (fun x => (fst x, subst_env_i_aux (length (fst x).(pVars) + k) ρ (snd x))) bs)
    | eFix nm v ty1 ty2 b => eFix nm v (subst_env_i_ty k ρ ty1) (subst_env_i_ty k ρ ty2)
                                 (subst_env_i_aux (2+k) ρ b)
    | eTy ty => eTy (subst_env_i_ty k ρ ty)
    end.

  Definition subst_env_i := subst_env_i_aux 0.

    (** Converting from values back to expressions.
       This will be used to compare results of the evaluation with different semantics, or
       for stating soundness theorem for the translation to a different language, e.g.
       to Template Coq terms.

       The most non-trivial part is to convert closures, for which we have to perform some form
       of substitution of values from the value environment (see [subst_env])
       Inspired by the implementation of
       "A Certified Implementation of ML with Structural Polymorphism" by Jacques Garrigue.
     *)

  Notation apps := vars_to_apps.

  Fixpoint of_val_i (v : val) : expr :=
    match v with
    | vConstr c i vs => apps (eConstr c i) (map of_val_i vs)
    | vClos ρ nm cm ty1 ty2 e =>
      let res := match cm with
                 | cmLam => eLambda nm ty1 e
                 | cmFix fixname => eFix fixname nm ty1 ty2 e
                end
      in subst_env_i (map (fun x => (fst x, of_val_i (snd x))) ρ) res
    | vTyClos ρ nm e => subst_env_i (map (fun x => (fst x, of_val_i (snd x))) ρ)
                                 (eTyLam nm e)
    | vTy ty => eTy ty

    end.

  Notation exprs := (map (fun x => (fst x, of_val_i (snd x)))).

  (** *** Notations for the environment substitution *)
  Notation "e .[ ρ ] n " := (subst_env_i_aux n ρ e) (at level 6).

  Definition inst_env_i (ρ : env val) (e : expr) : expr :=
    subst_env_i (map (fun x => (fst x, of_val_i (snd x))) ρ) e.
  Notation "e .[ ρ ]" := (subst_env_i ρ e) (at level 6).

  Import Lia.

  Lemma lookup_i_of_val_env ρ n v :
    lookup_i ρ n = Some v -> lookup_i (exprs ρ) n = Some (of_val_i v).
  Proof.
    revert dependent n.
    induction ρ;intros n0 Hρ.
    + easy.
    + destruct a;simpl in *.
      destruct n0.
      * simpl in *. inversion Hρ. subst. reflexivity.
      * simpl in *. replace (n0 - 0) with n0 in * by lia. easy.
  Qed.

  Lemma inst_env_i_in (ρ : env val) n :
    n <? length ρ ->
    {v | lookup_i ρ n = Some v /\ (eRel n).[exprs ρ] = of_val_i v}.
  Proof.
    intros Hlt.
    revert dependent n.
    induction ρ;intros n1 Hlt.
    + easy.
    + destruct (Nat.eqb n1 0) eqn:Hn1.
      * destruct a. eexists. split.
        ** simpl. rewrite Hn1.
           reflexivity.
        ** simpl in *. unfold inst_env_i,subst_env_i. simpl.
           assert (n1=0) by (apply EqNat.beq_nat_eq; easy).
           subst. simpl. reflexivity.
      * destruct a.
        assert (Hn2 : {n2 | n1 = S n2}) by (destruct n1 as [ | n2]; tryfalse; exists n2; reflexivity).
        destruct Hn2 as [n2 Heq_n2]. replace (n1-1) with n2 by lia.
        subst. simpl in Hlt. unfold is_true in *. rewrite Nat.ltb_lt in Hlt.
        apply Lt.lt_S_n in Hlt. rewrite <- Nat.ltb_lt in Hlt.
        specialize (IHρ _ Hlt). destruct IHρ as [v1 HH]. destruct HH as [H1 H2].
        exists v1. split.
        ** simpl in *. replace (n2 - 0) with n2 by lia. assumption.
        ** specialize (lookup_i_length _ _ Hlt) as Hlookup.
           destruct Hlookup.
           simpl in *. unfold inst_env_i,subst_env_i in *. simpl in *.
           rewrite <- H2. replace (n2 - 0) with n2 by lia.
           apply lookup_i_of_val_env in H1.
           now eapply from_option_indep.
  Qed.

End NamelessSubst.

(** ** Substitution for the named representation *)
Module NamedSubst.

  (** Currenlty we do not use named substitution in our soundness proof. *)

  (** NOTE: assumes, that expression in [ρ] are closed! *)
 Fixpoint subst_env (ρ : list (ename * expr)) (e : expr) : expr :=
  match e with
  | eRel i as e' => e'
  | eVar nm  => match lookup ρ nm with
                    | Some v => v
                    | None => e
                    end
  | eLambda nm ty b => eLambda nm ty (subst_env (remove_by_key nm ρ) b)
  | eTyLam nm b => eTyLam nm (subst_env (remove_by_key nm ρ) b)
  | eLetIn nm e1 ty e2 => eLetIn nm (subst_env ρ e1) ty (subst_env (remove_by_key nm ρ) e2)
  | eApp e1 e2 => eApp (subst_env ρ e1) (subst_env ρ e2)
  | eConstr t i as e' => e'
  | eConst nm => eConst nm
  | eCase nm_i ty e bs =>
    (* TODO: this case is not complete! We ignore variables bound by patterns *)
    eCase nm_i ty (subst_env ρ e) (map (fun x => (fst x, subst_env ρ (snd x))) bs)
  | eFix nm v ty1 ty2 b => eFix nm v ty1 ty2 (subst_env (remove_by_key v ρ) b)
  | eTy _ => e
  end.

  Fixpoint of_val (v : val) : expr :=
    match v with
    | vConstr x i vs => vars_to_apps (eConstr x i) (map of_val vs)
    | vClos ρ nm cm ty1 ty2 e =>
      let res := match cm with
                 | cmLam => eLambda nm ty1 e
                 | cmFix fixname => eFix fixname nm ty1 ty2 e
                 end
      in subst_env (map (fun x => (fst x, of_val (snd x))) ρ) res
    | vTyClos ρ nm e => subst_env (map (fun x => (fst x, of_val (snd x))) ρ)
                                 (eTyLam nm e)
    | vTy ty => eTy ty
    end.

 Definition inst_env (ρ : env val) (e : expr) : expr :=
    subst_env (map (fun x => (fst x, of_val (snd x))) ρ) e.

End NamedSubst.

Module Equivalence.
  Import NamelessSubst.
  Reserved Notation "v1 ≈ v2" (at level 50).

  Inductive val_equiv : relation val :=
  | veqConstr i n (vs1 vs2 : list val) :
      Forall2 (fun v1 v2 => v1 ≈ v2) vs1 vs2 -> vConstr i n vs1 ≈ vConstr i n vs2
  | veqClosLam ρ1 ρ2 nm ty1 e1 e2 :
      inst_env_i ρ1 (eLambda nm ty1 e1) = inst_env_i ρ2 (eLambda nm ty1 e2) ->
      (* ty2 used only by a fixpoint, so it doesn't matter here *)
      forall ty2 ty2', vClos ρ1 nm cmLam ty1 ty2 e1 ≈ vClos ρ2 nm cmLam ty1 ty2' e2
  | veqClosFix ρ1 ρ2 n ty1 ty2 e1 e2 :
      (forall fixname ty2 , inst_env_i ρ1 (eFix fixname n ty1 ty2 e1) =
       inst_env_i ρ2 (eFix fixname n ty1 ty2 e2)) ->
       (forall fixname, vClos ρ1 n (cmFix fixname) ty1 ty2 e1 ≈ vClos ρ2 n (cmFix fixname) ty1 ty2 e2)
   | veqClosTyLam ρ1 ρ2 nm e1 e2 :
       inst_env_i ρ1 (eTyLam nm e1) = inst_env_i ρ2 (eTyLam nm e2) ->
       (* ty2 used only by a fixpoint, so it doesn't matter here *)
       vTyClos ρ1 nm e1 ≈ vTyClos ρ2 nm e2
   | veqTy ty :
       vTy ty ≈ vTy ty
   where
   "v1 ≈ v2" := (val_equiv v1 v2).

   Definition list_val_equiv vs1 vs2 := Forall2 (fun v1 v2 => v1 ≈ v2) vs1 vs2.
   Notation " vs1 ≈ₗ vs2 " := (list_val_equiv vs1 vs2) (at level 50).

   Instance val_equiv_reflexive : Reflexive val_equiv.
   Proof.
     intros v. induction v using val_ind_full.
     + constructor.
       induction l;constructor; inversion H; easy.
     + destruct cm;constructor;reflexivity.
     + constructor. reflexivity.
     + constructor.
   Defined.

   (* TODO:  Add the rest to prove that [val_equiv] is indeed an equivalence *)
   Axiom val_equiv_symmetric : Symmetric val_equiv.
   Axiom val_equiv_transitive : Transitive val_equiv.

   Existing Instance val_equiv_symmetric.
   Existing Instance val_equiv_transitive.

   (* TODO:  Define these  *)
   Axiom list_val_equiv_reflexive : Reflexive list_val_equiv.
   Axiom list_val_equiv_symmetric : Symmetric list_val_equiv.
   Axiom list_val_equiv_transitive : Transitive list_val_equiv.

   Existing Instance list_val_equiv_reflexive.
   Existing Instance list_val_equiv_symmetric.
   Existing Instance list_val_equiv_transitive.

   Lemma list_val_compat v1 v2 vs1 vs2 :
     v1 ≈ v2 -> vs1 ≈ₗ vs2 -> (v1 :: vs1) ≈ₗ (v2 :: vs2).
   Proof.
     intros Heq Heql.
     constructor;easy.
   Qed.

   Instance cons_compat : Proper (val_equiv ==> list_val_equiv ==> list_val_equiv) cons.
   Proof.
      cbv;intros;apply list_val_compat;assumption.
    Defined.

    Lemma constr_cons_compat (vs1 vs2 : list val) (i : inductive) (nm : ename) :
      vs1 ≈ₗ vs2 -> (vConstr i nm vs1) ≈ (vConstr i nm vs2).
    Proof.
      intros Heql.
      constructor.
      induction Heql.
      + constructor.
      + constructor; assumption.
    Defined.

    Instance constr_morph i nm : Proper (list_val_equiv ==> val_equiv) (vConstr i nm).
    Proof.
      cbv;intros;apply constr_cons_compat;assumption.
    Defined.
End Equivalence.