Require Import MapProofs.Common.
Set Bullet Behavior "Strict Subproofs".
Require Import MapProofs.Bounds.
Require Import MapProofs.Tactics.

Section WF.
Context {e : Type} {a : Type} {HEq : Eq_ e} {HOrd : Ord e} {HEqLaws : EqLaws e}  {HOrdLaws : OrdLaws e}.

(** ** Verification of [lookup] *)

Lemma lookup_spec:
 forall (s: Map e a) lb ub i, Bounded s lb ub -> lookup i s = sem s i.
Proof.
  intros ???? HB.
  induction HB.
  * simpl. reflexivity.
  * subst; simpl.
    destruct (compare i x) eqn:?.
    + replace (i == x) with true by order_Bounds e.
      rewrite (sem_outside_above HB1) by order_Bounds e.
      reflexivity.
    + replace (i == x) with false by order_Bounds e.
      rewrite IHHB1.
      rewrite (sem_outside_below HB2) by order_Bounds e.
      simpl_options.
      reflexivity.
    + replace (i == x) with false by order_Bounds e.
      rewrite IHHB2.
      rewrite (sem_outside_above HB1) by order_Bounds e.
      simpl_options.
      reflexivity.
Qed.

(** ** Verification of [member] *)

Lemma member_spec:
 forall (s: Map e a) lb ub i, Bounded s lb ub -> member i s = true <-> exists v, sem s i = Some v.
Proof.
  intros. induction H.
  - simpl. split. intros. discriminate H. intros. destruct H. discriminate H.
  - subst. simpl. destruct (compare i x) eqn: ?; split; intros.
    + replace (i==x) with true by order_Bounds e.
      rewrite (sem_outside_above H) by order_Bounds e.
      simpl. exists v. reflexivity.
    + reflexivity.
    + replace (i==x) with false by order_Bounds e.
      rewrite (sem_outside_below H0) by order_Bounds e.
      simpl_options. apply IHBounded1 in H3. destruct H3. exists x0. assumption.
    + assert (sem s2 i = None). { eapply sem_outside_below. apply H0. unfold isLB.
      order_Bounds e. }
      rewrite H5 in H3. assert (i == x = false). { rewrite compare_Lt in Heqc.
      apply lt_not_eq. assumption. } rewrite H6 in H3. simpl in H3. simpl_options.
      apply IHBounded1. destruct H3. exists x0. assumption.
    + replace (i==x) with false by order_Bounds e.
      rewrite (sem_outside_above H) by order_Bounds e.
      simpl. apply IHBounded2 in H3. destruct H3. exists x0. assumption.
    + assert (sem s1 i = None). { eapply sem_outside_above. apply H. order_Bounds e. }
      rewrite H5 in H3. rewrite compare_Gt in Heqc. apply gt_not_eq in Heqc. rewrite Heqc in H3.
      simpl_options. destruct H3. apply IHBounded2. exists x0. assumption.
Qed.

(** ** Verification of [notMember] *)

Lemma notMember_spec:
 forall (s: Map e a) lb ub i, Bounded s lb ub -> notMember i s = true <-> sem s i = None.
Proof.
  intros ???? HB.
  unfold notMember, op_zd__. split; intros.
  pose proof (@member_spec s lb ub i). apply H0 in HB. destruct HB. apply contrapositive in H2.
  unfold not in H2. destruct (sem s i). destruct H2. exists a0. reflexivity. reflexivity.
  rewrite negb_true_iff in H. intro. rewrite H3 in H. inversion H.
  pose proof (@member_spec s lb ub i). apply H0 in HB. destruct HB. apply contrapositive in H1.
  rewrite negb_true_iff. destruct (member i s). contradiction. reflexivity. intro.
  destruct H3. rewrite H3 in H. inversion H.
Qed.

(** ** Verification of [findWithDefault] *)
Lemma findWithDefault_spec:
  forall (m: Map e a) lb ub i v, Bounded m lb ub ->
  Some (findWithDefault v i m) = sem m i ||| Some v.
Proof.
  intros. induction H.
  - simpl. reflexivity.
  - simpl. destruct (compare i x) eqn : ?.
    + assert (sem s1 i = None). { eapply sem_outside_above. eassumption. solve_Bounds e. }
      rewrite H5. assert (i == x = true) by (order e). rewrite H6. reflexivity.
    + assert (i == x = false) by (order e). assert (sem s2 i = None). { eapply sem_outside_below.
      eassumption. solve_Bounds e. } rewrite H5. rewrite H6. simpl. rewrite oro_None_r.
      rewrite oro_None_r. apply IHBounded1.
    + assert (i == x = false) by (order e). assert (sem s1 i = None). { eapply sem_outside_above.
      eassumption. solve_Bounds e. } rewrite H5. rewrite H6. simpl. apply IHBounded2.
Qed.
(** ** Verification of [lookupLT] *)
Fixpoint goJustLT k  (k1: e) v1 (m : Map e a) : option (e * a) :=
  match m with
  | Tip => Some (k1, v1)
  | Bin sz k2 v2 l r => if (_GHC.Base.<=_ k k2) then goJustLT k k1 v1 l else
    goJustLT k k2 v2 r
  end.
Fixpoint lookupLT' k (m : Map e a) :=
  match m with
  | Tip => None
  | Bin sz k1 v1 l r => if (_GHC.Base.<=_ k k1) then lookupLT' k l else goJustLT k k1 v1 r
  end.

Lemma lookupLT_equiv:
  forall m k,
  lookupLT' k m = lookupLT k m.
Proof.
  intros. unfold lookupLT'. unfold lookupLT. unfold goJustLT. reflexivity.
Qed.

Lemma goJustLT_pres_smaller: forall k k1 v1 m k2 v2 lb ub,
  Bounded m lb ub ->
  _GHC.Base.<_ k1 k = true ->
  goJustLT k k1 v1 m = Some (k2, v2) ->
  _GHC.Base.<_ k2 k = true.
Proof.
  intros. generalize dependent k1. revert v1 v2 k2 k. induction H; intros.
  - simpl in H1. inversion H1; subst. assumption.
  - simpl in H6. destruct (_GHC.Base.<=_ k x) eqn : ?.
   + eapply IHBounded1. eassumption. eassumption.
   + assert (_GHC.Base.<_ x k = true) by (order e). eapply IHBounded2. apply H7.
      apply H6.
Qed.

Lemma goJustLT_bounded: forall k k1 v1 m k2 v2 lb ub l u,
  Bounded m lb ub ->
  _GHC.Base.<_ k1 k = true ->
  goJustLT k k1 v1 m = Some (k2, v2) ->
  (lb = Some l /\ _GHC.Base.<=_ l k1 = true -> _GHC.Base.<=_ l k2 = true )
  /\ (ub = Some u /\ _GHC.Base.<=_ k1 u = true -> _GHC.Base.<=_ k2 u = true).
Proof.
  intros. generalize dependent k1. revert k v1 k2 v2 u l. induction H; intros.
  - simpl in H1. inversion H1; subst. split; intros; subst; solve_Bounds e.
  - simpl in H6. destruct (_GHC.Base.<=_ k x) eqn : ?.
    + split; intros; subst.  specialize (IHBounded1 _ _ _ _ u l _ H5 H6). destruct IHBounded1.
       apply H3. apply H7. specialize (IHBounded1 _ _ _ _ x l  _ H5 H6). destruct IHBounded1.
        destruct H7; subst. assert (Some x = Some x /\ _GHC.Base.<=_ k1 x = true).
        split. reflexivity. order e. apply H8 in H7.  assert (compare x u = Lt) by (solve_Bounds e).
        order e.
    + assert (_GHC.Base.<_ x k = true) by (order e).  split; intros; subst.
      specialize (IHBounded2  _ _ _ _ u x _ H7 H6). destruct IHBounded2.
      destruct H8; subst. assert (_GHC.Base.<=_ x k2 = true). apply H3. split. reflexivity.
      order e. assert (_GHC.Base.<_ l x = true) by (solve_Bounds e). order e.
      specialize (IHBounded2 _ _ _ _ u l _ H7 H6). destruct IHBounded2. apply H9.
      split. apply H8. destruct H8. subst. solve_Bounds e.
Qed.

Lemma goJustLT_nothing_between: forall k k1 v1 m lb ub k2 v2,
  Bounded m lb ub ->
  _GHC.Base.<_ k1 k = true ->
  goJustLT k k1 v1 m = Some (k2, v2) ->
  (forall i, compare k2 i = Lt /\ compare i k = Lt ->
  sem m i = None).
Proof.
  intros. generalize dependent i. generalize dependent k2. generalize dependent k1.
  revert k v1 v2.
  induction H; intros.
  - reflexivity.
  - simpl. simpl in H6. destruct ( _GHC.Base.<=_ k x) eqn : ?.
    + assert (i == x = false) by (order e). rewrite H8. assert (sem s2 i = None). {
      eapply sem_outside_below. eassumption. solve_Bounds e. } rewrite H9.
      simpl. repeat(rewrite oro_None_r). eapply IHBounded1. apply H5. apply H6.
      assumption.
    + assert (_GHC.Base.<_ x k = true) by (order e).
      pose proof goJustLT_bounded. specialize (H9 _ _ _ _ _ _ _ _ x k H0 H8 H6).
      destruct H9. assert (_GHC.Base.<=_ x k2 = true). apply H9. split. reflexivity.
      order e. assert (_GHC.Base.<_ x i = true). order e. assert (sem s1 i = None).
      eapply sem_outside_above. eassumption. solve_Bounds e. rewrite H13.
      assert (i == x = false) by (order e). rewrite H14. simpl. eapply IHBounded2.
      apply H8. apply H6. apply H7.
Qed.

Lemma goJustLT_finds_upper_bound: forall k k1 v1 m lb ub k2 v2,
  Bounded m lb ub ->
  _GHC.Base.<_ k1 k = true ->
  goJustLT k k1 v1 m = Some (k2, v2) ->
   (_GHC.Base.<_  k2 k = true) /\
  (forall k3, (_GHC.Base.<_  k3 k = true) /\ (k2 == k3 = false) /\
  sem m k3 <> None -> (_GHC.Base.<_  k3 k2 = true)).
Proof.
  intros. pose proof (goJustLT_nothing_between k k1 v1 m lb ub k2 v2 H H0 H1).
  split. eapply goJustLT_pres_smaller. apply H. apply H0. apply H1. intros.
  specialize (H2 k3). destruct H3. destruct H4.
  destruct (_GHC.Base.<_ k3 k2 ) eqn : ?.
  - reflexivity.
  - assert (sem m k3 = None). apply H2. split. order e. order e. contradiction.
Qed.

Lemma goJustLt_val_in_map: forall k k1 v1 m lb ub k2 v2,
  Bounded m lb ub ->
  goJustLT k k1 v1 m = Some (k2, v2) ->
  sem m k2 = Some v2 \/ ((k2 == k1 = true) /\ v2 = v1).
Proof.
  intros. generalize dependent k2. revert k k1 v1 v2. induction H; intros.
  - simpl in H0. inversion H0; subst. right. split. apply Eq_Reflexive. reflexivity.
  - simpl. simpl in H5. destruct (_GHC.Base.<=_ k x) eqn : ?.
    + specialize (IHBounded1 k k1 v1 v2 k2 H5). destruct IHBounded1.
      * rewrite H6. simpl. left. reflexivity.
      * right. apply H6.
    + assert (_GHC.Base.<_ x k = true) by (order e).
      pose proof goJustLT_bounded. specialize (H7 k x v s2 k2 v2 (Some x) ub x k H0 H6 H5).
      destruct H7. assert (_GHC.Base.<=_ x k2 = true). apply H7. split. reflexivity. order e.
      assert (sem s1 k2 = None). eapply sem_outside_above. eassumption. solve_Bounds e. rewrite H10.
      simpl. specialize (IHBounded2 k x v v2 k2 H5). destruct IHBounded2.
      * assert (k2 == x = false) by (solve_Bounds e). rewrite H12. simpl. left.
        assumption.
      * destruct H11.  left. rewrite H11. simpl. subst. reflexivity.
Qed.

Lemma goJustLt_never_none: forall k k1 v1 m,
  goJustLT k k1 v1 m <> None.
Proof.
  intros. revert k k1 v1. induction m; intros.
  - simpl. destruct (_GHC.Base.<=_ k0 k ). apply IHm1. apply IHm2.
  - simpl. intro contra. discriminate contra.
Qed.

(*Part 1 of the spec: If lookupLT returns a k1, v1 pair, then (k1, v1) is in the map
  and k1 is the largest key smaller than k*)
Lemma lookupLT_spec_Some:
  forall (m: Map e a) lb ub k (k1: e) v1, Bounded m lb ub ->
  lookupLT k m = Some (k1, v1) ->
  sem m k1 = Some v1 /\ (_GHC.Base.<_  k1 k = true) /\
  (forall k2, (_GHC.Base.<_  k2 k = true) /\ (k1 == k2 = false) /\
  sem m k2 <> None -> (_GHC.Base.<_  k2 k1 = true)).
