Require Import Morphisms.
Require Import Equivalence.
Require Import Program.Basics.
Require Import Lra Lia.
Require Import Classical.
Require Import FunctionalExtensionality.
Require Import IndefiniteDescription ClassicalDescription.

Require Import hilbert.

Require Export RandomVariableLpR.
Require Import quotient_space.
Require Import RbarExpectation.

Require Import Event.
Require Import Almost.
Require Import utils.Utils.
Require Import List.

Set Bullet Behavior "Strict Subproofs".

Section L2.
  Context {Ts:Type}
          {dom: SigmaAlgebra Ts}
          (prts: ProbSpace dom).

  Lemma big2 : 1 <= 2.
  Proof.
    lra.
  Qed.
  Let nneg2 : nonnegreal := bignneg 2 big2.
  Canonical nneg2.

  Global Instance IsL2_Finite (rv_X:Ts->R)
        {rrv:RandomVariable dom borel_sa rv_X}
        {lp:IsLp prts 2 rv_X} : IsFiniteExpectation prts rv_X.
  Proof.
    apply IsLp_Finite in lp; trivial.
    apply big2.
  Qed.

  Lemma isfe_sqr_islp2 (f : Ts -> R) :
    IsFiniteExpectation prts (rvsqr f) ->
    IsLp prts 2 f.
  Proof.
    intros.
    unfold IsLp.
    apply IsFiniteExpectation_proper with (x := rvsqr f); trivial.
    intro x.
    rewrite rvpower2.
    - unfold rvsqr, rvabs.
      now rewrite <- Rsqr_abs.
    - apply nnfabs.
  Qed.

  Global Instance is_L2_mult_finite x y
        {xrv:RandomVariable dom borel_sa x}
        {yrv:RandomVariable dom borel_sa y} :
    IsLp prts 2 x -> IsLp prts 2 y ->
    IsFiniteExpectation prts (rvmult x y).
  Proof.
    intros HH1 HH2.
    unfold IsLp, IsFiniteExpectation in *.
    match_case_in HH1
    ; [intros ? eqq1 | intros eqq1]
    ; rewrite eqq1 in HH1
    ; try contradiction.
    match_destr_in HH1; try contradiction.
    match_case_in HH2
    ; [intros ? eqq2 | intros eqq2]
    ; rewrite eqq2 in HH2
    ; try contradiction.
    match_destr_in HH2; try contradiction.
    apply Expectation_abs_then_finite.
    - generalize (rvprod_abs_bound x y)
      ; intros xyle.

      rewrite (Expectation_pos_pofrf _).
      generalize (Finite_NonnegExpectation_le (rvabs (rvmult x y))
                                              (rvplus (rvsqr x) (rvsqr y))
                                              _
                                              _
                 )
      ; intros HH.
      rewrite <- HH; trivial.
      + etransitivity; try eapply xyle.
        intros a.
        unfold rvscale, rvabs, rvmult.
        assert (0 <= Rabs (x a * y a))
          by apply Rabs_pos.
        lra.
      + generalize (NonnegExpectation_sum (rvsqr x) (rvsqr y))
        ; intros HH3.
        erewrite NonnegExpectation_pf_irrel in HH3.
        rewrite HH3.

        rewrite rvpower_abs2_unfold in eqq1, eqq2.

        rewrite (Expectation_pos_pofrf _) in eqq1.
        rewrite (Expectation_pos_pofrf _) in eqq2.
        invcs eqq1.
        invcs eqq2.
        rewrite H0, H1.
        reflexivity.
  Qed.

  Lemma isfe_l2_prod (f g : Ts -> R)
           (rv1 : RandomVariable dom borel_sa f)
           (rv2 : RandomVariable dom borel_sa g)  :
    IsFiniteExpectation prts (rvsqr f) ->
    IsFiniteExpectation prts (rvsqr g) ->
    IsFiniteExpectation prts (rvmult f g).
  Proof.
    intros.
    apply is_L2_mult_finite; trivial; now apply isfe_sqr_islp2.
  Qed.

  Lemma variance_l2 (f : Ts -> R)
        (rv : RandomVariable dom borel_sa f)
        {isl2: IsLp prts 2 f} :
    FiniteExpectation prts (rvsqr (rvminus f (const (FiniteExpectation prts f)))) =
    FiniteExpectation prts (rvsqr f) - Rsqr (FiniteExpectation prts f).
  Proof.
    assert (rv_eq (rvsqr (rvminus f (const (FiniteExpectation prts f))))
                  (rvplus (rvplus (rvsqr f)
                                   (rvscale (- 2 * FiniteExpectation prts f)
                                            f))
                          (const (Rsqr (FiniteExpectation prts f))))).
    {
      intro x.
      rv_unfold.
      unfold Rsqr.
      ring.
    }
    rewrite (FiniteExpectation_ext prts _ _ H).
    do 2 rewrite FiniteExpectation_plus.
    rewrite FiniteExpectation_scale.
    rewrite FiniteExpectation_const.
    unfold Rsqr.
    ring.
  Qed.

  Lemma variance_bound (x : Ts -> R) (c : R)
        {rv : RandomVariable dom borel_sa x}
        {isl2 : IsLp prts 2 x} :
    rv_le (rvsqr x) (const c²) ->
    FiniteExpectation prts (rvsqr (rvminus x (const (FiniteExpectation prts x)))) <=  c².
  Proof.
    intros.
    rewrite variance_l2.
    apply Rle_trans with (r2 := FiniteExpectation prts (rvsqr x)).
    - assert (0 <= (FiniteExpectation prts x)²).
      {
        apply Rle_0_sqr.
      }
      lra.
    - replace (c²) with (FiniteExpectation prts (const c²)).
      + now apply FiniteExpectation_le.
      + apply FiniteExpectation_const.
   Qed.

  Lemma isfe_sqr_seq (X : nat -> Ts -> R)
           (rv : forall n, RandomVariable dom borel_sa (X n)) :
    (forall n, IsFiniteExpectation prts (rvsqr (X n))) ->
    forall j k, IsFiniteExpectation prts (rvmult (X j) (X k)).
  Proof.
    intros.
    now apply isfe_l2_prod.
  Qed.

  Lemma IsFiniteExpectation_rvsqr_lower f
           {rv: RandomVariable dom borel_sa f}
           {isfe2 : IsFiniteExpectation prts (rvsqr f)} :
    IsFiniteExpectation prts f.
  Proof.
    apply IsL2_Finite; trivial.
    now apply isfe_sqr_islp2.
  Qed.

  Definition L2RRVinner (x y:LpRRV prts 2) : R
    := FiniteExpectation prts (rvmult x y).

  Global Instance L2RRV_inner_proper : Proper (LpRRV_eq prts ==> LpRRV_eq prts ==> eq) L2RRVinner.
  Proof.
    unfold Proper, respectful, LpRRV_eq.

    intros x1 x2 eqq1 y1 y2 eqq2.
    unfold L2RRVinner.
    assert (eqq:almostR2 prts eq (rvmult x1 y1) (rvmult x2 y2)).
    - LpRRV_simpl.
      now apply almostR2_eq_mult_proper.
    - eapply FiniteExpectation_proper_almostR2; try eapply eqq
      ; try typeclasses eauto.
  Qed.

  Lemma L2RRV_inner_comm (x y : LpRRV prts 2) :
    L2RRVinner x y = L2RRVinner y x.
  Proof.
    unfold L2RRVinner.
    apply FiniteExpectation_ext.
    apply rvmult_comm.
  Qed.

  Lemma L2RRV_inner_pos (x : LpRRV prts 2) : 0 <= L2RRVinner x x.
  Proof.
    unfold L2RRVinner.
    apply FiniteExpectation_pos.
    typeclasses eauto.
  Qed.

  Lemma L2RRV_inner_zero_inv (x:LpRRV prts 2) : L2RRVinner x x = 0 ->
                                         LpRRV_eq prts x (LpRRVconst prts 0).
  Proof.
    unfold L2RRVinner, LpRRV_eq; intros.
    eapply FiniteExpectation_zero_pos in H; try typeclasses eauto.
    destruct H as  [P [Pall eq_on]].
    exists P.
    split; trivial.
    intros a Pa.
    specialize (eq_on a Pa).
    unfold LpRRVconst, const, rvmult; simpl in *.
    now apply Rsqr_0_uniq in eq_on.
  Qed.

  Lemma L2RRV_inner_scal (x y : LpRRV prts 2) (l : R) :
    L2RRVinner (LpRRVscale prts l x) y = l * L2RRVinner x y.
  Proof.
    unfold L2RRVinner, LpRRVscale; simpl.
    rewrite (FiniteExpectation_ext _ _ (rvscale l (rvmult x y))).
    - destruct (Req_EM_T l 0).
      + subst.
        erewrite (FiniteExpectation_ext _ _ (const 0)).
        * rewrite FiniteExpectation_const; lra.
        * intro x0.
          unfold rvscale, rvmult, const; lra.
      + now rewrite (FiniteExpectation_scale _ l (rvmult x y)).
    - intro x0.
      unfold rvmult, rvscale.
      lra.
  Qed.

  Global Instance L2Expectation_l1_prod (rv_X1 rv_X2:Ts->R)
        {rv1 : RandomVariable dom borel_sa rv_X1}
        {rv2 : RandomVariable dom borel_sa rv_X2}
        {l21:IsLp prts 2 rv_X1}
        {l22:IsLp prts 2 rv_X2}
    :  IsFiniteExpectation prts (rvabs (rvmult rv_X1 rv_X2)).

  Proof.
    assert (NonnegativeFunction (rvabs (rvmult rv_X1 rv_X2))) by apply nnfabs.
    generalize (Expectation_pos_pofrf (rvabs (rvmult rv_X1 rv_X2))); intros.
    generalize (rvprod_abs1_bound rv_X1 rv_X2); intros.
    assert (NonnegativeFunction (rvplus (rvsqr rv_X1) (rvsqr rv_X2)))
      by (apply rvplus_nnf; apply nnfsqr).
    generalize (Finite_NonnegExpectation_le _ _ H H2 H1); intros.
    unfold IsLp, IsFiniteExpectation in *.
    rewrite (Expectation_pos_pofrf _) in l21.
    rewrite (Expectation_pos_pofrf _)  in l22.
    match_case_in l21
    ; [intros ? eqq1 | intros eqq1..]
    ; rewrite eqq1 in l21
    ; try contradiction.
    match_case_in l22
    ; [intros ? eqq2 | intros eqq2..]
    ; rewrite eqq2 in l22
    ; try contradiction.
    assert (NonnegativeFunction (rvsqr rv_X1)) by apply nnfsqr.
    assert (NonnegativeFunction (rvsqr rv_X2)) by apply nnfsqr.
    generalize (NonnegExpectation_sum (rvsqr rv_X1) (rvsqr rv_X2)); intros.
    cut_to H3.
    - rewrite Expectation_pos_pofrf with (nnf := H).
      now rewrite <- H3.
    - erewrite NonnegExpectation_pf_irrel in H6.
      rewrite H6.
      rewrite (NonnegExpectation_ext _ _ (rvpower_abs2_unfold _)) in eqq1.
      rewrite (NonnegExpectation_ext _ _  (rvpower_abs2_unfold _)) in eqq2.
      erewrite NonnegExpectation_pf_irrel in eqq1.
      rewrite eqq1.
      erewrite NonnegExpectation_pf_irrel in eqq2.
      rewrite eqq2.
      simpl.
      now unfold is_finite.
  Qed.

  Lemma conv_l2_prob_le_div
        (eps : posreal)
        (X : Ts -> R)
        (rv : RandomVariable dom borel_sa X)
        (pofrf: NonnegativeFunction X) :
  Rbar_le (ps_P (event_ge dom X eps))
          (Rbar_div (NonnegExpectation (rvsqr X))
                    (Rsqr eps)).
    Proof.
      assert (event_equiv (event_ge dom X eps)
                          (event_ge dom (rvsqr X) (Rsqr eps))).
      - intro x.
        split; intros.
        + apply Rge_le in H.
          apply Rle_ge.
          apply Rsqr_incr_1; trivial.
          left; apply cond_pos.
        + apply Rge_le in H.
          apply Rle_ge.
          apply Rsqr_incr_0; trivial.
          left; apply cond_pos.
      - rewrite H.
        rewrite mkpos_Rsqr.
        rewrite Rbar_div_div_pos.
        apply Markov_ineq_div.
    Qed.

  Lemma conv_l2_prob_le1
        (eps : posreal)
        (Xn: Ts -> R)
        (rvxn : RandomVariable dom borel_sa Xn) :
    is_finite (NonnegExpectation (rvsqr (rvabs Xn))) ->
    ps_P (event_ge dom (rvabs Xn) eps) <=
    (NonnegExpectation (rvsqr (rvabs Xn))) / (Rsqr eps).
    Proof.
      assert (RandomVariable dom borel_sa (rvabs Xn)).
      - now apply rvabs_rv.
      - assert (NonnegativeFunction (rvabs Xn)).
        now apply nnfabs.
        intros.
        generalize (conv_l2_prob_le_div eps (rvabs Xn) H H0).
        rewrite <- H1.
        simpl.
        intros.
        erewrite ps_proper; try eapply H2.
        intros ?; simpl.
        reflexivity.
    Qed.

  Lemma conv_l2_prob_le
        (eps : posreal)
        (X Xn: Ts -> R)
        (rvx : RandomVariable dom borel_sa X)
        (rvxn : RandomVariable dom borel_sa Xn) :
    is_finite (NonnegExpectation (rvsqr (rvabs (rvminus X Xn)))) ->
    ps_P (event_ge dom (rvabs (rvminus X Xn)) eps) <=
    (NonnegExpectation (rvsqr (rvabs (rvminus X Xn)))) / (Rsqr eps).
    Proof.
      intros.
      apply conv_l2_prob_le1; trivial.
    Qed.

  Lemma conv_l1_prob_le
        (eps : posreal)
        (X: Ts -> R)
        {rvx : RandomVariable dom borel_sa X}:
    is_finite (NonnegExpectation (rvabs X)) ->
    ps_P (event_ge dom (rvabs X) eps) <=
    (NonnegExpectation (rvabs X)) / eps.
    Proof.
      assert (RandomVariable dom borel_sa (rvabs X)).
      - now apply rvabs_rv.
      - assert (NonnegativeFunction (rvabs X)).
        now apply nnfabs.
        intros.
        generalize (Markov_ineq_div (rvabs X) H H0 eps); intros.
        rewrite <- H1 in H2.
        intros.
        erewrite ps_proper; try eapply H2.
        intros ?; simpl.
        reflexivity.
    Qed.

  Lemma conv_l1_prob_le_minus
        (eps : posreal)
        (X Xn: Ts -> R)
        {rvx : RandomVariable dom borel_sa X}
        {rvxn : RandomVariable dom borel_sa Xn} :
    is_finite (NonnegExpectation (rvabs (rvminus X Xn))) ->
    ps_P (event_ge dom (rvabs (rvminus X Xn)) eps) <=
    (NonnegExpectation (rvabs (rvminus X Xn))) / eps.
    Proof.
      apply conv_l1_prob_le.
    Qed.

  Lemma conv_l2_prob1
        (eps : posreal)
        (Xn: nat -> Ts -> R)
        (rvxn : forall n, RandomVariable dom borel_sa (Xn n)) :
    (forall n, is_finite (NonnegExpectation (rvsqr (rvabs (Xn n))))) ->
    is_lim_seq (fun n => NonnegExpectation (rvsqr (rvabs (Xn n)))) 0 ->
    is_lim_seq (fun n => ps_P (event_ge dom (rvabs (Xn n)) eps)) 0.
  Proof.
    intros.
    apply is_lim_seq_le_le_loc with (u := fun _ => 0)
                                    (w := (fun n => (NonnegExpectation (rvsqr (rvabs (Xn n)))) / (Rsqr eps))).
    - unfold eventually.
      exists (0%nat).
      intros.
      split.
      + apply ps_pos.
      + apply conv_l2_prob_le1; trivial.
    - apply is_lim_seq_const.
    - apply is_lim_seq_div with (l1 := 0) (l2 := Rsqr eps); trivial.
      + apply is_lim_seq_const.
      + apply Rbar_finite_neq.
        apply Rgt_not_eq.
        apply Rsqr_pos.
      + unfold is_Rbar_div.
        simpl.
        unfold is_Rbar_mult, Rbar_mult'.
        f_equal.
        now rewrite Rmult_0_l.
  Qed.

  Lemma conv_l2_prob
        (eps : posreal)
        (X: Ts -> R)
        (Xn: nat -> Ts -> R)
        (rvx : RandomVariable dom borel_sa X)
        (rvxn : forall n, RandomVariable dom borel_sa (Xn n)) :
    (forall n, is_finite (NonnegExpectation (rvsqr (rvabs (rvminus X (Xn n)))))) ->
    is_lim_seq (fun n => NonnegExpectation (rvsqr (rvabs (rvminus X (Xn n))))) 0 ->
    is_lim_seq (fun n => ps_P (event_ge dom (rvabs (rvminus X (Xn n))) eps)) 0.
  Proof.
    intros.
    apply conv_l2_prob1; trivial.
  Qed.

    Lemma conv_l1_prob
        (eps : posreal)
        (X: Ts -> R)
        (Xn: nat -> Ts -> R)
        (rvx : RandomVariable dom borel_sa X)
        (rvxn : forall n, RandomVariable dom borel_sa (Xn n)) :
    (forall n, is_finite (NonnegExpectation (rvabs (rvminus X (Xn n))))) ->
    is_lim_seq (fun n => NonnegExpectation (rvabs (rvminus X (Xn n)))) 0 ->
    is_lim_seq (fun n => ps_P (event_ge dom (rvabs (rvminus X (Xn n))) eps)) 0.
  Proof.
    intros.
    apply is_lim_seq_le_le_loc with (u := fun _ => 0)
                                    (w := (fun n => (NonnegExpectation (rvabs (rvminus X (Xn n)))) / eps)).
    - unfold eventually.
      exists (0%nat).
      intros.
      split.
      + apply ps_pos.
      + apply conv_l1_prob_le; trivial.
    - apply is_lim_seq_const.
    - apply is_lim_seq_div with (l1 := 0) (l2 := eps); trivial.
      + apply is_lim_seq_const.
      + apply Rbar_finite_neq.
        apply Rgt_not_eq.
        apply cond_pos.
      + unfold is_Rbar_div.
        simpl.
        unfold is_Rbar_mult, Rbar_mult'.
        f_equal.
        now rewrite Rmult_0_l.
  Qed.

  Lemma L2RRV_inner_plus (x y z : LpRRV prts 2) :
    L2RRVinner (LpRRVplus prts x y) z = L2RRVinner x z + L2RRVinner y z.
  Proof.
    unfold L2RRVinner, LpRRVplus; simpl.
    erewrite (FiniteExpectation_ext _ _ (rvplus (rvmult x z) (rvmult y z))).
    - erewrite <- FiniteExpectation_plus.
      apply FiniteExpectation_pf_irrel.
    - intro x0.
      unfold rvmult, rvplus.
      lra.
  Qed.

  (* get abs version by saying (x : L2RRV) <-> (abs x : L2RRV) *)

  Lemma L2RRV_inner_plus_r (x y z : LpRRV prts 2) :
    L2RRVinner x (LpRRVplus prts y z) = L2RRVinner x y  + L2RRVinner x z.
  Proof.
    do 3 rewrite L2RRV_inner_comm with (x := x).
    now rewrite L2RRV_inner_plus.
  Qed.

  Lemma L2RRV_inner_scal_r (x y : LpRRV prts 2) (l : R) :
    L2RRVinner x (LpRRVscale prts l y) = l * L2RRVinner x y.
  Proof.
    do 2 rewrite L2RRV_inner_comm with (x := x).
    now rewrite L2RRV_inner_scal.
  Qed.

  Lemma L2RRV_Cauchy_Schwarz (x1 x2 : LpRRV prts 2) :
    0 < L2RRVinner x2 x2 ->
    Rsqr (L2RRVinner x1 x2) <= (L2RRVinner x1 x1)*(L2RRVinner x2 x2).
  Proof.
    generalize (L2RRV_inner_pos
                  (LpRRVminus prts
                     (LpRRVscale prts (L2RRVinner x2 x2) x1)
                     (LpRRVscale prts (L2RRVinner x1 x2) x2))); intros.
    rewrite LpRRVminus_plus, LpRRVopp_scale in H.
    repeat (try rewrite L2RRV_inner_plus in H; try rewrite L2RRV_inner_plus_r in H;
            try rewrite L2RRV_inner_scal in H; try rewrite L2RRV_inner_scal_r in H).
    ring_simplify in H.
    unfold pow in H.
    do 3 rewrite Rmult_assoc in H.
    rewrite <- Rmult_minus_distr_l in H.
    replace (0) with (L2RRVinner x2 x2 * 0) in H by lra.
    apply Rmult_le_reg_l with (r := L2RRVinner x2 x2) in H; trivial.
    rewrite L2RRV_inner_comm with (x := x2) (y := x1) in H.
    unfold Rsqr; lra.
  Qed.

  Ltac L2RRV_simpl
    := repeat match goal with
              | [H : LpRRV _ _ |- _ ] => destruct H as [???]
              end
       ; unfold LpRRVplus, LpRRVminus, LpRRVopp, LpRRVscale
       ; simpl.

   Lemma L2RRV_L2_L1
         (x : LpRRV prts 2) :
    Rsqr (FiniteExpectation prts x) <= FiniteExpectation prts (rvsqr x).
   Proof.
     generalize (L2RRV_Cauchy_Schwarz x (LpRRVconst prts 1)); intros.
     assert (L2RRVinner (LpRRVconst prts 1) (LpRRVconst prts 1) = 1).
     unfold L2RRVinner.
     L2RRV_simpl.
     unfold rvmult.
     rewrite (FiniteExpectation_ext prts _ (const 1)).
     - apply FiniteExpectation_const.
     - intro x0.
       unfold const; lra.
     - rewrite H0 in H.
       rewrite Rmult_1_r in H.
       assert (L2RRVinner x (LpRRVconst prts 1) = FiniteExpectation prts x).
       + unfold L2RRVinner.
         rewrite (FiniteExpectation_ext _ _  x); trivial.
         intro x0.
         L2RRV_simpl.
         unfold rvmult, const.
         lra.
       + rewrite H1 in H.
         unfold L2RRVinner in H.
         rewrite (FiniteExpectation_ext _ _ _ (symmetry (rvsqr_eq _))) in H.
         apply H; lra.
  Qed.

     Lemma conv_l2_l1
        (Xn: nat -> Ts -> R)
        (rvxn : forall n, RandomVariable dom borel_sa (Xn n))
        (isl: forall n, IsLp prts 2 (Xn n)):
    is_lim_seq (fun n => FiniteExpectation prts (rvsqr (rvabs (Xn n)))) 0 ->
    is_lim_seq (fun n => FiniteExpectation prts (rvabs (Xn n))) 0.
    Proof.
      intros.
      assert (forall n, 0 <= FiniteExpectation prts (rvsqr (rvabs (Xn n)))).
      - intros.
        apply FiniteExpectation_pos.
        unfold NonnegativeFunction, rvabs, rvsqr; intros.
        apply Rle_0_sqr.
      - apply is_lim_seq_le_le_loc with
            (u := fun _ => 0)
            (w := (fun n => Rsqrt (mknonnegreal (FiniteExpectation prts (rvsqr (rvabs (Xn n)))) (H0 n)))).
        + exists (0%nat); intros.
          assert (0 <= FiniteExpectation prts (rvabs (Xn n))).
          * apply FiniteExpectation_pos.
            unfold rvabs, NonnegativeFunction; intros.
            apply Rabs_pos.
          * split; trivial.
            generalize (L2RRV_L2_L1 (pack_LpRRV prts (rvabs (Xn n))));intros.
            generalize Rsqr_le_to_Rsqrt; intros.
            specialize (H4 (mknonnegreal _ (H0 n))
                           (mknonnegreal _ H2)).
            apply H4; simpl.
            apply H3.
        + apply is_lim_seq_const.
        + apply is_lim_seq_ext with
          (u := fun n=> Rsqrt_abs (FiniteExpectation prts (rvsqr (rvabs (Xn n))))).
          * intros.
            unfold Rsqrt_abs; f_equal.
            apply nonneg_ext. (* CAUTION : This uses proof irrelevance. *)
            now rewrite Rabs_pos_eq.
          * replace (0) with (Rsqrt_abs 0) by apply Rsqrt_abs_0.
            apply is_lim_seq_continuous; [|trivial].
            apply continuity_pt_Rsqrt_abs_0.
    Qed.

    Lemma conv_l2_l1_minus
        (X: Ts -> R)
        (Xn: nat -> Ts -> R)
        (rvx : RandomVariable dom borel_sa X)
        (rvxn : forall n, RandomVariable dom borel_sa (Xn n))
        (isl: forall n, IsLp prts 2 (rvminus X (Xn n))) :
    is_lim_seq (fun n => FiniteExpectation prts (rvsqr (rvabs (rvminus X (Xn n))))) 0 ->
    is_lim_seq (fun n => FiniteExpectation prts (rvabs (rvminus X (Xn n)))) 0.
    Proof.
      now apply conv_l2_l1.
    Qed.

  Definition L2RRVq_inner : LpRRVq prts 2 -> LpRRVq prts 2 -> R
    := quot_lift2_to _ L2RRVinner.

  Lemma L2RRVq_innerE x y : L2RRVq_inner (Quot _ x) (Quot _ y) = (L2RRVinner x y).
  Proof.
    apply quot_lift2_toE.
  Qed.

  Hint Rewrite L2RRVq_innerE : quot.

  Lemma L2RRVq_inner_comm (x y : LpRRVq_ModuleSpace prts nneg2) :
    L2RRVq_inner x y = L2RRVq_inner y x.
  Proof.
    LpRRVq_simpl.
    apply L2RRV_inner_comm.
  Qed.

  Lemma L2RRVq_inner_pos (x : LpRRVq_ModuleSpace prts nneg2) : 0 <= L2RRVq_inner x x.
  Proof.
    LpRRVq_simpl.
    apply L2RRV_inner_pos.
  Qed.

  Lemma L2RRVq_inner_zero_inv (x:LpRRVq_ModuleSpace prts nneg2) : L2RRVq_inner x x = 0 ->
                                                       x = zero.
  Proof.
    unfold zero; simpl.
    LpRRVq_simpl; intros; LpRRVq_simpl.
    now apply L2RRV_inner_zero_inv.
  Qed.

  Lemma L2RRVq_inner_scal (x y : LpRRVq_ModuleSpace prts nneg2) (l : R) :
    L2RRVq_inner (scal l x) y = l * L2RRVq_inner x y.
  Proof.
    unfold scal; simpl.
    LpRRVq_simpl.
    apply L2RRV_inner_scal.
  Qed.

  Lemma L2RRVq_inner_plus (x y z : LpRRVq_ModuleSpace prts nneg2) :
    L2RRVq_inner (plus x y) z = L2RRVq_inner x z + L2RRVq_inner y z.
  Proof.
    unfold plus; simpl.
    LpRRVq_simpl.
    apply L2RRV_inner_plus.
  Qed.

  Definition L2RRVq_PreHilbert_mixin : PreHilbert.mixin_of (LpRRVq_ModuleSpace prts nneg2)
    := PreHilbert.Mixin (LpRRVq_ModuleSpace prts nneg2) L2RRVq_inner
                        L2RRVq_inner_comm  L2RRVq_inner_pos L2RRVq_inner_zero_inv
                        L2RRVq_inner_scal L2RRVq_inner_plus.

  Canonical L2RRVq_PreHilbert :=
    PreHilbert.Pack (LpRRVq prts 2) (PreHilbert.Class _ _ L2RRVq_PreHilbert_mixin) (LpRRVq prts 2).

  Context {p:R}.
  Context (pbig:1 <= p).

  Lemma L2RRVq_Cauchy_Schwarz (x1 x2 : LpRRVq prts 2) :
    0 < L2RRVq_inner x2 x2 ->
    Rsqr (L2RRVq_inner x1 x2) <= (L2RRVq_inner x1 x1)*(L2RRVq_inner x2 x2).
  Proof.
    LpRRVq_simpl.
    apply L2RRV_Cauchy_Schwarz.
  Qed.

  (*
  (* generalize to be over any normed space *)
   Definition Cauchy_crit (Un : nat -> LpRRV prts 2) : Prop :=
    forall eps:R,
      eps > 0 ->
      exists N : nat,
        (forall n m:nat,
          (n >= N)%nat -> (m >= N)%nat -> LpRRVnorm prts (LpRRVminus prts (Un n) (Un m)) < eps).
*)

  Lemma L2RRVq_norm_norm (x : LpRRVq prts 2) :
    Hnorm x = LpRRVq_norm prts x.
  Proof.
    unfold Hnorm; simpl.
    LpRRVq_simpl.
    rewrite LpRRVq_normE.
    unfold LpRRVnorm.
    unfold L2RRVinner.
    rewrite power_sqrt.
    - f_equal.
      apply FiniteExpectation_ext.
      intros ?; simpl.
      now rewrite rvpower_abs2_unfold, rvsqr_eq.
    - apply FiniteExpectation_pos.
      typeclasses eauto.
  Qed.

  Lemma L2RRVq_ball_ball (x : LpRRVq prts 2) eps (y : LpRRVq prts 2) :
    ball x eps y <-> LpRRVq_ball prts big2 x eps y.
  Proof.
    unfold ball.
    rewrite L2RRVq_norm_norm.
    LpRRVq_simpl.
    rewrite LpRRVq_ballE.
    unfold minus, plus, opp; simpl.
    autorewrite with quot.
    rewrite LpRRVq_normE.
    unfold LpRRVball.
    now rewrite LpRRVminus_plus.
  Qed.

  Lemma Hnorm_minus_opp {T:PreHilbert} (a b:T) :
    (Hnorm (minus a b) = Hnorm (minus b a)).
  Proof.
    rewrite <- (norm_opp (minus a b)).
    rewrite opp_minus.
    reflexivity.
  Qed.

  Lemma hball_pre_uniform_eq x eps :
    @Hierarchy.ball (@PreHilbert_UniformSpace L2RRVq_PreHilbert) x (pos eps)
    = @Hierarchy.ball (LpRRVq_UniformSpace prts 2 big2) x (pos eps).
  Proof.
    unfold Hierarchy.ball.
    apply functional_extensionality; simpl; intros.
    unfold ball.
    rewrite L2RRVq_norm_norm.
    destruct (Quot_inv x); subst.
    destruct (Quot_inv x0); subst.
    rewrite LpRRVq_ballE.
    unfold minus, plus, opp; simpl.
    autorewrite with quot.
    rewrite LpRRVq_normE.
    unfold LpRRVball.
    erewrite LpRRV_norm_proper; [reflexivity |].
    rewrite LpRRVminus_plus.
    reflexivity.
  Qed.

  Lemma hball_pre_uniform (F : (PreHilbert_UniformSpace -> Prop) -> Prop) x eps :
    F (@Hierarchy.ball (@PreHilbert_UniformSpace L2RRVq_PreHilbert) x (pos eps)) ->
    F (@Hierarchy.ball (LpRRVq_UniformSpace prts 2 big2) x (pos eps)).
  Proof.
    now rewrite hball_pre_uniform_eq.
  Qed.

  Lemma cauchy_pre_uniform (F : (PreHilbert_UniformSpace -> Prop) -> Prop) :
    @cauchy (@PreHilbert_UniformSpace L2RRVq_PreHilbert) F ->
    @cauchy (LpRRVq_UniformSpace prts 2 big2) F.
  Proof.
    intros HH eps.
    destruct (HH eps) as [x HH2].
    exists x.
    now apply hball_pre_uniform.
  Qed.

  Lemma L2RRVq_lim_complete (F : (PreHilbert_UniformSpace -> Prop) -> Prop) :
    ProperFilter F -> cauchy F -> forall eps : posreal, F (ball (LpRRVq_lim prts big2 F) eps).
  Proof.
    intros.
    generalize (LpRRVq_lim_complete prts big2 F H)
    ; intros HH.
    cut_to HH.
    - specialize (HH eps).
      replace (LpRRVq_ball prts big2 (LpRRVq_lim prts big2 F) eps) with
          (ball (LpRRVq_lim prts big2 (fun x : LpRRVq prts 2 -> Prop => F x)) eps) in HH; trivial.
      apply functional_extensionality; simpl; intros.
      unfold ball; simpl.
      rewrite L2RRVq_norm_norm.
      replace (fun x : LpRRVq prts 2 -> Prop => F x) with F by trivial.

      destruct (Quot_inv (LpRRVq_lim prts big2 F)) as [l leqq].
      rewrite leqq.
      destruct (Quot_inv x); subst; simpl in *.
      unfold minus, plus, opp; simpl.
      autorewrite with quot.
      rewrite LpRRVq_ballE, LpRRVq_normE.
      unfold LpRRVball.
      erewrite LpRRV_norm_proper; [reflexivity |].
      rewrite LpRRVminus_plus.
      reflexivity.
    - now apply cauchy_pre_uniform.
  Qed.

  Definition L2RRVq_Hilbert_mixin : Hilbert.mixin_of (L2RRVq_PreHilbert)
    := Hilbert.Mixin (L2RRVq_PreHilbert) (LpRRVq_lim prts big2) L2RRVq_lim_complete.

  Canonical L2RRVq_Hilbert :=
    Hilbert.Pack (LpRRVq prts 2) (Hilbert.Class _ _ L2RRVq_Hilbert_mixin) (LpRRVq prts 2).

