(* Copyright 2012-2015 by Adam Petcher.				*
 * Use of this source code is governed by the license described	*
 * in the LICENSE file at the root of the source tree.		*)

Set Implicit Arguments.

Require Import FCF.
Require Import HasDups.
Require Import RndInList.
Require Import CompFold.
Require Import Permutation.

(* Indistinguishability definition for DRBGs *)
Section DRBG.

  (* The type of random seeds. *)
  Variable S : Set.
  Hypothesis S_EqDec : EqDec S.
  Variable RndS : Comp S.

  (* The type of DRBG outputs. *)
  Variable R : Set.
  Hypothesis R_EqDec : EqDec R.
  Variable RndR : Comp R.

  (* The DRBG *)
  Variable f : S -> R.

  Variable A : R -> Comp bool.

  Definition DRBG_G0 :=
    s <-$ RndS ;
    A (f s).

  Definition DRBG_G1 :=
    r <-$ RndR;
    A r.

  Definition DRBG_Advantage := | Pr[DRBG_G0] - Pr[DRBG_G1] |.

End DRBG.

Require Import PRF.

(* To keep things simple, we will assume that PRF outputs are bit vectors, and the DRBG output is a list of these bit vectors.  This setup can be generalized, if necessary.  *)

(* We need an adaptively-secure PRF because we use the PRF output to produce the next input, and therefore this input is unpredictable. *)

Local Open Scope list_scope.
Local Opaque evalDist.