Proof.
  intros. rewrite <- lookupLT_equiv in H0. generalize dependent k. revert k1 v1. induction H; intros; split; intros.
  - inversion H0.
  - inversion H0.
  - simpl in H5. simpl. destruct (_GHC.Base.<=_  k x) eqn : ?.
    + apply IHBounded1 in H5. destruct H5. rewrite H5. simpl. reflexivity.
    + assert ( _GHC.Base.<_ x k = true) by (order e).
      pose proof (goJustLT_finds_upper_bound k x v s2 (Some x) ub k1 v1 H0 H6 H5).
      destruct H7. specialize (H8 x).
      pose proof (goJustLt_val_in_map k x v s2 (Some x) ub k1 v1 H0 H5).
      pose proof goJustLT_bounded. specialize (H10 k x v s2 k1 v1 (Some x) ub x k H0 H6 H5).
      destruct H10. assert (_GHC.Base.<=_ x k1 = true). apply H10. split. reflexivity. order e.
      assert (sem s1 k1 = None). eapply sem_outside_above. eassumption. solve_Bounds e.
      rewrite H13. simpl. destruct H9.
      * assert (k1 == x = false) by (solve_Bounds e). rewrite H14. simpl. assumption.
      * destruct H9. subst. rewrite H9. reflexivity.
  - simpl in H5. destruct (_GHC.Base.<=_ k x) eqn : ?.
    + simpl. specialize (IHBounded1 k1 v1 k H5). destruct IHBounded1. destruct H7. split.
      assumption. intros. apply H8. destruct H9. destruct H10.
      split. assumption. split. assumption. assert (k2 == x = false) by (order e).
      assert (sem s2 k2 = None). eapply sem_outside_below. eassumption. solve_Bounds e.
      rewrite H13 in H11. rewrite H12 in H11. simpl in H11. repeat (rewrite oro_None_r in H11).
      assumption.
    + assert (_GHC.Base.<_ x k = true) by (order e). split. eapply goJustLT_pres_smaller. apply H0.
      apply H6. apply H5. intros. destruct H7. destruct H8. simpl in H9.
      pose proof goJustLT_bounded. specialize (H10 k x v s2 k1 v1 (Some x) ub x k H0 H6 H5).
      destruct H10. assert (_GHC.Base.<=_ x k1 = true). apply H10. split. reflexivity.
      order e. destruct (compare k2 k1) eqn : ?.
      order e.
      order e.
      assert (k2 == x = false) by (order e). rewrite H13 in H9. simpl in H9.
      assert (sem s1 k2 = None). eapply sem_outside_above. eassumption. solve_Bounds e.
      rewrite H14 in H9. simpl in H9. eapply goJustLT_finds_upper_bound.
       apply H0. apply H6. apply H5. split; try(assumption); split; assumption.
Qed.

(*Part 2: If lookupLT returns None, then every key in the map is smaller than k*)
Lemma lookupLT_spec_None:
  forall (m: Map e a) lb ub k, Bounded m lb ub ->
  lookupLT k m = None ->
  (forall k2 v2, sem m k2 = Some v2 -> _GHC.Base.<=_ k k2 = true).
Proof.
  intros. generalize dependent k2. generalize dependent k. revert v2. induction H; intros.
  - inversion H1.
  - rewrite <- lookupLT_equiv in H5. simpl in H5. destruct (_GHC.Base.<=_ k x) eqn : ?.
    simpl in H6. destruct (sem s1 k2) eqn : ?.
    * simpl in H6; inversion H6; subst. eapply IHBounded1. apply H5. apply Heqo.
    * simpl in H6. destruct (k2 == x) eqn : ?.
      -- order e.
      -- simpl in H6. solve_Bounds e.
    * assert (goJustLT k x v s2 <> None). apply goJustLt_never_none. rewrite H5 in H7.
      contradiction.
Qed.

(** ** Verification of [lookupLE] *)
Fixpoint goJustLE k (k1: e) v1 (m : Map e a) : option (e * a) :=
  match m with
  | Tip => Some (k1, v1)
  | Bin sz k2 v2 l r => match compare k k2 with
                        | Lt => goJustLE k k1 v1 l
                        | Eq => Some (k2, v2)
                        | Gt => goJustLE k k2 v2 r
                        end
  end.

Fixpoint lookupLE' k (m : Map e a) :=
  match m with
  | Tip => None
  | Bin sz k1 v1 l r => match compare k k1 with
                        | Lt => lookupLE' k l
                        | Eq => Some (k1, v1)
                        | Gt => goJustLE k k1 v1 r
                        end
  end.

Lemma lookupLE_equiv:
  forall m k,
  lookupLE' k m = lookupLE k m.
Proof.
  intros. unfold lookupLE'. unfold lookupLE. unfold goJustLE. reflexivity.
Qed.

Lemma goJustLE_pres_smaller: forall k k1 v1 m k2 v2 lb ub,
  Bounded m lb ub ->
  _GHC.Base.<_ k1 k = true ->
  goJustLE k k1 v1 m = Some (k2, v2) ->
  _GHC.Base.<=_ k2 k = true.
Proof.
  intros. generalize dependent k1. revert v1 v2 k2 k. induction H; intros.
  - simpl in H1. inversion H1; subst. order e.
  - simpl in H6. destruct (compare k x) eqn : ?.
    + inversion H6; subst. order e.
    + eapply IHBounded1. eassumption. eassumption.
    + assert (_GHC.Base.<_ x k = true) by (order e). eapply IHBounded2. apply H7.
      apply H6.
Qed.

Lemma goJustLE_bounded: forall k k1 v1 m k2 v2 lb ub l u,
  Bounded m lb ub ->
  _GHC.Base.<_ k1 k = true ->
  goJustLE k k1 v1 m = Some (k2, v2) ->
  (lb = Some l /\ _GHC.Base.<=_ l k1 = true -> _GHC.Base.<=_ l k2 = true )
  /\ (ub = Some u /\ _GHC.Base.<=_ k1 u = true -> _GHC.Base.<=_ k2 u = true).
Proof.
  intros. generalize dependent k1. revert k v1 k2 v2 u l. induction H; intros.
  - simpl in H1. inversion H1; subst. split; intros; subst; solve_Bounds e.
  - simpl in H6. destruct (compare k x) eqn : ?.
    + inversion H6; subst. split; intros. order e. destruct H3. subst. solve_Bounds e.
    + split; intros; subst.  specialize (IHBounded1 _ _ _ _ u l _ H5 H6). destruct IHBounded1.
       apply H3. apply H7. specialize (IHBounded1 _ _ _ _ x l  _ H5 H6). destruct IHBounded1.
        destruct H7; subst. assert (Some x = Some x /\ _GHC.Base.<=_ k1 x = true).
        split. reflexivity. order e. apply H8 in H7.  assert (compare x u = Lt) by (solve_Bounds e).
        order e.
    + assert (_GHC.Base.<_ x k = true) by (order e).  split; intros; subst.
      specialize (IHBounded2  _ _ _ _ u x _ H7 H6). destruct IHBounded2.
      destruct H8; subst. assert (_GHC.Base.<=_ x k2 = true). apply H3. split. reflexivity.
      order e. assert (_GHC.Base.<_ l x = true) by (solve_Bounds e). order e.
      specialize (IHBounded2 _ _ _ _ u l _ H7 H6). destruct IHBounded2. apply H9.
      split. apply H8. destruct H8. subst. solve_Bounds e.
Qed.

Lemma goJustLE_nothing_between: forall k k1 v1 m lb ub k2 v2,
  Bounded m lb ub ->
  _GHC.Base.<_ k1 k = true ->
  goJustLE k k1 v1 m = Some (k2, v2) ->
  (forall i, compare k2 i = Lt /\ compare i k = Lt ->
  sem m i = None).
Proof.
  intros. generalize dependent i. generalize dependent k2. generalize dependent k1.
  revert k v1 v2.
  induction H; intros.
  - reflexivity.
  - simpl. simpl in H6. destruct (compare k x) eqn : ?.
    + assert (i == x = false) by (order e). rewrite H8. assert (sem s2 i = None). {
      eapply sem_outside_below. eassumption. solve_Bounds e. } rewrite H9.
      simpl. repeat(rewrite oro_None_r). inversion H6; subst. eapply sem_outside_above.
      eassumption. solve_Bounds e.
    + assert (i == x = false) by (order e). rewrite H8. assert (sem s2 i = None). {
      eapply sem_outside_below. eassumption. solve_Bounds e. } rewrite H9.
      simpl. repeat(rewrite oro_None_r).  eapply IHBounded1. apply H5. apply H6.
      assumption.
    + assert (_GHC.Base.<_ x k = true) by (order e).
      pose proof goJustLE_bounded. specialize (H9 _ _ _ _ _ _ _ _ x k H0 H8 H6).
      destruct H9. assert (_GHC.Base.<=_ x k2 = true). apply H9. split. reflexivity.
      order e. assert (_GHC.Base.<_ x i = true). order e. assert (sem s1 i = None).
      eapply sem_outside_above. eassumption. solve_Bounds e. rewrite H13.
      assert (i == x = false) by (order e). rewrite H14. simpl. eapply IHBounded2.
      apply H8. apply H6. apply H7.
Qed.

Lemma goJustLE_finds_upper_bound: forall k k1 v1 m lb ub k2 v2,
  Bounded m lb ub ->
  _GHC.Base.<_ k1 k = true ->
  goJustLE k k1 v1 m = Some (k2, v2) ->
   (_GHC.Base.<=_  k2 k = true) /\
  (forall k3, (_GHC.Base.<_  k3 k = true) /\ (k2 == k3 = false) /\
  sem m k3 <> None -> (_GHC.Base.<_  k3 k2 = true)).
Proof.
  intros. pose proof (goJustLE_nothing_between k k1 v1 m lb ub k2 v2 H H0 H1).
  split. eapply goJustLE_pres_smaller. apply H. apply H0. apply H1. intros.
  specialize (H2 k3). destruct H3. destruct H4.
  destruct (_GHC.Base.<_ k3 k2 ) eqn : ?.
  - reflexivity.
  - assert (sem m k3 = None). apply H2. split. order e. order e. contradiction.
Qed.

Lemma goJustLE_val_in_map: forall k k1 v1 m lb ub k2 v2,
  Bounded m lb ub ->
  goJustLE k k1 v1 m = Some (k2, v2) ->
  sem m k2 = Some v2 \/ ((k2 == k1 = true) /\ v2 = v1).
Proof.
  intros. generalize dependent k2. revert k k1 v1 v2. induction H; intros.
  - simpl in H0. inversion H0; subst. right. split. apply Eq_Reflexive. reflexivity.
  - simpl. simpl in H5. destruct (compare k x) eqn : ?.
    + inversion H5; subst. assert (sem s1 k2 = None). eapply sem_outside_above.
      eassumption. solve_Bounds e. rewrite H3. rewrite Eq_Reflexive. simpl.
      left. reflexivity.
    + specialize (IHBounded1 k k1 v1 v2 k2 H5). destruct IHBounded1.
      * rewrite H6. simpl. left. reflexivity.
      * right. apply H6.
    + assert (_GHC.Base.<_ x k = true) by (order e).
      pose proof goJustLE_bounded. specialize (H7 k x v s2 k2 v2 (Some x) ub x k H0 H6 H5).
      destruct H7. assert (_GHC.Base.<=_ x k2 = true). apply H7. split. reflexivity. order e.
      assert (sem s1 k2 = None). eapply sem_outside_above. eassumption. solve_Bounds e. rewrite H10.
      simpl. specialize (IHBounded2 k x v v2 k2 H5). destruct IHBounded2.
      * assert (k2 == x = false) by (solve_Bounds e). rewrite H12. simpl. left.
        assumption.
      * destruct H11.  left. rewrite H11. simpl. subst. reflexivity.
Qed.

Lemma goJustLE_never_none: forall k k1 v1 m,
  goJustLE k k1 v1 m <> None.
Proof.
  intros. revert k k1 v1. induction m; intros.
  - simpl. destruct (compare k0 k) eqn : ?.
    + intro contra. discriminate contra.
    + apply IHm1.
    + apply IHm2.
  - simpl. intro contra. discriminate contra.
Qed.

(*Part 1 of the spec: If lookupLT returns a k1, v1 pair, then (k1, v1) is in the map
  and k1 is the largest key less than or equal to than k*)
Lemma lookupLE_spec_Some:
  forall (m: Map e a) lb ub k (k1: e) v1, Bounded m lb ub ->
  lookupLE k m = Some (k1, v1) ->
  sem m k1 = Some v1 /\ (_GHC.Base.<=_  k1 k = true) /\
  (forall k2, (_GHC.Base.<_  k2 k = true) /\ (k1 == k2 = false) /\
  sem m k2 <> None -> (_GHC.Base.<_  k2 k1 = true)).