End L2.


(* Contribution to the Coq Library   V6.3 (July 1999)                    *)

(****************************************************************************)
(*                 The Calculus of Inductive Constructions                  *)
(*                                                                          *)
(*                                Projet Coq                                *)
(*                                                                          *)
(*                     INRIA                        ENS-CNRS                *)
(*              Rocquencourt                        Lyon                    *)
(*                                                                          *)
(*                                Coq V5.10                                 *)
(*                              Nov 25th 1994                               *)
(*                                                                          *)
(****************************************************************************)
(*                                  misc.v                                  *)
(****************************************************************************)
Require Export Lci.

(****************)
Definition antisym (A : Set) (R : A -> A -> Prop) :=
  forall x y : A, R x y -> R y x -> x = y :>A.

(********************)
Definition pi1 : forall (A : Set) (P : A -> Prop), {x : A | P x} -> A.

Proof.
simple induction 1; auto.
Defined.

(********************)
Lemma pi2 :
 forall (A : Set) (P : A -> Prop) (p : {x : A | P x}), P (pi1 A P p).

Proof.
simple induction p; unfold pi1 in |- *; trivial.
Qed.

(*******************)
Definition inversible (S : Set) (Mult : S -> S -> S)
  (I x : S) := exists y : S, Mult x y = I /\ Mult y x = I.