Section PRF_DRBG.

  Variable Key D : Set.
  (* The range of the PRF is a bit vector of length eta. *)
  Variable eta : nat.
  Hypothesis D_EqDec : EqDec D.

  Variable RndKey : Comp Key.

  (* f is an adaptively-secure PRF. *)
  Variable f : Key -> D -> Bvector eta.

  (* For this construction, we need an injection from the range of the PRF to the domain.  This allows us to use the previous PRF output to compute the next one. *)
  Variable injD : Bvector eta -> D.
  Hypothesis injD_correct :
    forall r1 r2, (injD r1) = (injD r2) -> r1 = r2.

  (* The length (in PRF output blocks) of the DRBG output is l.  This value must be positive. *)
  Variable l : nat.
  Hypothesis l_pos : l  > 0.

  (* Because the DRBG is constructed using feedback from the previous iteration, we need an initial value.  We assume an arbitrary bit vector and then inject it into the domain of the PRF.  This arrangement was chosen for simplicity, and it could easily be modified or generalized. *)
  Variable r_init : Bvector eta.
  Definition v_init := injD r_init.

  (* The computation used to obtain uniform random values in the range of the DRBG.  This computation is used only in the security definition. *)
  Definition RndOut := compMap _ (fun _ => {0, 1}^eta) (forNats l).

  (* We model the DRBG using a function that uses the previous output value (injected into the domain) as the current input value of the PRF. *)
  Fixpoint PRF_DRBG_f (v : D)(n : nat)(k : Key) :=
    match n with
        | O => nil
        | S n' =>
          r <- (f k v);
            r :: (PRF_DRBG_f (injD r) n' k)
    end.

  Definition PRF_DRBG (k : Key) :=
    PRF_DRBG_f v_init l k.

  (* The adversary against the DRBG. *)
  Variable A : list (Bvector eta) -> Comp bool.
  Hypothesis A_wf : forall c, well_formed_comp (A c).

  (* Step 1: inline definitions and simplify. *)
  Definition PRF_DRBG_G1 :=
    s <-$ RndKey ;
    A (PRF_DRBG_f v_init l s).

  (* This game is equivalent to the first game in the DRBG security definition. *)
  Theorem PRF_DRBG_G1_equiv :
    Pr[DRBG_G0 RndKey PRF_DRBG A] == Pr[PRF_DRBG_G1].

    reflexivity.

  Qed.

  (* Step 2: use the PRF as an oracle.  This will allow us to apply the security definition and replace it in the next step.*)
  Fixpoint PRF_DRBG_f_G2 (v : D)(n : nat) :=
    match n with
        | O => $ ret nil
        | S n' =>
          r <--$ (OC_Query _ v);
            ls' <--$ (PRF_DRBG_f_G2 (injD r) n');
                $ ret (r :: ls')
    end.

  (* The constructed adversary against the PRF. *)
  Definition PRF_A := (ls <--$ PRF_DRBG_f_G2 v_init l; $ A ls).

  Theorem PRF_DRBG_f_G2_wf :
    forall n v,
      well_formed_oc (PRF_DRBG_f_G2 v n).

    induction n; intuition; simpl in *;
    fcf_well_formed.
  Qed.

  Theorem PRF_A_wf : well_formed_oc PRF_A.

    unfold PRF_A; fcf_well_formed.
    apply PRF_DRBG_f_G2_wf.

  Qed.

  Definition PRF_DRBG_G2 :=
    s <-$ RndKey ;
    [b, _] <-$2 PRF_A unit _ (f_oracle f _ s) tt;
    ret b.

  (* In an intermediate step, put the construction in the form of a (deterministic) computation.  Then we can more easily change it to an oracle interaction in the following step. *)
  Fixpoint PRF_DRBG_f_G1_1 (v : D)(n : nat)(k : Key) :=
    match n with
        | O => ret nil
        | S n' =>
          r <-$ ret (f k v);
          ls <-$ (PRF_DRBG_f_G1_1 (injD r) n' k);
            ret (r :: ls)
    end.

  Definition PRF_DRBG_G1_1 :=
    s <-$ RndKey ;
    ls <-$ PRF_DRBG_f_G1_1 v_init l s;
    A ls.

  Theorem  PRF_DRBG_f_G1_1_eq_ret :
    forall k n v,
       comp_spec eq (PRF_DRBG_f_G1_1 v n k) (ret (PRF_DRBG_f v n k)).

    induction n; intuition; simpl in *.

    (* comp_spec eq is registered as a setoid, so intuition will discharge simple goals. *)
    fcf_reflexivity.

    fcf_simp.
    fcf_transitivity.
    fcf_skip_eq.
    fcf_reflexivity.
    fcf_simp.
    fcf_reflexivity.
  Qed.

  Theorem PRF_DRBG_G1_1_equiv :
    Pr[PRF_DRBG_G1] == Pr[PRF_DRBG_G1_1].

    unfold PRF_DRBG_G1, PRF_DRBG_G1_1.

     fcf_skip.
     fcf_to_prhl_eq.
     fcf_symmetry.
     fcf_transitivity.
     fcf_with PRF_DRBG_f_G1_1_eq_ret fcf_skip_eq.
     fcf_reflexivity.

     fcf_simp.
     fcf_reflexivity.

   Qed.

   Theorem PRF_DRBG_f_G1_1_G2_equiv :
     forall k n v,
     comp_spec (fun x1 x2 => x1 = fst x2) (PRF_DRBG_f_G1_1 v n k)
     ((PRF_DRBG_f_G2 v n) unit unit_EqDec
        (f_oracle f (Bvector_EqDec eta) k) tt).

     induction n; intuition; simpl in *.

     fcf_simp.
     fcf_spec_ret.

     fcf_skip.
     unfold f_oracle.

     (* we are left with a unification variable for the specification, we can supply a value for it by specializing the appropriate theorem. *)
     eapply (comp_spec_ret _ _ (fun x1 x2 => x1 = fst x2)).
     trivial.

     simpl in *.
     intuition; subst.

     fcf_skip.
     fcf_simp.
     fcf_spec_ret.

   Qed.

  Theorem PRF_DRBG_G1_G2_equiv :
    Pr[ PRF_DRBG_G1 ] == Pr[ PRF_DRBG_G2 ].

    (* equality for rational numbers is a setoid, so we can rewrite with it. *)
    rewrite PRF_DRBG_G1_1_equiv.
    unfold  PRF_DRBG_G1_1,  PRF_DRBG_G2.
    unfold PRF_A.
    simpl.
    fcf_skip.

    fcf_inline_first.
    fcf_to_prhl_eq.

    fcf_with PRF_DRBG_f_G1_1_G2_equiv fcf_skip.

    fcf_simp.
    simpl.
    fcf_inline_first.

    fcf_ident_expand_l.
    fcf_skip.
    fcf_simp.
    fcf_reflexivity.

  Qed.

  (* Step 3: replace the PRF with a random function *)
  Definition PRF_DRBG_G3 :=
    [b, _] <-$2 PRF_A _ _ (randomFunc ({0,1}^eta) _) nil;
    ret b.

  Theorem PRF_DRBG_G2_G3_close :
    | Pr[PRF_DRBG_G2] - Pr[PRF_DRBG_G3] | <= PRF_Advantage RndKey ({0,1}^eta) f _ _ PRF_A.

    reflexivity.
  Qed.

  (* Step 4 : Replace the random function with random values.  This is the same as long as there are no duplicates in the list of random function inputs. *)
  Definition PRF_DRBG_G4 :=
    [b, _] <-$2 PRF_A _ _ (fun _ _ => x <-$ {0, 1}^eta; ret (x, tt)) tt;
    ret b.

  (* Step 3.1: Preserve duplicate inputs using an oracle that keeps track of all the queries. *)
  Definition randomFunc_withDups ls x :=
    y <-$
      (match (arrayLookup _ ls x) with
        | Some y => ret y
        | None => {0,1}^eta
       end);
    ret (y, (x, y) :: ls).

  Definition PRF_DRBG_G3_1 :=
    [b, _] <-$2 PRF_A _ _ (randomFunc_withDups) nil;
    ret b.

  (* randomFunc_withDups behaves the same as randomFunc, even though the state information is different. *)
  Theorem randomFunc_withDups_spec :
    forall x1 x2 a,
      (forall x, arrayLookup _ x1 x = arrayLookup _ x2 x) ->
    comp_spec
     (fun y1 y2 : Bvector eta * list (D * Bvector eta) =>
      fst y1 = fst y2 /\
      (forall a0 : D,
       arrayLookup D_EqDec (snd y1) a0 = arrayLookup D_EqDec (snd y2) a0))
     (randomFunc ({ 0 , 1 }^eta) D_EqDec x1 a) (randomFunc_withDups x2 a).

    intuition.
    unfold randomFunc, randomFunc_withDups.
    rewrite H.
    case_eq (arrayLookup D_EqDec x2 a); intuition.
    fcf_simp.
    fcf_spec_ret.
    simpl.
    case_eq (eqb a0 a); intuition.
    rewrite eqb_leibniz in H1.
    subst.
    rewrite H.
    trivial.

    fcf_skip.
    fcf_spec_ret.
    simpl.
    rewrite H.
    trivial.

  Qed.

  Theorem PRF_DRBG_G3_1_eq :
    Pr[PRF_DRBG_G3] == Pr[PRF_DRBG_G3_1].

    unfold PRF_DRBG_G3, PRF_DRBG_G3_1.
    fcf_to_prhl_eq.

    fcf_skip.

    eapply (fcf_oracle_eq (fun x1 x2 => forall a, arrayLookup _ x1 a = arrayLookup _ x2 a)); intuition.
    apply randomFunc_withDups_spec; intuition.

    fcf_simp.
    simpl in H1; intuition; subst.
    fcf_reflexivity.

  Qed.

  (* Expose the bad event to the game. *)
  Definition PRF_DRBG_G3_2 :=
    [b, ls] <-$2 PRF_A _ _ (randomFunc_withDups) nil;
    ret (b, hasDups _ (fst (split ls))).

  Theorem PRF_DRBG_G3_1_2_eq :
    Pr[PRF_DRBG_G3_1] == Pr[x <-$ PRF_DRBG_G3_2; ret (fst x)].

    unfold PRF_DRBG_G3_1, PRF_DRBG_G3_2.
    simpl.
    fcf_inline_first.
    fcf_skip.
    fcf_simp.
    fcf_inline_first.
    fcf_skip.
    fcf_simp.
    simpl.
    fcf_reflexivity.

  Qed.

  (* Obtain a new random value for all inputs.  This game is only equal to the previous game when there are no duplicates in the inputs. *)
  Definition PRF_DRBG_G3_3 :=
    [b, ls] <-$2 PRF_A _ _  (fun ls a => x <-$ {0, 1}^eta; ret (x, (a, x)::ls)) nil;
    ret (b, hasDups _ (fst (split ls))).

  (* The "equal until bad" specification for randomFunc_withDups and the oracle that always produces a new random value.  This specification forms the core of the proofs of the two parts of the fundamental lemma in the following two theorems. *)
  Theorem PRF_A_randomFunc_eq_until_bad :
    comp_spec
      (fun y1 y2 =>
         hasDups _ (fst (split (snd y1))) =
         hasDups _ (fst (split (snd y2))) /\
         (hasDups _ (fst (split (snd y1))) = false ->
          snd y1 = snd y2 /\ fst y1 = fst y2))
      (PRF_A _ _ randomFunc_withDups nil)
      (PRF_A _ _
             (fun (ls : list (D * Bvector eta)) (x : D) =>
         r <-$ { 0 , 1 }^eta; ret (r, (x, r) :: ls)) nil).

    eapply (fcf_oracle_eq_until_bad (fun x => hasDups _ (fst (split x))) (fun x => hasDups _ (fst (split x))) eq); intuition.
    apply PRF_A_wf.

    unfold randomFunc_withDups.
    destruct ( arrayLookup D_EqDec a b);
    fcf_well_formed.

    fcf_well_formed.

    subst.
    unfold randomFunc_withDups.
    case_eq (arrayLookup _ x2 a); intuition.
    fcf_irr_r.
    fcf_simp.
    fcf_spec_ret; simpl.

    remember (split x2) as z.
    destruct z.
    simpl in *.
    trivial.
    simpl in *.
    remember (split x2) as z.
    destruct z.
    simpl in *.
    destruct (in_dec (EqDec_dec D_EqDec) a l0); intuition.
    discriminate.
    rewrite notInArrayLookupNone_unzip in H.
    discriminate.
    intuition.
    rewrite unzip_eq_split in H3.
    remember (split x2) as z.
    destruct z.
    pairInv.
    simpl in *.
    intuition.

    simpl in *.
    remember (split x2) as z.
    destruct z.
    simpl in *.
    destruct (in_dec (EqDec_dec D_EqDec) a l0).
    discriminate.
    rewrite notInArrayLookupNone_unzip in H.
    discriminate.
    intuition.
    rewrite unzip_eq_split in H3.
    remember (split x2) as z.
    destruct z.
    pairInv.
    simpl in *.
    intuition.

    fcf_skip.
    fcf_spec_ret.

    unfold randomFunc_withDups in *.
    fcf_simp_in_support.
    simpl.
    remember (split c0) as z.
    destruct z.
    simpl in *.
    destruct (in_dec (EqDec_dec D_EqDec) d l0); intuition.

    fcf_simp_in_support.
    simpl in *.
    remember (split c0) as z.
    destruct z.
    simpl in *.
    destruct (in_dec (EqDec_dec D_EqDec) d l0); intuition.

  Qed.

  Theorem PRF_DRBG_G3_2_3_badness_same :
    Pr  [x <-$ PRF_DRBG_G3_2; ret snd x ] ==
    Pr  [x <-$ PRF_DRBG_G3_3; ret snd x ].

    unfold PRF_DRBG_G3_2, PRF_DRBG_G3_3.
    fcf_inline fcf_left.
    fcf_inline fcf_right.
    fcf_to_prhl_eq.
    fcf_skip.
    apply PRF_A_randomFunc_eq_until_bad.

    fcf_simp.
    intuition.
    simpl in *.
    fcf_spec_ret.
  Qed.

  Theorem PRF_DRBG_G3_2_3_eq_until_bad :
    forall a : bool,
      evalDist PRF_DRBG_G3_2 (a, false) == evalDist PRF_DRBG_G3_3 (a, false).

    intuition.
    unfold PRF_DRBG_G3_2, PRF_DRBG_G3_3.
    fcf_to_prhl.
    fcf_skip.
    apply PRF_A_randomFunc_eq_until_bad.
    fcf_simp.
    fcf_spec_ret.
    simpl in *; pairInv; intuition; subst;
    trivial.

    simpl in *.
    pairInv.
    rewrite H2.
    rewrite <- H2 in H6.
    edestruct H3; intuition; subst.
    trivial.

  Qed.

  Theorem PRF_DRBG_G3_2_3_close :
  | Pr[x <-$ PRF_DRBG_G3_2; ret (fst x)] - Pr[x <-$ PRF_DRBG_G3_3; ret (fst x)] | <= Pr[x <-$ PRF_DRBG_G3_3; ret (snd x)].

    rewrite ratDistance_comm.
    fcf_fundamental_lemma.

    symmetry.
    apply PRF_DRBG_G3_2_3_badness_same.

    intuition.
    symmetry.
    apply PRF_DRBG_G3_2_3_eq_until_bad.

  Qed.

  Theorem PRF_DRBG_G3_3_G4_eq :
    Pr[ x <-$ PRF_DRBG_G3_3; ret (fst x) ] == Pr[ PRF_DRBG_G4 ].

    unfold PRF_DRBG_G3_3, PRF_DRBG_G4.
    simpl.
    fcf_inline_first.
    fcf_to_prhl_eq.
    fcf_skip.
    eapply (fcf_oracle_eq (fun x1 x2 => True)); intuition.
    fcf_skip.
    fcf_spec_ret.
    simpl in H1.
    intuition; subst.
    fcf_simp.
    fcf_inline_first.
    simpl.
    fcf_skip.
    simpl; fcf_simp.
    fcf_reflexivity.

  Qed.

  (* Now we need to compute the probability of the "bad" event.  First we will simplify the game defining this event.*)

  (* The state of the random function is no longer necessary.  We can simplify things by changing the oracle interaction into a standard (recursive) computation. *)
  Fixpoint PRF_DRBG_f_bad (v : D)(n : nat) :=
    match n with
      | O =>  ret nil
      | S n' =>
          r <-$ {0,1}^eta;
          ls' <-$ (PRF_DRBG_f_bad (injD r) n');
          ret (v :: ls')
    end.

  Definition PRF_DRBG_G3_bad_1 :=
    ls <-$ PRF_DRBG_f_bad v_init l;
    ret (hasDups _ ls).

   (* The relational specification on the new computation that produces the bad event.  We prove that the list of values produced by this computation is a permutation of the list produced by the oracle interaction in game 3.  Perhaps this could be an equality of we adjust the model, but a permutation works fine for our purposes, since the only thing that matters is the presence/absence of duplicates in the list. *)
   Theorem PRF_DRBG_f_bad_spec :
     forall n v ls,
     comp_spec (fun x1 x2 => Permutation (fst (split (snd x1))) ((fst (split ls)) ++ x2))
     ((PRF_DRBG_f_G2 v n) _ _
        (fun (ls : list (D * Bvector eta)) (a : D) =>
         x <-$ { 0 , 1 }^eta; ret (x, (a, x) :: ls)) ls)
     (PRF_DRBG_f_bad v n).

     induction n; intuition; simpl in *.
     fcf_simp.
     fcf_spec_ret.
     simpl.
     rewrite app_nil_r.
     apply Permutation_refl.

     fcf_inline_first.
     fcf_skip.
     fcf_skip.
     fcf_spec_ret.
     simpl in H3.
     simpl.
     destruct (split ls).
     simpl in H3. simpl.
     eapply Permutation_trans.
     apply H3.
     apply Permutation_cons_app.
     apply Permutation_refl.
   Qed.

   Theorem PRF_DRBG_G3_bad_equiv :
     Pr[x <-$ PRF_DRBG_G3_3; ret (snd x)] == Pr[PRF_DRBG_G3_bad_1].

     unfold PRF_DRBG_G3_3, PRF_DRBG_G3_bad_1.
     simpl.
     fcf_inline_first.
     fcf_to_prhl_eq.
     fcf_skip.
     apply PRF_DRBG_f_bad_spec.
     simpl in H1.
     fcf_inline_first.
     fcf_irr_l.
     fcf_simp.
     simpl.
     fcf_spec_ret.

     apply Permutation_hasDups.
     trivial.

   Qed.

   (* In the next simplification, we remove the v input from the recursive function, and simply put the random values in the list. *)
   Fixpoint PRF_DRBG_f_bad_2 (n : nat) :=
    match n with
        | O =>  ret nil
        | S n' =>
          r <-$ {0,1}^eta;
            ls' <-$ (PRF_DRBG_f_bad_2 n');
            ret (r :: ls')
    end.

   Definition PRF_DRBG_G3_bad_2 :=
     ls <-$ PRF_DRBG_f_bad_2 (pred l);
     ret (hasDups _ (v_init :: (map injD ls))).

   (* This new recursive computation is similar to the previous one---we just need to shift everything over by one place, and map the injection over the output. *)
   Theorem PRF_DRBG_f_bad_2_equiv :
     forall n v,
     comp_spec (fun x1 x2 => x1 = v :: (map injD x2))
               (PRF_DRBG_f_bad v (S n))
               (PRF_DRBG_f_bad_2 n).

     induction n; intuition; simpl in *.
     fcf_irr_l.
     fcf_simp.
     fcf_spec_ret.

     fcf_skip.
     fcf_skip.
     fcf_spec_ret.

   Qed.

   Theorem PRF_DRBG_G3_bad_1_2_equiv :
     Pr[PRF_DRBG_G3_bad_1] == Pr[PRF_DRBG_G3_bad_2].

     unfold PRF_DRBG_G3_bad_1, PRF_DRBG_G3_bad_2.
     fcf_to_prhl_eq.

     destruct l; simpl; intuition.
     fcf_simp.
     simpl.
     fcf_reflexivity.

     fcf_skip.
     apply PRF_DRBG_f_bad_2_equiv.
     simpl in H1.
     subst.

     fcf_spec_ret.

   Qed.

   (* The previous recursive function is equivalent to mapping the computation that produces random values over a list of the appropriate length.  The form thet uses compMap can be unified with some existing theory to compute the probability of the event. *)
   Definition PRF_DRBG_G3_bad_3 :=
     ls <-$ compMap _ (fun _ => {0, 1}^eta) (forNats (pred l));
     ret (hasDups _ (v_init :: (map injD ls))).

   Theorem PRF_DRBG_f_bad_2_compMap_equiv :
     forall n,
     comp_spec eq
     (PRF_DRBG_f_bad_2 n)
     (compMap (Bvector_EqDec eta) (fun _ : nat => { 0 , 1 }^eta)
        (forNats n)).

     induction n; intuition; simpl in *.
     fcf_reflexivity.
     fcf_skip.
     fcf_skip.
     apply IHn.
     subst.
     fcf_reflexivity.

   Qed.

   Theorem PRF_DRBG_G3_bad_2_3_equiv :
     Pr[PRF_DRBG_G3_bad_2] == Pr[PRF_DRBG_G3_bad_3].

     unfold PRF_DRBG_G3_bad_2, PRF_DRBG_G3_bad_3.
     fcf_to_prhl_eq.
     pose proof PRF_DRBG_f_bad_2_compMap_equiv.
     fcf_skip.

   Qed.

   (* Don't apply the injection to the random values and initial input. *)
   Definition PRF_DRBG_G3_bad_4 :=
     ls <-$ compMap _ (fun _ => {0, 1}^eta) (forNats (pred l));
     ret (hasDups _ (r_init :: ls)).

    Theorem PRF_DRBG_G3_bad_3_4_equiv :
     Pr[PRF_DRBG_G3_bad_3] == Pr[PRF_DRBG_G3_bad_4].

     unfold PRF_DRBG_G3_bad_3, PRF_DRBG_G3_bad_4.
     fcf_to_prhl_eq.
     fcf_skip.
     fcf_spec_ret.
     unfold v_init.

     symmetry.
     erewrite (hasDups_inj_equiv _ _ (r_init :: b)).
     simpl. eauto.
     trivial.
   Qed.

   (* HasDups.v has a theorem that computes the probability of duplicates in a list of random values.  We need a form of the dupProb theorem that allows the first item in the list to be fixed.  *)
   Theorem dupProb_const :
    forall (X : Set)(ls : list X)(v : Bvector eta),
      Pr[x <-$ compMap _ (fun _ => {0, 1}^eta) ls; ret (hasDups _ (v :: x))] <=
      ((S (length ls)) ^ 2 / 2 ^ eta).

     intuition.
     (* Either the list of random values has duplicates, or v is in this list.  The probability value that we want is (at most) the sum of the probabilities of these two events.  The evalDist_orb_le theorem allows us to reason about them separately.  Put the game in a form that unifies with this theorem. *)

     fcf_rewrite_l (Pr[x <-$ compMap (Bvector_EqDec eta) (fun _ : X => { 0 , 1 }^eta) ls;
                      ret ((if (in_dec (EqDec_dec _) v x) then true else false) || (hasDups (Bvector_EqDec eta) x)) ]
                 ).
     fcf_skip.
     simpl.
     destruct ( in_dec (EqDec_dec (Bvector_EqDec eta)) v x).
     simpl.
     intuition.
     rewrite orb_false_l.
     intuition.

     rewrite evalDist_orb_le.

     (* Use a theorem from the library to determine the probability that v is present in the random list. *)
     rewrite FixedInRndList_prob.
     (* Now determine the probability that there are duplicates in the random list. *)
     rewrite dupProb.

     (* The rest is just arithmetic. *)
     simpl.
     rewrite mult_1_r.
     replace (S (length ls + length ls * S (length ls))) with (S (length ls) + length ls * S (length ls))%nat.
     rewrite ratAdd_num.
     eapply ratAdd_leRat_compat.
     eapply leRat_terms;
     lia.
     eapply leRat_terms.
     eapply mult_le_compat; lia.
     trivial.
     lia.
   Qed.

   Theorem PRF_DRBG_G3_bad_4_small :
      Pr[PRF_DRBG_G3_bad_4] <= (l ^ 2 / 2 ^ eta).

     unfold PRF_DRBG_G3_bad_4.
     rewrite dupProb_const.
     destruct l.
     lia.

     simpl.
     rewrite forNats_length.
     rewrite mult_1_r.
     reflexivity.

   Qed.

   (* Combine all of the results related to the G3 games to show that G3 and G4 are close. *)
   Theorem PRF_DRBG_G3_G4_close :
     | Pr[ PRF_DRBG_G3 ] - Pr[  PRF_DRBG_G4 ] | <= (l^2 / 2^eta).

     rewrite PRF_DRBG_G3_1_eq.
     rewrite PRF_DRBG_G3_1_2_eq.
     rewrite <- PRF_DRBG_G3_3_G4_eq.
     rewrite  PRF_DRBG_G3_2_3_close.
     rewrite PRF_DRBG_G3_bad_equiv.
     rewrite PRF_DRBG_G3_bad_1_2_equiv.
     rewrite PRF_DRBG_G3_bad_2_3_equiv.
     rewrite PRF_DRBG_G3_bad_3_4_equiv.
     apply PRF_DRBG_G3_bad_4_small.

   Qed.

   (* Finally, show that G4 is equivalent to the second game in the DRBG security definition. *)
   Theorem PRF_DRBG_f_G2_compMap_spec :
     forall n v,
     comp_spec (fun x1 x2 => fst x1 = x2)
     ((PRF_DRBG_f_G2 v n) unit unit_EqDec
        (fun (_ : unit) (_ : D) => x <-$ { 0 , 1 }^eta; ret (x, tt)) tt)
     (compMap (Bvector_EqDec eta) (fun _ : nat => { 0 , 1 }^eta) (forNats n)).

     induction n; intuition; simpl in *.
     fcf_simp.
     fcf_spec_ret.

     fcf_inline_first.
     fcf_skip.
     fcf_skip.
     fcf_spec_ret.
   Qed.

  Theorem PRF_DRBG_G4_DRBG_equiv :
    Pr[PRF_DRBG_G4] == Pr[DRBG_G1 RndOut A].

    unfold PRF_DRBG_G4, DRBG_G1, RndOut, PRF_A.
    simpl.
    fcf_inline_first.
    fcf_to_prhl_eq.
    fcf_with PRF_DRBG_f_G2_compMap_spec fcf_skip.

    simpl.
    fcf_inline_first.
    fcf_ident_expand_r.
    fcf_skip.

  Qed.

  (* The final security result showing that the advantage of the adversary against the DRBG is at most the advantage of the constructed adversary against the PRF, and some negligible value. *)

  Theorem PRF_DRBG_Adv_small :
    DRBG_Advantage RndKey RndOut PRF_DRBG A <=
    PRF_Advantage RndKey ({ 0 , 1 }^eta) f D_EqDec (Bvector_EqDec eta) PRF_A
    + l ^ 2 / 2 ^ eta.

    intuition.
    unfold DRBG_Advantage.
    rewrite PRF_DRBG_G1_equiv.
    rewrite PRF_DRBG_G1_G2_equiv.
    rewrite <- PRF_DRBG_G4_DRBG_equiv.
    eapply ratDistance_le_trans.
    apply PRF_DRBG_G2_G3_close.
    apply PRF_DRBG_G3_G4_close.

  Qed.

  (*Print Assumptions PRF_DRBG_Adv_small.*)

End PRF_DRBG.


From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq.
From LCAC Require Import Relations_ext.

Set Implicit Arguments.

Notation nopts n T := (iter n option T).

Inductive term (V : Type) : Type :=
  | var of V
  | app of term V & term V
  | abs of term (option V).

Notation term' n V := (term (nopts n V)).

Fixpoint tmap (V1 V2 : Type) (f : V1 -> V2) (t : term V1) : term V2 :=
  match t with
    | var a => var (f a)
    | app tl tr => app (tmap f tl) (tmap f tr)
    | abs t => abs (tmap (Option.map f) t)
  end.

Fixpoint somenth (T : Type) (n : nat) (a : T) : nopts n T :=
  match n with
    | 0 => a
    | n.+1 => Some (somenth n a)
  end.

Fixpoint substitute_var
  (V : Type) (n : nat) (t : term V) : nopts n (option V) -> term' n V :=
  match n with
    | 0 => fun v => match v with
        | None => t
        | Some v => var v
      end
    | n.+1 => fun v => match v with
        | None => var None
        | Some v => tmap some (substitute_var n t v)
      end
  end.

Fixpoint substitute
  (V : Type) (n : nat) (t1 : term V) (t2 : term' n (option V)) : term' n V :=
  match t2 with
    | var v => substitute_var n t1 v
    | app t2l t2r => app (substitute n t1 t2l) (substitute n t1 t2r)
    | abs t2' => abs (substitute n.+1 t1 t2')
  end.

Fixpoint substitute_seq_var2
  (V : Type) (ts : seq (term V)) : nopts (size ts) V -> term V :=
  match ts with
    | [::] => fun v => var v
    | t :: ts => fun v => match v with
        | None => t
        | Some v => substitute_seq_var2 ts v
      end
  end.

Fixpoint substitute_seq_var1
  (V : Type) (n : nat) (ts : seq (term V)) :
  nopts (n + size ts) V -> term' (n + 0) V :=
  match n with
    | 0 => fun v => substitute_seq_var2 ts v
    | n.+1 => fun v => match v with
        | None => var None
        | Some v => tmap some (substitute_seq_var1 n ts v)
      end
  end.

Fixpoint substitute_seq
  (V : Type) (n : nat) (ts : seq (term V)) (t : term' (n + size ts) V) :
  term' (n + 0) V :=
  match t with
    | var v => substitute_seq_var1 n ts v
    | app tl tr => app (substitute_seq n ts tl) (substitute_seq n ts tr)
    | abs t => abs (substitute_seq n.+1 ts t)
  end.

Lemma substitute_seq_nil V n (t : term' (n + 0) V) :
  substitute_seq n [::] t = t.
Proof.
move: n t; fix IH 2 => n; case => //=.
- elim: n => // {IH} n IH //=; case => // v.
  by rewrite (IH v).
- move => tl tr; f_equal; apply IH.
- move => t; f_equal; apply IH.
Qed.

Reserved Notation "t ->1b t'" (at level 70, no associativity).
Reserved Notation "t ->bp t'" (at level 70, no associativity).

Inductive betared1 : forall V, relation (term V) :=
  | betared1beta V (t1 : term (option V)) (t2 : term V) :
    app (abs t1) t2 ->1b substitute 0 t2 t1
  | betared1appl V (t1 t1' t2 : term V) :
    t1 ->1b t1' -> app t1 t2 ->1b app t1' t2
  | betared1appr V (t1 t2 t2' : term V) :
    t2 ->1b t2' -> app t1 t2 ->1b app t1 t2'
  | betared1abs V (t t' : term (option V)) : t ->1b t' -> abs t ->1b abs t'
  where "t ->1b t'" := (betared1 t t').

Inductive parred : forall V, relation (term V) :=
  | parredvar V (x : V) : var x ->bp var x
  | parredapp V (t1 t1' t2 t2' : term V) :
    t1 ->bp t1' -> t2 ->bp t2' -> app t1 t2 ->bp app t1' t2'
  | parredabs V (t t' : term (option V)) : t ->bp t' -> abs t ->bp abs t'
  | parredbeta V (t1 t1' : term (option V)) (t2 t2' : term V) :
    t1 ->bp t1' -> t2 ->bp t2' -> app (abs t1) t2 ->bp substitute 0 t2' t1'
  where "t ->bp t'" := (parred t t').


Require Import NArith.
Require Import Arith.
Require Import List.
Require Import CpdtTactics.
Require Import JamesTactics.
Require Import Coq.Program.Basics.
Require Import EqDec.
Require Import Misc.
Require Import Bag.
Require Import Omega.
Require Import KonneTactics.
Import ListNotations.

Class enumerable A := {
  enumerate : list A;
  enumerateContainsEverything : forall a, In a enumerate
}.

Lemma concatIn {A} {a:A} l {L} `{eqDec A} : In a l -> In l L -> In a (concat L).
  intros.
  induction L as [|l' L'].
  + crush.
  + simpl.
    apply in_or_app.
    destruct (l =? l').
    - subst_max.
      intuition.
    - crush.
Qed.

Instance enumerableSigT {A B} `{eqDec A} `{enumerable A}
                              `{forall a:A, eqDec (B a)} `{forall a:A, enumerable (B a)} :
                              enumerable {a : A & B a}.
  refine {|
    enumerate := bindList
      (enumerate (A := A)) (fun a =>
      map (existT _ a) (enumerate (A := B a)))
  |}.
Proof.
  Opaque concat.
  Opaque map.
  intros.
  destruct a as [a b].
  unfold bindList.
  apply (concatIn (existT _ a <$> enumerate)).
  + apply in_map.
    apply enumerateContainsEverything.
  + match goal with
    | |- In ?A (?F <$> _) => remember F as f; assert (A = f a) as R by crush
    end.
    rewrite R.
    apply in_map.
    apply enumerateContainsEverything.
Defined.

Instance enumerableProd {A B} `{eqDec A} `{enumerable A} `{eqDec B} `{enumerable B} : enumerable (A * B).
  refine {|
    enumerate := bindList
      enumerate (fun a => pair a <$> enumerate)
  |}.
Proof.
  Opaque concat.
  Opaque map.
  intros.
  destruct a as [a b].
  unfold bindList.
  apply (concatIn (pair a <$> enumerate)).
  + apply in_map.
    apply enumerateContainsEverything.
  + match goal with
    | |- In ?A (?F <$> _) => remember F as f; assert (A = f a) as R by crush
    end.
    rewrite R.
    apply in_map.
    apply enumerateContainsEverything.
Defined.

Instance enumerableEmptySet : enumerable Empty_set.
  refine {|enumerate := []|}.
Proof.
  crush.
Defined.

Instance enumerableUnit : enumerable unit.
  refine {|enumerate := [tt]|}.
Proof.
  crush.
Defined.

Instance enumerableSigT' {A B} `{eqDec A} `{enumerable A}
                            `{forall a:A, eqDec (B a)} `{forall a:A, enumerable (B a)} :
                            enumerable (sigT B).
  apply enumerableSigT.
Defined.

Instance enumerableSum {A B} `{enumerable A} `{enumerable B} : enumerable (A + B).
  refine {|enumerate := inl <$> enumerate ++ inr <$> enumerate|}.
Proof.
  intro.
  rewrite in_app_iff.
  destruct a.
  - left.
    apply in_map.
    apply enumerateContainsEverything.
  - right.
    apply in_map.
    apply enumerateContainsEverything.
Defined.

Instance eqDecUnit : eqDec unit.
  constructor.
  decide equality.
Defined.

Fixpoint argMax'' {A} (f:A->nat) (l:list A) {struct l} : l <> [] -> A.
  refine(
  match l with
  | [] => _
  | a::l' => fun _ =>
    (match l' as l'' return l' = l'' -> A with
    | [] => fun _ => a
    | _ =>  fun _ => let a' := argMax'' _ f l' _ in
            if f a' <=? f a then a else a'
    end) _
  end).
Proof.
  - congruence.
  - congruence.
  - congruence.
Defined.

Lemma allSmallerThanArgMax'' {A} :
  forall f l (a:A) (H : l <> []), In a l ->
    f a <= f (argMax'' f l H).
Proof.
  intro f.
  induction l as [|a' l' IHl].
  - congruence.
  - intros.
    match goal with H:In _ _ |- _ => rename H into H' end.
    cbn.
    break_match; [crush|].
    generalize_proofs.
    specialize (IHl a p).
    subst_max.
    break_match.
    + specialize (leb_complete _ _ Heqb); intro; clear Heqb.
      destruct H' as [|H'].
      * subst_max. omega.
      * specialize (IHl H'). omega.
    + specialize (leb_complete_conv _ _ Heqb); intro; clear Heqb.
      destruct H' as [|H'].
      * subst_max. omega.
      * specialize (IHl H'). omega.
Defined.

Definition argMax' {A} `{enumerable A} (f:A->nat) (a:A) : A.
  refine(argMax'' f enumerate _).
Proof.
  specialize (enumerateContainsEverything a).
  intros; intro.
  find_rewrite.
  specialize in_nil.
  crush.
Defined.

Lemma allSmallerThanArgMax {A} `{enumerable A} :
  forall f (a' a:A), f a <= f (argMax' f a').
Proof.
  intros.
  unfold argMax'.
  apply allSmallerThanArgMax''.
  apply enumerateContainsEverything.
Qed.

Fixpoint argMaxL  {A} (f:A->nat) (l:list A) {struct l} : list A :=
  match l with
    | [] => []
    | a :: l' =>
      match (argMaxL f l') with
        | [] => [a]
        | a' :: as' =>
          if f a <? f a' then
            a' :: as'
          else
            if f a =? f a' then
              a :: a' :: as'
            else
              [a]
      end
  end.

Lemma argMaxL_all_same :
  forall A l f (a : A) a',
    In a (argMaxL f l) ->
    In a' (argMaxL f l) ->
    f a' = f a.
Proof.
  induction l; intros; simpl in *; intuition.
  repeat break_match; simpl in *; auto;
  intuition; repeat find_rewrite; auto;
    match goal with
      | |- f ?a = f ?a' =>
        try solve [specialize (IHl f a a'); forward IHl; repeat find_rewrite; simpl; intuition];
        try solve [specialize (IHl f a' a); forward IHl; repeat find_rewrite; simpl; intuition]
    end.
Qed.

Lemma argMaxL_non_empty :
  forall A l f (a : A),
    In a l ->
    argMaxL f l <> [].
Proof.
  destruct l; intros; simpl in *; intuition; subst;
  repeat break_match; simpl in *; congruence.
Qed.

Lemma allSmallerThanArgMaxL :
  forall A l f (a : A) a',
    In a (argMaxL f l) ->
    In a' l ->
    f a' <= f a.
Proof.
  induction l; intros; simpl in *; intuition.
  - subst. repeat break_match; simpl in *; auto.
    + intuition. subst. auto.
    + apply Nat.ltb_lt in Heqb.
      intuition; subst; try omega.
      assert (f a = f a0); try omega.
      eapply argMaxL_all_same; eauto; rewrite Heql0; simpl in *; intuition.
    + intuition; repeat find_rewrite; auto.
      assert (f a = f a0); try omega.
      eapply argMaxL_all_same; eauto; rewrite Heql0; simpl in *; intuition.
    + intuition. subst. auto.
  - repeat break_match; simpl in *; auto.
    + intuition. subst.
      exfalso; eapply argMaxL_non_empty; eauto.
    + intuition; repeat find_rewrite; auto;
      eapply IHl; eauto; repeat find_rewrite; simpl; auto.
    + intuition; repeat find_rewrite; auto;
      eapply IHl; eauto; repeat find_rewrite; simpl; auto.
    + intuition. subst.
      apply Nat.ltb_ge in Heqb.
      eapply le_trans; [|eauto].
      eapply IHl; eauto; repeat find_rewrite; simpl; auto.
Qed.

Definition argMax {A} `{enumerable A} (f:A->nat) : A -> {a:A | forall a', f a' <= f a}.
  intro P.
  refine (exist _ (argMax' f P) _).
  apply allSmallerThanArgMax.
Defined.


Require Import CoqStock.comparable.
Require Import CoqStock.List.

Require Import Reexamined.derive_def.
Require Import Reexamined.regex.

Reserved Notation "xs =~ r" (at level 80).
Reserved Notation "xs !=~ r" (at level 80).

Inductive matches_prop {A: Type} {cmp: comparable A} : regex A -> (list A) ->  Prop :=
  | empty_matches :
    [] =~ empty

  | char_matches (a : A):
    [a] =~ char a

  | or_matches_l (r s : regex A) (xs : list A):
    xs =~ r ->
    (* --------- *)
    xs =~ or r s

  | or_matches_r (r s : regex A) (xs : list A):
    xs =~ s ->
    (* --------- *)
    xs =~ or r s

  | and_matches (r s : regex A) (xs: list A) :
    xs =~ r ->
    xs =~ s ->
    (* --------- *)
    xs =~ and r s

  | concat_matches (r s : regex A) (xs ys: list A) :
    xs =~ r ->
    ys =~ s ->
    (* --------- *)
    (xs ++ ys) =~ concat r s

  | not_matches (r : regex A) (xs : list A):
    xs !=~ r ->
    (* --------- *)
    xs =~ not r

  | star_matches_nil (r : regex A):
    [] =~ star r

  | star_matches_concat (r : regex A) (xs ys : list A):
    xs =~ r ->
    ys =~ star r ->
    (* --------- *)
    (xs ++ ys) =~ star r

with not_matches_prop {A: Type} {cmp: comparable A}: regex A -> list A -> Prop :=
  | fail_not_matches (xs: list A):
    (* --------- *)
    xs !=~ fail

  | empty_not_matches (xs: list A):
    (xs <> []) ->
    (* --------- *)
    xs !=~ empty

  | char_not_matches (a: A) (xs: list A):
    (xs <> [a]) ->
    (* --------- *)
    xs !=~ (char a)

  | or_not_matches (r s: regex A) (xs: list A):
    xs !=~ r ->
    xs !=~ s ->
    (* --------- *)
    xs !=~ or r s

  | and_not_matches_l (r s: regex A) (xs: list A):
    xs !=~ r ->
    (* --------- *)
    xs !=~ and r s

  | and_not_matches_r (r s: regex A) (xs: list A):
    xs !=~ s ->
    xs !=~ and r s

  | concat_not_matches (r s: regex A) (xs ys: list A):
    xs !=~ r \/ ys !=~ s ->
    (* --------- *)
    (xs ++ ys) !=~ concat r s

  | not_not_matches (r: regex A) (xs: list A):
    xs =~ r ->
    (* --------- *)
    xs !=~ not r

  | star_not_matches (r: regex A) (xs: list A):
    xs <> [] ->
    xs !=~ concat r (star r) ->
    (* --------- *)
    xs !=~ star r

where "xs =~ r" := (matches_prop r xs) and "xs !=~ r" := (not_matches_prop r xs).

Theorem matches_prop_describes_matches_impl:
  forall
    {A: Type}
    {cmp: comparable A}
    (r: regex A)
    (xs: list A),
  matchesb r xs = true <-> matches_prop r xs
.
(* TODO: Help Wanted
   If this theorem is proved,
   then matches_prop can be used in proofs,
   rather than induction on xs and matchesb.
*)
Abort.


(** Solutions to "Elements of Set Theory" Chapter 3 **)
(** Coq coding by choukh, May 2020 **)

Require Export ZFC.Elements.EST3_3.

Example ex3_2_a : ∀ A B C, A × (B ∪ C) = (A × B) ∪ (A × C).
Proof with auto.
  intros. ext.
  - apply CPrdE1 in H as [a [Ha [b [Hb H]]]].
    apply BUnionE in Hb as [].
    + apply BUnionI1. subst x. apply CPrdI...
    + apply BUnionI2. subst x. apply CPrdI...
  - apply BUnionE in H as [];
      apply CPrdE1 in H as [a [Ha [b [Hb H]]]];
      subst x; apply CPrdI...
    + apply BUnionI1. apply Hb.
    + apply BUnionI2. apply Hb.
Qed.

Example ex3_2_a' : ∀ A B C, (A ∪ B) × C = (A × C) ∪ (B × C).
Proof with auto.
  intros. ext.
  - apply CPrdE1 in H as [a [Ha [b [Hb H]]]].
    apply BUnionE in Ha as [].
    + apply BUnionI1. subst x. apply CPrdI...
    + apply BUnionI2. subst x. apply CPrdI...
  - apply BUnionE in H as [];
      apply CPrdE1 in H as [a [Ha [b [Hb H]]]];
      subst x; apply CPrdI...
    + apply BUnionI1. apply Ha.
    + apply BUnionI2. apply Ha.
Qed.

Example ex3_2_b: ∀ A B C, ⦿ A → A × B = A × C → B = C.
Proof with auto.
  intros A B C [a Ha] H. ext.
  - assert (<a, x> ∈ A × B) by (apply CPrdI; assumption).
    rewrite H in H1. apply CPrdE2 in H1 as []...
  - assert (<a, x> ∈ A × C) by (apply CPrdI; assumption).
    rewrite <- H in H1. apply CPrdE2 in H1 as []...
Qed.

Example ex3_3: ∀ A ℬ, A × ⋃ℬ = ⋃{A × X | X ∊ ℬ}.
Proof.
  intros. ext.
  - apply CPrdE1 in H as [a [Ha [b [Hb Heq]]]].
    apply UnionAx in Hb as [B [HB Hb]]. subst x.
    eapply FUnionI. apply HB. apply CPrdI; assumption.
  - apply FUnionE in H as [B [HB Hx]].
    apply CPrdE1 in Hx as [a [Ha [b [Hb Heq]]]]. subst x.
    apply CPrdI. apply Ha. apply UnionAx.
    exists B. split. apply HB. apply Hb.
Qed.

Example ex3_4: ¬ ∃ S, ∀ a b, <a, b> ∈ S.
Proof with auto.
  intros [S H]. apply ex2_8.
  exists {⋃ s | s ∊ S}. intros s.
  specialize H with s s.
  apply ReplAx. exists <s, s>. split...
  ext Hx.
  - rewrite op_union in Hx.
    apply PairE in Hx as []; subst...
  - apply SingE in Hx; subst.
    apply UnionAx. exists {s,}. split... apply PairI1.
Qed.

Example ex3_5_b: ∀ A B, A × B = ⋃{{x,} × B | x ∊ A}.
Proof.
  intros. ext.
  - apply CPrdE1 in H as [a [Ha [b [Hb Heq]]]].
    eapply FUnionI. apply Ha. subst x.
    apply CPrdI. apply SingI. apply Hb.
  - apply FUnionE in H as [a [Ha Hx]].
    apply CPrdE1 in Hx as [a' [Ha' [b [Hb Heq]]]].
    apply SingE in Ha'. subst a. subst x.
    apply CPrdI; assumption.
Qed.

Example ex3_6: ∀ X, is_rel X ↔ X ⊆ dom X × ran X.
Proof.
  intros X. split.
  - intros Hr. unfold Sub. intros x Hx. assert (Heq := Hx).
    apply rel_pair in Heq. rewrite Heq. rewrite Heq in Hx. apply CPrdI.
    + eapply domI. apply Hx.
    + eapply ranI. apply Hx.
    + apply Hr.
  - unfold is_rel. intros Hsub x Hx. apply Hsub in Hx.
    apply CPrdE1 in Hx as [a [Ha [b [Hb Heq]]]].
    exists a, b. apply Heq.
Qed.

Example ex3_7: ∀ R, is_rel R → fld R = ⋃⋃R.
Proof.
  intros. ext.
  - apply BUnionE in H0 as [].
    + apply SepE in H0 as [Hx _]. apply Hx.
    + apply SepE in H0 as [Hx _]. apply Hx.
  - apply UnionAx in H0 as [p [Hp Hxp]].
    apply UnionAx in Hp as [q [Hq Hpq]].
    destruct (H q Hq) as [a [b Heq]].
    subst q. apply PairE in Hpq as []; subst p.
    + apply SingE in Hxp. subst x.
      apply BUnionI1. eapply domI. apply Hq.
    + apply PairE in Hxp as []; subst x.
      * apply BUnionI1. eapply domI. apply Hq.
      * apply BUnionI2. eapply ranI. apply Hq.
Qed.

Example ex3_8_a: ∀ 𝒜, dom ⋃𝒜 = ⋃{dom R | R ∊ 𝒜}.
Proof.
  intros. ext.
  - apply domE in H as [y Hxy].
    apply UnionAx in Hxy as [A [HA Hxy]].
    eapply FUnionI. apply HA. eapply domI. apply Hxy.
  - apply FUnionE in H as [A [HA Hx]].
    apply domE in Hx as [y Hxy]. eapply domI.
    apply UnionAx. exists A. split; eassumption.
Qed.

Example ex3_8_b: ∀ 𝒜, ran ⋃𝒜 = ⋃{ran R | R ∊ 𝒜}.
Proof.
  intros. ext.
  - apply ranE in H as [y Hxy].
    apply UnionAx in Hxy as [A [HA Hxy]].
    eapply FUnionI. apply HA. eapply ranI. apply Hxy.
  - apply FUnionE in H as [A [HA Hx]].
    apply ranE in Hx as [y Hxy]. eapply ranI.
    apply UnionAx. exists A. split; eassumption.
Qed.

Example ex3_9_a: ∀ 𝒜, dom ⋂𝒜 ⊆ ⋂{dom R | R ∊ 𝒜}.
Proof.
  intros 𝒜 x H.
  apply domE in H as [y Hxy].
  apply InterE in Hxy as [[A HA] Hxy]. apply InterI.
  exists (dom A). apply ReplI. apply HA.
  intros B HB. apply ReplAx in HB as [C [HC Heq]].
  subst B. eapply domI. apply Hxy in HC. apply HC.
Qed.

Example ex3_9_b: ∀ 𝒜, ran ⋂𝒜 ⊆ ⋂{ran R | R ∊ 𝒜}.
Proof.
  intros 𝒜 x H.
  apply ranE in H as [y Hxy].
  apply InterE in Hxy as [[A HA] Hxy]. apply InterI.
  exists (ran A). apply ReplI. apply HA.
  intros B HB. apply ReplAx in HB as [C [HC Heq]].
  subst B. eapply ranI. apply Hxy in HC. apply HC.
Qed.

Example ex_3_10_3: ∀ a b c d,
  <<<a, b>, c>, d> = <<a, b>, c, d>.
Proof. reflexivity. Qed.

Example ex_3_10_2: ∀ a b c d,
  <<<a, b>, c>, d> = <<a, b, c>, d>.
Proof. reflexivity. Qed.

Example ex_3_10_1: ∀ a b c d,
  <<<a, b>, c>, d> = <a, b, c, d>.
Proof. reflexivity. Qed.

Example ex3_11: ∀ F G,
  is_function F → is_function G → dom F = dom G
  → (∀x ∈ dom F, F[x] = G[x]) → F = G.
Proof. exact func_ext_intro. Qed.

Example ex3_12: ∀ f g,
  is_function f → is_function g →
  f ⊆ g ↔ dom f ⊆ dom g ∧ ∀x ∈ dom f, f[x] = g[x].
Proof with eauto.
  intros f g Hf Hg. split.
  - intros H. split; intros x Hx; apply domE in Hx as [y Hp].
    + apply H in Hp. eapply domI...
    + assert (Hp' := Hp). apply H in Hp'.
      apply func_ap in Hp... apply func_ap in Hp'... subst...
  - intros [Hsub H] p Hdf. apply func_pair in Hdf as Heq...
    rewrite Heq in Hdf. apply func_ap in Hdf as Hapf...
    apply domI in Hdf. apply Hsub in Hdf as Hdg.
    apply func_correct in Hdf as Hpf... apply func_correct in Hdg as Hpg...
    apply H in Hdf as Hapeq. congruence.
Qed.

Example ex3_13: ∀ f g,
  is_function f → is_function g → f ⊆ g → dom g ⊆ dom f → f = g.
Proof with eauto.
  intros f g Hf Hg Hs Hds. apply func_ext_intro...
  - apply sub_antisym... intros x Hx. apply domE in Hx as [y Hp].
    apply Hs in Hp. eapply domI...
  - intros x Hx. apply domE in Hx as [y Hp].
    apply func_ap in Hp as Heqf... apply Hs in Hp.
    apply func_ap in Hp as Heqg... subst...
Qed.

Example ex3_14_a:  ∀ f g,
  is_function f → is_function g → is_function (f ∩ g).
Proof with eauto.
  intros * Hf Hg. split.
  - intros x Hx. apply BInterE in Hx as [Hx _].
    apply func_pair in Hx... exists (π1 x), (π2 x)...
  - intros y Hy. apply domE in Hy as [x Hy]...
    exists x. split... intros y' Hy'.
    apply BInterE in Hy as [Hy _].
    apply BInterE in Hy' as [Hy' _]. clear Hg. eapply func_sv...
Qed.

Example ex3_14_b:  ∀ f g,
  is_function f → is_function g →
  (∀x ∈ dom f ∩ dom g, f[x] = g[x]) ↔ is_function (f ∪ g).
Proof with eauto.
  intros * Hf Hg. split; intros.
  - split.
    + intros p Hp. apply BUnionE in Hp as [Hp|Hp];
        apply func_pair in Hp; eauto; exists (π1 p), (π2 p)...
    + intros x Hx. apply domE in Hx as [y Hy]...
      exists y. split... intros y' Hy'.
      apply BUnionE in Hy as [Hy|Hy];
      apply BUnionE in Hy' as [Hy'|Hy'].
      * clear Hg. eapply func_sv...
      * apply domI in Hy as Hdf. apply domI in Hy' as Hdg.
        apply func_ap in Hy... apply func_ap in Hy'...
        assert (x ∈ dom f ∩ dom g). apply BInterI...
        apply H in H0. congruence.
      * apply domI in Hy as Hdf. apply domI in Hy' as Hdg.
        apply func_ap in Hy... apply func_ap in Hy'...
        assert (x ∈ dom f ∩ dom g). apply BInterI...
        apply H in H0. congruence.
      * clear Hf. eapply func_sv...
  - apply BInterE in H0 as [Hdf Hdg].
    apply func_correct in Hdf... apply func_correct in Hdg...
    eapply func_sv... apply BUnionI1... apply BUnionI2...
Qed.

Example ex3_15: ∀ 𝒜, (∀f ∈ 𝒜, is_function f) →
  (∀ f g ∈ 𝒜, f ⊆ g ∨ g ⊆ f) → is_function ⋃𝒜.
Proof with eauto.
  intros. repeat split.
  - intros p Hp. apply UnionAx in Hp as [f [Hf Hp]].
    apply H in Hf. eapply func_pair in Hf...
    exists (π1 p), (π2 p)...
  - intros x Hx. apply domE in Hx as [y Hy]...
    exists y. split... intros y' Hy'.
    apply UnionAx in Hy  as [f [Hf Hpf]].
    apply UnionAx in Hy' as [g [Hg Hpg]].
    destruct (H0 f Hf g Hg).
    + apply H1 in Hpf. eapply (func_sv g)...
    + apply H1 in Hpg. eapply (func_sv f)...
Qed.

Example ex3_16: ¬ ∃ F, ∀ f, is_function f → f ∈ F.
Proof with auto.
  intros [F H].
  set (λ f, ∀x ∈ dom f, ∀y ∈ dom f, x = y) as P1.
  set (λ f, ∀z ∈ dom f, <z, z> ∈ f) as P2.
  set {f ∊ F | P1 f ∧ P2 f } as C.
  apply ex2_8. exists (⋃⋃C). intros.
  apply UnionAx. exists ({{a,},}). split...
  apply UnionAx. exists ({{{a,},},}). split...
  assert ({{{a,},},} = {<a, a>,}) by reflexivity.
  assert ({<a, a>,} = Ident {a,}). {
    ext.
    - apply SingE in H1. subst x. apply ReplAx. exists a. split...
    - apply ReplAx in H1 as [b [Ha Hp]].
      apply SingE in Ha. subst b x...
  }
  rewrite H0, H1. apply SepI. apply H. apply ident_is_func.
  split. intros x Hx y Hy.
  apply domE in Hx as [x' Hx]. apply identE in Hx as [Hx _].
  apply domE in Hy as [y' Hy]. apply identE in Hy as [Hy _].
  apply SingE in Hx. apply SingE in Hy. subst...
  intros z Hz. apply domE in Hz as [z' Hz].
  apply identE in Hz as Heq. destruct Heq as [_ Heq]. subst...
Qed.

Example ex3_17_a: ∀ F G,
  single_rooted F → single_rooted G → single_rooted (F ∘ G).
Proof with eauto.
  intros * Hsf Hsg y Hy. apply ranE in Hy as [x Hx]...
  exists x. split... intros x' Hx'.
  apply compoE in Hx  as [t [Htg Htf]].
  apply compoE in Hx' as [u [Hug Huf]].
  assert (t = u) by (clear Hsg; eapply singrE; eauto).
  subst. clear Hsf. eapply singrE...
Qed.

Example ex3_17_b: ∀ F G,
  injective F → injective G → injective (F ∘ G).
Proof with auto.
  intros * [Hff Hsf] [Hfg Hsg]. split.
  apply compo_func... apply ex3_17_a...
Qed.

Example ex3_20: ∀ F A, F ↾ A = F ∩ A × ran F.
Proof with eauto.
  intros. ext Hx.
  - apply restrE1 in Hx as [a [b [Ha [Hp Heq]]]].
    subst x. apply BInterI... apply CPrdI... eapply ranI...
  - apply BInterE in Hx as [Hx Hcp].
    apply CPrdE1 in Hcp as [a [Ha [b [Hb Heq]]]].
    subst x. apply restrI...
Qed.

Example ex3_21: ∀ R S T, (R ∘ S) ∘ T = R ∘ (S ∘ T).
Proof with eauto.
  intros. ext Hx.
  - pose proof (compo_rel (R ∘ S) T).
    apply rel_pair in Hx as Heq... rewrite Heq in *.
    apply compoE in Hx as [t [Ht1 Ht2]].
    apply compoE in Ht2 as [u [Hu1 Hu2]].
    eapply compoI... eapply compoI...
  - pose proof (compo_rel R (S ∘ T)).
    apply rel_pair in Hx as Heq... rewrite Heq in *.
    apply compoE in Hx as [t [Ht1 Ht2]].
    apply compoE in Ht1 as [u [Hu1 Hu2]].
    eapply compoI... eapply compoI...
Qed.

Example ex3_22_a: ∀ F A B, A ⊆ B → F⟦A⟧ ⊆ F⟦B⟧.
Proof.
  intros * H y Hy. apply imgE in Hy as [x [Hx Hp]].
  apply H in Hx. eapply imgI; eauto.
Qed.

Example ex3_22_b: ∀ F G A, (F ∘ G)⟦A⟧ = F⟦G⟦A⟧⟧.
Proof with eauto.
  intros. ext y Hy.
  - apply imgE in Hy as [x [Hx Hp]].
    apply compoE in Hp as [t [Htg Htf]].
    eapply imgI... eapply imgI...
  - apply imgE in Hy as [x [Hx Hpf]].
    apply imgE in Hx as [w [Hw Hpg]].
    eapply imgI... eapply compoI...
Qed.

Example ex3_22_c: ∀ Q A B, Q ↾ (A ∪ B) = (Q ↾ A) ∪ (Q ↾ B).
Proof with auto.
  intros. ext Hx.
  - apply restrE1 in Hx as [a [b [Ha [Hp Heq]]]]. subst x.
    apply BUnionE in Ha as [].
    + apply BUnionI1. apply restrI...
    + apply BUnionI2. apply restrI...
  - apply BUnionE in Hx as [Hx|Hx];
    apply restrE1 in Hx as [a [b [Ha [Hp Heq]]]]; subst x.
    + apply restrI... apply BUnionI1...
    + apply restrI... apply BUnionI2...
Qed.

Example ex3_23_a: ∀ A B, B ∘ Ident A = B ↾ A.
Proof with eauto.
  intros. ext Hx.
  - pose proof (compo_rel B (Ident A)).
    apply rel_pair in Hx as Heq... clear H. rewrite Heq in Hx.
    apply compoE in Hx as [t [Hta Htb]].
    apply identE in Hta as [Hp1 Ht].
    subst t. rewrite Heq. apply restrI...
  - apply restrE1 in Hx as [a [b [Ha [Hp Heq]]]]. subst x.
    eapply compoI... apply identI...
Qed.

Example ex3_23_b: ∀ A C, (Ident A)⟦C⟧ = A ∩ C.
Proof with eauto.
  intros. ext Hx.
  - apply imgE in Hx as [w [Hc Hp]].
    apply identE in Hp as [Ha Heq]. subst x. apply BInterI...
  - apply BInterE in Hx as [Ha Hc].
    eapply imgI... apply identI...
Qed.

Example ex3_24: ∀ F A,
  is_function F → F⁻¹⟦A⟧ = {x ∊ dom F | F[x] ∈ A}.
Proof with eauto.
  intros F A Hf. ext.
  - apply SepE in H as [_ [w Hp]]. apply SepE in Hp as [Hp [_ Hw]].
    rewrite π1_correct in Hw. apply SepE in Hp as [_ [_ Hq]].
    rewrite π1_correct, π2_correct in Hq.
    apply SepI. eapply domI... erewrite func_ap...
  - apply SepE in H as [Hd Hy].
    pose proof (ap_exists F Hf x Hd) as [y [_ [Hxy Heq]]].
    eapply ranI. apply SepI; try split.
    + rewrite inv_op in Hxy...
    + exists y, x...
    + rewrite π1_correct. rewrite Heq in Hy...
Qed.

Example ex3_25: ∀ G,
  is_function G → (G ∘ G⁻¹) = Ident (ran G).
Proof. exact compo_inv_ran_ident. Qed.

(* ex3_26: see EX7.v *)

Example ex3_27: ∀ F G, dom (F ∘ G) = G⁻¹⟦dom F⟧.
Proof with eauto.
  intros. ext Hx.
  - apply domE in Hx as [y Hp].
    apply compoE in Hp as [t [Htg Htf]].
    eapply imgI. eapply domI... rewrite <- inv_op...
  - apply imgE in Hx as [w [Hw Hpf]].
    rewrite <- inv_op in Hpf. apply domE in Hw as [x' Hpg].
    eapply domI. eapply compoI...
Qed.

Example ex3_28: ∀ f A B G,
  f: A ⇔ B → is_function G →
  dom G = 𝒫 A → (∀x ∈ dom G, G[x] = f⟦x⟧) →
  G: 𝒫 A ⇒ 𝒫 B ∧ injective G.
Proof with eauto.
  intros * [[Hff Hfs] [Hdf Hrf]] Hfg Hdgeq Hapeq.
  split. split... split...
  - intros y Hy. apply ranE in Hy as [x Hp].
    apply domI in Hp as Hdg. apply Hapeq in Hdg.
    apply func_ap in Hp... subst y. rewrite Hdg.
    assert (f⟦x⟧ ⊆ ran f) by apply img_included.
    apply PowerAx. eapply sub_trans...
  - split... intros y Hy. apply ranE in Hy as [X HX]...
    exists X. split... intros X' HX'. subst A.
    apply domI in HX as Hd. apply domI in HX' as Hd'.
    apply func_ap in HX... apply func_ap in HX'...
    rewrite Hapeq in HX... rewrite Hapeq in HX'... subst y.
    clear Hrf Hfg Hapeq.
    ext Hx.
    + rewrite Hdgeq in Hd. rewrite PowerAx in Hd.
      apply Hd in Hx as Hpx. apply func_correct in Hpx...
      eapply imgI in Hpx as Himg... rewrite <- HX' in Himg.
      apply imgE in Himg as [x' [Hx' Hpx']].
      assert (x = x') by (eapply singrE; eauto). subst...
    + rewrite Hdgeq in Hd'. rewrite PowerAx in Hd'.
      apply Hd' in Hx as Hpx. apply func_correct in Hpx...
      eapply imgI in Hpx as Himg... rewrite HX' in Himg.
      apply imgE in Himg as [x' [Hx' Hpx']].
      assert (x = x') by (eapply singrE; eauto). subst...
Qed.

Example ex3_29: ∀ f A B G,
  f: A ⟹ B → G: B ⇒ 𝒫 A →
  (∀b ∈ dom G, G[b] = {x ∊ A | f[x] = b}) → injective G.
Proof with eauto.
  intros * [Hff [Hdf Hrf]] [Hgf [Hdg _]] H. subst A B.
  split... intros y Hy. apply ranE in Hy as [b Hb]...
  exists b. split... intros b' Hb'.
  apply domI in Hb as Hd. apply domI in Hb' as Hd'.
  apply func_ap in Hb... apply func_ap in Hb'... subst y.
  apply H in Hd as Heq. apply H in Hd' as Heq'.
  rewrite <- Hb' in Heq. rewrite Heq' in Heq.
  rewrite Hdg in Hd. clear Hb' Hd' Heq'.
  apply ranE in Hd as [x Hp]. apply func_ap in Hp as Hap...
  assert (Hx: x ∈ Sep (dom f) (λ x, f [x] = b)). {
    apply SepI... apply domI in Hp...
  }
  rewrite <- Heq in Hx. apply SepE in Hx as [_ Hfb]. subst...
Qed.

(** 克纳斯特－塔斯基定理的引理 **)
(* 设L是完全格，F: L ⇒ L 是次序保持函数，则F在L中有最小不动点和最大不动点 *)
Example ex3_30: ∀ F A, F: 𝒫 A ⇒ 𝒫 A →
  (∀ X Y, X ⊆ Y ∧ Y ⊆ A → F[X] ⊆ F[Y]) →
  let ℬ := {X ∊ 𝒫 A | F[X] ⊆ X} in
  let 𝒞 := {X ∊ 𝒫 A | X ⊆ F[X]} in
  let B := ⋂ℬ in let C := ⋃𝒞 in
  F[B] = B ∧ F[C] = C ∧ ∀X ∈ dom F, F[X] = X → B ⊆ X ∧ X ⊆ C.
Proof with eauto.
  intros * [Hf [Hd Hr]] HM ℬ 𝒞 B C.
  assert (HAp: <A, F[A]> ∈ F). {
    eapply func_correct... rewrite Hd. apply all_in_its_power.
  }
  assert (HAaps: F[A] ⊆ A). {
    apply PowerAx. apply Hr. eapply ranI...
  }
  assert (HA: A ∈ ℬ). {
    apply SepI... apply all_in_its_power.
  }
  assert (HBs: B ⊆ A). {
    intros x Hx. apply InterE in Hx as [[y H1] H2]. apply H2...
  }
  assert (HBp: <B, F[B]> ∈ F). {
    eapply func_correct... rewrite Hd. apply PowerAx...
  }
  assert (HBaps: F[B] ⊆ B). {
    intros x Hx. apply InterI. exists A... intros X HX.
    cut (F[B] ⊆ X). intros. apply H...
    cut (F[B] ⊆ F[X] ∧ F[X] ⊆ X). intros []. eapply sub_trans...
    assert (HX':= HX). apply SepE in HX' as [HXP HXs].
    rewrite PowerAx in HXP. split... apply HM. split...
    intros b Hb. apply InterE in Hb as [_ Hb]. apply Hb...
  }
  assert (HCs: C ⊆ A). {
    intros x Hx. apply UnionAx in Hx as [X [HX Hx]].
    apply SepE in HX as [HX _]. rewrite PowerAx in HX. apply HX...
  }
  assert (HCp: <C, F[C]> ∈ F). {
    eapply func_correct... rewrite Hd. apply PowerAx...
  }
  assert (HCaps: C ⊆ F[C]). {
    intros x Hx. apply UnionAx in Hx as [X [HX Hx]].
    cut (X ⊆ F[C]). intros. apply H...
    cut (X ⊆ F[X] ∧ F[X] ⊆ F[C]). intros []. eapply sub_trans...
    assert (HX':= HX). apply SepE in HX' as [_ HXs].
    split... apply HM. split...
    intros c Hc. apply UnionAx. exists X. split...
  }
  split; [|split].
  - (* F[B] = B *) apply sub_antisym...
    intros x Hx. apply InterE in Hx as [_ Hx]. apply Hx.
    apply SepI. apply Hr. eapply ranI... apply HM. split...
  - (* F[C] = C *) apply sub_antisym...
    intros x Hx. apply UnionAx. exists (F[C]). split...
    apply SepI. apply Hr. eapply ranI... apply HM. split...
    apply PowerAx. apply Hr. eapply ranI...
  - intros X HX Heq. split.
    + (* B ⊆ X *) intros b Hb.
      apply InterE in Hb as [_ Hb]. apply Hb.
      apply SepI. apply Hr. rewrite <- Heq. eapply ranI.
      apply func_correct... rewrite <- Heq at 2...
    + (* X ⊆ C *) intros c Hc.
      apply UnionAx. exists X. split...
      apply SepI. apply Hr. rewrite <- Heq. eapply ranI.
      apply func_correct... rewrite <- Heq at 1...
Qed.

(* ex3_31: see EST3_2.v Theorem AC_I_iff_II *)


Require Import Coq.Logic.Classical_Prop.
Require Import Logic.lib.Coqlib.
Require Import Logic.GeneralLogic.Base.
Require Import Logic.GeneralLogic.Complete.ContextProperty.
Require Import Logic.GeneralLogic.ProofTheory.BasicSequentCalculus.
Require Import Logic.GeneralLogic.Complete.ContextProperty_Kripke.

Local Open Scope logic_base.

Section ContextProperty.

Context {L: Language}
        {Gamma: Derivable L}
        {bSC: BasicSequentCalculus L Gamma}.

Lemma maximal_consistent_spec :
  forall Phi, maximal consistent Phi <-> consistent Phi /\ forall x, consistent (Union _ Phi (Singleton _ x)) -> Phi x.
Proof.
  intros.
  split; intros [? ?]; split; auto.
  + intros.
    specialize (H0 _ H1).
    specialize (H0 (fun x H => Union_introl _ _ _ _ H)).
    specialize (H0 x).
    apply H0; right; constructor.
  + intros.
    hnf; intros.
    apply H0.
    unfold consistent in*.
    destruct H1 as [y ?].
    exists y.
    intro; apply H1.
    eapply deduction_weaken; [| exact H4].
    intros ? [? | ?]; auto.
    destruct H5; auto.
Qed.

Lemma maximal_consistent_derivable_closed:
  forall (Phi: context),
  maximal consistent Phi ->
  derivable_closed Phi.
Proof.
  intros.
  hnf; intros.
  assert (consistent (Union _ Phi (Singleton _ x))).
  {
    destruct H as [[y ?] _].
    exists y.
    intro.
    pose proof deduction_subst1 _ _ _ H0 H1.
    auto.
  }
  destruct H.
  specialize (H2 _ H1).
  specialize (H2 (fun x H => Union_introl _ _ _ x H)).
  apply H2.
  right; constructor.
Qed.

Lemma MCS_element_derivable:
  forall(Phi: context),
  maximal consistent Phi ->
  (forall x: expr, Phi x <-> Phi |-- x).
Proof.
  intros.
  apply derivable_closed_element_derivable, maximal_consistent_derivable_closed.
  auto.
Qed.

End ContextProperty.


Require Coq.FSets.FSetFacts.
Require Coq.FSets.FSetInterface.
Require Coq.FSets.FSetProperties.
Require Import Coq.Lists.SetoidList.

Module SetUtil (Import M:FSetInterface.WS).
  Module P := FSetProperties.Properties M.
  Lemma in_elements_impl_in:
    forall e s,
    List.In e (elements s) ->
    In e s.
  Proof.
    intros.
    apply elements_2.
    apply In_InA.
    + apply Build_Setoid_Theory.
      * unfold Reflexive.
        auto.
      * unfold Symmetric.
        auto.
      * unfold Transitive.
        intros.
        apply E.eq_trans with (y:=y); repeat assumption.
    + assumption.
  Qed.

  Lemma in_impl_in_elements:
    forall e s,
    In e s ->
    exists e', E.eq e e' /\ List.In e' (elements s).
  Proof.
    intros.
    apply elements_1 in H.
    apply InA_alt in H.
    assumption.
  Qed.

  Lemma in_iff_in_elements:
    forall e s,
    (forall e1 e2, E.eq e1 e2 -> e1 = e2) ->
    (In e s <-> List.In e (elements s)).
  Proof.
    intros.
    split.
    - intros. apply in_impl_in_elements in H0.
      destruct H0 as (k', (Heq, Hin)).
      apply H in Heq.
      subst.
      assumption.
    - apply in_elements_impl_in.
  Qed.

  Lemma nonempty_in:
    forall s,
    ~ Empty s ->
    exists e, In e s.
  Proof.
    remember ((fun (s:t) => ~ Empty s ->
    exists e, In e s) <: t -> Type) as P.
    assert (X:= P.set_induction (P:=P)).
    subst.
    apply X.
    - intros.
      contradiction H0.
    - intros.
      exists x.
      apply P.Add_Equal in H1.
      assert (In x (add x s)). {
        auto using add_1.
      }
      unfold Equal in *.
      apply H1.
      assumption.
  Qed.
End SetUtil.


(** *** Projet Coq 2016 - L3 S2 - Lucca Hirschi *)

(** Vous pouvez lire ce document dans sa version HTML mais l'idéal est de le compiler
au fur et à mesure pour lire les messages renvoyés par Coq.
 *)
(** Lien vers la page du projet:
<<http://www.lsv.ens-cachan.fr/~hirschi/enseignements/progLogique/
>>
 *)

(************************)
(** * I : Introduction **)
(************************)
(** Ce projet est constitué de trois parties pratiquement indépendantes. La première
section est assez facile conceptuellement mais demande d'écrire pas mal de preuves.
La seconde section demande plus de réflexion. Essayez de l'aborder en TP pour que
je puisse vous aider. La troisième section demande d'avoir lu la seconde.*)

(** Plan:
[II: Axiomes de la logique classique] Preuves autour de la logique classique et de ses axiomatisations
[III: Relations bien fondées] Deux notions de bonne fondaison pour les relations et relations entre
      ces définitions.
[IV: Récursions et relations bien fondées] Spécification faible vs. forte puis deux approches pour
     définir et spécifier des fonctions récursives non structurellement décroissantes.
 *)

(********************************************)
(** * II : Axiomes de la logique classique **)
(********************************************)
(** L'axiomatisation de base de Coq ne permet que de prouver des preuves en logique
intuitioniste (et non classique). Si l'on veut travailler dans une logique classique,
on doit alors déclarer un "axiome classique" dans Coq. On peut ajouter le raisonnement
par l'absurde, ou ajouter la loi de Peirce par exemple. L'objectif de la première partie
du projet est de montrer que les logiques classiques induites par cinq axiomes différents
ont la même expressivité.*)

Definition peirce := forall P Q:Prop, ((P->Q)->P)->P.
Definition classic := forall P:Prop, ~~ P -> P.
Definition excluded_middle := forall P:Prop, P \/ ~P.
Definition de_morgan_not_and_not := forall P Q:Prop, ~(~P/\~Q)->P\/Q.
Definition implies_to_or := forall P Q:Prop, (P->Q)->(~P\/Q).

(** *** Exercice 1: preuves classiques *)
(***************************************)
(** **** Question 1:*)(** Prouvez que les logiques induites par ces propriétés ont la même
expressivité. Le plus simple est de choisir un ordre (par exemple
classic => peirce => implies_to_or => ... => classic) et prouvez une série de lemmes de la forme:
                       *)

(* Abréviations :
 * peirce : pl (peirce law)
 * classic : cl
 * excluded_middle : em
 * de_morgan_not_and_not : dm
 * implies_to_or : ito
 *)

(* Ordre choisi :
 * classic => peirce => excluded_middle => implies_to_or
 * => de_morgan_not_and_not => classic
 *)

(* Pour montrer les lemmes, on va se contenter de montrer des lemmes du type loi1 => loi2. Pour cela, on a besoin du lemme intermédiaire suivant : *)

Lemma simple_to_complex : forall A B:Prop, (B->A) -> (forall P : Prop, (A->P) -> (B->P)).
Proof.
intros A B BiA P AiP Bt.
apply AiP.
apply BiA.
assumption.
Qed.

(***** Classic => peirce *****)
Lemma cl_pl : forall P:Prop, (classic -> P) -> (peirce -> P).
apply simple_to_complex.
intro pl.
intros P nnP.
assert ((~P -> P) ->P) as plPFalse. (*on applique pl avec P et false*)
apply pl.
apply plPFalse.
intro nP.
destruct nnP.
assumption.
Qed.

(***** Peirce => excluded_middle *****)
Lemma pl_em :  forall P:Prop, (peirce -> P) -> (excluded_middle -> P).
Proof.
apply simple_to_complex.
intro em.
intros P Q.
assert (P\/~P) as emP.
apply em.
destruct emP as [Ptrue|nP].

intro . (*si P*)
assumption.

intro imp. (*si ~P*)
apply imp.
intro Ptrue.
destruct nP.
assumption.
Qed.

(***** excluded_middle => implies_to_or *****)

(*Question : ici, le ; ne permet pas de factoriser le code... Comment faire.*)
Lemma or_commut : forall P Q:Prop, P\/Q <-> Q\/P.
Proof.
intros P Q.
split.
intro or.
destruct or.
right.
assumption.
left.
assumption.
intro or.
destruct or.
right.
assumption.
left.
assumption.
Qed.

Lemma em_ito :  forall P:Prop, (excluded_middle -> P) -> (implies_to_or -> P).
Proof.
apply simple_to_complex.
intro ito.
intro P.
assert ((P->P)->~P\/P) as itoPP.
apply ito.
apply or_commut.
apply itoPP.
intro Pt.
assumption.
Qed.

(***** implies_to_or => de_morgan_not_and_not *****)
Lemma ito_dm : forall P:Prop, (implies_to_or -> P) -> (de_morgan_not_and_not -> P).
Proof.
apply simple_to_complex.
intros dm P Q PiQ.
assert (~(~~P/\~Q) -> (~P \/ Q)) as dm_nPQ. (*on applique dm avec ~P et Q*)
apply dm.
apply dm_nPQ.
intro nAnd.
destruct nAnd as [nnP nQ].
destruct nnP.
intro Ptrue.
destruct nQ.
apply PiQ.
assumption.
Qed.

(***** de_morgan_not_and_not => classic *****)
Lemma dm_cl :  forall P:Prop, (de_morgan_not_and_not -> P) -> (classic -> P).
Proof.
apply simple_to_complex.
intros cl P Q nAnd.
apply cl.
intro nOr.
destruct nAnd.
split.

intro nP. (*on montre ~P ... *)
destruct nOr.
left.
assumption.

intro nP. (*puis ~Q*)
destruct nOr.
right.
assumption.
Qed.

(** **** Question 2:*)(** Prouvez la dualité classique entre [exists] et [forall].*)
Theorem forallExists : forall A, forall P : A -> Prop,
                         peirce -> (~ (forall x : A, P x) <-> (exists x : A, ~ P x)).
Proof.
intros A P.
apply cl_pl.
intro cl.
split.

intro nforall. (* => *)
apply cl.
intro nexists.
destruct nforall.
intro x.
apply cl.
intro nPx.
destruct nexists.
exists x.
assumption.

intro exists_nPx. (* <= *)
destruct exists_nPx as [x nPx].
intro forallPx.
destruct nPx.
apply forallPx.
Qed.

(** Et le symétrique? A-t-on besoin de la logique classique? *)

(*ici, on n'a pas besoin de la logique classique car on n'utilise à aucun moment un lemme équivalent au tiers exclus*)
Theorem existsForall : forall A, forall P : A -> Prop,
                         (~ (exists x : A, P x) <-> (forall x : A, ~ P x)).
Proof.
intros A P.
split.

intros nexists x nPx. (* => *)
destruct nexists.
exists x.
assumption.

intros forallnPx existsPx. (* <= *)
destruct existsPx as [x Px].
assert (~P x) as nPx.
apply forallnPx .
apply nPx.
assumption.
Qed.

(**************************************)
(** * III : Relations bien fondées   **)
(**************************************)
(** Il faut avoir lu la seconde section pour aborder celle-ci. *)
(** Dans cette section, on va formaliser le prédicat "relation bien fondée" et on va prouver,
entre autre, l'implication et la réciproque entre:
 - (i) une relation est bien fondée (selon notre formalisation),
 - (ii) une relation n'admet pas de suite infinie décroissante.*)
(** Le sens direct est prouvable en logique intuitionniste. On introduira donc
pas d'axiome supplémentaire. On prouvera par contre la réciproque en logique classique (avec l'un
des axiomes de la section II) + un axiome magique.*)

(** ** 1. Sens direct en logique intuitionniste **)
(*************************************************)
(** Il faut commencer par formaliser cette propriété (i) en Coq. Commençons par les relations.
On se limitera dans ce projet aux relations entre un même ensemble. Le type des relations sur un
ensemble A s'écrit donc [R : A -> A -> Prop]. Regardez par exemple la relation "<" sur les
entiers:*)
Check (lt: nat -> nat -> Prop).
(** Pour formaliser qu'une relation est bien fondée (i) on va définir un prédicat [Acce] sur les
 éléments [x] d'un ensemble [A]:
(a) les éléments minimaux pour [R] vérifient le prédicat,
(b) si tous les éléments [y] plus petits que [x] vérifient le prédicat alors [x] le vérifie aussi.
On note que (a) est un cas particulier de (b) ce qui nous permet d'écrire: *)
Inductive Acce (A:Set) (R:A->A->Prop) : A->Prop :=
  Accessible : forall x:A, (forall y:A, R y x -> Acce A R y) -> Acce A R x.
(** Intuitivement, [Acce A R x] est prouvable si vous avez une preuve (et donc un objet fini)
qui explore tous les éléments plus petits que [x]. Moralement, ce prédicat est donc prouvable
uniquement pour les éléments qui n'appartiennent à aucune chaîne infinie décroissante.*)

(** On peut donc formaliser le prédicat "bien fondée":*)
Definition bienFonde (A:Set) (R:A->A->Prop) : Prop := forall a:A, Acce A R a.
(** Cette présentation est plus effective que (ii), si vous prouvez qu'une relation
est bienFondé alors vous construisez une fonction qui pour tout élément de [A]
explore toutes les chaînes descendantes à partir de cet élément. C'est un outil
essentiel pour pouvoir définir des fonctions récursives bien fondées mais non
structurellement décroissantes comme nous le verrons dans la partie IV. *)

(** Remarquez qu'on a (pratiquement) redéfinit  des termes existants : *)
Print Acce.
Print well_founded.

(** *** Exercice 2: Préliminaires **)
(***********************************)
(** **** Question 1:*)(** Ecrivez le prédicat sur les relations vérifiant (ii):
"la relation n'admet pas de suite infinie décroissante". Ecrivez l'énoncé du sens direct).*)
(**  *)

(*
Definition infDec (A:Set) (R:A->A->Prop) : Prop := exists a:A, forall b:A, R b a /\ a <> b -> exists c:A, R c b /\ b <> c.

Check infDec.
Definition notInfDec(A:Set) (R:A->A->Prop) : Prop := forall a:A, exists b:A, forall c:A, R b a /\ a<>b /\ (R c b -> b = c). (*(~R c b \/ b = c). *)
*)

(* ici une suite est une fonction de N dans un certain ensemble A*)
Definition bienFonde2 (A:Set) (R:A->A->Prop) : Prop :=
  ~ (exists seq : nat->A, forall n : nat, R (seq (S n)) (seq n)).

(*Theorem direct : forall A:Set, forall R:A->A->Prop, bienFonde A R -> notInfDec A R.
Proof.
admit.
Qed.*)

(** **** Question 2:*)(** Pour vous échauffer, prouver les deux lemmes suivants qui pourront
vous servir dans la suite.*)

Lemma acce_uneEtape : forall (A:Set) (R : A -> A -> Prop) (a b:A),
                        R a b -> Acce A R b -> Acce A R a.
intros A R a b aInfb bAcce.
inversion bAcce.
apply H.
assumption.
Qed.

Lemma nonAcce_uneEtape : forall (A:Set) (R : A -> A -> Prop) (a b:A),
                           R a b -> ~ Acce A R a -> ~ Acce A R b.
intros A R a b aInfb aNotAcce bAcce.
destruct aNotAcce.
apply acce_uneEtape with (b:=b);assumption.
Qed.

(**  *)
(** **** Question 3:*)(** Prouvez maintenant le lemme suivant permettant de réaliser des inductions
en exploitant une relation bien fondée (notez que c'est le but premier des relations bien
fondées: permettre d'aller au delà des fonctions récursives structurellement décroissantes).
Lui aussi pourra vous être utile. Pensez bien au lemme d'induction généré par la définition
inductive du prédicat [Acce].*)

Lemma bienFonde_ind : forall (A : Set) (R : A -> A -> Prop),
                        bienFonde A R ->
                        forall P : A -> Prop,
                          (forall x : A, (forall y : A, R y x -> P y) -> P x) ->
                          forall a : A, P a.

Check Acce_ind.
intros A R bfR P heredite a.
apply Acce_ind with (A:=A) (R:=R).
unfold bienFonde in bfR.
intros x RimpAcce RimpP.
apply heredite.
assumption.
unfold bienFonde in bfR.
apply bfR.
Qed.

(**  *)
(** *** Exercice 3: Preuves de bonne fondaison **)
(************************************************)
(** **** Question 1:*)(** On montre que la relation [< : nat -> nat -> Prop] est bien fondée
(conseil: vous aurez besoin d'un lemme d'induction forte).*)
Check nat_ind.

Lemma strong_induction : forall P : nat -> Prop, P 0 -> (forall m : nat, (forall n : nat, lt n m -> P n) -> P m) -> forall k : nat, P k.
intros P P0 heredite n.
apply heredite.
induction n.

intros n2 n2lt0. (*initialisation*)
unfold lt in n2lt0.
inversion n2lt0.

intros n0 n0ltSn. (*hérédité*)
inversion n0ltSn.
apply heredite.
assumption.
apply IHn.
assumption.
Qed.

Lemma lt_bienFonde : bienFonde nat lt.
unfold bienFonde.
apply strong_induction.

apply Accessible. (*initialisation*)
intros y ylt0.
inversion ylt0.
intros m H. (*hérédité*)
apply Accessible.
assumption.
Qed.

(** **** Question 2:*)(** Ecrivez le prédicat [lex] qui prend deux relations et qui formalise
la relation lexicographique sur ces deux relations. Prouvez maintenant que si deux relations
sont bien fondées alors la relation lexicographique de ces deux relations l'est aussi.*)
(**  *)
Print le.
Locate "(".
Print pair.
Print prod.
Print nat.
Print S.

Inductive lex (A:Set) (R:A->A->Prop) (R' : A->A->Prop) : A*A -> A*A -> Prop :=
fstInf : forall c c' : A*A, R (fst c) (fst c') -> lex A R R' c c'
|sndInf :  forall c c' : A*A, fst c = fst c' /\ R' (snd c) (snd c') -> lex A R R' c c'.

Lemma bfLex : forall (A:Set) (R R':A->A->Prop), bienFonde A R -> bienFonde A R' ->bienFonde (A*A) (lex A R R').
Proof.
(*intros A R R' bfR bfR'.
unfold bienFonde.
intro a.
apply Accessible.
intros y ylexa.
unfold lex in ylexa.
destruct ylexa.
unfold bienFonde in bfR.*)
admit.
Qed.

Check bienFonde_ind.
(** *** Exercice 4: Le sens direct **)
(************************************)
(** Et maintenant, prouvez le sens direct de l'équivalence entre (i) et (ii). *)
(**  *)
Theorem direct : forall A:Set, forall R:A->A->Prop, bienFonde A R -> bienFonde2 A R.
Proof.
unfold bienFonde2.
intros A R bfR existsInfDec.
destruct existsInfDec as [seq seqIsInfDec] .

Definition P (A:Set) (R:A->A->Prop) (seq:nat -> A)(x:A) :=  (exists n : nat, x = seq n) -> ~ Acce A R x.

assert (forall a:A, P A R seq a).
intro a.
apply bienFonde_ind with (R:=R).
assumption.

unfold P. (*hérédité*)
intros x HR xInSeq.
destruct xInSeq as [n xInSeq].

assert (R (seq (S n)) x). (*Évite d'avoir à faire deux fois la même preuve*)
rewrite xInSeq.
apply seqIsInfDec.
apply nonAcce_uneEtape with (a:=seq (S n)).
assumption.
apply HR.
assumption.
exists (S n).
reflexivity.

unfold bienFonde in bfR. (*conclusion*)
assert (~Acce A R (seq 0)).
apply H.
exists 0.
reflexivity.
destruct H0.
apply bfR.
Qed.

(** ** 2. Réciproque en logique classique **)
(*******************************************)
(** On s'attaque maintenant à la réciproque!*)

(** *** Exercice 5: Préliminaires **)
(***********************************)
(** La réciproque n'est pas prouvable en logique intuitionniste (des intuitions? écrivez-les).
On introduit donc un axiome classique que l'on pourra utiliser dans la suite. La syntaxe est
"[Axiom [nom_axiome] : P.]".*)

(*Intuition : si on part de l'hypothèse qu'il n'existe pas de suite infiniment décroissante,
on risque d'avoir du mal à trouver les éléments minimum de la relation de bonne fondaison
car on a rien de concret : on n'a que des suites finies dont on ne connaît rien,
et en particulier pas les premiers éléments.
J'imagine qu'il vaut mieux raisonner par contraposée, ce qui nécessite le tiers exclus.
On peut alors construire récursivement une suite infiniment décroissante à partir de la relation bien fondée*)

(** Tentez de prouver la réciproque sur papier en logique classique.
 De quoi avez-vous besoin ?
 Est-ce que c'est prouvable dans Coq (avec l'axiome classique) ?*)
(** Vous avez le droit d'ajouter un axiome tant qu'il appartient à la
théorie des ensembles de Zermelo-Fraenkel
(cf.Wikipedia).*)
(**  *)

(** *** Exercice 6: la réciproque **)
(***********************************)
(** Et maintenant, muni de ces deux axiomes, prouvez la réciproque.*)

Axiom classic_ax : peirce.

(* pour construire une suite infiniment décroissante d'éléments non accessible,
on va devoir à chaque étape choisir un élément des éléments plus petits que
l'élément qu'on est en train de considérer. On a donc besoin de l'axiome du choix.
En fait, l'axiome du choix dépendant va nous suffire ici.*)

(*L'axiome du choix dépendant tel qu'il apparaît sur wikipedia*)
Axiom choice_v0 : forall A:Set, forall R : A -> A -> Prop,
                    (exists x y : A, R x y) ->
                    (forall x:A, exists y : A, R x y) ->
                    (exists seq:nat -> A, forall n :nat, R (seq n) (seq (S n))).

(*Je me suis permis de faire la modification de l'axiome directement vers l'ensemble des éléments satisfaisant un certain prédicat. Pour prouver l'implication du premier énoncé vers le second, il faudrait utiliser choice_v0 avec le type dépendant {x:A|P x}. Je n'ai malheureusement pas le temps de le faire (deuxième projet oblige ;) )*)
Axiom choice : forall A:Set, forall R:A->A->Prop, forall P: A -> Prop,
                    (exists x y : A , P x /\ P y /\ R y x) ->
                    (forall x:A,P x -> (exists y : A, P y /\ R y x)) ->
                    (exists seq:nat -> A, forall n :nat, R (seq (S n)) (seq n)).

(*On utilise les deux sens de l'équivalence entre une imlplication et sa contraposée dans la preuve de indirect*)
Lemma contraposee : forall p q:Prop, (~p -> ~q) <-> (q -> p).
split. (*->  avec tiers exclus*)
intros npInq qTrue.
assert (classic -> p). (* on va ici utiliser classic plutôt que pierce*)
intro classic.
apply classic.
intro np.
apply npInq; assumption.
apply cl_pl.
assumption.
apply classic_ax.

(*<- sans tiers exclus*)
intros npInq np qT.
destruct np.
apply npInq.
assumption.
Qed.

(* Un petit lemme bien utile pour la suite *)
Lemma notImp : forall p q:Prop, ~(p -> q) -> (~q /\ p).
  intros p q npImpq.
  split.

  (*~(p -> q) -> ~q*)
  intro qT.
  destruct npImpq.
  intro pT.
  assumption.

  (*~(p -> q) -> p*)
  assert (peirce -> p).
  apply cl_pl.
  intro classic.
  apply classic.
  intro np.
  destruct npImpq.
  intro pT.
  exfalso.
  apply np.
  assumption.
  apply H.
  apply classic_ax.
Qed.

(*Maintenant on rentre dans la partie importante de la preuve : la construction de l'élément suivant dans la construction de notre suite décroissante. Je l'ai mise dans un lemme à part car on en a besoin deux fois.*)
(*.*)
Lemma constr_seq : forall A:Set, forall R : A->A->Prop, forall x:A, ~Acce A R x -> (exists y: A, ~Acce A R y /\ R y x).
  intros A R x.
  (*on utilise le fait que x n'est pas accessible*)
 assert (~Acce A R x -> ~ (forall y: A, R y x -> Acce A R y)).
apply contraposee.
apply Accessible.
intro nax.

(*on utilise forallexists*)
assert (exists y, ~(R y x -> Acce A R y)).
apply forallExists.
apply classic_ax.
apply H.
assumption.
destruct H0 as [y H0].
exists y.

(*il ne nous reste plus qu'à appliquer le lemme précédent*)
apply notImp.
assumption.
Qed.

Theorem indirect : forall A:Set, forall R:A->A->Prop, bienFonde2 A R -> bienFonde A R.
(* on commence par dire qu'on veut prouver la contraposée*)
intros A R.
apply contraposee.
intros nbfR bf2.
destruct bf2.

(*on veut alors récupérer un élément non accessible qui nous permettra de prouver que la relation est non vide (ce qui est une des hypothèses de l'axiome du choix dépendant*)
assert (exists na:A, ~Acce A R na).
apply forallExists.
apply classic_ax.
assumption.
destruct H as [na NAcc].

(*On peut à présent appliquer l'axiome du choix dépendant*)
apply choice with (P:=fun x => ~Acce A R x).

(*on montre que la relation est non vide*)
assert (exists y: A, ~Acce A R y /\ R y na).
apply constr_seq.
assumption.
destruct H as [y H].
exists na.
exists y.
split;assumption.

(*on tombe alors sur le cas de construction du lemme précédent*)
apply constr_seq.
Qed.

(**************************************************)
(** * IV : Récursions et relations bien fondées  **)
(**************************************************)
(** On revient maintenant sur les fonctions récursives totales mais non structurellement décroissantes
(comme la  fonction pgcd vue en TP). Nous allons voir que les relations bien fondées font parties
des ingrédients nécessaires dans les deux approches discutées dans les deux sous-sections suivantes.
L'objectif est ici d'écrire une fonction pgcd et de prouver sa spécification (i.e., elle calcule
bien le pgcd). *)
(** Dans cette section on s'autorise l'aide de la tactique [omega] qui résout pas mal de systèmes
d'équations et d'inéquations de [nat]. *)
Require Import Omega.

(** Avant de commencer, il nous faut comprendre les notions de spécification faible vs. sépcification
forte. Prenons par exemple, un prédicat [R: A -> B -> Prop] représentant une spécification d'une
fonction [f : A -> B]. On dit que [f] vérifie la spécification [R] quand [forall a:A, R a (f a)].
- (i) Une spécification faible consiste à définir la fonction [f:A->B] dans un premier temps puis
à prouver dans un second temps qu'elle vérifie sa spécification attendue.
- (ii) Une spécification forte consiste à écrire la spécification de [f] dans son type. Typiquement,
un tel type combinera des informations sur les types des données manipulées et des propositions
qu'ils doivent vérifier. Par exemple une spécification forte de la division euclidienne pourrait être
le type suivant: *)
Variable euclideType :forall a b:nat, 0 < b ->
                                      {p:nat*nat | a = (fst p)*b + snd p /\ 0 <= snd p < b}.
(** Ce type décrit les fonctions qui prennent deux entiers [a] et [b], une preuve que [0<b]
et renvoie une paire d'entiers [p] décrivant (couple,quotient) avec les propriétés attendues. *)
(** Formellement, voici comment est défini [{x:A | P }]: *)
Print sig.
(** On voit bien que ce type décrit les éléments de [A] embarquant une preuve qu'ils vérifient [P]. *)
(** Un habitant du type [{x:A | P}] n’est pas tout à fait un habitant du type [A]. Cependant, on
peut toujours le décomposer pour en extraire un élément de type [A] qui satisfait la propriété [P],
à l’aide de la construction match. Voici un exemple: *)
Definition removeSpec (a : {x : nat | x > 0}) : nat  :=
  match a with
    | exist a' Pa => a'
  end.
Check removeSpec.
(** Voyons maintenant comment composer des spécifications. Par exemple: *)
Check le_gt_dec.
Check (le_gt_dec 1 2).
(** Le "+" de [le_gt_dec] est l'équivalent du ou logique mais à valeur dans les données (possiblement
spécifiées). *)

Print sumbool.
Print le_gt_dec.

(** *** Exercice 7: Spécifications et types dépendants *)
(*******************************************************)
(** Question 1: En utilisant les fonctions [div2_of_even] et [test_even], écrivez une fonction dont
 le type est [forall n : nat, {p:nat | n = p+p}+{p:nat | pred n = p+p}]. *)
Require Import Coq.Arith.Even.
Open Scope nat_scope.
Parameter div2_of_even : forall n:nat, even n -> {p:nat | n = p+p}.
Parameter test_even : forall n:nat, {even n}+{even (pred n)}.
Print sumbool.

Definition div2 (n: nat) : {p:nat | n = p+p}+{p:nat | pred n = p+p} :=
  match test_even n with
    |left n_ev  => inl (div2_of_even n n_ev)
    |right nm1_ev => inr (div2_of_even (pred n) nm1_ev)
    end.

(** Question 2: Ecrivez (sans tactique) une fonction prédecesseur fortement spécifiée. *)

(*Definition pred (n:nat) : {p:nat|n = S p}+{n = 0} :=
  match n return {p:nat|n = S p}+{n = 0} with
    |0 => inright (eq_refl)
    |S p => inleft {p|n = S p}
  end.*)

Search nat.
(** Question 3: Ecrivez (uniquement avec des tactiques) une fonction prédecesseur fortement spécifiée. *)
(*Reset pred'.*)
Print nat.
Definition pred' : forall n:nat, {p:nat | n = S p}+{n = 0}.
  intro n.
  assert (n = 0 \/ 0 < n).
  case (zerop n).
  intro n0.
  left.
  assumption.
  intro ng0.
  right.
  assumption.
  destruct H. (*ceci ne fonctionne pas*)

Defined.

(** *** Exercice 8: Définitions par équation et par induction bien fondée *)
(**************************************************************************)

(** ** 1. Définition par équation **)
(***********************************)

(** L'idée de cette approche est de raisonner en trois temps:
a. écrire le corps de la fonction
b. démontrer sa terminaison
c. construire le point fixe et prouver sa spécification
 *)

(** a. L'idée est de remplacer une définition inductive [f x = expr] où [expr] contient [f] par
une équation de point fixe [f x = F f x] (f étant le point fixe de [F]). Par exemple voici le [F]
que l'on pourrait définir dans le but de calculer la division euclidienne. *)
Definition div_it_F (f:nat->nat->nat*nat) (m n:nat) :=
  match le_gt_dec n m with
    | left _ => let (q, r) := f (m-n) n in (S q, r)
    | right _ => (0, m)
  end.
(** On définit maintenant la fonction qui itère [F] un certain nombres de fois: [F^n g a] *)
Fixpoint iter (A:Set) (n:nat)(F:A->A)(g:A){struct n} : A :=
  match n with
      O => g
    | S p => F (iter A p F g)
  end.
Implicit Arguments iter [A].

(** b. On peut maintenant montrer la terminaison: pour des entiers [n,m] il va toujours exister un
nombre d'itération [p] pour lequel on atteint le point fixe de [F]. *)
Definition div_it_terminates :
  forall n m:nat, 0 < m ->
                  {v : nat * nat |
                   exists p : nat, (forall k:nat, p < k -> forall g:nat -> nat -> nat * nat,
                                                             iter k div_it_F g n m = v)}.
  intro n.
  (** On veut faire une induction forte sur [n]: *)
  elim n using (well_founded_induction lt_wf).
  (** Question 1: Terminez la preuve *)
Defined.

(** c. Construction du point fixe. *)
Definition div_it (n m:nat)(H:0 < m) : nat*nat :=
  let (v, _) := div_it_terminates n m H in v.
(** Preuve du point fixe *)
Theorem div_it_fix_eqn :
  forall (n m:nat)(h:(0 < m)),
    div_it n m h =
    match le_gt_dec m n with
      | left H => let (q,r) := div_it (n-m) m h in (S q, r)
      | right H => (0, n)
    end.
Proof.
  (** Question 2: Ecrivez la preuve. *)
Qed.

(** Preuve de Correction *)
Theorem div_it_correct1 :
  forall (m n:nat)(h:0 < n),
    m = fst (div_it m n h) * n + snd (div_it m n h).
Proof.
  intros m; elim m using (well_founded_ind lt_wf).
  (** Question 3: Terminez la preuve. *)
Qed.
Theorem div_it_correct2 :
  forall (m n:nat)(h:0 < n), snd (div_it m n h) < n.
Proof.
  (** Question 4: Ecrivez la preuve. *)
Qed.

(** ** 2. Définition par induction bien fondée **)
(************************************************)

(** L'approche précédente utilisait une spécification faible des fonctions manipulées. Dans cette
section, on va voir comment définir des fonctions récursives en incorporant leur bonne fondaison
dans leur type. On en profitera pour donner des spécifications fortes. *)
(** Le principal outil que l'on utilisera est la fonction [well_founded_induction]. *)

Require Import Wellfounded.

Check well_founded_induction.
(** Cette fonction prend 5 arguments et renvoie une fonction de type [∀ x:A, P x]. Décrivons ses
arguments:
  1. [A] (de type [Set]) est le domaine de la fonction que l'on est en train de définir
  2. [R:A->A->Prop] est une relation binaire sur [A]
  3. [well_founded A R] est une preuve que [R] est bien fondée
  4. [P:A->Set] est une fonction qui calcule le type de la fonction que l'on est en train de calculer      (elle associe à chaque input un type de retour dans [Set] qui contiendra sa spécification)
  5  [(∀ x:A, (∀ y:A, R y x -> P y) -> P x)] est une fonction qui prend en argument:
       (a) un argument [x:A],
       (b) une fonction qui en fonction d'un élement [y:A] et d'une preuve que [y] "est plus petit"
           que [x] renvoie le résultat attendu pour [x]
     et qui renvoie le résultat attendu pour [x]. On voit que cette fonction nous calcule le résultat
     pour [x] en fonction des résultats pour les [y] plus petits que [x]. En quelque sorte, son type
     la contraint à ne faire que des appels récursifs bien fondés vis à vis de [R].
Au final, [well_founded_induction] nous construit en sortie un terme de type [∀ x:A, P x] c'est à dire
une fonction qui à [x:A] nous donne un élément de [P x] vérifiant la spécfication.
 **)
(** Voyons comment utiliser cette fonction dans le cas d'une fonction calculant la division
    euclidienne.
1. nat
2. relation lt *)
Print lt.
(** 3. lt_wf (équivalent de lt_bienFonde prouvée dans la partie III) *)
Print lt_wf.
(** 4. définition suivante: *)
Definition div_type (m:nat) := forall n:nat, 0 < n -> {q:nat & {r:nat | m = q*n+r /\ r < n}}.
(** 5. La fonction doit avoir le type [∀ x:nat, (∀ y:nat, y < x → div_type y)→ div_type x]. Nous
allons la construire avec des tactiques. *)
Definition body_div :
  forall x:nat, (forall y:nat, y < x -> div_type y) -> div_type x.
  intros m rec.
  unfold div_type.
  intros n G.
  destruct (le_gt_dec n m).
  (** Question 5: Terminez la définition. *)
Qed.
(** Pour garder plus de contrôle sur la fonction que l'on est en train de définir, il est possible
    d'utiliser la tactique [refine <terme>] pour un terme contenant des [_]. La tactique va essayer
    de matcher le terme avec le type et décharger une partie des preuves qu'elle n'arrive pas
    à trouver. Exemple: *)
Definition Body_div' :
  forall x:nat, (forall y:nat, y < x -> div_type y) -> div_type x.
  unfold div_type at 2.
  (**
  refine (fun m div_rec n Hlt =>
            match le_gt_dec n m with
              | left H_n_le_m =>
                match div_rec (m-n) _ n _ with
                  (** Notez la présence des [_]: Coq vous demandera ensuite de donner des termes
                        pour remplir les trous ce qui correspond à prouver les spécifications des
                        arguments de [dic_rec]. *)
                  (** TODO **)
                  | right H_n_gt_m =>
                    (** TODO **)
                end).
   *)
  admit.
Defined.

(** On peut maintenant écrire notre fonction comme décrit plus haut: *)
Definition div :
  forall m n:nat, 0 < n -> {q:nat &{r:nat | m = q*n+r /\ r < n}} :=
  well_founded_induction lt_bienFonde div_type body_div.
Print div.
(** Aucun lemme de correction n'est nécessaire car [div] est fortement sépcifiée ;) *)

(** ** 3. PGCD *)
(***************)

(** *** Exercice 9: preuve de PGCD **)
(**************************************)
(** choisissez l'approche de votre choix pour écrire et prouver une fonction calculant le PGCD de deux entiers. *)


(** Boolean Unification

- Author: Dan Dougherty, WPI

- Based a treatment in Term Rewriting and All That, by Franz Baader
  and Tobias Nipkow

 *)

(**
Axiom comA : forall x y, A x y = A y x.
Axiom assocA : forall x y z,  A (A x y) z = A x (A y z).
Axiom invA : forall x, A x x = T0.
AxiomidA : forall x, A T0 x = x.

Axiom comM : forall x y, M x y = M y x.
Axiom assocM : forall x y z, M (M x y) z = M x (M y z).
Axiom o2M : forall x, M x x = x.
Axiom zeroM : forall x, M T0 x = T0.
Axiom idM : forall x, M T1 x = x.

Axiom dist : forall x y z, M x (A y z) = A (M x y) (M x z).

 *)

Require Export Omega.
Require Export List.
Export ListNotations.
(* for set_union *)
From Coq Require Export Lists.ListSet.
(* for composition *)
Require Export Basics.
Require Export Setoid.
Require Export Morphisms.
Require Export Relation_Definitions.

(* Require Import Utilities. *)

(** * Variables *)

Definition var := nat.
(* Implicit Types v w x y z : var. *)

(** ** Equality and order on vars *)

Definition eqb_var := Nat.eqb.
Definition ltb_var := Nat.ltb.

(** Equality between vars is decidable *)

(* @@ todo: understand why this works in (eg) vars_term, while
 (decidable_eq_nat) does not work
 *)

Definition var_dec (x y: var) : {x = y} + {x <> y}.
  decide equality.
Defined.

(** * Terms *)

Inductive term: Type :=
| T0  : term
| T1 : term
| V  : var -> term
| A : term -> term -> term
| M : term -> term -> term.

(** *** multiplication binds more tightly than addition *)

Notation "x +' y" := (A x y) (at level 50, left associativity).
Notation "x *' y" := (M x y) (at level 49, left associativity).

(*
(* Notation testing *)

Parameters t1 t2 : term.
Definition t3 := t1 +' t2 +' t1.
Definition t4 := (t1 +' t2) +' t1.
Definition t5 := t1 +' t2 *' t1.
Definition t6 := t1 +' (t2 *' t1).

Goal t3 = t4.
Proof.
  reflexivity.
Qed.
Goal t5 = t6.
Proof.
  reflexivity.
Qed.
 *)

(** *** a gotcha: *)
(** if f is a function on terms, beware of writing things like
    (f   s*t)
this will be interpreted as ((f s) * t)
*)

(** * Variables occurring  *)

(** Use this for now (allowing duplications) since it makes some
    things easier to prove.  Is there a reason to eliminate
    duplications?? *)

Fixpoint vars_term (t: term) : list var :=
  match t with
  | T0 => []
  | T1 => []
  | V x => [x]
  | A t1 t2 => (vars_term t1) ++ ( vars_term t2)
  | M t1 t2 => (vars_term t1) ++ ( vars_term t2)
  end.

Fixpoint ground_term (t: term) : bool :=
  match t with
  | T0 => true
  | T1 => true
  | (V _ ) => false
  | A t1 t2 => (ground_term t1) && (ground_term t2)
  | M t1 t2 => (ground_term t1) && (ground_term t2)
end.

Inductive Ground_term : term -> Prop :=
| G0 : Ground_term T0
| G1 : Ground_term T1
| GA : forall t1 t2, Ground_term t1 ->
                     Ground_term t2 ->
                     Ground_term (A t1 t2)
| GM : forall t1 t2, Ground_term t1 ->
                     Ground_term t2 ->
                     Ground_term (M t1 t2).

Lemma ground_no_vars (t: term) :
  Ground_term t -> vars_term t = [].
Proof.
  intros H.
  induction t as [ | | v | t1 t2| t1 t2].
  - reflexivity.
  - reflexivity.
  - inversion H.
  - inversion H.
    firstorder.
    simpl.
    rewrite H4; rewrite H5.
    reflexivity.
  - inversion H.
    firstorder.
    simpl.
    rewrite H4; rewrite H5.
    reflexivity.
Qed.

Lemma append_nil1 :
  forall (A: Type) (l1 l2: list A),
    l1 ++ l2 = [] -> l1 = [].
Proof.
  intros T l1 l2 H.
  destruct l1 as [|k].
  - reflexivity.
  - inversion H.
Qed.

Lemma append_nil2 :
  forall (A: Type) (l1 l2: list A),
    l1 ++ l2 = [] -> l2 = [].
Proof.
  intros T l1 l2 H.
  - destruct l2 as [|k].
    + reflexivity.
    + assert (a: l1 = []).
      apply append_nil1 in H; easy.
      rewrite a in H.
      inversion H.
Qed.

Lemma append_nil:
  forall (A: Type) (l1 l2: list A),
    l1 ++ l2 = [] ->
    l1 = [] /\ l2 = [].
Proof.
  intros T l1 l2 H.
  split.
  apply append_nil1 with (l2 := l2); easy.
  apply append_nil2 with (l1 := l1); easy.
Qed.

Lemma no_vars_ground (t: term) :
  vars_term t = [] -> Ground_term t.
Proof.
  intros H.
  induction t as [ | | v | t1 t2| t1 t2].
  - apply G0.
  - apply G1.
  - inversion H.
  - simpl in H.
    apply append_nil in H.
    destruct  H.
    firstorder.
    apply GA; easy.
  - simpl in H.
    apply append_nil in H.
    destruct  H.
    firstorder.
    apply GM; easy.
Qed.

    (** * Axioms *)

(* @@ Has to be Parameter rather than Variable, else it is not visible
in other files *)

Parameter eqv : term -> term -> Prop.
Infix " == " := eqv (at level 70).

Axiom comA :
  forall x y, x +' y == y +' x.
Axiom assocA :
  forall x y z,  (x +' y) +' z == x +' (y +' z).
Axiom invA :
  forall x, x +' x == T0 .
Axiom idA :
  forall x, T0 +' x == x.
Axiom dist :
  forall x y z, x *'  (y +' z) == (x *' y) +' (x *' z).
Axiom comM :
  forall x y, x *' y ==  y *' x.
Axiom assocM :
  forall x y z, (x *' y) *' z == x *' (y *' z).
Axiom o2M :
  forall x, x *' x == x.
Axiom T0M :
  forall x, T0 *' x == T0.
Axiom idM :
  forall x, T1 *' x == x.

Hint Resolve comA assocA invA idA dist comM assocM o2M T0M idM.

(** * Make == suitable for setoid rewriting *)

(** ** == is an equivalence relation *)

Axiom eqv_ref : Reflexive eqv.
Axiom eqv_sym : Symmetric eqv.
Axiom eqv_trans : Transitive eqv.

Add Parametric Relation : term eqv
    reflexivity proved by @eqv_ref
    symmetry proved by @eqv_sym
    transitivity proved by @eqv_trans
      as eq_set_rel.

Axiom A_compat :
    forall x x' , eqv x x' ->
    forall y y' , eqv y y' ->
      eqv (A x y) (A x' y').

Axiom M_compat :
    forall x x' , eqv x x' ->
    forall y y' , eqv y y' ->
      eqv (M x y) (M x' y').

(** ** == is a congruence wrt addition and multiplication *)

Add Parametric Morphism : A with
  signature eqv ==> eqv ==> eqv as A_mor.
exact A_compat.
Qed.

Add Parametric Morphism : M with
  signature eqv ==> eqv ==> eqv as M_mor.
exact M_compat.
Qed.

Hint Resolve eqv_ref eqv_sym eqv_trans A_compat M_compat.

(** * Useful Little Results *)

(** *** Identities and absorption apply on either side *)

Lemma idA' (x: term) :
 x +' T0 ==  x .
Proof.
  rewrite comA; easy.
Qed.

Lemma absorbM' (x: term) :
  x *' T0 == T0.
Proof.
  rewrite comM; easy.
Qed.

Lemma idM' (x: term) :
  x *' T1 == x .
Proof.
  rewrite comM; easy.
Qed.

(** *** Everything is a 0-divisor *)

Lemma T0_div :
  forall x, x *' (x +' T1) == T0.
Proof.
  intros; rewrite dist; rewrite o2M.
  rewrite comM; rewrite idM; rewrite invA; easy.
Qed.

(** *** Additive inverses are unique *)

Lemma inv_uniqueA :
  forall x y, x +' y == T0 -> x == y.
Proof.
  intros.
  assert (x +' y +' y == T0 +' y).
  -   now rewrite H.
  - rewrite idA in H0.
    rewrite assocA in H0.
    rewrite invA in H0.
    now rewrite idA' in H0.
Qed.

(** *** Additive cancellation on the left and the right *)

Lemma cancelA :
  forall x y z,  x +' z ==  y +' z -> x == y.
Proof.
  intros x y z H.
  cut ((x +' z) +' z ==  (y +' z) +' z).
  - intros H0. repeat rewrite assocA in H0.
    repeat rewrite invA in H0.
    repeat rewrite idA' in H0; easy.
  - rewrite H; easy.
Qed.

Lemma cancelA' :
  forall x y z, z +' x ==  y +' z -> x == y.
Proof.
  intros x y z H.
  rewrite comA in H.
  apply cancelA with (z := z); easy.
Qed.

Hint Resolve idA' absorbM' idM' T0_div inv_uniqueA inv_uniqueA cancelA cancelA'.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (y : natural) : natural := mult Zero Zero.


From Coq Require Import Classical.
From Coq Require Export Ensembles.
From ZornsLemma Require Import EnsemblesImplicit.
From Coq Require Export Relation_Definitions.
From ZornsLemma Require Import Relation_Definitions_Implicit.
From ZornsLemma Require Import EnsemblesSpec.

Section MinimalElements.

Variable T:Type.
Variable R:relation T.

(* R is well-founded if and only if every nonempty subset of
   T has a minimal element *)

Definition minimal_element_property : Prop :=
  forall S:Ensemble T, Inhabited S -> exists x:T, In S x /\
    forall y:T, In S y -> ~ R y x.

Lemma WF_implies_MEP: well_founded R -> minimal_element_property.
Proof.
unfold well_founded.
unfold minimal_element_property.
intros WF S Hinh.
destruct Hinh.
revert x H.
apply (@well_founded_ind T R WF
 (fun x:T =>
  In S x -> exists y:T, In S y /\ (forall z:T, In S z -> ~ R z y))).
intros.
case (classic (forall y:T, In S y -> ~ R y x)).
- exists x.
  split.
  + assumption.
  + assumption.
- intro.
  apply not_all_ex_not in H1.
  destruct H1.
  apply imply_to_and in H1.
  destruct H1.
  apply H with x0.
  + apply NNPP.
    assumption.
  + assumption.
Qed.

(* Prop. 2.1 from n-lab page "well-founded relation" 2021-11-21
   This is why the [minimal_element_property] is way too strong for
   constructive reasoning.
   This proof can even be performed in a topos. See the n-lab for this. *)
Lemma MEP_inh_impl_LEM :
  minimal_element_property ->
  (exists x y, R y x) ->
  (forall P : Prop, P \/ ~ P).
Proof.
  intros ? ? Q.
  destruct H0 as [x [y Hxy]].
  pose (P := Union (Singleton x) (fun a => R y x /\ Q)).
  specialize (H P).
  destruct H as [x0].
  { exists x. left. constructor. }
  destruct H.
  destruct H.
  2: {
    left.
    apply H.
  }
  inversion H; subst; clear H.
  right.
  intros ?.
  unshelve eapply (H0 _ _ Hxy).
  right. split; assumption.
Qed.

(* This fact holds constructively. *)
Lemma MEP_implies_WF: minimal_element_property -> well_founded R.
Proof.
intros MEP. red. intros.
constructor. intros.
unshelve epose proof (MEP_inh_impl_LEM MEP _) as LEM.
{ eauto. }
destruct (LEM (Acc R y)) as [|]; try assumption.
exfalso.
assert (Inhabited [x:T | ~ Acc R x]) as HInh.
{ exists y.
  constructor; assumption.
}
apply MEP in HInh as [? [[?] ?]].
contradict H1.
constructor.
intros.
destruct (LEM (Acc R y0)) as [|]; try assumption.
exfalso.
apply H2 with y0.
- constructor; assumption.
- assumption.
Qed.

End MinimalElements.

Require Import ClassicalChoice.

Section DecreasingSequences.

(* R is well-founded if and only if there is no infinite strictly
   decreasing sequence of elements of T *)

Variable T:Type.
Variable R:relation T.

Definition decreasing_sequence_property :=
  forall a:nat->T, exists n:nat, ~ R (a (S n)) (a n).

Lemma WF_implies_DSP: well_founded R -> decreasing_sequence_property.
Proof.
unfold decreasing_sequence_property.
intros WF a.
remember (a 0) as a0.
revert a0 a Heqa0.
apply (well_founded_ind WF (fun x:T =>
  forall a:nat->T, x = a 0 -> exists n:nat, ~ R (a (S n)) (a n))).
intros.
case (classic (R (a 1) (a 0))).
- intro.
  pose (b := fun n:nat => a (S n)).
  assert (exists n:nat, ~ R (b (S n)) (b n)).
  { apply H with (a 1).
    - rewrite H0.
      assumption.
    - trivial.
  }
  destruct H2.
  exists (S x0).
  unfold b in H2.
  assumption.
- exists 0.
  assumption.
Qed.

Lemma DSP_implies_WF: decreasing_sequence_property -> well_founded R.
Proof.
unfold decreasing_sequence_property.
intro DSP.
apply MEP_implies_WF.
unfold minimal_element_property.
intro S0.
intros.
apply NNPP.
intuition.
assert (forall x:T, In S0 x -> exists y:T, In S0 y /\ R y x).
{ intros.
  apply NNPP.
  intuition.
  assert (forall y:T, ~(In S0 y /\ R y x)).
  { apply not_ex_all_not. assumption. }
  apply H0.
  exists x.
  split.
  - assumption.
  - intros.
    apply H3 with y.
    tauto.
}
pose (S_type := {x:T | In S0 x}).
assert (exists f:S_type -> S_type, forall x:S_type,
  R (proj1_sig (f x)) (proj1_sig x)).
{ apply choice with (R:=fun x y:S_type => R (proj1_sig y) (proj1_sig x)).
  intro.
  destruct x.
  simpl.
  pose proof (H1 x i).
  destruct H2 as [? [? ?]].
  exists (exist (fun x:T => In S0 x) x0 H2).
  simpl. assumption.
}
destruct H2 as [f Hf].
destruct H.
pose (b := nat_rect (fun n:nat => S_type)
  (exist (fun x:T => In S0 x) x H)
  (fun (n:nat) (x:S_type) => f x)).
simpl in b.
pose (a := fun n:nat => (proj1_sig (b n))).
assert (forall n:nat, R (a (S n)) (a n)).
{ unfold a.
  intro.
  simpl.
  apply Hf.
}
contradict DSP.
apply ex_not_not_all.
exists a.
apply all_not_not_ex.
auto.
Qed.

End DecreasingSequences.