Proof.
  intros. rewrite <- lookupLE_equiv in H0. generalize dependent k. revert k1 v1. induction H; intros; split; intros.
  - inversion H0.
  - inversion H0.
  - simpl in H5. simpl. destruct (compare k x) eqn : ?.
    + inversion H5; subst. assert (sem s1 k1 = None). eapply sem_outside_above. eassumption.
      solve_Bounds e. rewrite H3. rewrite Eq_Reflexive. reflexivity.
    + apply IHBounded1 in H5. destruct H5. rewrite H5. simpl. reflexivity.
    + assert ( _GHC.Base.<_ x k = true) by (order e).
      pose proof (goJustLE_finds_upper_bound k x v s2 (Some x) ub k1 v1 H0 H6 H5).
      destruct H7. specialize (H8 x).
      pose proof (goJustLE_val_in_map k x v s2 (Some x) ub k1 v1 H0 H5).
      pose proof goJustLE_bounded. specialize (H10 k x v s2 k1 v1 (Some x) ub x k H0 H6 H5).
      destruct H10. assert (_GHC.Base.<=_ x k1 = true). apply H10. split. reflexivity. order e.
      assert (sem s1 k1 = None). eapply sem_outside_above. eassumption. solve_Bounds e.
      rewrite H13. simpl. destruct H9.
      * assert (k1 == x = false) by (solve_Bounds e). rewrite H14. simpl. assumption.
      * destruct H9. subst. rewrite H9. reflexivity.
  - simpl in H5. destruct (compare k x ) eqn : ?.
    + inversion H5; subst. split. order e. intros. order e.
    + simpl. specialize (IHBounded1 k1 v1 k H5). destruct IHBounded1. destruct H7. split.
      assumption. intros. apply H8. destruct H9. destruct H10.
      split. assumption. split. assumption. assert (k2 == x = false) by (order e).
      assert (sem s2 k2 = None). eapply sem_outside_below. eassumption. solve_Bounds e.
      rewrite H13 in H11. rewrite H12 in H11. simpl in H11. repeat (rewrite oro_None_r in H11).
      assumption.
    + assert (_GHC.Base.<_ x k = true) by (order e). split. eapply goJustLE_pres_smaller. apply H0.
      apply H6. apply H5. intros. destruct H7. destruct H8. simpl in H9.
      pose proof goJustLE_bounded. specialize (H10 k x v s2 k1 v1 (Some x) ub x k H0 H6 H5).
      destruct H10. assert (_GHC.Base.<=_ x k1 = true). apply H10. split. reflexivity.
      order e. destruct (compare k2 k1) eqn : ?.
      order e.
      order e.
      assert (k2 == x = false) by (order e). rewrite H13 in H9. simpl in H9.
      assert (sem s1 k2 = None). eapply sem_outside_above. eassumption. solve_Bounds e.
      rewrite H14 in H9. simpl in H9. eapply goJustLE_finds_upper_bound.
       apply H0. apply H6. apply H5. split; try(assumption); split; assumption.
Qed.

Lemma goJustLE_spec_eq: forall m lb ub k v k' v',
  Bounded m lb ub ->
  sem m k = Some v ->
  (exists k1, k1 == k = true /\ goJustLE k k' v' m = Some (k1, v)).
Proof.
  intros. generalize dependent k. revert v k' v'. induction H; intros.
  - inversion H0.
  - simpl in H5. simpl. destruct (sem s1 k) eqn : ?.
    + assert (compare k x = Lt) by (solve_Bounds e).
      rewrite H6. apply IHBounded1. simpl in H5. inversion H5; subst. assumption.
    + simpl in H5. destruct (k == x) eqn : ?. assert (compare k x = Eq) by (order e).
      * rewrite H6. exists x. split. order e. inversion H5. reflexivity.
      * simpl in H5. assert (compare k x = Gt) by (solve_Bounds e). rewrite H6.
        apply IHBounded2. assumption.
Qed.

(*Part 2: If the value is in the map, lookupLE returns it*)
Lemma lookupLE_spec_eq: forall (m: Map e a) lb ub k v,
  Bounded m lb ub ->
  sem m k = Some v ->
  (exists k1, k1 == k = true /\ lookupLE k m = Some (k1, v)).
Proof.
  intros. generalize dependent k. revert v. induction H; intros.
  - inversion H0.
  - simpl in H5. rewrite <- lookupLE_equiv. simpl.
    destruct (sem s1 k) eqn : ?.
    + assert (compare k x = Lt) by (solve_Bounds e). rewrite H6. apply IHBounded1.
      simpl in H5. inversion H5; subst. assumption.
    + simpl in H5. destruct (k == x) eqn : ?.
      * simpl in H5. exists x. split. order e. assert (compare k x = Eq) by (order e).
        rewrite H6. inversion H5; subst. reflexivity.
      * simpl in H5. assert (compare k x = Gt) by (solve_Bounds e). rewrite H6.
        eapply goJustLE_spec_eq. eassumption. assumption.
Qed.

(*Part 3: If lookupLT returns None, then every key in the map is smaller than k*)
Lemma lookupLE_spec_None:
  forall (m: Map e a) lb ub k, Bounded m lb ub ->
  lookupLE k m = None ->
  (forall k2 v2, sem m k2 = Some v2 -> _GHC.Base.<_ k k2 = true).
Proof.
  intros. generalize dependent k2. generalize dependent k. revert v2. induction H; intros.
  - inversion H1.
  - rewrite <- lookupLE_equiv in H5. simpl in H5. destruct (compare k x) eqn : ?.
    + simpl in H6. order e.
    + simpl in H6. destruct (sem s1 k2) eqn : ?.
      * simpl in H6; inversion H6; subst. eapply IHBounded1. apply H5. apply Heqo.
      * simpl in H6. destruct (k2 == x) eqn : ?.
      -- order e.
      -- simpl in H6. solve_Bounds e.
    + assert (goJustLE k x v s2 <> None). apply goJustLE_never_none. rewrite H5 in H7.
      contradiction.
Qed.

End WF.


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