(************)
Lemma inv_com :
 forall (S : Set) (Mult : S -> S -> S) (I x : S),
 commutativity S Mult ->
 (exists y : S, Mult x y = I) -> inversible S Mult I x.

Proof.
intros; unfold inversible in |- *.
elim H0; intros.
exists x0.
split.
assumption.
elim (H x x0); assumption.
Qed.


Require Import Tweetnacl.Libs.Export.
Require Export Tweetnacl.Low.M.
Require Import ssreflect.

Module Low.

Definition S (a : list Z) : list Z := Low.M a a.

End Low.

Lemma Sq_length : forall a,
  length a = 16 ->
  length (Low.S a) = 16.
Proof. intros; rewrite /Low.S M_length ; omega. Qed.

Open Scope Z.

Lemma Sq_Zlength : forall a,
  Zlength a = 16 ->
  Zlength (Low.S a) = 16.
Proof. intros; rewrite /Low.S M_Zlength ; omega. Qed.

Lemma Sq_bound_length : forall a,
  (length a = 16)%nat ->
  Forall (fun x => -Z.pow 2 26 < x < Z.pow 2 26) a ->
  Forall (fun x => -38 <= x < Z.pow 2 16 + 38) (Low.S a).
Proof. intros; rewrite /Low.S ; apply M_bound_length; go. Qed.

Lemma Sq_bound_Zlength : forall a,
  Zlength a = 16 ->
  Forall (fun x => -Z.pow 2 26 < x < Z.pow 2 26) a ->
  Forall (fun x => -38 <= x < Z.pow 2 16 + 38) (Low.S a).
Proof. intros; rewrite /Low.S ; apply M_bound_Zlength; go. Qed.

Close Scope Z.


Require Import HoTT.Homotopy.
Require Import pointed_spaces.

Set Implicit Arguments.
Unset Strict Implicit.
Import pointed_spaces.pt_map_notation.

Definition loop_space_type (X : pt_type) : Type := point X = point X.

Definition loop_space (X : pt_type) : pt_type :=
  {| carrier := loop_space_type X ;
     point := idpath |}.

Section loop_space_functorial.

Variables X Y : pt_type.
Variable f : X .-> Y.

Definition loop_space_map_carrier (* (X Y : pt_type) (f : pt_map X Y)*) :
   loop_space_type X -> loop_space_type Y :=
   fun p =>
     !pt_map_point f @ map f p @ pt_map_point f.

Definition loop_space_map_refl :
   loop_space_map_carrier idpath = idpath.
Proof.
  unfold loop_space_map_carrier.
  rewrite idpath_map.
  apply opposite_left_inverse.
Defined.

Definition loop_space_map_concat (p q : loop_space_type X) :
   loop_space_map_carrier (p @ q) =
     loop_space_map_carrier p @ loop_space_map_carrier q.
Proof.
  transitivity (!pt_map_point f @ map f p @ map f q @ pt_map_point f).
  unfold loop_space_map_carrier.
  apply whisker_left.
  rewrite concat_map.
  rewrite concat_associativity.
  reflexivity.
  unfold loop_space_map_carrier.
  repeat rewrite concat_associativity.
  apply whisker_left.
  apply whisker_left.
  repeat  rewrite <- concat_associativity.
  apply whisker_right.
(*  rewrite concat_associativity. *)
  rewrite opposite_right_inverse.
  reflexivity.
Defined.

Definition loop_space_map : loop_space X .-> loop_space Y.
exists loop_space_map_carrier.
simpl.
exact loop_space_map_refl.
Defined.

End loop_space_functorial.


Require Export prosa.results.edf.rta.bounded_nps.
Require Export prosa.analysis.facts.preemption.rtc_threshold.limited.
From mathcomp Require Import ssreflect ssrbool eqtype ssrnat seq path fintype bigop.

(** * RTA for EDF with Fixed Preemption Points *)
(** In this module we prove the RTA theorem for EDF-schedulers with
    fixed preemption points. *)

(** Throughout this file, we assume the EDF priority policy, ideal uni-processor
    schedules, and the basic (i.e., Liu & Layland) readiness model. *)
Require Import prosa.model.priority.edf.
Require Import prosa.model.processor.ideal.
Require Import prosa.model.readiness.basic.

(** Furthermore, we assume the task model with fixed preemption points. *)
Require Import prosa.model.preemption.limited_preemptive.
Require Import prosa.model.task.preemption.limited_preemptive.

(** ** Setup and Assumptions *)

Section RTAforFixedPreemptionPointsModelwithArrivalCurves.

  (** Consider any type of tasks ... *)
  Context {Task : TaskType}.
  Context `{TaskCost Task}.
  Context `{TaskDeadline Task}.

  (**  ... and any type of jobs associated with these tasks. *)
  Context {Job : JobType}.
  Context `{JobTask Job Task}.
  Context `{JobArrival Job}.
  Context `{JobCost Job}.

  (** Consider any arrival sequence with consistent, non-duplicate arrivals. *)
  Variable arr_seq : arrival_sequence Job.
  Hypothesis H_arrival_times_are_consistent : consistent_arrival_times arr_seq.
  Hypothesis H_arr_seq_is_a_set : arrival_sequence_uniq arr_seq.

  (** Consider an arbitrary task set ts, ... *)
  Variable ts : list Task.

  (** ... assume that all jobs come from this task set, ... *)
  Hypothesis H_all_jobs_from_taskset : all_jobs_from_taskset arr_seq ts.

  (** ... and the cost of a job cannot be larger than the task cost. *)
  Hypothesis H_valid_job_cost:
    arrivals_have_valid_job_costs arr_seq.

  (** Next, we assume we have the model with fixed preemption points.
     I.e., each task is divided into a number of non-preemptive segments
     by inserting statically predefined preemption points. *)
  Context `{JobPreemptionPoints Job}.
  Context `{TaskPreemptionPoints Task}.
  Hypothesis H_valid_model_with_fixed_preemption_points:
    valid_fixed_preemption_points_model arr_seq ts.

  (** Let max_arrivals be a family of valid arrival curves, i.e., for
     any task [tsk] in ts [max_arrival tsk] is (1) an arrival bound of
     [tsk], and (2) it is a monotonic function that equals 0 for the
     empty interval delta = 0. *)
  Context `{MaxArrivals Task}.
  Hypothesis H_valid_arrival_curve : valid_taskset_arrival_curve ts max_arrivals.
  Hypothesis H_is_arrival_curve : taskset_respects_max_arrivals arr_seq ts.

  (** Let [tsk] be any task in ts that is to be analyzed. *)
  Variable tsk : Task.
  Hypothesis H_tsk_in_ts : tsk \in ts.

  (** Next, consider any ideal uni-processor schedule with limited
      preemptions of this arrival sequence ...  *)
  Variable sched : schedule (ideal.processor_state Job).
  Hypothesis H_jobs_come_from_arrival_sequence:
    jobs_come_from_arrival_sequence sched arr_seq.
  Hypothesis H_schedule_with_limited_preemptions:
    schedule_respects_preemption_model arr_seq sched.

  (** ... where jobs do not execute before their arrival or after completion. *)
  Hypothesis H_jobs_must_arrive_to_execute : jobs_must_arrive_to_execute sched.
  Hypothesis H_completed_jobs_dont_execute : completed_jobs_dont_execute sched.

  (** Assume we have sequential tasks, i.e, jobs from the
      same task execute in the order of their arrival. *)
  Hypothesis H_sequential_tasks : sequential_tasks sched.

  (** Next, we assume that the schedule is a work-conserving schedule... *)
  Hypothesis H_work_conserving : work_conserving arr_seq sched.

  (** ... and the schedule respects the policy defined by the
      [job_preemptable] function (i.e., jobs have bounded non-preemptive
      segments). *)
  Hypothesis H_respects_policy : respects_policy_at_preemption_point arr_seq sched.

  (** ** Total Workload and Length of Busy Interval *)

  (** We introduce the abbreviation [rbf] for the task request bound function,
     which is defined as [task_cost(T) × max_arrivals(T,Δ)] for a task T. *)
  Let rbf := task_request_bound_function.

  (** Next, we introduce [task_rbf] as an abbreviation
     for the task request bound function of task [tsk]. *)
  Let task_rbf := rbf tsk.

  (** Using the sum of individual request bound functions, we define the request bound
     function of all tasks (total request bound function). *)
  Let total_rbf := total_request_bound_function ts.

  (** We define a bound for the priority inversion caused by jobs with lower priority. *)
  Let blocking_bound :=
    \max_(tsk_other <- ts | (tsk_other != tsk) && (task_deadline tsk_other > task_deadline tsk))
     (task_max_nonpreemptive_segment tsk_other - ε).

  (** Next, we define an upper bound on interfering workload received from jobs
     of other tasks with higher-than-or-equal priority. *)
  Let bound_on_total_hep_workload A Δ :=
    \sum_(tsk_o <- ts | tsk_o != tsk)
     rbf tsk_o (minn ((A + ε) + task_deadline tsk - task_deadline tsk_o) Δ).

  (** Let L be any positive fixed point of the busy interval recurrence. *)
  Variable L : duration.
  Hypothesis H_L_positive : L > 0.
  Hypothesis H_fixed_point : L = total_rbf L.

  (** ** Response-Time Bound *)

  (** To reduce the time complexity of the analysis, recall the notion of search space. *)
  Let is_in_search_space := is_in_search_space ts tsk L.

  (** Consider any value R, and assume that for any given arrival offset A in the search space,
     there is a solution of the response-time bound recurrence which is bounded by R. *)
  Variable R : duration.
  Hypothesis H_R_is_maximum:
    forall (A : duration),
      is_in_search_space A ->
      exists (F : duration),
        A + F = blocking_bound
                + (task_rbf (A + ε) - (task_last_nonpr_segment tsk - ε))
                + bound_on_total_hep_workload A (A + F) /\
        F + (task_last_nonpr_segment tsk - ε) <= R.

  (** Now, we can leverage the results for the abstract model with bounded non-preemptive segments
      to establish a response-time bound for the more concrete model of fixed preemption points.  *)

  Let response_time_bounded_by := task_response_time_bound arr_seq sched.

  Theorem uniprocessor_response_time_bound_edf_with_fixed_preemption_points:
    response_time_bounded_by tsk R.
  Proof.
    move: (H_valid_model_with_fixed_preemption_points) => [MLP [BEG [END [INCR [HYP1 [HYP2 HYP3]]]]]].
    move: (MLP) => [BEGj [ENDj _]].
    case: (posnP (task_cost tsk)) => [ZERO|POSt].
    { intros j ARR TSK.
      move: (H_valid_job_cost _ ARR) => POSt.
      move: POSt; rewrite /valid_job_cost TSK ZERO leqn0; move => /eqP Z.
        by rewrite /job_response_time_bound /completed_by Z.
    }
    eapply uniprocessor_response_time_bound_edf_with_bounded_nonpreemptive_segments with (L0 := L).
    all: eauto 2 with basic_facts.
    { rewrite subKn; first by done.
      rewrite /task_last_nonpr_segment  -(leq_add2r 1) subn1 !addn1 prednK; last first.
      {  rewrite /last0 -nth_last.
        apply HYP3; try by done.
        rewrite -(ltn_add2r 1) !addn1 prednK //.
        move: (number_of_preemption_points_in_task_at_least_two
                 _ _ H_valid_model_with_fixed_preemption_points _ H_tsk_in_ts POSt) => Fact2.
        move: (Fact2) => Fact3.
          by rewrite size_of_seq_of_distances // addn1 ltnS // in Fact2.
      }
      { apply leq_trans with (task_max_nonpreemptive_segment tsk).
        - by apply last_of_seq_le_max_of_seq.
        - rewrite -END; last by done.
          apply ltnW; rewrite ltnS; try done.
            by apply max_distance_in_seq_le_last_element_of_seq; eauto 2.
      }
    }
  Qed.

End RTAforFixedPreemptionPointsModelwithArrivalCurves.


Require Import Utf8.
Require Import FunctionalExtensionality.
Require Import Arith.
Require Import NArith.
Require Import ZArith.
Require Import Picinae_i386.
Require Import strncmp_i386.
Require Import strncmp_proofs.

Import X86Notations.
Open Scope N.

(* Example #4: Partial correctness
   EAX equals zero if the input strings are equal up to n, EAX is negative if
   the first lexicographically precedes the second, and EAX is positive
   otherwise. *)

(* Define string equality *)
Definition streq (m:addr->N) (p1 p2:addr) (k:N) :=
  ∀ i, i < k -> m (p1⊕i) = m (p2⊕i) /\ 0 < m (p1⊕i).

(* The invariant-set for this property makes no assumptions at program-start
   (address 0), and puts a loop-invariant at address 8. *)
Definition strncmp_invs (m:addr->N) (esp:N) (a:addr) (s:store) :=
  let p1 := m Ⓓ[esp ⊕ 4] in
  let p2 := m Ⓓ[esp ⊕ 8] in
  let n := m Ⓓ[esp ⊕ 12] in

  match a with
  (* 0x40c00000: PUSH EBP *)
  | 0 => Some (24 <= esp)

  (* 0x40c00040: MOV EDI,dword ptr [ESP] *)
  (* n > 0 && exists i < n, p1[i] != p2[i] /\ p2[i] != '\0' *)
  | 64 => Some (exists i, i < n /\
                (m (p1 ⊕ i) <> m (p2 ⊕ i) /\ (m (p2 ⊕ i) <> 0)))

(*
  (* 0x40c00049: MOVZX EBX,byte ptr [ESI + 0x1] *)
  (* p1[0] == p2[0] *)
  | 73 => Some (p1 = p2)
*)

  (* 0x40c00081: MOVZX EBX,byte ptr [ESP + 0x7] *)
  (* n > 0 && forall i < n, p1[i] == p2[i] != '\0' *)
  | 129 => Some (n > 0 /\
                (forall i, i < n -> (m (p1 ⊕ i) = m (p2 ⊕ i) /\ m (p1 ⊕ i) <> 0)))

  (* 0x40c00086: ADD ESP,0x8 *)
  (* n > 0 && exists i < n, p1[i] != p2[i] || p1[i] == '\0' || p2[i] == '\0' *)
  | 134 => Some (n > 0 /\
                (exists i, i < n /\ p1 <> p2 \/ p1 ⊕ i = 0 \/ p2 ⊕ i = 0))

  (* 0x40c00090: ADD ESP,0x8 *)
  (* n = 0 *)
  | 144 => Some (n = 0)

(*
  (* 0x40c000a0: XOR EAX,EAX *)
  (* n > 0 && exists i < n, p1[i] == '\0' *)
  | 160 => Some (n > 0 /\
                (exists i, i < n /\ (p1 ⊕ i = 0)))
*)
  | _ => None
  end.

(* Interpreting EAX as a signed integer yields a number n
   which is 0 if the third argument is 0 or
   whose sign equals the comparison of the ith byte in the two input strings,
   where the two strings are identical before i,
   and n may also be zero if the ith bytes are equal. *)

Definition strncmp_post (m:addr->N) (esp:N) (_:exit) (s:store) :=
  let p1 := (m Ⓓ[esp ⊕ 4]) in
  let p2 := (m Ⓓ[esp ⊕ 8]) in
  let p3 := (m Ⓓ[esp ⊕ 12]) in
  ∃ n i, s R_EAX = Ⓓn /\
             ((n = 0 /\ p3 = 0) \/
             (streq m p1 p2 i /\
             (n = 0 -> (m (p1 ⊕ i) = (m (p2 ⊕ i)))) /\
             (m (p1 ⊕ i) ?= m (p2 ⊕ i)) = (toZ 32 n ?= Z0)%Z)).

(* The invariant-set and post-conditions are combined *)
Definition strncmp_invset (mem:addr->N) (esp:N) :=
  invs (strncmp_invs mem esp) (strncmp_post mem esp).

(* (MDL0) Assume that on entry the processor is in a valid state.
   (ESP0) Let esp be the value of the ESP register on entry.
   (MEM0) Let mem be the memory state on entry.
   (RET) Assume the return address on the stack on entry is not within strcmp(!)
   (XP0) Let x and s' be the exit condition and store after n instructions execute.
   From these, we prove that all invariants hold true for arbitrary n. *)