(** **** Exercise: 2 stars (double_plus) *)
Lemma double_plus : forall n, double n = n + n .
Proof.
  intros n. induction n as [| n'].
     simpl. reflexivity.
    simpl. rewrite -> IHn'. rewrite <- plus_n_Sm.
    reflexivity. Qed.
(** [] *)


Module Nats.

Fixpoint eqb (n m : nat) : bool :=
    match n with
    | O =>  match m with
            | O => true
            | S _ => false
            end
    | S n' => match m with
            | O => false
            | S m' => eqb n' m'
            end
    end.

Notation "x =? y" := (eqb x y) (at level 70).

Fixpoint evenb (n: nat) : bool :=
    match n with
    | O => true
    | S O => false
    | S (S n') => evenb n'
    end.

Definition oddb (n: nat) : bool := negb (evenb n).

End Nats.

Module Lists.

Import Nats.

Notation "x :: xs" := (cons x xs)(at level 60, right associativity).
Notation "[ ]" := nil.
Notation "[ x ; .. ; y ]" := (cons x .. (cons y nil) .. ).
Notation "x ++ y" := (app x y) (at level 60, right associativity).

Fixpoint rev {X: Type} (l: list X) : list X :=
    match l with
    | nil => nil
    | x::xs => (rev xs) ++ [x]
    end.

Fixpoint nth_err {X: Type} (l: list X) (n: nat) : option X :=
    match l with
    | [] => None
    | x::xs => if n =? 0 then Some x else nth_err xs (pred n)
    end.

Fixpoint filter {X: Type} (test: X -> bool) (l: list X) : list X :=
    match l with
    | [] => []
    | x::xs => if test x
               then x :: (filter test xs)
               else filter test xs
    end.

End Lists.

Import Lists.
Import Nats.

Theorem inj_ex1: forall (n m o: nat),
    [n;m] = [o;o] -> [n] = [m].
Proof.
    intros n m o H.
    injection H.
    intros H1 H2.
    rewrite H1.
    rewrite H2.
    reflexivity.
Qed.

Fixpoint eqb (n m : nat) : bool :=
    match n with
    | O =>  match m with
            | O => true
            | S _ => false
            end
    | S n' => match m with
            | O => false
            | S m' => eqb n' m'
            end
    end.

Lemma eqs: forall n m: nat,
    eqb (S n) (S m) = eqb n m.
Proof.
      reflexivity.
Qed.

Theorem eqbt: forall n m, eqb n m = true -> n = m.
Proof.
    intro n. induction n as [|n' IHn'].
    - intros m eq. destruct m as [| m'].
      reflexivity.
      discriminate eq.
    - intros m eq. destruct m as [| m'].
      discriminate eq.
      rewrite -> eqs in eq.
      rewrite -> IHn' with m'.
      reflexivity.
      apply eq.
Qed.

Theorem nea: forall (n: nat) (X: Type) (l: list X),
    length l = n -> nth_err l n = None.
Proof.
    intros n X l.
    generalize dependent n.
    induction l as [|x xs IHxs].
    - intro n. destruct n as [| n'].
      + reflexivity.
      + intro H.
        discriminate H.
    - intro n. destruct n as [| n'].
      + intro H.
        discriminate H.
      + simpl. intro H.
        inversion H.
        apply IHxs.
        reflexivity.
Qed.

Fixpoint combine {X Y: Type} (lx: list X) (ly: list Y)
    : list (X * Y) :=
    match lx, ly with
    | [], _ => []
    | _, [] => []
    | x::tx, y::ty => (x, y) :: (combine tx ty)
    end.

Fixpoint split {X Y: Type} (l: list (X * Y))
    : (list X) * (list Y) :=
    match l with
    | [] => ([], [])
    | (x, y) :: ls => match (split ls) with
                    | (p, q) => (x :: p, y :: q)
    end
    end.

Lemma feq: forall {X Y: Type} (x y : X) (f: X -> Y),
    x = y -> f x = f y. Admitted.

Lemma rmcons: forall {X: Type} (lx ly: list X) (x: X),
    lx = ly -> x::lx = x::ly. Admitted.

Theorem comb_sp: forall X Y (l: list (X * Y)) l1 l2,
    split l = (l1, l2) ->
    combine l1 l2 = l.
Proof.
    intros X Y l.
    induction l as [| x xs IHx].
    - intros l1 l2.
      intro H.
      inversion H.
      reflexivity.
    - destruct x as [a b].
      simpl.
      destruct (split xs) as [lx ly].
      intros l1 l2 H.
      injection H as H1 H2.
      rewrite <- H1.
      rewrite <- H2.
      simpl.
      apply rmcons.
      apply IHx.
      reflexivity.
Qed.

Definition sillyfun1 (n: nat) : bool :=
    if n =? 3 then true
    else if n =? 5 then true
    else false.

Lemma eqb_true: forall (n m: nat), n =? m = true -> n = m. Admitted.

Theorem sillyfun1_odd: forall (n: nat),
    sillyfun1 n = true -> oddb n = true.
Proof.
    intros n eq.
    unfold sillyfun1 in eq.
    destruct (n =? 3) eqn: Heqe3.
    - apply eqb_true in Heqe3.
      rewrite -> Heqe3.
      reflexivity.
    - destruct (n =? 5) eqn: Heqe5.
      + apply eqb_true in Heqe5.
        rewrite -> Heqe5.
        reflexivity.
      + discriminate eq.
Qed.

Theorem eqbsym: forall (n m: nat),
    (n =? m) = (m =? n).
Proof.
    intros n.
    induction n as [| n' IHn].
    - destruct m.
      reflexivity.
      reflexivity.
    - destruct m.
      reflexivity.
      simpl.
      apply IHn.
Qed.

Lemma eqt: forall n: nat, n =? n = true.
Proof.
    intro n.
    induction n as [| n' IHn].
    reflexivity.
    simpl.
    apply IHn.
Qed.

Theorem eqb_trans: forall n m p,
    n =? m = true ->
    m =? p = true ->
    n =? p = true.
Proof.
    intros n m p.
    intros eq1 eq2.
    apply eqb_true in eq1.
    apply eqb_true in eq2.
    rewrite -> eq1.
    rewrite -> eq2.
    apply eqt.
Qed.

Theorem filter_exe: forall (X: Type) (test: X -> bool) (x: X) (l lf: list X),
    filter test l = x::lf ->
    test x = true.
Proof.
    intros.
    generalize dependent x.
    generalize dependent lf.
    induction l as [| y ys IHy].
    - intros. induction lf.
      + discriminate H.
      + discriminate H.
    - intros.
      inversion H.
      destruct (test y) eqn: P.
      + injection H1 as Ha Hb.
        rewrite <- Ha.
        apply P.
      + apply IHy in H1.
        apply H1.
Qed.


Require Import Coquelicot.Coquelicot.
Set Bullet Behavior "Strict Subproofs".

Require Import Coq.Reals.Rbase.
Require Import Coq.Reals.Rfunctions.
Require Import List.
Require Import EquivDec Nat Omega Lra.

Require Import LibUtils ListAdd RealAdd.
Import ListNotations.

Local Open Scope R.
(* The standard library defines sum_f_R0 as an inclusive sum from 0.
   It then defines infinite_sum in terms of it.

   Inclusive ranges are much harder to reason about formulate lemmas than exclusive (end) ranges,
   since they don't allow for empty ranges.

   infinite summations don't really care, so we formulate the nicer version here,
   along with an alternative infinite_sum that is proven identical to the original
 *)

Section sum'.
  Fixpoint sum_f_R0' (f : nat -> R) (N : nat) {struct N} : R :=
    match N with
    | 0%nat => 0%R
    | S i => sum_f_R0' f i + f i
    end.

  Lemma sum_f_R0_sum_f_R0' f N :
    sum_f_R0 f N = sum_f_R0' f (S N).
  Proof.
    induction N; simpl.
    - lra.
    - rewrite IHN.
      simpl; trivial.
  Qed.

  Lemma sum_f_R0'_ext (f1 f2:nat->R) n :
    (forall x, (x < n)%nat -> f1 x = f2 x) ->
    sum_f_R0' f1 n = sum_f_R0' f2 n.
  Proof.
    intros eqq.
    induction n; simpl.
    - trivial.
    - rewrite eqq by omega.
      rewrite IHn; trivial.
      intros; apply eqq.
      omega.
  Qed.

  Lemma sum_f_R0'_split f n m :
    (m <= n)%nat ->
    sum_f_R0' f n =
    sum_f_R0' f m +
    sum_f_R0' (fun x => f (x+m)%nat) (n-m).
  Proof.
    intros lem.
    induction n; simpl.
    - assert (m = 0)%nat by omega.
      subst; simpl; lra.
    - destruct (m == S n); unfold equiv, complement in *.
      + subst.
        simpl.
        rewrite Rplus_assoc.
        f_equal.
        replace (n - n)%nat with 0%nat by omega.
        simpl.
        lra.
      + rewrite IHn by omega.
        rewrite Rplus_assoc.
        f_equal.
        destruct m; simpl.
        * replace (n-0)%nat with n by omega.
          replace (n+0)%nat with n by omega.
          trivial.
        * replace (n - m)%nat with (S (n - S m))%nat by omega.
          simpl.
          f_equal.
          f_equal.
          omega.
  Qed.

  Lemma sum_f_R0'_split_on f n m :
    (m < n)%nat ->
    sum_f_R0' f n =
    sum_f_R0' f m +
    f m +
    sum_f_R0' (fun x => f (x+S m)%nat) (n- S m).
  Proof.
    intros ltm.
    rewrite (sum_f_R0'_split f n (S m) ltm).
    simpl; trivial.
  Qed.

  Lemma sum_f_R0_peel f n :
    sum_f_R0 f (S n) = sum_f_R0 f n + f (S n).
  Proof.
    simpl; trivial.
  Qed.

  Lemma sum_f_R0_ext (f1 f2:nat->R) n :
    (forall x, (x <= n)%nat -> f1 x = f2 x) ->
    sum_f_R0 f1 n = sum_f_R0 f2 n.
  Proof.
    intros eqq.
    induction n; simpl.
    - apply eqq; omega.
    - rewrite eqq by omega.
      rewrite IHn; trivial.
      intros; apply eqq.
      omega.
  Qed.

  Lemma sum_f_R0_split f n m:
    (m < n)%nat ->
    sum_f_R0 f n =
    sum_f_R0 f m +
    sum_f_R0 (fun x => f (x+S m))%nat (n-S m).
  Proof.
    intros ltm.
    induction n; simpl.
    - omega.
    - destruct (m == n); unfold equiv, complement in *.
      + subst.
        rewrite Nat.sub_diag; simpl; trivial.
      + rewrite IHn by omega.
        rewrite Rplus_assoc.
        f_equal.
        replace (n - m)%nat with (S (n - S m))%nat by omega.
        simpl.
        f_equal.
        f_equal.
        omega.
  Qed.

  Lemma sum_f_R0_split_on f n m:
    (S m < n)%nat ->
    sum_f_R0 f n =
    sum_f_R0 f m +
    f (S m) +
    sum_f_R0 (fun x => f (x+S (S m)))%nat (n-S (S m)).
  Proof.
    intros ltm.
    rewrite (sum_f_R0_split f n m) by omega.
    repeat rewrite Rplus_assoc.
    f_equal.
    rewrite (sum_f_R0_split  (fun x : nat => f (x + S m)%nat) (n - S m) 0) by omega.
    simpl.
    f_equal.
    replace (n - S (S m))%nat with (n - S m - 1)%nat by omega.
    apply sum_f_R0_ext.
    intros.
    f_equal.
    omega.
  Qed.

  Lemma sum_f_R0'_chisel f N n :
  (n < N)%nat ->
  sum_f_R0' f N = sum_f_R0'  (fun x : nat => if equiv_dec x n then 0 else f x) N + (f n).
Proof.
  Proof.
    intros ltm.
    repeat rewrite (sum_f_R0'_split_on _ N n ltm).
    destruct (n == n); unfold equiv, complement in *; subst; [| intuition].
    rewrite Rplus_0_r.
    rewrite Rplus_comm.
    repeat rewrite <- Rplus_assoc.
    f_equal.
    rewrite Rplus_comm.
    f_equal.
    + apply sum_f_R0'_ext; intros.
      destruct (x == n);  unfold equiv, complement in *; subst; [| intuition].
      omega.
    + apply sum_f_R0'_ext; intros.
      destruct (x + S n == n)%nat;  unfold equiv, complement in *; subst; [| intuition].
      omega.
  Qed.

  Lemma sum_f_R0'_const c n: sum_f_R0' (fun _ : nat => c) n = (c * INR n)%R.
  Proof.
    induction n; simpl.
    - lra.
    - rewrite IHn.
      destruct n; simpl; lra.
  Qed.

  Lemma sum_f'_as_fold_right f (n:nat) s :
    sum_f_R0' (fun x : nat => f (x + s)%nat) n = fold_right (fun a b => f a + b) 0 (seq s n).
  Proof.
    revert s.
    induction n; simpl; trivial.
    intros.
    rewrite (IHn s).
    destruct n; [simpl; lra | ].
    replace (seq s (S n)) with ([s]++seq (S s) n) by (simpl; trivial).
    rewrite seq_Sn.
    repeat rewrite fold_right_app.
    simpl.
    rewrite (fold_right_plus_acc _ (f (S (s + n)) + 0)).
    rewrite Rplus_assoc.
    f_equal.
    f_equal.
    rewrite Rplus_0_r.
    f_equal.
    omega.
  Qed.

  Lemma sum_f_R0'_as_fold_right f (n:nat) :
    sum_f_R0' f n = fold_right (fun a b => f a + b) 0 (seq 0 n).
  Proof.
    generalize (sum_f'_as_fold_right f n 0); simpl; intros HH.
    rewrite <- HH.
    apply sum_f_R0'_ext.
    intros.
    f_equal.
    omega.
  Qed.

  Lemma sum_f_R0'_plus f1 f2 n :
    sum_f_R0' (fun x => f1 x + f2 x) n = sum_f_R0' f1 n + sum_f_R0' f2 n.
  Proof.
    induction n; simpl; [lra | ].
    rewrite IHn.
    lra.
  Qed.

  Lemma sum_f_R0'_mult_const f1 n c :
    sum_f_R0' (fun x => c * f1 x) n = c * sum_f_R0' f1 n.
  Proof.
    induction n; simpl; [lra | ].
    rewrite IHn.
    lra.
  Qed.

  Lemma sum_f_R0'_le f n :
    (forall n, (0 <= f n)) ->
    0 <= sum_f_R0' f n.
  Proof.
    intros fpos.
    induction n; simpl.
    - lra.
    - specialize (fpos n).
      lra.
  Qed.

  Lemma sum_f_R0'_plus_n f n1 n2 : sum_f_R0' f (n1 + n2) =
                                   sum_f_R0' f n1 +
                                   sum_f_R0' (fun x => f (n1+x))%nat n2.
  Proof.
    repeat rewrite sum_f_R0'_as_fold_right.
    rewrite seq_plus.
    rewrite fold_right_app.
    rewrite fold_right_plus_acc.
    simpl.
    rewrite (seq_shiftn_map n1).
    rewrite fold_right_map.
    trivial.
  Qed.

  Lemma sum_f_R0'_le_f (f g:nat->R) n :
    (forall i, (i < n)%nat -> f i <= g i) ->
    sum_f_R0' f n <= sum_f_R0' g n.
  Proof.
    induction n; simpl.
    - lra.
    - intros fa.
      apply Rplus_le_compat; auto.
  Qed.

End sum'.

Section inf_sum'.

  Definition infinite_sum' (s : nat -> R) (l : R) : Prop
    := forall eps : R,
      eps > 0 ->
      exists N : nat,
        forall n : nat,
          (n >= N)%nat ->
          R_dist (sum_f_R0' s n) l < eps.

  Theorem infinite_sum_infinite_sum' (s : nat -> R) (l : R) :
    infinite_sum s l <-> infinite_sum' s l.
  Proof.
    unfold infinite_sum, infinite_sum'.
    split; intros H.
    - intros eps epsgt.
      destruct (H eps epsgt) as [N Nconv].
      exists (S N); intros n ngt.
      destruct n.
      + omega.
      + rewrite <- sum_f_R0_sum_f_R0'.
        apply Nconv.
        omega.
    - intros eps epsgt.
      destruct (H eps epsgt) as [N Nconv].
      exists N; intros n ngt.
      rewrite sum_f_R0_sum_f_R0'.
      apply Nconv.
      omega.
  Qed.

  Lemma infinite_sum'_ext (s1 s2 : nat -> R) (l : R) :
    (forall x, s1 x = s2 x) ->
    infinite_sum' s1 l <-> infinite_sum' s2 l.
  Proof.
    intros eqq.
    unfold infinite_sum'.
    split; intros H eps eps_gt
    ; destruct (H eps eps_gt) as [N Nconv]
    ; exists N; intros n0 n0_ge
    ; specialize (Nconv n0 n0_ge)
    ; erewrite sum_f_R0'_ext; eauto.
  Qed.

  Lemma infinite_sum'_prefix s l n :
    infinite_sum' s (l + (sum_f_R0' s n)) <->
    infinite_sum' (fun x => s (x + n))%nat l.
  Proof.
    unfold infinite_sum'.
    split; intros H
    ; intros eps eps_gt
    ; specialize (H eps eps_gt)
    ; destruct H as [N Nconv].
    - exists N
      ; intros n0 n0_ge.
      specialize (Nconv (n + n0)%nat).
      cut_to Nconv; [ | omega].
      replace (R_dist (sum_f_R0' (fun x : nat => s (x + n)%nat) n0) l) with
            ( R_dist (sum_f_R0' s (n + n0)) (l + sum_f_R0' s n)); trivial.
      unfold R_dist.
      rewrite (sum_f_R0'_split s (n+n0) n) by omega.
      replace ((n + n0 - n)%nat) with n0 by omega.
      f_equal.
      lra.
    - exists (N+n)%nat
      ; intros n0 n0_ge.
      specialize (Nconv (n0-n)%nat).
      cut_to Nconv; [ | omega].
      replace (R_dist (sum_f_R0' s n0) (l + sum_f_R0' s n))
                      with (R_dist (sum_f_R0' (fun x : nat => s (x + n)%nat) (n0 - n)) l); trivial.
      unfold R_dist.
      rewrite (sum_f_R0'_split s n0 n) by omega.
      f_equal.
      lra.
  Qed.

    Lemma infinite_sum'_split n s l :
      infinite_sum' s l <->
      infinite_sum' (fun x => s (x + n))%nat (l - (sum_f_R0' s n)).
    Proof.
      rewrite <- (infinite_sum'_prefix s (l - (sum_f_R0' s n)) n).
      replace (l - sum_f_R0' s n + sum_f_R0' s n) with l by lra.
      tauto.
    Qed.

    (*
    Lemma infinite_sum'_unique_half f l1 l2 :
      infinite_sum' f l1 ->
      infinite_sum' f l2 ->
      l2 <= l1 ->
      l1 = l2.
    Proof.
      unfold infinite_sum'; intros inf1 inf2 le.
      destruct (Req_dec (l1 - l2) 0); [lra | ].
      assert (gt0:(l1 - l2) / 2 > 0) by lra.
      specialize (inf1 _ gt0).
      destruct inf1 as [N1 inf1].
      specialize (inf2 _ gt0).
      destruct inf2 as [N2 inf2].
      specialize (inf1 (max N1 N2)).
      specialize (inf2 (max N1 N2)).

      l2 - x < (l1 - l2) / 2
                         l1 - x < (l1 - l2) / 2k

     *)

    Lemma R_dist_too_small_impossible_lt r l1 l2 :
      l1 < l2 ->
      R_dist r l1 < R_dist l1 l2 / 2 ->
      R_dist r l2 < R_dist l1 l2 / 2 -> False.
    Proof.
      intros ltl inf1 inf2.
      generalize (Rplus_lt_compat _ _ _ _ inf1 inf2); intros ltt.
      replace (R_dist l1 l2 / 2 + R_dist l1 l2 / 2) with (R_dist l1 l2) in ltt by lra.
      rewrite (R_dist_sym r l1) in ltt.
      generalize (R_dist_tri l1 l2 r); intros.
      lra.
    Qed.

    Lemma R_dist_too_small_impossible_neq r l1 l2 :
      l1 <> l2 ->
      R_dist r l1 < R_dist l1 l2 / 2 ->
      R_dist r l2 < R_dist l1 l2 / 2 -> False.
    Proof.
      intros neq inf1 inf2.
      destruct (Rlt_le_dec l1 l2).
      - eapply R_dist_too_small_impossible_lt; eauto.
      - destruct r0.
        + rewrite (R_dist_sym l1 l2) in * .
          eapply R_dist_too_small_impossible_lt; eauto.
        + intuition.
    Qed.

    Lemma infinite_sum'_unique {f l1 l2} :
      infinite_sum' f l1 ->
      infinite_sum' f l2 ->
      l1 = l2.
    Proof.
      unfold infinite_sum'; intros inf1 inf2.
      destruct (Req_dec (l1 - l2) 0); [lra | ].
      generalize (Rabs_pos_lt _ H); intros gt0.
      apply Rlt_gt in gt0.
      assert (gt02:R_dist l1  l2 / 2 > 0) by (unfold R_dist; lra).
      specialize (inf1 _ gt02).
      specialize (inf2 _ gt02).
      destruct inf1 as [N1 inf1].
      destruct inf2 as [N2 inf2].
      specialize (inf1 (max N1 N2)).
      specialize (inf2 (max N1 N2)).
      cut_to inf1; [ | apply Nat.le_max_l].
      cut_to inf2; [ | apply Nat.le_max_r].
      revert inf1 inf2.
      generalize (sum_f_R0' f (max N1 N2)); intros.
      eelim R_dist_too_small_impossible_neq; try eapply inf1; eauto.
      lra.
    Qed.

    Lemma infinite_sum'_const_shift {c d} :
      infinite_sum' (fun _ => c) d ->
      (infinite_sum' (fun _ => c) (d+c)).
    Proof.
      intros.
      apply (infinite_sum'_split 1  (fun _ => c) (d+c)).
      simpl.
      replace (d + c - (0 + c)) with d; trivial.
      lra.
    Qed.

    Lemma infinite_sum'_const0 {d} :
      infinite_sum' (fun _ : nat => 0) d ->
      d = 0.
    Proof.
      unfold infinite_sum'; intros HH.
      destruct (Req_dec d 0); trivial.
      assert (gt0:Rabs d/2>0).
      {
        generalize (Rabs_pos_lt d H).
        lra.
      }
      specialize (HH _ gt0).
      destruct HH as [N Nconv].
      specialize (Nconv N).
      cut_to Nconv; [ | left; trivial].
      rewrite sum_f_R0'_const in Nconv.
      unfold R_dist in Nconv.
      replace (0 * INR N - d) with (- d) in Nconv by lra.
      rewrite Rabs_Ropp in Nconv.
      lra.
    Qed.

    Lemma infinite_sum'_const1 {c d} :
      infinite_sum' (fun _ => c) d -> c = 0.
    Proof.
      intros inf1.
      generalize (infinite_sum'_const_shift inf1); intros inf2.
      generalize (infinite_sum'_unique inf1 inf2); intros eqq.
      lra.
    Qed.

    Lemma infinite_sum'_const {c d} :
      infinite_sum' (fun _ => c) d -> c = 0 /\ d = 0.
    Proof.
      intros inf1.
      generalize (infinite_sum'_const1 inf1); intros; subst.
      generalize (infinite_sum'_const0 inf1); intros; subst.
      tauto.
    Qed.

    Lemma infinite_sum'_const2 {c d} :
      infinite_sum' (fun _ => c) d -> d = 0.
    Proof.
      intros inf1.
      generalize (infinite_sum'_const inf1); tauto.
    Qed.

  Hint Resolve Nat.le_max_l Nat.le_max_r : arith.

  Lemma infinite_sum'_plus {f1 f2} {sum1 sum2} :
    infinite_sum' f1 sum1 ->
    infinite_sum' f2 sum2 ->
    infinite_sum' (fun x => f1 x + f2 x) (sum1 + sum2).
  Proof.
    intros inf1 inf2 ε εpos.
    destruct (inf1 (ε/2)) as [N1 H1]
    ; [lra | ].
    destruct (inf2 (ε/2)) as [N2 H2]
    ; [lra | ].

    exists (max N1 N2).
    intros n ngt.

    specialize (H1 n).
    cut_to H1; [ | apply (le_trans _ (max N1 N2)); auto with arith].
    specialize (H2 n).
    cut_to H2; [ | apply (le_trans _ (max N1 N2)); auto with arith].

    rewrite sum_f_R0'_plus.
    generalize (R_dist_plus (sum_f_R0' f1 n) sum1 (sum_f_R0' f2 n) sum2); intros.
    lra.
  Qed.

  Lemma infinite_sum'0 : infinite_sum' (fun _ : nat => 0) 0.
  Proof.
    intros ε εgt.
    exists 0%nat.
    intros.
    rewrite sum_f_R0'_const.
    replace (0 * INR n) with 0 by lra.
    rewrite R_dist_eq.
    lra.
  Qed.

  Lemma infinite_sum'_mult_const {f1} {sum1} c :
    infinite_sum' f1 sum1 ->
    infinite_sum' (fun x => c * f1 x) (c * sum1).
  Proof.
    intros inf1.
    destruct (Req_dec c 0).
    - subst.
      rewrite (infinite_sum'_ext _ (fun _ => 0)) by (intros; lra).
      replace (0 * sum1) with 0 by lra.
      apply infinite_sum'0.
    - intros ε εpos.
      assert (Rabs c > 0) by (apply Rabs_pos_lt; trivial).
      destruct (inf1 (ε/ (Rabs c))) as [N1 H1].
      + apply Rdiv_lt_0_compat; lra.
      + exists N1.
        intros n ngt.
        specialize (H1 n ngt).
        rewrite sum_f_R0'_mult_const.
        rewrite R_dist_mult_l.
        apply (Rmult_lt_compat_l (Rabs c)) in H1; [ | lra].
        replace ( Rabs c * (ε / Rabs c)) with ε in H1; trivial.
        unfold Rdiv.
        rewrite Rmult_comm.
        rewrite Rmult_assoc.
        rewrite (Rmult_comm (/ Rabs c)).
        rewrite <- Rmult_assoc.
        rewrite Rinv_r_simpl_l; trivial.
        lra.
  Qed.

  Lemma Rabs_pos_plus_lt x y :
    x > 0 ->
    y > 0 ->
    y < Rabs (x + y).
  Proof.
    intros.
    rewrite Rabs_right; lra.
  Qed.

  Lemma infinite_sum'_pos f sum :
    infinite_sum' f sum ->
    (forall n, (0 <= f n)) ->
    0 <= sum.
  Proof.
    intros inf fpos.
    destruct (Rge_dec sum 0); [ lra | ].
    red in inf.
    apply Rnot_ge_lt in n.
    destruct (inf (- sum)); [ lra | ].
    specialize (H x).
    cut_to H; [ | omega].
    unfold R_dist in H.
    destruct (Req_dec (sum_f_R0' f x) 0).
    - rewrite H0 in H.
      replace (0 - sum) with (- sum) in H by lra.
      rewrite Rabs_right in H by lra.
      lra.
    - generalize (Rabs_pos_plus_lt (sum_f_R0' f x ) (- sum)); intros HH.
      cut_to HH.
      + eelim Rlt_irrefl.
        eapply Rlt_trans; eauto.
      + generalize (sum_f_R0'_le f x fpos); intros HH2.
        lra.
      + lra.
Qed.

  Lemma infinite_sum'_le f1 f2 sum1 sum2 :
    infinite_sum' f1 sum1 ->
    infinite_sum' f2 sum2 ->
    (forall n, (f1 n <= f2 n)) ->
    sum1 <= sum2.
  Proof.
    intros inf1 inf2 fle.

    generalize (infinite_sum'_mult_const (-1)%R inf1); intros ninf1.
    generalize (infinite_sum'_plus inf2 ninf1); intros infm.
    apply infinite_sum'_pos in infm.
    - lra.
    - intros.
      specialize (fle n).
      lra.
  Qed.

End inf_sum'.

Section harmonic.

  Lemma pow_le1 n : (1 <= 2 ^ n)%nat.
  Proof.
    induction n; simpl; omega.
  Qed.

  Lemma Sle_mult_gt1 a n :
    (n > 0)%nat ->
    (a > 1)%nat ->
    (S n <= a * n)%nat.
  Proof.
    destruct a; try omega.
    destruct a; try omega.
    intros.
    simpl.
    destruct n; simpl; try omega.
    apply le_n_S.
    rewrite plus_comm.
    apply le_n_S.
    fold add.
    rewrite <- plus_assoc.
    apply Nat.le_add_r.
  Qed.

  Lemma pow_exp_gt a b :
    (a > 1)%nat ->
    (a ^ b > b)%nat.
  Proof.
    intros neq.
    induction b; simpl.
    - omega.
    - apply gt_n_S in IHb.
      eapply le_gt_trans; try eassumption.
      apply Sle_mult_gt1; omega.
  Qed.
  Lemma sum_f_R0'_eq2 n :
    sum_f_R0' (fun _:nat => 1 / INR (2^(S n))) (2^n)%nat = 1/2.
  Proof.
    intros.
    rewrite sum_f_R0'_const.
    replace (2 ^ S n)%nat with (2 * 2 ^ n)%nat by reflexivity.
    rewrite mult_INR.
    unfold Rdiv.
    rewrite Rinv_mult_distr.
    - repeat rewrite Rmult_assoc.
      rewrite <- Rinv_l_sym.
      + simpl; lra.
      + apply INR_nzero_eq.
        apply Nat.pow_nonzero.
        omega.
    - simpl; lra.
    - apply INR_nzero_eq.
      apply Nat.pow_nonzero.
      omega.
  Qed.

  Lemma sum_f_R0'_bound2 (n:nat) : sum_f_R0' (fun i:nat => 1 / INR (S i)) (2^n)%nat >= 1+(INR n)/2.
  Proof.
    intros.
    induction n.
    - simpl; lra.
    - rewrite S_INR.
      simpl pow.
      rewrite sum_f_R0'_plus_n.
      replace ( 1 + (INR n + 1) / 2) with ( 1 + INR n / 2 + 1 / 2) by lra.
      apply Rplus_ge_compat; trivial.
      rewrite Nat.add_0_r.
      clear.
      eapply Rge_trans; [ | right; apply (sum_f_R0'_eq2 n)].
      apply Rle_ge.
      apply sum_f_R0'_le_f; intros.
      unfold Rdiv.
      apply Rmult_le_compat_l; [ lra | ].
      apply Rinv_le_contravar.
      + apply INR_zero_lt.
        omega.
      + apply le_INR.
        simpl.
        omega.
  Qed.

  Lemma harmonic_diverges' l : ~ infinite_sum' (fun i:nat => 1 / INR (S i)) l.
  Proof.
    intros inf.
    specialize (inf 1).
    cut_to inf; try lra.
    destruct inf as [N Npf].
    specialize (Npf (2^(2*(N + Z.to_nat (up l))))%nat).
    cut_to Npf.
    - generalize (sum_f_R0'_bound2 (2 * (N + Z.to_nat (up l)))); intros sle.
      rewrite mult_INR in sle.
      unfold Rdiv in sle.
      rewrite Rinv_r_simpl_m in sle by (simpl; lra).
      unfold R_dist in Npf.
      apply Rabs_def2 in Npf.
      destruct Npf as [Npf1 Npf2].
      assert (oops:INR (N + Z.to_nat (up l)) < l) by lra.
      rewrite plus_INR in oops.
      assert (lgt:l > 0).
      { eapply Rle_lt_trans; try eapply oops.
        apply Rplus_le_le_0_compat
        ; apply pos_INR.
      }
      rewrite INR_up_pos in oops by lra.
      destruct (archimed l).
      generalize (pos_INR N).
      lra.
    - rewrite Nat.pow_mul_r.
      simpl.
      rewrite NPeano.Nat.pow_add_r.
      unfold ge.
      replace N with (N * 1)%nat at 1 by omega.
      apply mult_le_compat.
      + generalize (pow_exp_gt 4 N)
        ; omega.
      + generalize (Z.to_nat (up l)); intros n.
        destruct n; simpl.
        * omega.
        * generalize (pow_exp_gt 4 n); omega.
  Qed.

  Definition diverges (f:nat->R)
    := forall l, ~ infinite_sum f l.

  Theorem harmonic_diverges : diverges (fun i:nat => 1 / INR (S i)).
  Proof.
    intros l inf.
    apply infinite_sum_infinite_sum' in inf.
    eapply harmonic_diverges'; eauto.
  Qed.

End harmonic.

Section coquelicot.
Lemma infinite_sum_is_lim_seq (f:nat->R) (l:R) : is_lim_seq (fun i => sum_f_R0 f i) l <-> infinite_sum f l.
Proof.
  split; intros HH.
  - apply Series.is_series_Reals.
    unfold Series.is_series.
    red in HH.
    eapply filterlim_ext; try eapply HH.
    intros; simpl.
    rewrite sum_n_Reals.
    reflexivity.
  - apply Series.is_series_Reals in HH.
    unfold Series.is_series in HH.
    red.
    eapply filterlim_ext; try eapply HH.
    intros; simpl.
    rewrite sum_n_Reals.
    reflexivity.
Qed.
End coquelicot.


(* Useful properties of our Simple.v specification *)
Require Import Simple.

(* Dominates is transitive *)
Theorem dom_trans {D : Domain} :
        forall {s1 s2 s3},
               Dominates s1 s2 -> Dominates s2 s3 -> Dominates s1 s3.
  (* Break apart our Dominates arguments *)
  intros. destruct H. destruct H0. refine (conj _ _).

  (* Compose their parts *)
  intuition. intuition.
Qed.

(* NoWorse is reflexive *)
Theorem no_worse_refl {D : Domain} :
        forall {s}, NoWorse s s.
  intro. exact (or_intror eq_refl).
Qed.

(* NoWorse is transitive *)
Theorem no_worse_trans {D : Domain} :
        forall {s1 s2 s3},
               NoWorse s1 s2 -> NoWorse s2 s3 -> NoWorse s1 s3.
  (* Destruct our NoWorse arguments and solve each case *)
  intros. destruct H. destruct H0.

  (* Dominates s1 s2 /\ Dominates s2 s3 *)
  exact (or_introl (dom_trans H H0)).

  (* Dominates s1 s2 /\ s2 = s3 *)
  rewrite <- H0. exact (or_introl H).

  (* s1 = s2 /\ NoWorse s2 s3 *)
  rewrite H. exact H0.
Qed.

(* The next Solver in a NoWorseStream is NoWorse than the previous *)
Fixpoint nws_no_worse {D : Domain} {s}
                       n (nws : NoWorseStream s)
      :  NoWorse (get_solver (S n) nws)
                 (get_solver    n  nws)
      := match n,    nws with
             | 0,    nwsCons _ _ p _    => p
             | S n', nwsCons _ _ _ nws' => nws_no_worse n' nws'
         end.

(* All Solvers in a NoWorseStream s are NoWorse than s *)
Theorem get_solver_no_worse {D : Domain} :
        forall s n (nws : NoWorseStream s),
               NoWorse (get_solver n nws)
                        s.
  intros. induction n. destruct nws. simpl.
  exact (no_worse_refl).
  assert (no_worse_next := nws_no_worse n nws).
  apply (no_worse_trans no_worse_next IHn).
Qed.


From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat div.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(*** Universal
     quantifier *)

(** * Motivation *)

(** Suppose we wrote two functions: a simple (a.k.a. gold) implementation
    and its optimized version.
    How do we go about specifying their equivalence?
 *)

Section Motivation.
Variables A B : Type.

Variables fgold fopt : A -> B.

Lemma fopt_equiv_fgold :
  forall x : A, fgold x = fopt x.
Abort.

End Motivation.

(** * Dependently typed functions *)

(** ** Dependently typed predecessor function *)

Definition Pred n := if n is S n' then nat else unit.

(** the value of [unit] type plays the role of a placeholder *)
Print unit.

Definition predn_dep : forall n, Pred n :=
  fun n => if n is S n' then n' else tt.

Check erefl : predn_dep 7 = 6.
Fail Check erefl : predn_dep 0 = 0.
Check erefl : predn_dep 0 = tt.
Check predn_dep 0 : unit.
Check erefl : Pred 0 = unit.
Check predn_dep 7 : nat.

(** ** Annotations for dependent pattern matching *)

(** Type inference is undecidable *)
Fail Check (fun n => if n is S n' then n' else tt).

Check (fun n =>
  if n is S n' as n0 return Pred n0 then n' else tt).

(**
General form of pattern matching construction:
[match expr as T in (deptype A B) return exprR].

- [return exprR] denotes the dependent type of the expression
- [as T] is needed when we are matching on complex expressions,
  not just variables
*)

(** * Functional type is just a notation
      for a special case of [forall]  *)

Locate "->".

Check predn : nat -> nat.
Check predn : forall x : nat, nat.
Check predn : forall x : nat, (fun _ => nat) x.

(** * Usage of [forall] in standalone expressions *)

(* courtesy of Mathcomp book *)
Section StandardPredicates.
Variable T : Type.
Implicit Types (op add : T -> T -> T).

Definition associative op :=
  forall x y z, op x (op y z) = op (op x y) z.

Definition left_distributive op add :=
  forall x y z, op (add x y) z = add (op x z) (op y z).

Definition left_id e op :=
  forall x, op e x = x.

End StandardPredicates.

(** * Case study: the dual Frobenius rule *)

(* Due to Andrej Bauer:
https://github.com/andrejbauer/Homotopy/blob/8474551e28ceeeba4910370326dc3ffd5e340f09/OberwolfachTutorial/frobenius.v#L53-L58 *)

Definition LEM :=
  forall P : Prop, P \/ ~ P.

Definition Frobenius2 :=
  forall (A : Type) (P : A -> Prop) (Q : Prop),
    (forall x, Q \/ P x) <-> (Q \/ forall x, P x).

Lemma lem_implies_Frobenius2 : LEM -> Frobenius2.
Proof.
rewrite /LEM /Frobenius2.
move=> lem.
move=> A P Q.
split.
- move=> all_qpx.
  case: (lem Q); first by move=> q; left.
  move=> nq. right. move=> x.
  case: (all_qpx x); first by move/nq.
  by [].
case; first by move=> q x; left.
by move=> all_px x; right.

Restart.

move=> Lem A P Q.
case: (Lem Q)=> [q | not_q]; first by split=> _; left.
split=> [H | [//|x px]]; last by right.
by right=> x; case: (H x).
Qed.

Lemma Frobenius2_lem : Frobenius2 -> LEM.
Proof.
rewrite /Frobenius2=> frob.
move=> P.
case: (frob P (fun _ => False) P).
move=> H _; move: H.
by apply=> p; left.
Qed.

(*** Existential
     quantifier *)
Module MyExistential.

Inductive ex_my (A : Type) (P : A -> Prop) : Prop :=
| ex_intro (x : A) (proof : P x).

(** Simplified notation *)
Notation "’exists’ x : A , p" := (ex (fun x : A => p))
                                   (at level 200, right associativity).

(** Full-blown notation: multiple binders *)
Notation "'exists' x .. y , p" :=
  (ex_my (fun x => .. (ex_my (fun y => p)) ..))
  (at level 200, x binder, right associativity,
   format "'[' 'exists'  '/  ' x  ..  y ,  '/  ' p ']'")
  : type_scope.
End MyExistential.

Lemma exists_not_forall A (P : A -> Prop) :
  (exists x, P x) -> ~ (forall x, ~ P x).
Proof.
case=> x px.
move=> all.
exact: (all x px).
Qed.

(** Currying for dependent pair *)
Definition curry {A B C : Type} :
  (A * B -> C) -> (A -> B -> C).
move=> f a b.
exact: (f (pair a b)).
Defined.

Lemma curry_dep A (P : A -> Prop) Q :
  ((exists x, P x) -> Q) -> (forall x, P x -> Q).
Proof.
move=> f x px.
exact: (f (ex_intro _ x px)).
Qed.

Section Symmetric_Transittive_Relation.

Variables (D : Type) (R : D -> D -> Prop).

(* [Hypothesis] is a different syntax for [Variable] *)
Hypothesis Rsym :
  forall x y, R x y -> R y x.

Hypothesis Rtrans :
  forall x y z, R x y -> R y z -> R x z.

Lemma refl_if :
  forall x : D, (exists y, R x y) -> R x x.
Proof.
move=> x.
case=> y rxy.
move: (Rsym rxy); move: rxy.
by apply: Rtrans.
Qed.

End Symmetric_Transittive_Relation.

(*** Empty types,
     again *)

Lemma exfalso_quodlibet :
  False -> forall P : Prop, P.
Proof. by []. Qed.

(** Let's write down a proof term manually *)
Definition exfalso_quodlibet_term :
  False -> forall P : Prop, P
:=
  fun f =>
    match f with end.

(** A special case of exfalso. *)
(** Why does this typecheck at all? *)
Lemma False_implies_false :
  False -> false.
Proof. by case. Qed.

(** * Disjointness of constructors *)

(** Going in the other direction... *)
Lemma false_implies_False :
  false -> False.
Proof. by []. Qed.

(** What's going on here? Let's write a proof term *)
Check I : True.

Definition false_implies_False_term :
  false -> False
:=
  fun     eq :  false = true =>
    match eq in (_    = b)
             return (if b then False else True)
    with
    | erefl => I
    end.

(** * Injectivity of constructors *)

(** While we are at it,
    constructors are also injective *)
Lemma succ_inj n m :
  S n = S m -> n = m.
Proof.
case. (* special case for [case] *)
Show Proof.
done.
Qed.

Lemma pair_inj A B (a1 a2 : A) (b1 b2 : B) :
  (a1, b1) = (a2, b2) -> (a1 = a2) /\ (b1 = b2).
Proof. by case=> ->->. Qed.

(*** Induction *)

Lemma addnA :
  associative addn.
Proof.
by move=> x y z; elim: x=> // x IH; rewrite addSn IH.
Qed.

Lemma add0n :
  left_id 0 addn.
Proof. by []. Qed.

Lemma addn0 :
  right_id 0 addn.
Proof. by elim=> // x IH; rewrite addSn IH. Qed.

Lemma addSnnS m n :
  m.+1 + n = m + n.+1.
Proof. by elim: m=> // m IH; rewrite addSn IH. Qed.

Lemma addnC :
  commutative addn.
Proof.
move=> x y.
elim: x; first by rewrite addn0.
by move=> x IH; rewrite addSn IH -addSnnS.
Qed.

(** * How does induction work? *)

Check nat_ind.

Definition nat_ind_my
  : forall P : nat -> Prop,
    P 0 ->
    (forall n : nat, P n -> P n.+1) ->
    forall n : nat, P n
:=
  fun P p0 step =>
    fix rec n :=
      if n is n'.+1 then step n' (rec n')
      else p0.

(** Induction is just recursion! *)


Require Import Coq.Lists.List.
Require Import Coq.Arith.Compare_dec.
Require Import Arith.Wf_nat.
Require Import Recdef.

Open Scope nat_scope.

Definition max (a b : nat) :=
    match nat_compare a b with
    | Lt => b
    | _  => a
    end.

Inductive tree :=
    | Tip : tree
    | Bin : nat -> tree -> tree -> tree.

Definition ht (t : tree) :=
    match t with
    | Tip       => 0
    | Bin n _ _ => n
    end.

Definition join (x y : tree) : tree := Bin (max (ht x) (ht y) + 1) x y.

Function step (t : tree) (xs : list tree) {measure length xs} : list tree :=
    match xs with
    | nil      => t :: nil
    | u :: nil =>
        match nat_compare (ht t) (ht u) with
        | Lt => t :: u :: nil
        | _  => (join t u) :: nil
        end
    | u :: v :: ts =>
        match nat_compare (ht t) (ht u) with
        | Lt => t :: u :: v :: ts
        | _  =>
            match nat_compare (ht t) (ht v) with
            | Lt => step (join t u) (v :: ts)
            | _  => (* step t *) (step (join u v) ts)
                    (* step t (step (join u v) ts) is required, but not allowed *)
            end
        end
    end.
Proof.
    intros t xs u l v ts L X C1 C2. simpl. apply le_lt_SS. apply le_n.
    intros t xs u l v ts L X C1 C2. simpl. apply Lt.lt_n_Sn.
    intros t xs u l v ts L X C1 C2. simpl. apply le_lt_SS. apply le_n.
    intros t xs u l v ts L X C1 C2. simpl. apply le_lt_SS. apply le_n.
    intros t xs u l v ts L X C1 C2. simpl. apply Lt.lt_n_Sn.
    intros t xs u l v ts L X C1 C2. simpl. apply le_lt_SS. apply le_n.
Qed.


(** * Maps: Total and Partial Maps *)

(** _Maps_ (or _dictionaries_) are ubiquitous data structures both
		generally and in the theory of programming languages in
		particular; we're going to need them in many places in the coming
		chapters.  They also make a nice case study using ideas we've seen
		in previous chapters, including building data structures out of
		higher-order functions (from [Basics] and [Poly]) and the use of
		reflection to streamline proofs (from [IndProp]).

		We'll define two flavors of maps: _total_ maps, which include a
		"default" element to be returned when a key being looked up
		doesn't exist, and _partial_ maps, which return an [option] to
		indicate success or failure.  The latter is defined in terms of
		the former, using [None] as the default element. *)

(* ################################################################# *)
(** * The Coq Standard Library *)

(** One small digression before we begin...

		Unlike the chapters we have seen so far, this one does not
		[Require Import] the chapter before it (and, transitively, all the
		earlier chapters).  Instead, in this chapter and from now, on
		we're going to import the definitions and theorems we need
		directly from Coq's standard library stuff.  You should not notice
		much difference, though, because we've been careful to name our
		own definitions and theorems the same as their counterparts in the
		standard library, wherever they overlap. *)

From Coq Require Import Arith.Arith.
From Coq Require Import Bool.Bool.
Require Export Coq.Strings.String.
From Coq Require Import Logic.FunctionalExtensionality.
From Coq Require Import Lists.List.
Import ListNotations.

(** Documentation for the standard library can be found at
		http://coq.inria.fr/library/.

		The [Search] command is a good way to look for theorems involving
		objects of specific types.  Take a minute now to experiment with it. *)

(* ################################################################# *)
(** * Identifiers *)

(** First, we need a type for the keys that we use to index into our
		maps.  In [Lists.v] we introduced a fresh type [id] for a similar
		purpose; here and for the rest of _Software Foundations_ we will
		use the [string] type from Coq's standard library. *)

(** To compare strings, we define the function [eqb_string], which
		internally uses the function [string_dec] from Coq's string
		library. *)

Definition eqb_string (x y : string) : bool :=
	if string_dec x y then true else false.

(** (The function [string_dec] comes from Coq's string library.
		If you check the result type of [string_dec], you'll see that it
		does not actually return a [bool], but rather a type that looks
		like [{x = y} + {x <> y}], called a [sumbool], which can be
		thought of as an "evidence-carrying boolean."  Formally, an
		element of [sumbool] is either a proof that two things are equal
		or a proof that they are unequal, together with a tag indicating
		which.  But for present purposes you can think of it as just a
		fancy [bool].) *)

(** Now we need a few basic properties of string equality... *)
Theorem eqb_string_refl : forall s : string, true = eqb_string s s.
Proof.
	intros s. unfold eqb_string. destruct (string_dec s s) as [|Hs].
	- reflexivity.
	- unfold not in Hs. destruct Hs. reflexivity.
Qed.

(** The following useful property follows from an analogous
		lemma about strings: *)

Theorem eqb_string_true_iff : forall x y : string,
	eqb_string x y = true <-> x = y.
Proof.
	intros x y.
	unfold eqb_string.
	destruct (string_dec x y) as [|Hs].
	- subst. split. reflexivity. reflexivity.
	- split.
		+ intros contra. discriminate contra.
		+ intros H. rewrite H in Hs. destruct Hs. reflexivity.
Qed.

(** Similarly: *)

Theorem eqb_string_false_iff : forall x y : string,
	eqb_string x y = false <-> x <> y.
Proof.
	intros x y. rewrite <- eqb_string_true_iff.
	rewrite not_true_iff_false. reflexivity. Qed.

(** This handy variant follows just by rewriting: *)

Theorem false_eqb_string : forall x y : string,
	x <> y -> eqb_string x y = false.
Proof.
	intros x y. rewrite eqb_string_false_iff.
	intros H. apply H. Qed.

(* ################################################################# *)
(** * Total Maps *)

(** Our main job in this chapter will be to build a definition of
		partial maps that is similar in behavior to the one we saw in the
		[Lists] chapter, plus accompanying lemmas about its behavior.

		This time around, though, we're going to use _functions_, rather
		than lists of key-value pairs, to build maps.  The advantage of
		this representation is that it offers a more _extensional_ view of
		maps, where two maps that respond to queries in the same way will
		be represented as literally the same thing (the very same function),
		rather than just "equivalent" data structures.  This, in turn,
		simplifies proofs that use maps. *)

(** We build partial maps in two steps.  First, we define a type of
		_total maps_ that return a default value when we look up a key
		that is not present in the map. *)

Definition total_map (A : Type) := string -> A.

(** Intuitively, a total map over an element type [A] is just a
		function that can be used to look up [string]s, yielding [A]s. *)

(** The function [t_empty] yields an empty total map, given a default
		element; this map always returns the default element when applied
		to any string. *)

Definition t_empty {A : Type} (v : A) : total_map A :=
	(fun _ => v).

(** More interesting is the [update] function, which (as before) takes
		a map [m], a key [x], and a value [v] and returns a new map that
		takes [x] to [v] and takes every other key to whatever [m] does. *)

Definition t_update {A : Type} (m : total_map A)
										(x : string) (v : A) :=
	fun x' => if eqb_string x x' then v else m x'.

(** This definition is a nice example of higher-order programming:
		[t_update] takes a _function_ [m] and yields a new function
		[fun x' => ...] that behaves like the desired map. *)

(** For example, we can build a map taking [string]s to [bool]s, where
		["foo"] and ["bar"] are mapped to [true] and every other key is
		mapped to [false], like this: *)

Definition examplemap :=
	t_update (t_update (t_empty false) "foo" true)
					 "bar" true.

(** Next, let's introduce some new notations to facilitate working
		with maps. *)

(** First, we will use the following notation to create an empty
		total map with a default value. *)
Notation "'_' '!->' v" := (t_empty v)
	(at level 100, right associativity).

Example example_empty := (_ !-> false).

(** We then introduce a convenient notation for extending an existing
		map with some bindings. *)
Notation "x '!->' v ';' m" := (t_update m x v)
															(at level 100, v at next level, right associativity).

(** The [examplemap] above can now be defined as follows: *)

Definition examplemap' :=
	( "bar" !-> true;
		"foo" !-> true;
		_     !-> false
	).

(** This completes the definition of total maps.  Note that we
		don't need to define a [find] operation because it is just
		function application! *)

Example update_example1 : examplemap' "baz" = false.
Proof. reflexivity. Qed.

Example update_example2 : examplemap' "foo" = true.
Proof. reflexivity. Qed.

Example update_example3 : examplemap' "quux" = false.
Proof. reflexivity. Qed.

Example update_example4 : examplemap' "bar" = true.
Proof. reflexivity. Qed.

(** To use maps in later chapters, we'll need several fundamental
		facts about how they behave. *)

(** Even if you don't work the following exercises, make sure
		you thoroughly understand the statements of the lemmas! *)

(** (Some of the proofs require the functional extensionality axiom,
		which is discussed in the [Logic] chapter.) *)

(** **** Exercise: 1 star, standard, optional (t_apply_empty)

		First, the empty map returns its default element for all keys: *)

Lemma t_apply_empty : forall (A : Type) (x : string) (v : A),
	(_ !-> v) x = v.
Proof.
	intros. unfold t_empty. reflexivity.
Qed.
(** [] *)

(** **** Exercise: 2 stars, standard, optional (t_update_eq)

		Next, if we update a map [m] at a key [x] with a new value [v]
		and then look up [x] in the map resulting from the [update], we
		get back [v]: *)

Lemma t_update_eq : forall (A : Type) (m : total_map A) x v,
	(x !-> v ; m) x = v.
Proof.
	intros. unfold t_update. destruct (eqb_string x x) eqn:e.
	- reflexivity.
	- rewrite <- eqb_string_refl in e. discriminate e.
Qed.
(** [] *)

(** **** Exercise: 2 stars, standard, optional (t_update_neq)

		On the other hand, if we update a map [m] at a key [x1] and then
		look up a _different_ key [x2] in the resulting map, we get the
		same result that [m] would have given: *)

Theorem t_update_neq : forall (A : Type) (m : total_map A) x1 x2 v,
	x1 <> x2 ->
	(x1 !-> v ; m) x2 = m x2.
Proof.
	intros. unfold t_update. destruct (eqb_string x1 x2) eqn:E.
	- apply false_eqb_string in H. rewrite H in E. discriminate E.
	- reflexivity.
Qed.
(** [] *)

(** **** Exercise: 2 stars, standard, optional (t_update_shadow)

		If we update a map [m] at a key [x] with a value [v1] and then
		update again with the same key [x] and another value [v2], the
		resulting map behaves the same (gives the same result when applied
		to any key) as the simpler map obtained by performing just
		the second [update] on [m]: *)

Lemma t_update_shadow : forall (A : Type) (m : total_map A) x v1 v2,
	(x !-> v2 ; x !-> v1 ; m) = (x !-> v2 ; m).
Proof.
	intros A m x v1 v2. unfold t_update. apply functional_extensionality.
	intros y. destruct (eqb_string x y) eqn:E.
	- reflexivity.
	- reflexivity.
Qed.
(** [] *)

(** For the final two lemmas about total maps, it's convenient to use
		the reflection idioms introduced in chapter [IndProp].  We begin
		by proving a fundamental _reflection lemma_ relating the equality
		proposition on [id]s with the boolean function [eqb_id]. *)

(** **** Exercise: 2 stars, standard, optional (eqb_stringP)

		Use the proof of [eqbP] in chapter [IndProp] as a template to
		prove the following: *)

Lemma eqb_stringP : forall x y : string,
	reflect (x = y) (eqb_string x y).
Proof.
	intros. apply iff_reflect. rewrite eqb_string_true_iff. reflexivity.
Qed.
(** [] *)

(** Now, given [string]s [x1] and [x2], we can use the tactic
		[destruct (eqb_stringP x1 x2)] to simultaneously perform case
		analysis on the result of [eqb_string x1 x2] and generate
		hypotheses about the equality (in the sense of [=]) of [x1]
		and [x2]. *)

(** **** Exercise: 2 stars, standard (t_update_same)

		With the example in chapter [IndProp] as a template, use
		[eqb_stringP] to prove the following theorem, which states that
		if we update a map to assign key [x] the same value as it already
		has in [m], then the result is equal to [m]: *)

Theorem t_update_same : forall (A : Type) (m : total_map A) x,
	(x !-> m x ; m) = m.
Proof.
	intros. unfold t_update. apply functional_extensionality.
	intros y. destruct (eqb_stringP x y) as [H | H].
	- rewrite H. reflexivity.
	- reflexivity.
Qed.
(** [] *)

(** **** Exercise: 3 stars, standard, recommended (t_update_permute)

		Use [eqb_stringP] to prove one final property of the [update]
		function: If we update a map [m] at two distinct keys, it doesn't
		matter in which order we do the updates. *)

Theorem t_update_permute: forall (A : Type) (m : total_map A) v1 v2 x1 x2,
	x2 <> x1 ->
	(x1 !-> v1 ; x2 !-> v2 ; m)
	=
	(x2 !-> v2 ; x1 !-> v1 ; m).
Proof.
	intros. unfold t_update. apply functional_extensionality.
	intros. destruct (eqb_string x1 x) as [H1 | H1] eqn:X1.
	- destruct (eqb_string x2 x) as [H2 | H2] eqn:X2.
		+ rewrite eqb_string_true_iff in X1. rewrite eqb_string_true_iff in X2.
			subst. destruct H. reflexivity.
		+ reflexivity.
	- destruct (eqb_string x2 x) as [H2 | H2] eqn:X2.
		+ reflexivity.
		+ reflexivity.
Qed.

(* ################################################################# *)
(** * Partial maps *)

(** Finally, we define _partial maps_ on top of total maps.  A partial
		map with elements of type [A] is simply a total map with elements
		of type [option A] and default element [None]. *)

Definition partial_map (A : Type) := total_map (option A).

Definition empty {A : Type} : partial_map A := t_empty None.

Definition update {A : Type} (m : partial_map A) (x : string) (v : A) :=
	(x !-> Some v ; m).

(** We introduce a similar notation for partial maps: *)
Notation "x '|->' v ';' m" := (update m x v)
	(at level 100, v at next level, right associativity).

(** We can also hide the last case when it is empty. *)
Notation "x '|->' v" := (update empty x v)
	(at level 100).

Example examplepmap :=
	("Church" |-> true ; "Turing" |-> false).

(** We now straightforwardly lift all of the basic lemmas about total
		maps to partial maps.  *)

Lemma apply_empty : forall (A : Type) (x : string),
	@empty A x = None.
Proof.
	intros. unfold empty. rewrite t_apply_empty.
	reflexivity.
Qed.

Lemma update_eq : forall (A : Type) (m : partial_map A) x v,
	(x |-> v ; m) x = Some v.
Proof.
	intros. unfold update. rewrite t_update_eq.
	reflexivity.
Qed.

Theorem update_neq : forall (A : Type) (m : partial_map A) x1 x2 v,
	x2 <> x1 ->
	(x2 |-> v ; m) x1 = m x1.
Proof.
	intros A m x1 x2 v H.
	unfold update. rewrite t_update_neq. reflexivity.
	apply H.
Qed.

Lemma update_shadow : forall (A : Type) (m : partial_map A) x v1 v2,
	(x |-> v2 ; x |-> v1 ; m) = (x |-> v2 ; m).
Proof.
	intros A m x v1 v2. unfold update. rewrite t_update_shadow.
	reflexivity.
Qed.

Theorem update_same : forall (A : Type) (m : partial_map A) x v,
	m x = Some v ->
	(x |-> v ; m) = m.
Proof.
	intros A m x v H. unfold update. rewrite <- H.
	apply t_update_same.
Qed.

Theorem update_permute: forall (A : Type) (m : partial_map A) x1 x2 v1 v2,
	x2 <> x1 ->
	(x1 |-> v1 ; x2 |-> v2 ; m) = (x2 |-> v2 ; x1 |-> v1 ; m).
Proof.
	intros A m x1 x2 v1 v2. unfold update.
	apply t_update_permute.
Qed.

(* Wed Jan 9 12:02:45 EST 2019 *)


(* infotheo: information theory and error-correcting codes in Coq               *)
(* Copyright (C) 2020 infotheo authors, license: LGPL-2.1-or-later              *)
From mathcomp Require Import all_ssreflect ssralg fingroup finalg matrix.
Require Import Reals Lra.
From mathcomp Require Import Rstruct.
Require Import ssrR Reals_ext logb ssr_ext ssralg_ext bigop_ext Rbigop fdist.
Require Import proba jfdist_cond entropy.

(******************************************************************************)
(* Example 2.2.1 of T. M. Cover and J. A. Thomas. Elements of information     *)
(* theory. Wiley, 2006. 2nd edition                                           *)
(******************************************************************************)

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

Local Open Scope R_scope.
Local Open Scope fdist_scope.
Local Open Scope proba_scope.

Module conditional_entropy_example.

Definition zero : 'I_4 := ord0.
Definition one : 'I_4 := @Ordinal 4 1 isT.
Definition two : 'I_4 := @Ordinal 4 2 isT.
Definition three : 'I_4 := @Ordinal 4 3 isT.

Definition f := [ffun x : 'I_4 * 'I_4 => [eta (fun=>0) with
(zero, zero) |-> (1/8), (zero, one) |-> (1/16), (zero, two) |-> (1/16), (zero, three) |-> (1/4),
(one, zero) |-> (1/16), (one, one) |-> (1/8), (one, two) |-> (1/16), (one, three) |-> 0,
(two, zero) |-> (1/32), (two, one) |-> (1/32), (two, two) |-> (1/16), (two, three) |-> 0,
(three, zero) |-> (1/32), (three, one) |-> (1/32), (three, two) |-> (1/16), (three, three) |-> 0] x].

Lemma f0 : forall x, 0 <= f x.
Proof.
move=> x; rewrite ffunE; move: x.
case => -[ [? [[|[|[|[|[]//]]]]]
  | [? [[|[|[|[|[]//]]]]]
  | [? [[|[|[|[|[]//]]]]]
  | [? [[|[|[|[|[]//]]]]] | []//]]]]]; rewrite /f /=; try lra.
Qed.

Lemma f1 : \sum_(x in {: 'I_4 * 'I_4}) f x = 1.
Proof.
rewrite (eq_bigr (fun x => f (x.1, x.2))); last by case.
rewrite -(pair_bigA _ (fun x1 x2 => f (x1, x2))) /=.
rewrite !big_ord_recl !big_ord0 /f /= !ffunE /=; field.
Qed.

Definition d : {fdist 'I_4 * 'I_4} := locked (FDist.make f0 f1).

Lemma dE x : d x = f x.
Proof. by rewrite /d; unlock. Qed.

Lemma conditional_entropyE : cond_entropy d = 11/8.
Proof.
rewrite /cond_entropy /=.
rewrite !big_ord_recl big_ord0 !fdist_sndE /=.
rewrite !big_ord_recl !big_ord0 !dE /f /=.
rewrite /cond_entropy1 /=.
rewrite !big_ord_recl !big_ord0 /jcPr /Pr !(big_setX,big_set1) !dE /f /=.
rewrite !fdist_sndE /=.
rewrite !big_ord_recl !big_ord0 !dE /f !ffunE /=.
rewrite !(addR0,add0R,div0R,mul0R).
repeat (rewrite logDiv; try lra).
rewrite !log1 !sub0R !log4 !log8 !log16 !log32.
rewrite [X in log X](_ : _ = 1/4); last lra.
rewrite !div1R logV; last lra.
rewrite !log4.
rewrite [X in log X](_ : _ = 1/4); last lra.
rewrite !div1R logV; last lra.
rewrite !log4.
rewrite [X in log X](_ : _ = 1/4); last lra.
rewrite !div1R logV; last lra.
rewrite !log4.
field.
Qed.

End conditional_entropy_example.


(** * Computing the length of paths from [alpha] to [zero]

 After Wainer, Ketonen, Solovay, etc .

    Pierre Casteran, LaBRI, University of  Bordeaux *)

From hydras Require Import  Hprime  E0  Canon Paths
     Large_Sets.
From hydras Require Import  Simple_LexProd Iterates .
From Coq Require Import ArithRing Lia.
(* begin snippet LDef *)

From Equations Require Import Equations.
Import RelationClasses Relations.

#[global] Instance Olt : WellFounded E0lt := E0lt_wf.
#[global] Hint Resolve Olt : E0.

(** Using Coq-Equations for building a function which satisfies
    [Large_sets.L_spec] *)

Equations  L_ (alpha: E0) (i:nat) : nat by wf alpha E0lt :=
  L_ alpha  i with E0_eq_dec alpha E0zero :=
    { | left _zero => i ;
      | right _nonzero
          with Utils.dec (E0limit alpha) :=
          { | left _limit =>  L_ (Canon alpha i)  (S i) ;
            | right _successor =>  L_ (E0pred alpha) (S i)}}.

(*| .. coq:: in messages |*)
Solve All Obligations with auto with E0.

(*||*)
(* end snippet LDef *)

(* begin snippet AboutLEquation1 *)

About L__equation_1.
(* end snippet AboutLEquation1 *)

(** Paraphrase of equations generated by coq-equations *)

(* begin snippet Paraphrasesa:: no-out *)

Lemma L_zero_eqn : forall i, L_ E0zero i = i.
Proof. intro i; now rewrite L__equation_1. Qed.

Lemma L_eq2 alpha i :
  E0is_succ alpha -> L_ alpha i = L_ (E0pred alpha) (S i).
(* end snippet Paraphrasesa *)

Proof.
  intros; rewrite L__equation_1;  destruct (E0_eq_dec alpha E0zero).
  - subst; discriminate.
  - cbn; destruct (Utils.dec (E0limit alpha)) .
    apply Succ_not_T1limit in H; destruct H; auto.
    now cbn.
Qed.

(* begin snippet Paraphrasesb:: no-out *)
Lemma L_succ_eqn alpha i :
  L_ (E0succ alpha) i = L_ alpha (S i).
(* end snippet Paraphrasesb *)

Proof.
  intros;rewrite L_eq2;
    [autorewrite with E0_rw using trivial | auto with E0].
Qed.

Hint Rewrite L_zero_eqn L_succ_eqn : L_rw.

(* begin snippet Paraphrasesc:: no-out *)
Lemma L_lim_eqn alpha i :
  E0limit alpha ->
  L_ alpha i = L_ (Canon alpha i) (S i).
(* end snippet Paraphrasesc *)

Proof.
  intros;rewrite L__equation_1.
  destruct (E0_eq_dec alpha E0zero).
  - subst; discriminate.
  - cbn;  destruct (Utils.dec (E0limit alpha)) .
    + now cbn.
    + red in H; rewrite e in H; discriminate.
Qed.

(* begin snippet LFiniteOmega *)

Lemma L_finite : forall i k :nat,  L_ i k = (i+k)%nat. (* .no-out *)
(*| .. coq:: none |*)
Proof.
  induction i.
  - simpl E0fin; intro; now rewrite L_zero_eqn.
  - simpl; rewrite FinS_Succ_eq; intro k; autorewrite with E0_rw L_rw.
    rewrite IHi.
   + abstract lia.
Qed.
(*||*)

Lemma L_omega : forall k, L_ E0omega k = S (2 * k)%nat. (* .no-out *)
(*| .. coq:: none |*)
Proof.
  intro k; rewrite L_lim_eqn.
  - replace (Canon  E0omega  k) with (E0fin k).
    + rewrite L_finite; abstract lia.
    +  cbn; unfold Canon; cbn.
       apply E0_eq_intro.
       destruct k;  reflexivity.
  - now cbn.
Qed.
(*||*)
(* end snippet LFiniteOmega *)

Lemma L_ge_id alpha : forall i,  i <= L_ alpha i.
Proof  with auto with E0.
     pattern alpha; apply well_founded_induction with E0lt ...
   clear alpha; intros alpha IHalpha.
  destruct (Zero_Limit_Succ_dec alpha).
  -  destruct s.
   +  subst alpha. intro; rewrite L_zero_eqn. auto with arith.
   +   intros  k;  rewrite L_lim_eqn; auto.
     *  specialize (IHalpha (Canon alpha k)).
        destruct k;  simpl Canon.
        --  autorewrite with L_rw; auto. auto with arith.
        -- transitivity (S (S k)); [lia | apply IHalpha ]...
     -  destruct s as [beta e];  destruct (E0_eq_dec beta E0zero).
        +  subst  beta alpha.
           intros  k; autorewrite with L_rw; auto.
        +   subst alpha; intros k; autorewrite with L_rw ...
              transitivity (S k); [lia |] ...
Qed.

(* begin snippet LGeS *)

Lemma L_ge_S alpha :
  alpha <> E0zero -> S <<= L_ alpha. (* .no-out *)
(*| .. coq:: none |*)
Proof  with auto with E0.
     pattern alpha; apply well_founded_induction with E0lt ...
   clear alpha; intros alpha IHalpha.
  destruct (Zero_Limit_Succ_dec alpha).
  -  destruct s.
   +  intro; contradiction.
   +   intros H k;  rewrite L_lim_eqn; auto.
     *  specialize (IHalpha (Canon alpha k)).
        destruct k;  simpl Canon.
        apply L_ge_id.
        apply L_ge_id.
     -  destruct s as [beta e];  destruct (E0_eq_dec beta E0zero).
        +  subst  beta alpha.
           intros H k; autorewrite with L_rw; auto.
        +   subst alpha; intros H k; autorewrite with L_rw ...
              transitivity (S (S k)); [lia |] ...
              apply IHalpha ...
Qed.
(*||*)
(* end snippet LGeS *)

Lemma L_succ_ok  beta f :
  nf beta -> S <<= f -> L_spec beta f ->
  L_spec (succ beta)  (fun k =>  f (S k)).
Proof.
  intros; apply Large_Sets.L_succ_ok; auto.
Qed.

(** [L_] is correct w.r.t. its specification *)

Section L_correct_proof.

  Let P alpha :=  L_spec (cnf alpha) (L_ alpha).

  Lemma L_ok0 : P E0zero.
  Proof. red; simpl. left. intro k; now rewrite L_zero_eqn. Qed.

  Lemma L_ok_succ beta  : P beta -> P (E0succ beta).
  Proof with auto with E0.
    intro H; red;  rewrite Succ_rw.
    destruct (E0_eq_dec beta E0zero).
    -  subst; simpl; generalize (L_fin_ok 1); unfold L_fin.
       replace one with (T1nat 1); [simpl | trivial].
       intro; eapply L_spec_compat;  eauto.
       intros; rewrite L_eq2; auto with E0.
       rewrite E0pred_of_Succ, L_zero_eqn; trivial.
    -  apply L_spec_compat  with (L_succ (L_ beta));
         auto.
       + apply L_succ_ok; auto.
         * apply cnf_ok; auto.
         * intro k; apply L_ge_S; auto.
       + unfold L_succ; intro n0; now autorewrite with L_rw.
  Qed.

  Lemma L_ok_lim  alpha  :
    (forall beta,  (beta o< alpha)%e0 -> P beta) ->
    E0limit alpha -> P alpha.
  Proof with eauto with E0.
    unfold P; intros.
    apply L_spec_compat with (fun k =>  L_ (Canon alpha k) (S k)).
    -   generalize L_lim_ok; intro H1; unfold L_lim in H1.
       assert (H2 : T1limit (cnf alpha)) by (now destruct alpha).
       specialize (H1 (cnf alpha) cnf_ok H2 (fun k i => L_ (Canon alpha k) i)).
       apply H1; intro k; specialize (H (Canon alpha  (S k))).
       assert  (H3: (Canon alpha (S k) o< alpha)%e0 ).
       { apply CanonS_lt;  now apply Limit_not_Zero. }
       apply H in H3; apply L_spec_compat with (L_ (Canon alpha (S k))); auto.
    - intro n; rewrite (L_lim_eqn alpha); trivial.
  Qed.

  Lemma L_ok (alpha: E0) : P alpha.
  Proof with eauto with E0.
    apply well_founded_induction with E0lt ...
    clear alpha; intros alpha IHalpha.
    destruct (Zero_Limit_Succ_dec alpha) as [[H | H] | H].
    - subst; apply L_ok0.
    - apply L_ok_lim; auto.
    - destruct H as [beta Hbeta]; subst; apply L_ok_succ.
      apply IHalpha; auto with E0.
  Qed.

End L_correct_proof.

(* begin snippet LCorrect *)

Theorem L_correct alpha : L_spec (cnf alpha) (L_ alpha). (* .no-out *)
(*| .. coq:: none |*)
Proof. apply L_ok. Qed.
(*||*)
(* end snippet LCorrect *)

(** Comparison with Hardy's function H  *)

(* begin snippet HprimeL *)

Theorem H'_L_ alpha :
  forall i:nat,  (H'_ alpha i <= L_ alpha (S i))%nat. (* .no-out *)
(* end snippet HprimeL *)

Proof with auto with E0.
  pattern alpha ; apply well_founded_induction with E0lt ...
  clear alpha; intros alpha IHalpha i.
  destruct (Zero_Limit_Succ_dec alpha) as [[H | H] | H].
  - subst; rewrite H'_eq1, L_zero_eqn. abstract lia.
  - rewrite H'_eq3, L_lim_eqn ...
    apply Nat.lt_le_incl;
      apply Nat.lt_le_trans with (H'_ (Canon alpha (S i)) (S i)).
    apply H'_alpha_mono; auto with arith ...
    apply IHalpha ...
  -  destruct H as [beta e]; subst alpha;
       rewrite H'_eq2, L_succ_eqn ...
Qed.

Require Import Extraction.

Recursive Extraction L_.


Require Import Problem PeanoNat Omega.

Theorem solution : task.
Proof.
  unfold task.
  intros.
  do 2 (try destruct m; try destruct n; try omega).
  simpl in H.
  rewrite Nat.add_comm in H.
  inversion H.
Qed.


Require Export Fin.

Fixpoint fin_lift1 {n} (m : Fin.t n) : Fin.t (S n) :=
    match m with
    | @Fin.F1 n   => @Fin.F1 (S n)
    |  Fin.FS m => Fin.FS (fin_lift1 m)
    end.

Fixpoint fin_to_nat {n} (m : Fin.t n):=
    match m with
    | Fin.F1   => 0
    | Fin.FS m => S (fin_to_nat m)
    end.

Coercion fin_lift1  : Fin.t >-> Fin.t.
Coercion fin_to_nat : Fin.t >-> nat.


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

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

Unset Positivity Checking.
Unset Guard Checking.

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

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

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

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

Definition synth (lf2 : natural) (x : natural) : natural := mult lf2 x.