Theorem strncmp_partial_correctness:
  forall s esp mem n s' x
         (MDL0: models x86typctx s)
         (ESP0: s R_ESP = Ⓓ esp /\ 24 <= esp) (MEM0: s V_MEM32 = Ⓜ mem)
         (RET: strncmp_i386 s (mem Ⓓ[esp mod 2 ^ 32]) = None)
         (XP0: exec_prog fh strncmp_i386 0 s n s' x),
  trueif_inv (strncmp_invset mem esp strncmp_i386 x s').
Proof.
  intros.
  eapply prove_invs. exact XP0.

  (* pre-condition *)
  destruct ESP0 as [ESP ESP0].
  exact ESP0.

  (* Before splitting into cases, translate each hypothesis about the
     entry point store s to each instruction's starting store s1: *)
  intros.
  assert (MDL: models x86typctx s1).
    eapply preservation_exec_prog. exact MDL0. apply strncmp_welltyped. exact XP.
  (*
  assert (MEM: s1 V_MEM32 = Ⓜ mem).
    rewrite <- MEM0. eapply strncmp_preserves_memory. exact XP.
  rewrite (strncmp_nwc s1) in RET.
  assert (ESP := strncmp_preserves_esp _ _ _ _ _ (Exit a1) MDL0 ESP0 MEM0 RET XP).

  (* Break the proof into cases, one for each invariant-point. *)
  destruct_inv 32 PRE.

  (* Time how long it takes for each symbolic interpretation step to complete
     (for profiling and to give visual cues that something is happening...). *)
  Local Ltac step := time x86_step.

  (* Address 0 *)
  repeat step.

  (* Address 144 *)
  Show.
  *)
Admitted.


Require Import Basic.
Require Import Full.
Require Import Rosette.Quantified.
Require Import ListEx.
Require Import Integer.

Definition solveAddTransSpace : Space (Int * Int * Int * Int * Int) :=
  bind full (fun x:Int =>
  bind full (fun y:Int =>
  bind full (fun z:Int =>
    let a := plus (plus x y) z in
    let b := plus x (plus y z) in
      if equal a b then Basic.empty else single (x,y,z,a,b)))).

Definition solveAddTrans : Result (Int * Int * Int * Int * Int) :=
  search solveAddTransSpace.

Definition solveAddAddTrans : Result (Int * Int * Int * Int * Int) :=
  search (
    bind full (fun x:Int =>
    bind full (fun y:Int =>
    bind full (fun z:Int =>
      let a := plus (plus x (plus y y)) z in
      let b := plus x (plus y z) in
        if equal a b then empty else single (x,y,z,a,b))))).

Definition addTest :=
  let x := one in
  let y := one in
  let z := one in
  let a := plus (plus x (plus y y)) z in
  let b := plus x (plus y z) in
    equal a b.

Extraction Language Scheme.

Extraction "integer-tests" solveAddTransSpace solveAddTrans solveAddAddTrans addTest.


Set Implicit Arguments.

Require Import Platform.Cito.Syntax.

Require Import Platform.Cito.FreeVarsExpr.

Require Import Platform.Cito.Option.
Require Import Coq.Strings.String.
Local Open Scope string_scope.

Require Import Coq.Lists.List.
Import ListNotations.
Local Open Scope list_scope.

Require Import Bedrock.StringSet.
Import StringSet.
Require Import Platform.Cito.StringSetFacts.
Import FSetNotations.
Import FSetNotationsTrial.
Local Open Scope fset_scope.

Coercion string2elt (x : string) : elt := x.
Coercion singleton : elt >-> t.

Fixpoint inits stmt : StringSet.t :=
  match stmt with
    | Assign x _ => x
    | Label x _ => x
    | Seq a b => inits a + inits b
    | Skip => []
    | Syntax.If _ t f => inits t * inits f
    | While _ _ => []
    | Syntax.Call x _ _ => default empty (option_map singleton x)
  end.

Fixpoint uninited_reads inited stmt :=
  match stmt with
    | Assign _ e => free_vars e - inited
    | Label _ _ => []
    | Seq a b => uninited_reads inited a + uninited_reads (inited + inits a) b
    | Skip => []
    | Syntax.If e t f => (free_vars e - inited) + uninited_reads inited t + uninited_reads inited f
    | While e s => (free_vars e - inited) + uninited_reads inited s
    | Syntax.Call _ f args => List.fold_left (fun acc e => free_vars e - inited + acc) args (free_vars f - inited)
  end.

Require Import Platform.Cito.FuncCore.

Local Open Scope bool_scope.

Definition is_no_uninited_reads (f : FuncCore) := is_empty (uninited_reads (of_list (ArgVars f)) (Body f)).

Definition is_no_uninited (f : FuncCore) := is_no_uninited_reads f && mem (RetVar f) (inits (Body f)).


(* Testing the behavior of implicit arguments *)

(* Implicit on section variables *)

Set Implicit Arguments.
Unset Strict Implicit.

(* Example submitted by David Nowak *)

Section Spec.
Variable A : Set.
Variable op : forall A : Set, A -> A -> Set.
Infix "#" := op (at level 70).
Check (forall x : A, x # x).

(* Example submitted by Christine *)

Record stack : Type :=
  {type : Set; elt : type; empty : type -> bool; proof : empty elt = true}.

Check
  (forall (type : Set) (elt : type) (empty : type -> bool),
   empty elt = true -> stack).

(* Nested sections and manual/automatic implicit arguments *)

Variable op' : forall A : Set, A -> A -> Set.
Variable op'' : forall A : Set, A -> A -> Set.

Section B.

Definition eq1 := fun (A:Type) (x y:A) => x=y.
Definition eq2 := fun (A:Type) (x y:A) => x=y.
Definition eq3 := fun (A:Type) (x y:A) => x=y.

Arguments op' : clear implicits.
Global Arguments op'' : clear implicits.

Arguments eq2 : clear implicits.
Global Arguments eq3 : clear implicits.

Check (op 0 0).
Check (op' nat 0 0).
Check (op'' nat 0 0).
Check (eq1 0 0).
Check (eq2 nat 0 0).
Check (eq3 nat 0 0).

End B.

Check (op 0 0).
Check (op' 0 0).
Check (op'' nat 0 0).
Check (eq1 0 0).
Check (eq2 0 0).
Check (eq3 nat 0 0).

End Spec.

Check (eq1 0 0).
Check (eq2 0 0).
Check (eq3 nat 0 0).

(* Example submitted by Frédéric (interesting in v8 syntax) *)

Parameter f : nat -> nat * nat.
Notation lhs := fst.
Check (fun x => fst (f x)).
Check (fun x => fst (f x)).
Notation rhs := snd.
Check (fun x => snd (f x)).
Check (fun x => @ rhs _ _ (f x)).

(* Implicit arguments in fixpoints and inductive declarations *)

Fixpoint g n := match n with O => true | S n => g n end.

Inductive P n : nat -> Prop := c : P n n.

(* Avoid evars in the computation of implicit arguments (cf r9827) *)

Require Import List.

Fixpoint plus n m {struct n} :=
  match n with
  | 0 => m
  | S p => S (plus p m)
  end.

(* Check multiple implicit arguments signatures *)

Arguments eq_refl {A x}, {A}.

Check eq_refl : 0 = 0.

(* Check that notations preserve implicit (since 8.3) *)

Parameter p : forall A, A -> forall n, n = 0 -> True.
Arguments p [A] _ [n].
Notation Q := (p 0).
Check Q eq_refl.

(* Check implicits with Context *)

Section C.
Context {A:Set}.
Definition h (a:A) := a.
End C.
Check h 0.

(* Check implicit arguments in arity of inductive types. The three
   following examples used to fail before r13671 *)

Inductive I {A} (a:A) : forall {n:nat}, Prop :=
 | C : I a (n:=0).

Inductive I2 (x:=0) : Prop :=
 | C2 {p:nat} : p = 0 -> I2.
Check C2 eq_refl.

Inductive I3 {A} (x:=0) (a:A) : forall {n:nat}, Prop :=
 | C3 : I3 a (n:=0).

(* Check global implicit declaration over ref not in section *)

Section D. Global Arguments eq [A] _ _. End D.


Require Export GeoCoq.Elements.OriginalProofs.lemma_collinear4.

Section Euclid.

Context `{Ax:euclidean_neutral_ruler_compass}.

Lemma lemma_9_5a :
   forall A B C P Q R,
   TS P A B C -> BetS R P Q -> nCol R Q C -> Col A B R ->
   TS Q A B C.
Proof.
intros.
let Tf:=fresh in
assert (Tf:exists S, (BetS P S C /\ Col A B S /\ nCol A B P)) by (conclude_def TS );destruct Tf as [S];spliter.
assert (BetS C S P) by (conclude axiom_betweennesssymmetry).
let Tf:=fresh in
assert (Tf:exists F, (BetS C F Q /\ BetS R S F)) by (conclude postulate_Pasch_outer);destruct Tf as [F];spliter.
assert (Col R S F) by (conclude_def Col ).
assert (~ eq A B).
 {
 intro.
 assert (Col A B P) by (conclude_def Col ).
 contradict.
 }
assert (neq B A) by (conclude lemma_inequalitysymmetric).
assert (Col B R S) by (conclude lemma_collinear4).
assert (Col R S B) by (forward_using lemma_collinearorder).
assert (neq R S) by (forward_using lemma_betweennotequal).
assert (Col S F B) by (conclude lemma_collinear4).
assert (Col S B A) by (forward_using lemma_collinearorder).
assert (Col S B F) by (forward_using lemma_collinearorder).
assert (Col A B F).
by cases on (eq S B \/ neq S B).
{
 assert (Col B A S) by (forward_using lemma_collinearorder).
 assert (Col R S F) by (conclude_def Col ).
 assert (Col R B F) by (conclude cn_equalitysub).
 assert (Col R B A) by (forward_using lemma_collinearorder).
 assert (~ eq R B).
  {
  intro.
  assert (eq R S) by (conclude cn_equalitysub).
  assert (neq R S) by (forward_using lemma_betweennotequal).
  assert (neq R B) by (conclude cn_equalitysub).
  contradict.
  }
 assert (Col B F A) by (conclude lemma_collinear4).
 assert (Col A B F) by (forward_using lemma_collinearorder).
 close.
 }
{
 assert (Col B A F) by (conclude lemma_collinear4).
 assert (Col A B F) by (forward_using lemma_collinearorder).
 close.
 }
(** cases *)
assert (~ Col A B Q).
 {
 intro.
 assert (Col B Q R) by (conclude lemma_collinear4).
 assert (Col B R Q) by (forward_using lemma_collinearorder).
 assert (Col B R F) by (conclude lemma_collinear4).
 assert (Col R Q F).
 by cases on (eq B R \/ neq B R).
 {
  assert (~ eq A R).
   {
   intro.
   assert (eq A B) by (conclude cn_equalitysub).
   contradict.
   }
  assert (Col B A R) by (forward_using lemma_collinearorder).
  assert (Col B A F) by (forward_using lemma_collinearorder).
  assert (Col A R F) by (conclude lemma_collinear4).
  assert (Col B A Q) by (forward_using lemma_collinearorder).
  assert (Col B A R) by (forward_using lemma_collinearorder).
  assert (Col A R Q) by (conclude lemma_collinear4).
  assert (Col R F Q) by (conclude lemma_collinear4).
  assert (Col R Q F) by (forward_using lemma_collinearorder).
  close.
  }
 {
  assert (Col R Q F) by (conclude lemma_collinear4).
  close.
  }
(** cases *)
 assert (Col F Q R) by (forward_using lemma_collinearorder).
 assert (Col C F Q) by (conclude_def Col ).
 assert (Col F Q C) by (forward_using lemma_collinearorder).
 assert (neq F Q) by (forward_using lemma_betweennotequal).
 assert (Col Q R C) by (conclude lemma_collinear4).
 assert (Col R Q C) by (forward_using lemma_collinearorder).
 contradict.
 }
assert (BetS Q F C) by (conclude axiom_betweennesssymmetry).
assert (TS Q A B C) by (conclude_def TS ).
close.
Qed.

End Euclid.


Require Import proplogicST.
Require Import proplogic.
Require Import List.
Import ListNotations.

Fixpoint fm_to_ST (x : fm) : PL_Formula :=
  match x with
  | Impl a b => PL_imp (fm_to_ST a) (fm_to_ST b)
  | Var x => PL_var x
  | Neg a => PL_neg (fm_to_ST a)
  end.

Fixpoint ST_to_fm (x : PL_Formula) : fm :=
  match x with
  | PL_var x => Var x
  | PL_neg x => Neg (ST_to_fm x)
  | PL_imp a b => Impl (ST_to_fm a) (ST_to_fm b)
  end.

Lemma fm_ST_iso : forall A, fm_to_ST (ST_to_fm A) = A.
Proof. induction A; simpl; try congruence. Defined.

Lemma ST_fm_iso : forall A, ST_to_fm (fm_to_ST A) = A.
Proof. induction A; simpl; try congruence. Defined.

Lemma fm_ST_iso_map : forall S, map fm_to_ST (map ST_to_fm S) = S.
Proof.
  intros S.
  rewrite map_map.
  rewrite map_ext with (g := id).
  - apply map_id.
  - apply fm_ST_iso.
Defined.

Lemma ST_fm_iso_map : forall S, map ST_to_fm (map fm_to_ST S) = S.
Proof.
  intros S.
  rewrite map_map.
  rewrite map_ext with (g := id).
  - apply map_id.
  - apply ST_fm_iso.
Defined.

Lemma interp_equiv :
  forall f A, PL_interpretation f (fm_to_ST A) = fm_val f A.
Proof.
  intros f A.
  generalize dependent f.
  induction A; intros f.
  - cbn. unfold PL_imp_interpretation. congruence.
  - reflexivity.
  - cbn. unfold PL_neg_interpretation. congruence.
Defined.

Lemma satisfies_single :
  forall v A, Satisfies v [A] <-> Forall (PL_models v) (map fm_to_ST [A]).
Proof.
  intros v A.
  split; intros H.
  - simpl. constructor. unfold PL_models.
    unfold Satisfies in H.
    specialize (H A ltac:(left; constructor)).
    rewrite interp_equiv. assumption.
    apply Forall_nil.
  - apply Forall_inv in H.
    unfold PL_models, Satisfies in *.
    intros.
    inversion H0; subst.
    + rewrite interp_equiv in H. assumption.
    + inversion H1.
Qed.

Lemma satisfies_weaken : forall v A S, Satisfies v (A :: S) -> Satisfies v S.
Proof.
  unfold Satisfies.
  intros v A S H A0 H0.
  specialize (H A0).
  apply H. right. assumption.
Qed.

Lemma satisfies_adjoin : forall v A S, Satisfies v S -> fm_val v A = true -> Satisfies v (A :: S).
Proof.
  unfold Satisfies.
  intros v A S H H0 A0 H1.
  destruct H1; subst; auto.
Qed.

Lemma satisfies_forall :
  forall v S, Satisfies v S <-> Forall (PL_models v) (map fm_to_ST S).
Proof.
  intros v S.
  induction S.
  - split; intros; firstorder; constructor.
  - split; intros H.
    + assert (Satisfies v [a]).
      {
        unfold Satisfies in *.
        intros A H0.
        specialize (H a ltac:(left; auto)).
        inversion H0; subst; auto.
      }
      apply satisfies_single in H0.
      constructor.
      * apply Forall_inv in H0. assumption.
      * apply satisfies_weaken in H.
        apply IHS.
        assumption.
    + apply satisfies_adjoin.
      * apply Forall_inv_tail in H.
        apply IHS in H. assumption.
      * apply Forall_inv in H.
        unfold PL_models in H.
        rewrite interp_equiv in H. assumption.
Qed.

Lemma models_equiv : forall v A, PL_models v A <-> fm_val v (ST_to_fm A) = true.
Proof.
  intros v A.
  split; intros H.
  - rewrite <- interp_equiv, fm_ST_iso. unfold PL_models in H. assumption.
  - unfold PL_models. rewrite <- interp_equiv, fm_ST_iso in H.
    assumption.
Defined.

Lemma Satisfies_PL_list_models_single :
  forall S A, PL_list_models [S] A -> Models [ST_to_fm S] (ST_to_fm A).
Proof.
  intros S A H.
  unfold Models, PL_list_models in *.
  intros v H0.
  specialize (H v).
  rewrite satisfies_forall in H0.
  simpl in H0.
  rewrite fm_ST_iso in H0.
  apply H in H0.
  apply models_equiv.
  assumption.
Qed.

Lemma list_models_equiv :
  forall S A, PL_list_models S A <-> Models (map ST_to_fm S) (ST_to_fm A).
Proof.
  split.
  - induction S; intros.
    + unfold PL_list_models in H.
      intros v.
      specialize H with v.
      specialize (H ltac:(constructor)).
      unfold PL_models in H.
      simpl.
      intros _.
      rewrite <- interp_equiv.
      rewrite fm_ST_iso.
      assumption.
    + unfold Models.
      unfold PL_list_models in IHS.
      intros v H0.
      unfold PL_list_models in H.
      specialize (H v).
      apply models_equiv, H.
      rewrite satisfies_forall in H0.
      rewrite fm_ST_iso_map in H0.
      assumption.
  - induction S; intros.
    + unfold Models in H.
      unfold PL_list_models.
      intros v H0.
      specialize (H v ltac:(cbv; auto)).
      apply models_equiv.
      assumption.
    + unfold PL_list_models.
      intros v H0.
      specialize (H v).
      apply models_equiv.
      apply H.
      apply satisfies_forall.
      rewrite fm_ST_iso_map.
      assumption.
Defined.

Theorem ltheorem_to_list_proof : forall G A, G |- A -> PL_list_proof (map fm_to_ST G) (fm_to_ST A).
Proof.
  intros G A H.
  induction H eqn:E.
  - apply PL_assumption.
    remember (fun B : fm => if fm_eq_dec A B then true else false) as f.
    pose proof (existsb_exists f G).
    destruct H0.
    specialize (H0 e).
    destruct H0 as [A' [InA' fx]].
    rewrite Heqf in fx.
    destruct (fm_eq_dec _ _); try congruence.
    apply in_map.
    congruence.
  - destruct a eqn:Ea.
    + apply PL_axiom1.
    + apply PL_axiom2.
    + apply PL_axiom3.
  - subst.
    specialize (IHl1 l1 eq_refl).
    specialize (IHl2 l2 eq_refl).
    simpl in *.
    eapply PL_MP; eauto.
Defined.

Theorem list_proof_to_ltheorem : forall G A, PL_list_proof G A -> ltheorem (map ST_to_fm G) (ST_to_fm A).
Proof.
  intros G A H.
  induction H.
  - apply Lassmp.
    apply existsb_exists.
    exists (ST_to_fm A).
    split.
    + apply in_map. assumption.
    + destruct (fm_eq_dec _ _); congruence.
  - apply (Lax _ (A1 _ _)).
  - apply (Lax _ (A2 _ _ _)).
  - apply (Lax _ (A3 _ _)).
  - simpl in *.
    eapply Lmp; eauto.
Defined.

(* Example of transporting the proof of weakening from proplogicST to proplogic *)
Theorem ltheorem_weaken (S T : list fm)
  (subsetST : forall X, In X S -> In X T) (A : fm)
  (p : ltheorem S A) : ltheorem T A.
Proof.
  apply ltheorem_to_list_proof in p.
  apply PL_list_proof_weaken with (T := map fm_to_ST T) in p.
  apply list_proof_to_ltheorem in p.
  rewrite !ST_fm_iso_map, !ST_fm_iso in p.
  assumption.
  intros X H.
  apply in_map with (f := ST_to_fm) in H.
  rewrite ST_fm_iso_map in H.
  apply subsetST in H.
  apply in_map with (f := fm_to_ST) in H.
  rewrite fm_ST_iso in H.
  assumption.
Qed.

(* Transporting deduction theorem, one direction *)
Theorem dedl_transport : forall S A B, (S |- <{A -> B}>) -> ((A::S) |- B).
Proof.
  intros S A B H.
  apply ltheorem_to_list_proof in H.
  simpl in H.
  apply PL_deduction_thm_forward_proof in H.
  apply list_proof_to_ltheorem in H.
  simpl in H.
  rewrite !ST_fm_iso_map, !ST_fm_iso in H.
  assumption.
Defined.

Theorem dedr_transport : forall S A B, ((A::S) |- B) -> (S |- <{A -> B}>).
Proof.
  intros S A B H.
  apply ltheorem_to_list_proof in H.
  simpl in H.
  apply PL_deduction_thm_reverse_proof in H.
  apply list_proof_to_ltheorem in H.
  simpl in H.
  rewrite !ST_fm_iso_map, !ST_fm_iso in H.
  assumption.
Defined.

(* What we're actually interested in: transporting the completeness
   theorem *)
Theorem l_complete : forall S A, S ⊨ A -> S |- A.
Proof.
  intros S A H.
  rewrite <- (ST_fm_iso_map S) in H.
  rewrite <- ST_fm_iso in H.
  apply list_models_equiv in H.
  rewrite <- (ST_fm_iso_map S).
  rewrite <- ST_fm_iso.
  apply list_proof_to_ltheorem.
  apply PL_completeness_proof.
  assumption.
Defined.

(* There and back again: getting a proof of X -> X via completeness. *)
Example id_proof_completeness_transp : [] |- <{X -> X}>.
Proof.
  apply l_complete.
  unfold Models.
  simpl.
  intros v H.
  destruct (v X); auto.
Defined.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(** %\subsection*{ examples :  Matrix\_multiplication.v }%*)
Set Implicit Arguments.
Unset Strict Implicit.
Require Export vecspace_Mmn.
Require Export pointwise.
Require Export sums.

(** - Remember that (Fn F n) is the vectorspace $F^n$, based on the setoid (seq n F),
 and (Mmn F m n) is the vectorspace $M_{mn}$ of $m\times n$-matrices over $F$; based
 on the setoid (matrix F m n) *)

Section matrix_x_vector.
Definition mat_vec_mult_fun :
  forall (F : field) (m n : Nat), Mmn F m n -> Fn F n -> Fn F m.
intros.
simpl in X, X0.
simpl in |- *.
apply
 (Build_Map
    (Ap:=fun i : fin m =>
         sum (pointwise (uncurry (RING_comp (R:=F))) (Ap2_Map X i) X0))).
red in |- *; simpl in |- *.
intros.
apply sum_comp; auto with algebra;
 (apply toMap; apply pointwise_comp; auto with algebra).
simpl in |- *.
red in |- *; simpl in |- *.
intro; destruct X; simpl in |- *; auto with algebra.
Defined.

Definition matXvec :
  forall (F : field) (m n : Nat), Map2 (Mmn F m n) (Fn F n) (Fn F m).
intros; apply (Build_Map2 (Ap2:=mat_vec_mult_fun (F:=F) (m:=m) (n:=n))).
red in |- *; simpl in |- *; red in |- *; simpl in |- *.
intros.
apply sum_comp; auto with algebra;
 (apply toMap; apply pointwise_comp; auto with algebra).
simpl in |- *.
red in |- *; simpl in |- *.
intro; (apply H; auto with algebra).
Defined.
End matrix_x_vector.

Section matrix_x_matrix.
Definition mat_mat_mult_fun :
  forall (F : field) (m n p : Nat), Mmn F m n -> Mmn F n p -> Mmn F m p.
intros F m n p M N.
apply
 (Build_Map2
    (Ap2:=fun i j =>
          sum (pointwise (uncurry (RING_comp (R:=F))) (row M i) (col N j)))).
red in |- *; simpl in |- *.
intros.
apply sum_comp; auto with algebra.
apply toMap; apply pointwise_comp; auto with algebra.
change (row M x =' row M x' in _) in |- *.
apply row_comp; auto with algebra.
change (col N y =' col N y' in _) in |- *.
apply col_comp; auto with algebra.
Defined.

Definition matXmat :
  forall (F : field) (m n p : Nat), Map2 (Mmn F m n) (Mmn F n p) (Mmn F m p).
intros;
 apply (Build_Map2 (Ap2:=mat_mat_mult_fun (F:=F) (m:=m) (n:=n) (p:=p))).
red in |- *; simpl in |- *.
intros.
apply sum_comp; auto with algebra;
 (apply toMap; apply pointwise_comp; auto with algebra).
change (row x i =' row x' i' in _) in |- *.
apply row_comp; auto with algebra.
change (col y j =' col y' j' in _) in |- *.
apply col_comp; auto with algebra.
Defined.
End matrix_x_matrix.

Section facts.
Variable F : field.
Variable n m p : Nat.
Variable M : Mmn F m n.
Variable N : Mmn F n p.
Lemma matXmat_col :
 forall i : fin p,
 col (matXmat _ _ _ _ M N) i =' matXvec _ _ _ M (col N i) in _.
intros.
unfold col, matXmat, matXvec in |- *.
simpl in |- *.
red in |- *; simpl in |- *.
intros.
apply sum_comp; auto with algebra.
Qed.
End facts.

Section morefacts.
From Algebra Require Export Cfield_facts.
Variable F : cfield.
Variable n m p : Nat.
Variable M : Mmn F m n.
Variable N : Mmn F n p.
Lemma matXmat_row :
 forall i : fin m,
 row (matXmat _ _ _ _ M N) i =' matXvec _ _ _ (transpose N) (row M i) in _.
intros.
unfold transpose, row, matXmat, matXvec in |- *.
simpl in |- *.
destruct N.
red in |- *; simpl in |- *.
unfold row, col in |- *.
intros.
apply sum_comp; auto with algebra.
simpl in |- *.
red in |- *; simpl in |- *.
auto with algebra.
Qed.
End morefacts.
(* Note that one needs the fact that F is a *commutative* field *)


(*
Copyright © 2006-2008 Russell O’Connor

Permission is hereby granted, free of charge, to any person obtaining a copy of
this proof and associated documentation files (the "Proof"), to deal in
the Proof without restriction, including without limitation the rights to
use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of
the Proof, and to permit persons to whom the Proof is furnished to do so,
subject to the following conditions:

The above copyright notice and this permission notice shall be included in all
copies or substantial portions of the Proof.

THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS
FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR
COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER
IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF.
*)

Require Export Coq.PArith.BinPos.

(* Backwards compatibility for Hint Rewrite locality attributes *)
Set Warnings "-unsupported-attributes".

(**
* Lazy Nat
This s a lazified version of the natural number that allow one to delay
computation until demanded.  This is useful for large natural numbers
(often upper bounds) where only a small number of terms are actually needed
for compuation.
*)
Inductive LazyNat : Set :=
| LazyO : LazyNat
| LazyS : (unit -> LazyNat) -> LazyNat.

(**
** Successor
*)
Definition lazyS (n:LazyNat) : LazyNat := LazyS (fun _ => n).

(** Convert a nat to a lazy nat *)
Fixpoint LazifyNat (n : nat) {struct n} : LazyNat :=
  match n with
  | O => LazyO
  | S p => LazyS (fun _ => (LazifyNat p))
  end.

(**
** Predecessor
*)
Definition LazyPred (n:LazyNat) : LazyNat :=
match n with
| LazyO => LazyO
| LazyS n' => (n' tt)
end.

Lemma LazifyPred : forall n, LazifyNat (pred n) = LazyPred (LazifyNat n).
Proof.
 induction n; reflexivity.
Qed.

(**
** Addition
*)
Fixpoint LazyPlus (n m : LazyNat) {struct n} : LazyNat :=
  match n with
  | LazyO => m
  | LazyS p => LazyS (fun _ => LazyPlus (p tt) m)
  end.

Lemma LazifyPlus : forall n m, (LazifyNat (n + m) = LazyPlus (LazifyNat n) (LazifyNat m))%nat.
Proof.
 induction n.
  reflexivity.
 simpl.
 intros m.
 rewrite IHn.
 reflexivity.
Qed.

(**
** Multiplication
*)
Fixpoint Pmult_LazyNat (x:positive) (pow2:LazyNat) {struct x} : LazyNat :=
  match x with
    | xI x' => (LazyPlus pow2 (Pmult_LazyNat x' (LazyPlus pow2 pow2)))%nat
    | xO x' => Pmult_LazyNat x' (LazyPlus pow2 pow2)%nat
    | xH => pow2
  end.

Lemma LazifyPmult_LazyNat : forall x pow2, LazifyNat (Pmult_nat x pow2) = Pmult_LazyNat x (LazifyNat pow2).
Proof.
 induction x; simpl; intros pow2; repeat (rewrite LazifyPlus||rewrite IHx); reflexivity.
Qed.

(** Convert a positive to a lazy nat. This is the most common way of
    generating lazy nats. The simplest fixpoint to do this is not lazy,
    because the weak head normal form for x=2^k is fully computed. To
    get LazyS constructors sooner, we could also define a double function
    on LazyNat. *)
Definition LazyNat_of_P (x:positive) := Pmult_LazyNat x (LazyS (fun _ => LazyO)).

Lemma LazifyNat_of_P : forall x, LazifyNat (nat_of_P x) = LazyNat_of_P x.
Proof.
 intros x.
 refine (LazifyPmult_LazyNat _ _).
Qed.
(* begin hide *)
#[global]
Hint Rewrite <- LazifyNat_of_P LazifyPmult_LazyNat LazifyPlus LazifyPred : UnLazyNat.
(* end hide *)

Fixpoint Pplus_LazyNat (p:positive)(n:LazyNat) {struct n} : positive :=
match n with
| LazyO => p
| (LazyS n') => (Pplus_LazyNat (Pos.succ p) (n' tt))
end.


Require Import simple.

(* Require Import equate_map_reflection. *)

Require Import List.
Require Import ZArith.

Definition sum_loop :=
  (SWhile (BLt (ECon 0) (EVar "n"))
          (Seq (SAssign "s" (EPlus (EVar "s") (EVar "n")))
               (SAssign "n" (EPlus (EVar "n") (ECon (-1)%Z))))).
Definition sum_code :=
  Seq (SAssign "s" (ECon 0))
 (Seq sum_loop
      (SReturn (EVar "s"))).

Inductive sum_spec : kcfg -> (kcfg -> Prop) -> Prop :=
| mult_claim : forall c, kcell c = kra (KStmt sum_code) kdot ->
    forall nv sv m, store c ~=
      ("n" s|-> KInt nv :* "s" s|-> KInt sv :* m) ->
    (nv >= 0)%Z ->
    sum_spec c (returning c (nv * (nv + 1) / 2))
| loop_claim : forall c, kcell c = kra (KStmt sum_loop)
                                  (kra (KStmt (SReturn (EVar "s"))) kdot) ->
    forall nv sv m, store c ~=
      ("n" s|-> KInt nv :* "s" s|-> KInt sv :* m) ->
    (nv >= 0)%Z ->
    sum_spec c (returning c (sv + nv * (nv + 1) / 2))
.

Lemma sum_math nv :
   (nv * (nv + 1) / 2)%Z = (nv + (nv - 1) * (nv - 1 + 1) / 2)%Z.
Proof.
rewrite <- Z.div_add_l by auto with zarith.
apply f_equal2;ring.
Qed.

Lemma mult_sound : sound kstep sum_spec.
Proof.
simple_solver.
+ rewrite (sum_math nv) by auto with zarith; simple_run.
+ replace nv with 0%Z by auto with zarith; simple_run.
Qed.


Require Import String.
Require Import ZArith.
Require Import imp.

Local Open Scope Z.
Import List.ListNotations.
Local Open Scope list.
Local Open Scope string.

(** An execution trace is a sequence of zero or more steps.
    We will take the reflexive-transitive closure of the step
    relation using the library type clos_refl_trans_1n *)
Import Relation_Operators.

(** Execution tests can be written as a theorem claiming that
    an initial state reaches an expected final state *)
Lemma test_execution :
  clos_refl_trans_1n _ step_p (sum_pgm 100,[]) (pgm nil skip,[("sum",5050);("n",0)]).
Proof.
  Time repeat (eapply rt1n_trans;[once solve[repeat econstructor]|];simpl).
  apply rt1n_refl.
Time Qed.

(** The final state can also be filled in by the search.
    This statement uses a sort of existential quantification over the
    final environment e2 *)
Lemma test_execution2 :
  {e2:Env | clos_refl_trans_1n _ step_p (sum_pgm 100,[]) (pgm nil skip,e2)}.
Proof.
  eexists.
  Time repeat (eapply rt1n_trans;[once solve[repeat econstructor]|simpl]).
  apply rt1n_refl.
Time Defined.

(** The final environment can be extracted from this trace *)
Eval simpl in proj1_sig test_execution2.


(********************************************************************)
(*                                                                  *)
(*  The Why3 Verification Platform   /   The Why3 Development Team  *)
(*  Copyright 2010-2017   --   INRIA - CNRS - Paris-Sud University  *)
(*                                                                  *)
(*  This software is distributed under the terms of the GNU Lesser  *)
(*  General Public License version 2.1, with the special exception  *)
(*  on linking described in file LICENSE.                           *)
(*                                                                  *)
(********************************************************************)

(* This file is generated by Why3's Coq-realize driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.
Require HighOrd.
Require int.Int.

(* Why3 goal *)
Definition seq : forall (a:Type), Type.
intro a.
exact (list a).
Defined.

Global Instance seq_WhyType : forall (a:Type) {a_WT:WhyType a}, WhyType (seq a).
Proof.
intros a a_WT.
split.
exact (@nil a).
destruct a_WT.
decide equality.
Qed.

(* Why3 goal *)
Definition length: forall {a:Type} {a_WT:WhyType a}, (seq a) -> Z.
intros a a_WT.
exact (fix len l := match l with
  | nil => 0 | cons _ t => 1 + len t end)%Z.
Defined.

Hint Unfold length.

(* Why3 goal *)
Lemma length_nonnegative : forall {a:Type} {a_WT:WhyType a}, forall (s:(seq
  a)), (0%Z <= (length s))%Z.
intros a a_WT.
induction s.
auto with *.
unfold length. fold length. omega.
Qed.

(* Why3 goal *)
Definition empty: forall {a:Type} {a_WT:WhyType a}, (seq a).
intros a a_WT.
exact nil.
Defined.

(* Why3 goal *)
Lemma empty_length : forall {a:Type} {a_WT:WhyType a}, ((length (empty : (seq
  a))) = 0%Z).
intros a a_WT.
auto with *.
Qed.

(* Why3 goal *)
Definition get: forall {a:Type} {a_WT:WhyType a}, (seq a) -> Z -> a.
intros a (default, _) s i.
exact ((fix nth n l := match l with
  | nil => default
  | cons h t => if Zeq_bool n 0%Z then h else nth (n - 1)%Z t end) i s).
Defined.

(* Why3 goal *)
Definition set: forall {a:Type} {a_WT:WhyType a}, (seq a) -> Z -> a -> (seq
  a).
admit.
Admitted.

(* Why3 goal *)
Lemma set_def1 : forall {a:Type} {a_WT:WhyType a}, forall (s:(seq a)) (i:Z)
  (v:a), ((0%Z <= i)%Z /\ (i < (length s))%Z) -> ((length (set s i
  v)) = (length s)).
intros a a_WT s i v (h1,h2).
admit.
Admitted.

(* Why3 goal *)
Lemma set_def2 : forall {a:Type} {a_WT:WhyType a}, forall (s:(seq a)) (i:Z)
  (v:a), ((0%Z <= i)%Z /\ (i < (length s))%Z) -> ((get (set s i v) i) = v).
intros a a_WT s i v (h1,h2).
admit.
Admitted.

(* Why3 goal *)
Lemma set_def3 : forall {a:Type} {a_WT:WhyType a}, forall (s:(seq a)) (i:Z)
  (v:a), ((0%Z <= i)%Z /\ (i < (length s))%Z) -> forall (j:Z),
  ((0%Z <= j)%Z /\ (j < (length s))%Z) -> ((~ (j = i)) -> ((get (set s i v)
  j) = (get s j))).
intros a a_WT s i v (h1,h2) j (h3,h4) h5.
admit.
Admitted.

(* Why3 assumption *)
Definition infix_eqeq {a:Type} {a_WT:WhyType a} (s1:(seq a)) (s2:(seq
  a)): Prop := ((length s1) = (length s2)) /\ forall (i:Z), ((0%Z <= i)%Z /\
  (i < (length s1))%Z) -> ((get s1 i) = (get s2 i)).

Notation "x == y" := (infix_eqeq x y) (at level 70, no associativity).

Lemma length_nonneg:
  forall {a:Type} {a_WT:WhyType a} (s: seq a), (0 <= length s)%Z.
induction s.
auto with *.
unfold length. fold length. omega.
Qed.

(* Why3 goal *)
Lemma extensionality : forall {a:Type} {a_WT:WhyType a}, forall (s1:(seq a))
  (s2:(seq a)), (infix_eqeq s1 s2) -> (s1 = s2).
intros a a_WT.
induction s1.
inversion 1.
destruct s2; auto.
unfold length in H0. fold length in H0.
generalize (length_nonneg s2); omega.
destruct s2.
inversion 1.
unfold length in H0. fold length in H0.
generalize (length_nonneg s1); omega.
inversion 1.
apply f_equal2.
assert (h: (0 <= 0 < length (a0 :: s1)%list)%Z).
unfold length. fold length.
generalize (length_nonneg s1); omega.
generalize (H1 0%Z h); clear H1.
unfold get. destruct a_WT. auto.
apply IHs1.
split.
unfold length in H0. fold length in H0. omega.
intros i hi.
assert (h: (0 <= i+1 < length (a0 :: s1)%list)%Z).
unfold length. fold length. omega.
generalize (H1 (i+1)%Z h); clear H1.
unfold get. destruct a_WT.
assert (Zeq_bool (i+1) 0 = false).
generalize (Zeq_is_eq_bool (i+1) 0).
case (Zeq_bool (i+1) 0); intuition.
omega.
destruct (Zeq_bool (i+1) 0).
discriminate H1.
replace (i+1-1)%Z with i by omega.
auto.
Qed.

(* Why3 goal *)
Definition cons: forall {a:Type} {a_WT:WhyType a}, a -> (seq a) -> (seq a).
intros a aWT x l.
exact (cons x l).
Defined.

(* Why3 goal *)
Lemma cons_length : forall {a:Type} {a_WT:WhyType a}, forall (x:a) (s:(seq
  a)), ((length (cons x s)) = (1%Z + (length s))%Z).
intros a a_WT x s.
unfold length, cons. fold length; auto.
Qed.

(* Why3 goal *)
Lemma cons_get : forall {a:Type} {a_WT:WhyType a}, forall (x:a) (s:(seq a))
  (i:Z), ((0%Z <= i)%Z /\ (i <= (length s))%Z) -> (((i = 0%Z) ->
  ((get (cons x s) i) = x)) /\ ((~ (i = 0%Z)) -> ((get (cons x s) i) = (get s
  (i - 1%Z)%Z)))).
intros a (d,eq) x s i hi.
split.
intro; subst i; now auto.

destruct s.
simpl in hi. intro. absurd (i=0)%Z; omega.
intro h.
unfold get at 1.
simpl ((fix nth (n : int) (l : list a) {struct l} : a :=
   match l with
   | nil => d
   | (h0 :: t)%list => if Zeq_bool n 0 then h0 else nth (n - 1)%Z t
   end) i (cons x (a0 :: s)%list)).
destruct (Zeq_bool i 0) eqn:? in *.
generalize (Zeq_bool_eq _ _ Heqb). now intuition.
auto.
Qed.

(* Why3 goal *)
Definition snoc: forall {a:Type} {a_WT:WhyType a}, (seq a) -> a -> (seq a).
intros a aWT s x.
exact (s ++ List.cons x nil)%list.
Defined.

Open Scope list_scope.
Open Scope Z_scope.

Lemma length_append:
  forall {a:Type} {a_WT:WhyType a} s1 s2, length (s1 ++ s2) = length s1 + length s2.
induction s1.
auto.
intro s2. simpl ((a0 :: s1) ++ s2).
unfold length; fold length.
rewrite IHs1; omega.
Qed.

(* Why3 goal *)
Lemma snoc_length : forall {a:Type} {a_WT:WhyType a}, forall (s:(seq a))
  (x:a), ((length (snoc s x)) = (1%Z + (length s))%Z).
intros.
unfold snoc.
rewrite length_append.
simpl (length (x::nil)). omega.
Qed.

(* Why3 goal *)
Lemma snoc_get : forall {a:Type} {a_WT:WhyType a}, forall (s:(seq a)) (x:a)
  (i:Z), ((0%Z <= i)%Z /\ (i <= (length s))%Z) -> (((i < (length s))%Z ->
  ((get (snoc s x) i) = (get s i))) /\ ((~ (i < (length s))%Z) ->
  ((get (snoc s x) i) = x))).
admit.
(*
intros a a_WT (l, d) x i (h1,h2).
split; intros.
unfold mixfix_lbrb.
unfold default, elts; simpl; auto.
unfold length in *; simpl in *.
apply List.app_nth1.
rewrite <- (Zabs2Nat.id (Datatypes.length l)).
apply Zabs_nat_lt. omega.
unfold mixfix_lbrb.
unfold default, elts; simpl; auto.
unfold length in *; simpl in *.
assert (i = Z.of_nat (Datatypes.length l)).
omega.
rewrite List.app_nth2.
replace (Z.abs_nat i - Datatypes.length l) with O.
auto.
subst i.
rewrite (Zabs2Nat.id (Datatypes.length l)). omega.
subst i.
rewrite (Zabs2Nat.id (Datatypes.length l)). omega.
*)
Admitted.

(* Why3 goal *)
Lemma snoc_last : forall {a:Type} {a_WT:WhyType a}, forall (s:(seq a)) (x:a),
  ((get (snoc s x) (length s)) = x).
intros a a_WT s x.
Admitted. (* TODO *)

(* Why3 goal *)
Definition mixfix_lb_dtdt_rb: forall {a:Type} {a_WT:WhyType a}, (seq a) ->
  Z -> Z -> (seq a).

Admitted. (* TODO *)

(* Why3 goal *)
Lemma sub_length : forall {a:Type} {a_WT:WhyType a}, forall (s:(seq a)) (i:Z)
  (j:Z), ((0%Z <= i)%Z /\ ((i <= j)%Z /\ (j <= (length s))%Z)) ->
  ((length (mixfix_lb_dtdt_rb s i j)) = (j - i)%Z).
intros a a_WT s i j (h1,(h2,h3)).

Admitted. (* TODO *)

(* Why3 goal *)
Lemma sub_get : forall {a:Type} {a_WT:WhyType a}, forall (s:(seq a)) (i:Z)
  (j:Z), ((0%Z <= i)%Z /\ ((i <= j)%Z /\ (j <= (length s))%Z)) ->
  forall (k:Z), ((0%Z <= k)%Z /\ (k < (j - i)%Z)%Z) ->
  ((get (mixfix_lb_dtdt_rb s i j) k) = (get s (i + k)%Z)).
intros a a_WT s i j (h1,(h2,h3)) k (h4,h5).

Admitted. (* TODO *)

(* Why3 assumption *)
Definition mixfix_lb_dtdtrb {a:Type} {a_WT:WhyType a} (s:(seq a)) (i:Z): (seq
  a) := (mixfix_lb_dtdt_rb s i (length s)).

(* Why3 goal *)
Definition infix_plpl: forall {a:Type} {a_WT:WhyType a}, (seq a) -> (seq
  a) -> (seq a).
intros a aWT s1 s2.
exact (s1 ++ s2)%list.
Defined.

(* Why3 goal *)
Lemma concat_length : forall {a:Type} {a_WT:WhyType a}, forall (s1:(seq a))
  (s2:(seq a)), ((length (infix_plpl s1
  s2)) = ((length s1) + (length s2))%Z).
admit.
(*
intros a a_WT s1 s2.
unfold length, infix_plpl.
rewrite List.app_length.
rewrite Nat2Z.inj_add. auto.
*)
Admitted.

(* Why3 goal *)
Lemma concat_get1 : forall {a:Type} {a_WT:WhyType a}, forall (s1:(seq a))
  (s2:(seq a)) (i:Z), ((0%Z <= i)%Z /\ (i < (length s1))%Z) ->
  ((get (infix_plpl s1 s2) i) = (get s1 i)).
intros a a_WT s1 s2 i (h1,h2).

Admitted. (* TODO *)

(* Why3 goal *)
Lemma concat_get2 : forall {a:Type} {a_WT:WhyType a}, forall (s1:(seq a))
  (s2:(seq a)) (i:Z), (((length s1) <= i)%Z /\
  (i < ((length s1) + (length s2))%Z)%Z) -> ((get (infix_plpl s1 s2)
  i) = (get s2 (i - (length s1))%Z)).
intros a a_WT s1 s2 i (h1,h2).

Admitted. (* TODO *)

Fixpoint enum {a:Type} (f: Z -> a) (start: Z) (n: nat) : seq a :=
  match n with
  | O => nil
  | S p => (f start :: enum f (start+1)%Z p)%list end.

(* Why3 goal *)
Definition create: forall {a:Type} {a_WT:WhyType a}, Z -> (Z -> a) -> (seq
  a).
intros a a_WT n f.
exact (if Zlt_bool n 0 then nil else enum f 0%Z (Zabs_nat n)).
Defined.

Lemma enum_length:
  forall {a:Type} {a_WT:WhyType a} (f: Z -> a) n start,
  length (enum f start n) = Z.of_nat n.
induction n; intros.
now auto.
unfold enum. fold (enum f).
unfold length. fold length.
rewrite IHn.
rewrite Nat2Z.inj_succ. auto with *.
Qed.

(* Why3 goal *)
Lemma create_length : forall {a:Type} {a_WT:WhyType a}, forall (len:Z)
  (f:(Z -> a)), (0%Z <= len)%Z -> ((length (create len f)) = len).
intros a a_WT len f h1.
unfold create.
generalize (Z.ltb_lt len 0).
destruct (Zlt_bool len 0) eqn:?.
intuition.
intros _. clear Heqb.
rewrite enum_length.
rewrite Zabs2Nat.abs_nat_nonneg.
apply Z2Nat.id; auto.
assumption.
Qed.

(* Why3 goal *)
Lemma create_get : forall {a:Type} {a_WT:WhyType a}, forall (len:Z) (f:(Z ->
  a)) (i:Z), ((0%Z <= i)%Z /\ (i < len)%Z) -> ((get (create len f) i) = (f
  i)).
intros a a_WT len f i (h1,h2).

Admitted. (* TODO *)

(* Unused content named mixfix_lbrb
intros a (default, _) s i.
exact ((fix nth n l := match l with
  | nil => default
  | cons h t => if Zeq_bool n 0%Z then h else nth (n - 1)%Z t end) i s).
Defined.
 *)


(**************************************************
 * Author: Ana Nora Evans (ananevans@virginia.edu)
 **************************************************)
Require Import List.

Require Import Coq.Structures.Equalities.
Require Import Coq.Strings.String.
Require Import Coq.NArith.BinNat.
Require Import Coq.PArith.BinPos.

Require Import Coq.FSets.FMapAVL.
Require Import Coq.FSets.FMapFacts.
Require Import Coq.Structures.OrdersEx.
Require Import Coq.Structures.OrdersAlt.

Set Implicit Arguments.
Set Contextual Implicit.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Require Import extructures.ord.

Module N_as_OT := Backport_OT N_as_OT.
Module BinNatMap := FMapAVL.Make(N_as_OT).
Module BinNatMapExtra := WProperties_fun N_as_OT BinNatMap.
Module BinNatMapFacts := BinNatMapExtra.F.

Module backPositive_as_OT := Backport_OT Positive_as_OT.
Module PMap := FMapAVL.Make backPositive_as_OT.
Module PMapExtra := WProperties_fun Positive_as_OT PMap.
Module PMapFacts := PMapExtra.F.

Module backNat_as_OT := Backport_OT Nat_as_OT.
Module NatMap := FMapAVL.Make backNat_as_OT.
Module NatMapExtra := WProperties_fun backNat_as_OT NatMap.
Module NatMapFacts := NatMapExtra.F.

Module ListUtil.

  (* TODO: I would like to avoid passing eqb *)
  (* AAA: This can be fixed by using fmap in CoqUtils *)
  Fixpoint get_by_key {K V:Type} (eqb : K->K->bool) (k : K)
           (l : list (K*V)) : option V :=
    match l with
    | nil  => None
    | (k1,v1)::ls =>
     if (eqb k k1) then (Some v1)
     else (get_by_key eqb k ls)
    end.

End ListUtil.

Require Import Ascii.

Module Log.

  Open Scope char_scope.

  Definition natToDigit (n : nat) : Ascii.ascii :=
    match n with
    | 0 => "0"
    | 1 => "1"
    | 2 => "2"
    | 3 => "3"
    | 4 => "4"
    | 5 => "5"
    | 6 => "6"
    | 7 => "7"
    | 8 => "8"
    | _ => "9"
  end.

Close Scope char_scope.

  Definition log_nat (n : nat) : string :=
  let fix log_nat_aux (time n : nat) (acc : string) : string :=
      let acc' := String (natToDigit (Nat.modulo n 10)) acc in
      match time with
      | 0 => acc'
      | S time' =>
        match Nat.div n 10 with
        | 0 => acc'
        | n' => log_nat_aux time' n' acc'
        end
      end in
  log_nat_aux n n EmptyString.

  Definition log_N (n : N) : string :=
    log_nat (N.to_nat n).

   Definition log_pos (n : positive) : string :=
    log_nat (Pos.to_nat n).

End Log.


(** * 귀납법: 귀납적 증명 *)

(** 시작하기 전에 이전 장의 모든 정의들을 불러올 필요가 있다. *)

Require Export Basics.

(** [Require Export]가 동작하려면 [coqc]를 사용하여 [Basics.v]를
    [Basics.vo]로 우선 컴파일할 필요가 있다. .java 파일에서 .class
    파일을 만들거나 .c 파일에서 .o 파일을 만드는 것과 비슷하다. 이렇게
    컴파일하는 방법이 두 가지가 있다.

     - CoqIDE:

         [Basics.v]를 열고, "컴파일" 메뉴에서 "컴파일 버퍼"를 클릭한다.

         (주의: "-R LF"을 고려하도록 이 명령어들을 업데이트할 필요가
         있다.  CoqIDE 전문가 중에 이것을 어떻게 하는지 얘기해 줄 수
         있나요?)

     - 명령어:

         [make Basics.vo]

   문제가 있으면 (예를 들어, 콕 파일에서 나중에 식별자를 못찾는 것과
   같은) 콕에서 "load path"가 적절히 설정되지 않았기 때문일 수도 있다.
   [Print LoadPath.] 명령어는 이런 문제들을 해결하는데 도움이 될 수
   있다. *)

(* ################################################################# *)
(** * 귀납적 증명 *)

(** 지난 장에서 간략화 방법으로 쉽게 [0]이 [+]의 왼편 중립 원소라는
    것을 증명했다. _오른편_ 중립 원소이기도 함을 ...  *)

Theorem plus_n_O_firsttry : forall n:nat,
  n = n + 0.

(** ... 똑같이 간단하게 증명할 수 없다는 것을 보기도 하였다. 왜냐하면
    [n + 0]에서 [n]은 임의의 알려지지 않은 숫자이기 때문에 단순히
    [reflexivity]를 적용하는 것으로 증명되지 않는다. 그래서 [+] 정의에
    있는 [match]를 간략화시킬 수 없다. *)

Proof.
  intros n.
  simpl. (* 아무것도 하지 않는다! *)
Abort.

(** [destruct n]을 사용하여 가능한 경우들로 나누어도 더 진전할 수
    없다.  [n = 0]을 가정하는 경우의 분석 쪽은 증명할 수 있다. 어떤
    [n']의 [n = S n']인 경우에 똑같이 막힌다. *)

Theorem plus_n_O_secondtry : forall n:nat,
  n = n + 0.
Proof.
  intros n. destruct n as [| n'].
  - (* n = 0 *)
    reflexivity. (* 여기까지는 괜찮다... *)
  - (* n = S n' *)
    simpl.       (* ...하지만 여기에서 다시 막힌다. *)
Abort.

(** 한 단계 나아가기 위해 [destruct n']을 사용할 수도 있지만 [n]은
    임의로 큰 숫자일 수 있기 때문에 이렇게 그냥 진행하면 증명이 결코
    끝나지 않을 것이다. *)

(** 숫자, 리스트, 다른 귀납적 집합들에 대한 흥미로운 사실들을 증명하기
    위해 보통 더 강력한 추론 원리 _귀납법_이 필요하다.

    (고등학교부터, 이산수학 강의 등) _자연수에 대한 귀납법 원리_를
    떠올려 보자.  [P(n)]이 자연수 [n]을 사용하는 어떤 명제이고 모든
    [n]에 대해 [P]가 성립한다고 보이고 싶다면 이렇게 추론할 수 있다.
    - [P(O)]이 성립한다고 보인다.  - 어떤 [n']에 대해 [P(n')]이
    성립하면 [P(S n')]도 성립한다고 보인다.  - 모든 [n]에 대해 [P(n)]이
    성립한다고 결론 내린다.

    콕에서 증명 방법은 동일하다. 모든 [n]에 대해 [P(n)]을 증명하는
    목적을 가지고 시작하고 ([induction] 전술을 적용해서) 두 가지 분리된
    부분 목적들로 나눈다.  하나는 [P(O)]를 증명하는 것이고, 다른 하나는
    [P(n') -> P(S n')]을 증명하는 것이다. 이 방법이 다음 정리에 대해
    어떻게 작동하는지 보자.  *)

Theorem plus_n_O : forall n:nat, n = n + 0.
Proof.
  intros n. induction n as [| n' IHn'].
  - (* n = 0 *)    reflexivity.
  - (* n = S n' *) simpl. rewrite <- IHn'. reflexivity.  Qed.

(** [destruct]처럼, [induction] 전술은 부분 목적들에 도입한 변수
    이름들을 지정하는 [as...] 절을 받는다. 두 개의 부분 목적들이 있기
    때문에 [as...] 절에 [|]로 분리된 두 부분들이 있다. (엄밀히 말하면
    [as...] 절을 생략할 수 있고 콕이 우리 대신 이름들을 선택할
    것이다. 콕이 자동으로 지어준 이름들은 혼돈스러운 경향이 있기 때문에
    실제로 절을 생략하는 것은 좋지 않다.)

    첫 번째 부분 목적에서 [n]은 [0]으로 바꾼다. ([as...]의 처음 부분은
    비어있기 때문에) 새로운 변수들을 도입하지 않는다. 그리고 목적은 [0
    = 0 + 0]이 되고 간략화를 적용하면 증명을 마칠 수 있다.

    두 번째 부분 목적에서 [n]은 [S n']으로 바꾸고, [n' + 0 = n'] 가정을
    현재 문맥에 추가하고 [IHn'] (즉, [n']에 대한 귀납 가정) 이름을
    붙인다. [n']과 [IHn'] 이 두 이름들은 [as...] 절의 두 번째 부분에
    지정되어 있다. 이 경우 부분 목적은 [S n' = (S n') + 0]이 되고 [S
    n' = S (n' + 0)]으로 간략화시킬 수 있는데 [IHn']으로부터 유추할
    수 있다. *)

Theorem minus_diag : forall n,
  minus n n = 0.
Proof.
  (* WORKED IN CLASS *)
  intros n. induction n as [| n' IHn'].
  - (* n = 0 *)
    simpl. reflexivity.
  - (* n = S n' *)
    simpl. rewrite -> IHn'. reflexivity.  Qed.

(** (이 증명들에서 [intros] 전술은 사실 중복 사용된 것이다. 한정
    변수들을 포함하는 목적에 [induction] 전술을 적용할 때 필요한 만큼
    그 변수들을 자동으로 현재 문맥에 도입하기 때문이다.) *)

(** **** 연습문제: 별 두 개, 추천 (basic_induction)  *)
(** 귀납법을 사용하여 다음을 증명하라. 이전에 증명한 결과들을 필요로
    할 수도 있다. *)

Theorem mult_0_r : forall n:nat,
  n * 0 = 0.
Proof.
  (* 여기를 채우시오 *) Admitted.

Theorem plus_n_Sm : forall n m : nat,
  S (n + m) = n + (S m).
Proof.
  (* 여기를 채우시오 *) Admitted.

Theorem plus_comm : forall n m : nat,
  n + m = m + n.
Proof.
  (* 여기를 채우시오 *) Admitted.

Theorem plus_assoc : forall n m p : nat,
  n + (m + p) = (n + m) + p.
Proof.
  (* 여기를 채우시오 *) Admitted.
(** [] *)

(** **** 연습문제: 별 두 개 (double_plus)  *)
(** 인자를 두 배로 늘리는 다음 함수를 고려하시오: *)

Fixpoint double (n:nat) :=
  match n with
  | O => O
  | S n' => S (S (double n'))
  end.

(** 귀납법을 사용하여 [double]에 대한 간단한 사실을 증명하시오: *)

Lemma double_plus : forall n, double n = n + n .
Proof.
  (* 여기를 채우시오 *) Admitted.
(** [] *)

(** **** 연습문제: 별 두 개, 선택사항 (evenb_S)  *)
(** [evenb n] 정의에서 [n-2]에 대한 재귀 함수 호출은 불편한 점이
    있다. [n]에 대한 귀납법으로 [evenb n]에 대해 증명할 때 더 어렵게
    만들다. 왜냐하면 [n - 2]에 대한 귀납적 가정을 필요로 할 수 있기
    때문이다. 다음 보조 정리는 귀납법을 더 활용하기 쉬운 다른 형태의
    [evenb (S n)]의 성질을 제공한다. *)

(* Theorem evenb_S : forall n : nat, *)
(*   evenb (S n) = negb (evenb n). *)
(* Proof. *)
(*   (* 여기를 채우시오 *) Admitted. *)
(* (** [] *) *)

(** **** 연습문제: 별 한 개 (destruct_induction)  *)
(** [destruct] 전술과 [induction] 전술의 차이를 간략히 설명하시오.

(* 여기를 채우시오 *)
*)
(** [] *)

(* ################################################################# *)
(** * 증명 안에서 증명하기 *)

(** 콕에서도 비공식적인 수학에서와 같이 커다란 증명들은 일련의
    정리들로 종종 나누어 나중에 증명할 때 이전에 증명해놓은 정리들을
    참고하곤 한다. 하지만 때때로 증명하는 중에 너무 사소하고
    일반적이지 않고 너무 특별한 잡다한 사실이 필요하면 맨 상위 수준의
    이름을 붙이는 것이 꺼려진다. 그러한 경우에 필요한 곳에 필요한
    "부분 정리"를 간단히 기술하고 증명하는 것이 편리하다.
    [assert] 전술은 이런 것을 하도록 해준다. 예를 들어 이전에 [mult_0_plus] 정리를
    증명하면 이전 정리 [plus_0_n]을 참조한다. 그 자리에서 [plus_0_n]을 서술하고 증명하는
    대신 [assert]를 사용할 수 있다. *)

Theorem mult_0_plus' : forall n m : nat,
  (0 + n) * m = n * m.
Proof.
  intros n m.
  assert (H: 0 + n = n). { reflexivity. }
  rewrite -> H.
  reflexivity.  Qed.

(** [assert] 전술은 두 개의 부분 목적들을 도입한다. 첫 번째 부분
    목적은 선언한 명제 그 자체이다. 그 전술에 [H:]를 뒤이어 주어 그
    명제를 [H]로 이름 짓는다. ([destruct]와 [induction] 전술을 이 전에
    사용했을 때처럼 [as]를 가지고 명제 이름을 지을 수도 있다. [assert
    (0 + n = n) as H].) 이 명제의 증명을 중괄호 [{ ... }]로 감싸는
    것을 확인하시오. 이것은 콕을 대화식으로 사용할 때 이 부분 증명을
    끝냈을 때를 더 쉽게 볼 수 있게 하는 가독성을 위한 것이다. 두 번째
    목적은 [assert]를 실행한 지점에서의 목적과 동일한 것이다. 다만 [0
    + n = n]이라는 가정 [H]를 이제 이 문맥에서 활용할 수 있다는 점이
    차이가 있다. 즉, [assert]는 선언한 명제를 증명해야 하는 부분
    목적과 선언한 명제를 사용하여 증명하고자 했던 것을 진행하기 위한
    두 번째 부분 목적을 생성한다. *)

(** [assert]의 다른 예제... *)

(** 예를 들어, [(n + m) + (p + q) = (m + n) + (p + q)]을 증명한다고
    가정하자.  [=]의 양쪽에서 유일한 차이점은 첫 번째 [+]의 [m]과 [n]
    인자들이 뒤집혀있어서 덧셈의 교환 법칙([plus_comm])을 사용해서 한
    쪽을 다른 쪽으로 다시 작성할 수 있을 것처럼 보인다. 하지만
    [rewrite] 전술은 그다지 영리하지 않아서 _어디에_ 이 전술을
    적용할지 모른다. [+]을 세 군데에서 사용하는데 [rewrite ->
    plus_comm]은 _바깥쪽_ 덧셈에만 적용될 것이다... *)

Theorem plus_rearrange_firsttry : forall n m p q : nat,
  (n + m) + (p + q) = (m + n) + (p + q).
Proof.
  intros n m p q.
  (* (n + m)을 (m + n)으로 뒤집기만 하면 된다...
     plus_comm 정리를 적용하면 될 것처럼 보인다! *)
  rewrite -> plus_comm.
  (* 제대로 적용되지 않는다... 콕은 다른 덧셈에 적용했다!  *)
Abort.

(** 필요한 지점에 [plus_comm]을 사용하려면 (여기에서 다루는 특별한 [m]과 [n]에 대해)
    내부적으로 보조 정리 [n + m = m + n]을 도입해서 [plus_comm]으로 증명하면
    원하는 곳에 [plus_comm]을 사용한다. *)

Theorem plus_rearrange : forall n m p q : nat,
  (n + m) + (p + q) = (m + n) + (p + q).
Proof.
  intros n m p q.
  assert (H: n + m = m + n).
  { rewrite -> plus_comm. reflexivity. }
  rewrite -> H. reflexivity.  Qed.

(* ################################################################# *)
(** * 형식적 증명 대 비형식적 증명 *)

(** "_비형식적 증명은 알고리즘이고; 형식적 증명은 코드다_." *)

(** 수학적 주장의 성공적인 증명이란 무엇인가? 이 질문은 천 년간
    철학자들이 품어온 질문이다.  하지만 대략적으로 준비된 정의는 이럴
    수 있다. 수학적 명제 [P]의 증명은 독자나 청자에게 [P]가 확실히
    사실 임([P]의 참에 대한 논쟁의 여지가 없음)을 주입시키는 글로
    작성하거나 말로 설명하는 텍스트이다. 즉, 증명은 커뮤니케이션
    행위이다.

    커뮤니케이션 행위는 다른 종류의 독자들과 관여할 수 있다. 한편으로
    이 "독자"는 콕과 같은 프로그램으로 이런 경우 "믿음"이 주입되는
    방식이란 [P]를 어떤 형식적인 논리 규칙들로부터 기계적으로 유도될
    수 있다는 것이다. 그리고 이 증명은 이 사실을 검사하는데 있어서 이
    프로그램을 가이드하는 수단이다. 그러한 수단이 _형식적_ 증명이다.

    또 다른 각도에서 보면, 독자는 사람이 될 수 있고, 영어나 어떤 다른
    자연어로 증명을 작성할 수 있다. 따라서 반드시 _비형식적_이 될
    것이다. 여기서 성공에 대한 기준은 다소 명확하지 않게
    정해진다. "유효한" 증명은 독자가 [P]를 믿게 만드는 것이다.  하지만
    동일한 증명을 읽은 많은 다른 독자들 중에 일부는 주장을 설명하는
    특별한 방법으로 설득될 수 있고 다른 사람들은 그렇지 않을 수도
    있다. 어떤 독자들은 특별히 현학적이거나, 경험이 부족하거나 단지
    단순히 아둔할 수 있다. 그들을 설득하는 유일한 방법은 매우 고심해서
    상세하게 주장을 펼치는 것이다. 하지만 다른 독자들은 이 분야에 더
    익숙해서 모든 이 상세 내용으로 압도당해서 전체적인 주제를 잃을
    수도 있다. 그들이 원하는 것은 주요 아이디어들을 듣는 것이다.
    자세한 내용을 글로 작성하여 설명하며 진행하기보다 그들 스스로 상세
    사항들을 채우는 것이 더 쉬울 수 있기 때문이다. 궁극적으로 일반적인
    척도는 없다. 왜냐하면 생각할 수 있는 모든 독자를 설득할 수 있는
    비형식적 증명을 작성하는 방법이 유일하지 않기 때문이다.

    하지만 실제 상황에서 수학은 풍부한 관습들과 관용어구들을 개발해서
    복잡한 수학 대상들에 대해 글로 작성하는 것을 가능하게
    만들었다. 적어도 특정 커뮤니티 내에서는 커뮤니케이션을 꽤 잘할 수
    있다. 이러한 스타일의 커뮤니케이션 관습들은 증명이 좋은가 나쁜가를
    판단하는 꽤 분명한 척도를 제공한다.

    이 강의에서 우리는 콕을 사용하기 때문에 형식적 증명들에 대해 열심히
    공부할 것이다. 하지만 비형식적 증명들을 완전히 잊어버릴 수는 없다!
    형식적 증명은 다양한 방법에서 유용하지만 사람들이 아이디어를 교환하는데
    _그다지_ 효과적이지 않다. *)

(** 예를 들어, 덧심이 결합성을 갖음을 보이는 증명이 있다. *)

Theorem plus_assoc' : forall n m p : nat,
  n + (m + p) = (n + m) + p.
Proof. intros n m p. induction n as [| n' IHn']. reflexivity.
  simpl. rewrite -> IHn'. reflexivity.  Qed.

(** 콕은 이 증명을 완벽하다고 여길 것이다. 하지만 사람에게는
    증명의 의도를 파악하기 어렵다. 주석들과 구분점들을 사용하여
    조금 더 분명하게 구조를 보여줄 수 있다... *)

Theorem plus_assoc'' : forall n m p : nat,
  n + (m + p) = (n + m) + p.
Proof.
  intros n m p. induction n as [| n' IHn'].
  - (* n = 0 *)
    reflexivity.
  - (* n = S n' *)
    simpl. rewrite -> IHn'. reflexivity.   Qed.

(** ... 그리고 만일 콕에 익숙하다면 증명에 사용한 전술들을 하나씩 마음 속으로
    따라가며 각각에서 문맥과 목적 스택이 어떤지 상상할 수 있다. 하지만
    증명이 조금 더 복잡하면 머릿속으로 증명 과정을 그려보는 것은 불가능할 것이다.

    (현학적인) 수학자는 이 증명을 다음과 같이 작성할 수도 있다. *)

(** - _Theorem_: 어떤 [n], [m], [p]에 대하여,

      n + (m + p) = (n + m) + p.

    _증명_: [n]에 관한 귀납법에 의하여.

    - 첫째, [n = 0]을 가정하자.  다음을 증명해야 한다.

        0 + (m + p) = (0 + m) + p.

      [+] 정의에 의해 위 명제가 바로 참이다.

    - 다음, [n = S n']을 가정하고, 아래와 같다.

        n' + (m + p) = (n' + m) + p.

      다음을 반드시 증명해야 한다.

        (S n') + (m + p) = ((S n') + m) + p.

      [+]의 정의에 의해, 위 명제는 아래 명제로 부터 증명 가능하다.

        S (n' + (m + p)) = S ((n' + m) + p),

      이 명제는 귀납적 가정에 의해 바로 참이다. _Qed_. *)

(** 이 증명의 전체적인 형태는 기본적으로 비슷하다. 그리고 이것은 물론
    우연히 아니다.  콕은 [induction] 전술은 동일한 부분 목적들을
    동일한 순서로 생성하도록 설계되었다.  마치 수학자가 작성하는 점
    표시들과 같다. 하지만 상세히 들여다보면 중요한 차이점들이
    있다. 형식적 증명은 어떤 면들에서 훨씬 더 명시적이다 (예를 들어,
    [reflexivity]를 사용하는 것과 같이) 하지만 다른 점에서는 훨씬 덜
    명시적이다 (특히 콕 증명에서 어떤 시점의 "증명 상태"는 완전히
    묵시적이지만 반면에 비형식적 증명은 독자로 하여금 현재 어느
    시점인가를 반복해서 독자에게 상기시킨다.) *)

(** **** 연습문제: 별 두 개, 고급, 추천 (plus_comm_informal)  *)
(** [plus_comm]을 증명한 것을 비형식적 증명으로 변환해보시오.

    Theorem: Addition is commutative.

    Proof: (* 여기를 채우시오 *)
*)
(** [] *)

(** **** 연습문제: 별 두 개, 선택 사항 (beq_nat_refl_informal)  *)
(** 다음 정리를 비형식적으로 증명하시오. [plus_assoc]에 대한 비형식적 증명을
    참고하시오. 콕 전술들을 영어로 바꾸기만 하는 방식을 사용하지 마시오!

    Theorem: [true = beq_nat n n] for any [n].

    Proof: (* 여기를 채우시오 *)
[] *)

(* ################################################################# *)
(** * 추가 연습문제들 *)

(** **** 연습문제: 별 세 개, 추천 (mult_comm)  *)
(** [assert]를 사용해서 다음 정리를 증명하시오. [plus_swap]에 대한
    귀납법을 사용할 필요가 없다.  *)

Theorem plus_swap : forall n m p : nat,
  n + (m + p) = m + (n + p).
Proof.
  (* 여기를 채우시오 *) Admitted.

(** 이제 곱셈의 교환법칙을 증명하시오. (증명할 때 별도의 보조 정리를
    정의해서 증명할 필요가 분명히 있을 것이다. [plus_swap]이
    유용하다는 것을 발견할 수도 있다.) *)

Theorem mult_comm : forall m n : nat,
  m * n = n * m.
Proof.
  (* 여기를 채우시오 *) Admitted.
(** [] *)

(** **** 연습문제: 별 세 개, 선택 사항 (more_exercises)  *)
(** 종이를 들어, 아래 정리들 각각에 대해 먼저 (a) 간략화와 다시
    작성하기만으로 증명할 수 있는지, (b) 경우를 나누어
    분석([destruct])을 또한 요구하는지, (c) 귀납법을 또한 요구하는지
    _생각_해보시오. 예상을 해본 다음 증명을 채워보시오. (작성한 종이를
    제출할 필요는 없다. 콕으로 증명하기 전에 생각해보는 연습을 권하기
    위한 것이다!) *)

Check leb.

Theorem leb_refl : forall n:nat,
  true = leb n n.
Proof.
  (* 여기를 채우시오 *) Admitted.

Theorem zero_nbeq_S : forall n:nat,
  beq_nat 0 (S n) = false.
Proof.
  (* 여기를 채우시오 *) Admitted.

Theorem andb_false_r : forall b : bool,
  andb b false = false.
Proof.
  (* 여기를 채우시오 *) Admitted.

Theorem plus_ble_compat_l : forall n m p : nat,
  leb n m = true -> leb (p + n) (p + m) = true.
Proof.
  (* 여기를 채우시오 *) Admitted.

Theorem S_nbeq_0 : forall n:nat,
  beq_nat (S n) 0 = false.
Proof.
  (* 여기를 채우시오 *) Admitted.

Theorem mult_1_l : forall n:nat, 1 * n = n.
Proof.
  (* 여기를 채우시오 *) Admitted.

Theorem all3_spec : forall b c : bool,
    orb
      (andb b c)
      (orb (negb b)
               (negb c))
  = true.
Proof.
  (* 여기를 채우시오 *) Admitted.

Theorem mult_plus_distr_r : forall n m p : nat,
  (n + m) * p = (n * p) + (m * p).
Proof.
  (* 여기를 채우시오 *) Admitted.

Theorem mult_assoc : forall n m p : nat,
  n * (m * p) = (n * m) * p.
Proof.
  (* 여기를 채우시오 *) Admitted.
(** [] *)

(** **** 연습문제: 별 두 개, 선택 사항 (beq_nat_refl)  *)
(** 다음 정리를 증명하시오. ([true]를 등식의 왼편에 놓은 것이 이상하게 보일 수도 있지만
    콕 표준 라이브러리에서 이 정리를 서술하는 형태이어서 따른 것이다. 다시 작성하는 방식을
    사용하면 어느 방향이든 똑같이 잘 적용된다. 그래서 어느 방식으로 서술하든 이 정리를
    사용하면 문제가 없을 것이다.) *)

Theorem beq_nat_refl : forall n : nat,
  true = beq_nat n n.
Proof.
  (* 여기를 채우시오 *) Admitted.
(** [] *)

(** **** 연습문제: 별 두 개, 선택 사항 (plus_swap')  *)
(** [replace] 전술로 다시 작성할 특정 부분 낱말을 지정할 수 있고
   무엇으로 다시 작성할지 지정할 수 있다. [replace (t)를 (u)]를 증명
   목적에 나타난 식 [t](의 모든 경우)를 식 [u]로 바꾸고, [t = u]를
   추가적으로 부분 목적으로 생성한다. 이것은 단순히 [rewrite]를
   적용했을 때 목적의 틀린 부분에 대해 적용될 때 종종 유용하다.

   [replace] 전술을 사용하여 마치 [plus_swap]에 대해서처럼
   [plus_swap']을 증명하시오.  이 경우 [assert (n + m = m + n)]이
   필요하지 않을 것이다.  *)

Theorem plus_swap' : forall n m p : nat,
  n + (m + p) = m + (n + p).
Proof.
  (* 여기를 채우시오 *) Admitted.
(** [] *)

(** **** 연습문제: 별 세 개, 추천 (binary_commute)  *)
(** [Basics] 장의 [binary] 연습문제에서 작성했던
    [incr]과 [bin_to_nat] 함수들을 가지고,
    다음 다이어그램이 어느 방향으로 가도 동일함을 증명하시오.
                            incr
              bin ----------------------> bin
               |                           |
    bin_to_nat |                           |  bin_to_nat
               |                           |
               v                           v
              nat ----------------------> nat
                             S

    즉, 이진수를 증가하고 (단항) 자연수로 변환하면 먼저 자연수로
    변환하고 증가시킨 것과 동일한 결과를 낸다는 것이다.
    [bin_to_nat_pres_incr] 정리 ("pres"는 "preserves"로 사용)에
    이름을 붙이시오.

    이 연습문제를 풀기 전에 당신의 연습문제 풀이의 정의들을 [binary]
    여기 연습문제로 복사해서 이 파일 자체로 채점할 수 있도록 하시오.
    원래 정의들을 변경해서 이 성질을 더 쉽게 증명하고 싶다면 자유롭게 그렇게
    진행하면 된다!
     *)

(* 여기를 채우시오 *)
(** [] *)

(** **** 연습문제: 별 다섯 개, 고급 (binary_inverse)  *)
(** 이 연습문제는 이진수들에 대한 이전 연습문제의 연장이다. 이
    연습문제를 풀기 위해서 거기에 있는 정의들과 정리들이 필요할
    것이다. 채점을 위해 이 파일에 다른 파일을 참조하지 않아도
    완전하도록 그것들을 이 파일에 복사하시오.

    (a) 첫째, 자연수를 이진수로 변환하는 함수를 작성하시오. 그다음
        어떤 자연수라도 이진수로 변환한 다음 다시 자연수로 변환하면
        동일한 자연수로 돌아온다는 것을 증명하시오.

    (b) 자연스럽게 반대 방향에 대해서도 증명해야 한다고 생각할 수 있다.
        이진수에서 시작해서 자연수로 변환하고 다시 이진수로 돌아가면
        동일한 이진수가 된다. 하지만 이 경우는 참이 아니다! 그 이유를
        설명하시오.

    (c) "직접" 정규화하는 함수를 정의하시오. 즉, 이진수를 이진수로
        매핑하는 함수 [normalize]는 어떠한 이진수 b를 자연수로
        변환하고 다시 이진수로 변환한다 [(normalize b)].  이 함수를
        이용하여 반대 방향의 정리를 증명하시오. (경고: 이 부분은
        신중해야 한다!)

    다시 말하는데, 여기서 증명하는데 도움이 된다면 이전 정의들을
    자유롭게 변경하시오.
*)

(* 여기를 채우시오 *)
(** [] *)

(** $Date: 2017-08-22 17:13:32 -0400 (Tue, 22 Aug 2017) $ *)


Require Import Util.Class.

Require Import List.
Import ListNotations.

Definition AssocList X Y := list (X * Y).

Fixpoint update_AL{X Y}`{Eq X}(x : X)(y : Y)(ps : AssocList X Y) :=
  match ps with
  | [] => []
  | (x',y')::qs => if x =dec x' then (x,y)::qs else (x',y')::(update_AL x y qs)
  end.

Definition updates_AL{X Y}`{Eq X} : list (X * Y) -> AssocList X Y -> AssocList X Y := fold_right (fun '(x,y) ps => update_AL x y ps).

Lemma In_map_cons{X Y} : forall (x x' : X)(y : Y)(qs : AssocList X Y), In x (map fst ((x',y)::qs)) -> x <> x' -> In x (map fst qs).
Proof.
  intros.
  simpl in H.
  destruct H.
  symmetry in H; contradiction.
  assumption.
Qed.

Fixpoint lookup_safe{X Y}`{Eq X}(x : X)(ps : AssocList X Y) : In x (map fst ps) -> Y :=
  match ps as ps return In x (map fst ps) -> Y with
  | [] => fun xIn => match in_nil xIn with end
  | (x',y)::qs => fun xIn => match x =dec x' with
                             | left _ => y
                             | right p => lookup_safe x qs (In_map_cons x x' y qs xIn p)
                             end
  end.

Fixpoint lookup{X Y}`{Eq X}(x : X)(ps : AssocList X Y) : option Y :=
  match ps with
  | [] => None
  | (x',y)::qs => if x =dec x' then Some y else lookup x qs
  end.