Require Export Setoid Coq.Classes.Morphisms Omega.
Require Export Sets SetInterface SetConstructs SetProperties.
Require Export EqDec Computable Util Drop.
Require Export CSetTac CSetBasic CSetCases CSetGet CSetComputable CSetDisjoint CSetNotation.
Require Export ElemEq.
Require Export OrderedTypeComputable OrderedTypeLe.

Set Implicit Arguments.

(* idk who added this *)
Remove Hints trans_eq_bool.

Lemma minus_de_morgan X `{OrderedType X} x s t
  : (x \In s /\ (x \In t -> False) -> False)
    <-> ((x \In s -> False) \/ (x \In t)).
Proof.
  split; intros; dcr.
  - decide (x ∈ s); decide (x ∈ t); eauto.
  - intuition.
Qed.

Lemma in_dneg X `{OrderedType X} M x
  : x ∈ M <-> ~x ∉ M.
Proof.
  split; repeat intro; eauto.
  decide (x ∈ M); eauto.
  exfalso; eauto.
Qed.

Lemma in_dneg' X `{OrderedType X} M x
  : x ∈ M <-> ((x ∈ M -> False )->False).
Proof.
  split; repeat intro; eauto.
  decide (x ∈ M); eauto.
  exfalso; eauto.
Qed.

Smpl Add match goal with
         | [ |- context [(_ \In _ -> False) -> False] ] =>
           setoid_rewrite <- in_dneg'
         | [ |- context [(_ \In _ -> False) -> False] ] =>
           setoid_rewrite <- in_dneg'
         | [ |- context [(_ ∉ _) -> False] ] =>
           setoid_rewrite <- in_dneg
         end : cset.

Hint Resolve incl_empty minus_incl incl_right incl_left : auto.

Definition pe X `{OrderedType X} := prod_eq (@Equal X _ _) (@Equal X _ _).

Instance pe_morphism X `{OrderedType X}
 : Proper (Equal ==> Equal ==> (@pe X _)) pair.
Proof.
  unfold Proper, respectful.
  intros. econstructor; eauto.
Qed.

Instance pe_refl X `{OrderedType X} : Reflexive (@pe _ _).
Proof.
  hnf; intros. destruct x; econstructor; reflexivity.
Qed.

Instance pe_sym X `{OrderedType X} : Symmetric (@pe _ _).
Proof.
  hnf; intros. inv H0; econstructor; eauto.
  + rewrite H1; eauto; reflexivity.
  + rewrite H2; eauto; reflexivity.
Qed.

Instance pe_trans X `{OrderedType X} : Transitive (@pe _ _).
Proof.
  hnf; intros ? ? ? B C.
  eapply Equivalence_Transitive; eauto using Equal_ST.
Qed.

Ltac pe_rewrite :=
  repeat
    (match goal with
     | [ H : pe ?an _, H' : context [?an] |- _ ] =>
       setoid_rewrite H in H'; simpl in H'
     | [ H : pe ?an _ |-  context [?an] ] =>
       setoid_rewrite H; simpl
     end).

Instance Subset_morphism_2 X `{OrderedType X}
  : Proper (flip Subset ==> Subset ==> impl) (Subset).
Proof.
  unfold Proper, respectful, impl; intros.
  firstorder.
Qed.

Instance Subset_morphism_3 X `{OrderedType X}
  : Proper (Subset ==> flip Subset ==> flip impl) (Subset).
Proof.
  unfold Proper, respectful, impl; intros.
  firstorder.
Qed.

Lemma minus_single_singleton X `{OrderedType X} (s : set X) (x:X)
: s \ singleton x [=] s \ {x; {}}.
Proof.
  cset_tac; intuition.
Qed.

Lemma minus_single_singleton' X `{OrderedType X} (s : set X) (x:X)
: s \ singleton x ⊆ s \ {x; {}}.
Proof.
  cset_tac; intuition.
Qed.

Lemma minus_single_singleton'' X `{OrderedType X} (s : set X) (x:X)
: s \ {x; {}} ⊆ s \ singleton x.
Proof.
  cset_tac; intuition.
Qed.

Lemma fresh_of_list {X} `{OrderedType X} (L:list X) (y:X)
  : Util.fresh y L -> y ∉ of_list L.
Proof.
  general induction L; simpl in *. intro; cset_tac; eauto.
  intro. cset_tac'; intuition.
  eapply IHL; eauto. intro. eapply H0. constructor 2. eauto.
Qed.

Hint Extern 20 (?s \ {?x; {}} ⊆ ?s \ singleton ?x) => eapply minus_single_singleton''.
Hint Extern 20 (?s \ singleton ?x ⊆ ?s \ {?x; {}}) => eapply minus_single_singleton'.

Hint Extern 20 (?s \ {?x; {}} [=] ?s \ singleton ?x) => rewrite minus_single_singleton; reflexivity.
Hint Extern 20 (?s \ singleton ?x [=] ?s \ {?x; {}}) => rewrite minus_single_singleton; reflexivity.

Hint Extern 20 (Subset (?a \ _) ?a) => eapply minus_incl.
Hint Extern 20 (Subset (?a \ _) ?a') => progress (first [ has_evar a | has_evar a' | eapply minus_incl ]).

Hint Extern 20 (pe ?a ?a) => reflexivity.

Hint Extern 10 (Subset ?a (_ ∪ ?a)) => eapply incl_right.

Instance diff_proper_impl X `{OrderedType X}
: Proper (flip Subset ==> Subset ==> flip Subset) diff.
Proof.
  unfold Proper, respectful, flip; intros.
  cset_tac; intuition.
Qed.

Definition max_set {X} `{OrderedType X} (a:set X) (b:set X) :=
  if [SetInterface.cardinal a < SetInterface.cardinal b] then
    b
  else
    a.

Lemma cardinal_difference {X} `{OrderedType X} (s t: set X)
: SetInterface.cardinal (s \ t) <= SetInterface.cardinal s.
Proof.
  erewrite <- (diff_inter_cardinal s t).
  omega.
Qed.

Lemma cardinal_difference' {X} `{OrderedType X} (s t: set X)
: t ⊆ s
  -> SetInterface.cardinal (s \ t) = SetInterface.cardinal s - SetInterface.cardinal t.
Proof.
  intros.
  erewrite <- (diff_inter_cardinal s t).
  assert (s ∩ t [=] t). (cset_tac; intuition; eauto).
  rewrite H1. omega.
Qed.

Instance cardinal_morph {X} `{OrderedType X}
: Proper (@Subset X _ _ ==> Peano.le)  SetInterface.cardinal.
Proof.
  unfold Proper, respectful; intros.
  eapply subset_cardinal; eauto.
Qed.

Lemma NoDupA_decons A (R:A->A->Prop) x L
  : NoDupA R (x::L)
    -> NoDupA R L.
Proof.
  inversion 1; eauto.
Qed.

Lemma NoDupA_decons_notin X `{OrderedType X} x L
  :  NoDupA _eq (x :: L)
     -> x ∉ of_list L.
Proof.
  inversion 1; subst. rewrite <- InA_in; eauto.
Qed.

Hint Resolve NoDupA_decons NoDupA_decons_notin.

Lemma cardinal_of_list_nodup {X} `{OrderedType X} (Z:list X)
: NoDupA _eq Z -> SetInterface.cardinal (of_list Z) = length Z.
Proof.
  general induction Z; simpl in * |- *.
  - eapply empty_cardinal.
  - dcr. erewrite cardinal_2; eauto.
Qed.

Instance map_morph_Equal X `{OrderedType X} Y `{OrderedType Y}
         (f : X -> Y) `{Proper _ (_eq ==> _eq) f}
  : Proper (Equal ==> Equal) (map f).
Proof.
  unfold Proper, respectful; intros.
  cset_tac.
Qed.

Instance map_morph_Subset X `{OrderedType X} Y `{OrderedType Y}
         (f : X -> Y) `{Proper _ (_eq ==> _eq) f}
  : Proper (Subset ==> Subset) (map f).
Proof.
  unfold Proper, respectful; intros.
  cset_tac.
Qed.

Instance In_morph_Subset Y `{OrderedType Y}
  : Proper (_eq ==> Subset ==> impl) In.
Proof.
  unfold Proper, respectful, impl; intros.
  eapply H1. rewrite <- H0; eauto.
Qed.

Instance In_morph_Equal Y `{OrderedType Y}
  : Proper (_eq ==> Equal ==> iff) In.
Proof.
  unfold Proper, respectful, impl; intros.
  rewrite H0. cset_tac.
Qed.

Lemma cardinal_map {X} `{OrderedType X} {Y} `{OrderedType Y} (s: set X) (f:X -> Y)
      `{Proper _ (_eq ==> _eq) f}
: SetInterface.cardinal (SetConstructs.map f s) <= SetInterface.cardinal s.
Proof.
  pattern s. eapply set_induction.
  - intros. repeat rewrite SetProperties.cardinal_1; eauto.
    hnf. intros; intro. eapply map_iff in H3. dcr.
    eapply H2; eauto. eauto.
  - intros.
    erewrite (SetProperties.cardinal_2 H3 H4); eauto.
    decide (f x ∈ SetConstructs.map f s0).
    + assert (SetConstructs.map f s0 [=] {f x; SetConstructs.map f s0}). {
        cset_tac'. setoid_rewrite <- H10. eauto.
      }
      rewrite <- H2. rewrite H5.
      assert (SetConstructs.map f s' ⊆ {f x; SetConstructs.map f s0}). {
        hnf; intros. rewrite H5. eapply Add_Equal in H4.
        rewrite H4 in H6.
        revert H1 H6; clear; cset_tac'.
      }
      rewrite <- H6. omega.
    + rewrite <- H2. erewrite <- cardinal_2; eauto.
      hnf; intros.
      eapply Add_Equal in H4. rewrite H4 in *; clear H4.
      split; intros; revert n; cset_tac'.
Qed.

Hint Extern 20 ( ?v ∈ singleton ?v ) =>  eapply singleton_iff; reflexivity.
Hint Extern 20 ( ?s ⊆ ?s ∪ _ ) =>  eapply incl_left.
Hint Extern 20 ( ?s ⊆ _ ∪ ?s ) =>  eapply incl_right.
Hint Extern 20 => match goal with
                 | [ H: ?x ∈ ?s, H': ?x ∉ ?s |- _ ] => exfalso; eapply H', H
                 | [ H: ?x === ?y, H': ?x =/= ?y |- _ ] => exfalso; eapply H', H
                 | [ H: ?x === ?y, H': ?x === ?y -> False |- _ ]
                   => exfalso; eapply H', H
                 | [ H: ?y === ?x, H': ?x =/= ?y |- _ ] =>
                   exfalso; eapply H'; symmetry; eapply H
                 | [ H: ?y === ?x, H': ?x === ?y -> False |- _ ] =>
                   exfalso; eapply H'; symmetry; eapply H
                 | [ H: ?x =/= ?x |- _ ] => exfalso; eapply H; reflexivity
                 | [ H: ?x === ?x -> False |- _ ] => exfalso; eapply H; reflexivity
                 end.

Hint Resolve in_add_left union_left union_right get_list_union_map : cset.

Hint Resolve prod_eq_intro : cset.
Hint Resolve incl_singleton: cset.
Hint Resolve incl_empty : cset.
Hint Resolve add_struct_eq union_struct_eq_1 union_struct_eq_2 : cset.
Hint Resolve union_incl_split : cset.
Hint Resolve not_in_minus : cset.
Hint Resolve not_incl_minus : cset.

(* general hints *)

Hint Resolve equal_minus_empty incl_minus_empty incl_minus_change incl_minus_union
     incl_singleton union_incl_split : cset.

Hint Resolve incl_union_lr incl_union_left incl_union_right incl_add_right | 20 : cset.

Hint Resolve incl_empty : auto.

Lemma eq_union_lr (X : Type) (H : OrderedType X) (s s' t t' : set X)
  : s [=] s' -> t [=] t' -> s ∪ t [=] s' ∪ t'.
Proof.
  intros A B. rewrite A, B; eauto.
Qed.

Hint Immediate eq_union_lr : cset.

Lemma union_sym_simpl (X : Type) (H : OrderedType X) (s t : set X)
  : s ∪ t [=] t ∪ s.
Proof.
  eapply union_sym.
Qed.

Hint Resolve union_sym_simpl : cset.

Lemma incl_from_union_eq X `{OrderedType X} s t u
  : t [=] s ∪ u
    -> s ⊆ t.
Proof.
  intro eq; rewrite eq. eauto.
Qed.

Hint Extern 0 =>
match goal with
| [ H1 : ?s ⊆ ?t, H2: ?t ⊆ ?u |- ?s ⊆ ?u] => eapply (Subset_trans H1 H2)
| [ H : ?t [=] ?s ∪ ?u |- ?s ⊆ ?t] => eapply (incl_from_union_eq H)
end : cset.

Lemma add_minus_comm X `{OrderedType X} x s t:
  x ∉ t
  -> {x; s} \ t [=] {x; s \ t}.
Proof.
  cset_tac; intuition; eauto.
Qed.

Hint Resolve add_minus_comm : cset.

Create HintDb pe discriminated.

Ltac pe_rewrite_step :=
  match goal with
     | [ H : pe ?an _, H' : context [?an] |- _ ] =>
       setoid_rewrite H in H'; simpl in H'
     | [ H : pe ?an _ |-  context [?an] ] =>
       setoid_rewrite H; simpl
  end.

Hint Extern 1 => pe_rewrite_step : pe.

Hint Extern 10 =>
match goal with
|  [ |- pe (_, _) (_,_) ] => constructor
end : pe.

Lemma add_single_rm_single_incl X `{OrderedType X} x D
  : {x; D} \ singleton x ⊆ D.
Proof.
  cset_tac.
Qed.

Lemma minus_incl_add X `{OrderedType X} x (s t:set X)
:  s \ singleton x ⊆ t
   -> s [<=]{x; t}.
Proof.
  cset_tac.
Qed.

Lemma incl_minus_single_not_in X `{OrderedType X} x D
  : x ∉ D
    -> D ⊆ D \ singleton x.
Proof.
  cset_tac.
Qed.

Lemma minus_minus_minus_add X `{OrderedType X} s t x
  : s \ t \ singleton x ⊆ s \ {x; t}.
Proof.
  cset_tac.
Qed.

Hint Resolve minus_incl_add add_single_rm_single_incl
     incl_minus_single_not_in minus_minus_minus_add equiv_minus_union
  : cset.

Hint Resolve incl_meet_lr incl_meet_split : cset.

Definition lminus X `{OrderedType X} (s:set X) L := s \ of_list L.

Hint Extern 10 =>
match goal with
| [ H : ?a = ?b, H': ?c = ?b |- ?c = ?a ] => eapply (eq_trans H' (eq_sym H))
| [ H : ?b = ?a, H': ?b = ?c |- ?a = ?c ] => eapply (eq_trans (eq_sym H) H')
end : len.

Lemma incl_minus_both X `{OrderedType X} (s t u: set X)
  : s \ u ⊆ t
    -> u ⊆ t
    -> s ⊆ t.
Proof.
  intros. cset_tac'. decide (a ∈ u); eauto.
Qed.

Hint Extern 5 =>
match goal with
  | [ H1 : ?s \ ?u ⊆ ?t, H2 : ?u ⊆ ?t |- ?s ⊆ ?t ] => eapply (incl_minus_both H1 H2)
end : cset.

Instance instance_option_eq_trans_R X {R: relation X} `{Transitive _ R}
 : Transitive (option_eq R).
Proof.
  hnf; intros. inv H0; inv H1.
  + econstructor.
  + econstructor; eauto.
Qed.

Instance instance_option_eq_refl_R X {R: relation X} `{Reflexive _ R}
 : Reflexive (option_eq R).
Proof.
  hnf; intros. destruct x.
  + econstructor; eauto.
  + econstructor.
Qed.

Instance instance_option_eq_sym_R X {R: relation X} `{Symmetric _ R}
 : Symmetric (option_eq R).
Proof.
  hnf; intros. inv H0.
  + econstructor.
  + econstructor; eauto.
Qed.

(*
Instance diff_m_eq X `{OrderedType X}
  : Proper (eq ==> eq ==> eq) diff.
Proof.
  unfold Proper, respectful; intros; subst; eauto.
Qed.

Instance Subset_m_eq_eq_flip_impl X `{OrderedType X}
  : (Proper (eq ==> eq ==> flip impl) Subset).
Proof.
  unfold Proper, respectful, flip, impl; intros; subst; eauto.
Qed.

Instance Subset_m_Equal_eq_flip_impl X `{OrderedType X}
  : (Proper (Equal ==> eq ==> flip impl) Subset).
Proof.
  unfold Proper, respectful, flip, impl; intros; subst.
  rewrite H0; eauto.
Qed.
 *)

Instance prod_eq_fst_morphism X Y R R'
: Proper (@prod_eq X Y R R' ==> R) fst.
Proof.
  unfold Proper, respectful; intros.
  inversion H; simpl; eauto.
Qed.

Instance prod_eq_snd_morphism X Y R R'
: Proper (@prod_eq X Y R R' ==> R') snd.
Proof.
  unfold Proper, respectful; intros.
  inversion H; simpl; eauto.
Qed.

Lemma card_in_of_list X `{OrderedType X} ( l: list X) :
  NoDupA _eq l -> cardinal (of_list l) = length l.
Proof.
induction l; intro noDup; simpl; eauto.
- rewrite add_cardinal_2.
  + inversion_clear noDup. apply IHl in H1. rewrite H1. eauto.
  + inversion_clear noDup. intro no. apply <- InA_in in no. contradiction.
Qed.

Lemma add_cardinal X `{OrderedType X} (s : set X) x
  : cardinal {x; s} <= S (cardinal s).
Proof.
decide (x ∈ s);
  [apply add_cardinal_1 in i; rewrite i
  |apply add_cardinal_2 in n; rewrite n]; cset_tac.
Qed.

Lemma elements_length  X `{OrderedType X} (s : set X)
: length (elements s) = cardinal s.
Proof.
  rewrite SetInterface.cardinal_1. reflexivity.
Qed.

Lemma elements_of_list_size X `{OrderedType X} ( l : list X) :
  NoDupA _eq l -> length (elements (of_list l)) = length l.
intro noDup. rewrite elements_length. apply card_in_of_list.
exact noDup.
Qed.

Lemma hd_in_list  X `{OrderedType X} ( l : list X)  x :
 l <> nil -> InA _eq (hd x l) l.
intro nonNil.
destruct l.
- isabsurd.
- constructor. simpl. eauto.
Qed.

Lemma hd_in_elements X `{OrderedType X} ( s : set X) x:
 ~ s [=] ∅ -> hd x (elements s) ∈ s.
intro nonEmpty.
apply elements_iff.
apply hd_in_list.
rewrite <- elements_nil_eset.
eauto with cset.
Qed.

Lemma list_eq_app X (R: relation X) (l1 l2 l1' l2' : list X)
: list_eq R l1 l1' -> list_eq R l2 l2' -> list_eq R (l1++l2) (l1'++l2').
Proof.
intros eq1 eq2. general induction eq1; eauto using @list_eq.
Qed.

Lemma cardinal_union_difference X `{OrderedType X} (s t u : set X)
: cardinal (s ∪ (t \ u)) <= cardinal (s ∪ t).
Proof.
assert (s ∪ (t \ u) ⊆ s ∪ t). { cset_tac. }
rewrite H0. eauto.
Qed.

Lemma cardinal_set_tl
      (X : Type) `{OrderedType X}
      (s : set X)
      (n : nat)
  :
    cardinal (of_list (elements s)) = S n
    -> cardinal (of_list (tl (elements s))) = n
.
Proof.
  intro card_Sn.
  remember (elements s) as L.
  general induction L; simpl in *; eauto.
  - inv card_Sn.
  - rewrite add_cardinal_2 in card_Sn.
    + omega.
    + intro N.
      assert (nn := (elements_3w s)).
      rewrite <- HeqL in nn.
      inversion_clear nn.
      apply H0.
      apply <- InA_in.
      assumption.
Qed.

Lemma cardinal_tl
      (X : Type) `{OrderedType X}
      (n : nat)
      (s : set X)
  :
    cardinal s = S n
    -> cardinal (of_list (tl (elements s))) = n
.
Proof.
  induction n; intros card_s.
  - rewrite <- elements_length in card_s.
    assert (tl (elements s) = nil) as tl_nil.
    + destruct (elements s).
      * simpl. reflexivity.
      * simpl in *. assert (length l = 0). { omega. }
        apply length_zero_iff_nil.
        assumption.
    + rewrite tl_nil. simpl. apply empty_cardinal.
  - apply cardinal_set_tl.
    rewrite of_list_elements.
    assumption.
Qed.

Lemma union_exclusive X `{OrderedType X} s t
  : s ∪ t [=] s ∪ (t \ s).
Proof.
  cset_tac.
Qed.

Lemma in_add_right X `{OrderedType X} s x x'
  : x ∈ s -> x ∈ {x'; s}.
Proof.
  cset_tac; intuition.
Qed.

Hint Resolve in_add_right : cset.

Lemma set_decomp X `{OrderedType X} t s
  : s [=] s ∩ t ∪ (s \ t).
Proof.
  cset_tac.
Qed.

(* Hint Resolve <- / -> is implicitly local *)
Hint Resolve <- map_iff : cset.
Hint Resolve -> map_iff : cset.

Lemma map_spec_1 : forall (A : Type) (HA : OrderedType A) (B : Type) (HB : OrderedType B) (f : A -> B),
       Proper (_eq ==> _eq) f ->
       forall (s : ⦃A⦄) (b : B), b ∈ map f s -> (exists a : A, a ∈ s /\ b === f a).
  intros; eauto with cset.
Qed.

Lemma map_spec_2 : forall (A : Type) (HA : OrderedType A) (B : Type) (HB : OrderedType B) (f : A -> B),
       Proper (_eq ==> _eq) f ->
       forall (s : ⦃A⦄) (b : B), (exists a : A, a ∈ s /\ b === f a) -> b ∈ map f s.
  intros; eauto with cset.
Qed.

Hint Resolve map_spec_1 map_spec_2 : cset.

Lemma incl_minus_incl_union X `{OrderedType X} s t u
  : s \ t ⊆ u
    -> s ⊆ t ∪ u.
Proof.
  intros. rewrite <- H0. cset_tac.
Qed.

Lemma incl_union_lr_eq X `{OrderedType X} s t u v
  : s ∪ t [=] u
    -> v ∪ t ⊆ v ∪ u.
Proof.
  intros. rewrite <- H0. eauto with cset.
Qed.

Lemma incl_union_eq X `{OrderedType X} s t u
  : s ∪ t [=] u
    -> t ⊆ u.
Proof.
  intros. rewrite <- H0. eauto with cset.
Qed.

Lemma incl_add_union_union X `{OrderedType X} s x t u
  : s [=] {x; t}
    -> {x; u} ∪ t ⊆ u ∪ s.
Proof.
  intros. rewrite H0. cset_tac.
Qed.

Hint Immediate incl_minus_incl_union incl_union_lr_eq incl_union_eq incl_add_union_union : cset.

Lemma filter_add_in X `{OrderedType X} (p:X -> bool) `{Proper _ (_eq ==> eq) p} x s
  : p x -> SetInterface.filter p {x;s} [=] {x; SetInterface.filter p s}.
Proof.
  intros P; split; intros In; cset_tac.
Qed.

Lemma filter_add_notin X `{OrderedType X} (p:X -> bool) `{Proper _ (_eq ==> eq) p} x s
  : ~ p x -> SetInterface.filter p {x;s} [=] SetInterface.filter p s.
Proof.
  intros P; split; intros In; cset_tac.
Qed.

Lemma filter_incl X `{OrderedType X} (p:X -> bool) `{Proper _ (_eq ==> eq) p} s
  : SetInterface.filter p s ⊆ s.
Proof.
  hnf; intros. eapply zfilter_1; eauto.
Qed.

Lemma filter_add_incl X `{OrderedType X} (p:X -> bool) `{Proper _ (_eq ==> eq) p} s x
  : SetInterface.filter p {x; s} ⊆ {x; SetInterface.filter p s}.
Proof.
  decide (p x).
  - rewrite filter_add_in; eauto.
  - rewrite filter_add_notin; eauto with cset.
Qed.

Lemma filter_difference X `{OrderedType X} (p:X->bool) `{Proper _ (_eq ==> eq) p} s t
  : filter p (s \ t) [=] filter p s \ filter p t.
Proof.
  cset_tac.
Qed.

Lemma subset_filter X `{OrderedType X} (p:X->bool) `{Proper _ (_eq ==> eq) p} (lv lv':set X)
  : lv ⊆ lv'
    -> filter p lv ⊆ filter p lv'.
Proof.
  cset_tac.
Qed.

Lemma filter_singleton_in X `{OrderedType X} (p:X -> bool) `{Proper _ (_eq ==> eq) p} x
  : p x -> filter p (singleton x) [=] singleton x.
Proof.
  intros P; split; intros In; cset_tac.
Qed.

Lemma filter_singleton_notin X `{OrderedType X} (p:X -> bool) `{Proper _ (_eq ==> eq) p} x
  : ~ p x -> filter p (singleton x) [=] ∅.
Proof.
  intros P; split; intros In; cset_tac.
Qed.

Lemma cardinal_filter X `{OrderedType X} (p:X->bool) `{Proper _ (_eq ==> eq) p} (s:set X)
  : SetInterface.cardinal (filter p s) <= SetInterface.cardinal s.
Proof.
  eapply subset_cardinal, filter_incl; eauto.
Qed.

Lemma decide_mem_1 X `{OrderedType X} x (s:set X)
  : (x ∈ s -> False) \/ x ∈ s.
Proof.
  decide (x ∈ s); eauto.
Qed.

Lemma decide_mem_2 X `{OrderedType X} x (s:set X)
  : x ∈ s \/ (x ∈ s -> False).
Proof.
  decide (x ∈ s); eauto.
Qed.

Hint Resolve decide_mem_1 decide_mem_2.

Ltac set_simpl :=
  repeat
  match goal with
  | [ EQ : ?D [=] ?D', H : context [ ?D ] |- _ ]
    => is_var D; setoid_rewrite EQ in H
  | [ EQ : ?D [=] ?D' |- context [ ?D ] ]
    => is_var D; setoid_rewrite EQ
  | [ EQ : ?D [=] ?D' |- _ ] => is_var D; clear D EQ
  | [ EQ : ?D' [=] ?D, H : context [ ?D ] |- _ ]
    => is_var D; setoid_rewrite <- EQ in H
  | [ EQ : ?D' [=] ?D |- context [ ?D ] ]
    => is_var D; setoid_rewrite <- EQ
  | [ EQ : ?D' [=] ?D |- _ ] => is_var D; clear D EQ
  | [ I : context [ @union ?A ?H _ _ {} ] |- _ ]
    => rewrite (@empty_neutral_union_r A H) in I
  | [ I : context [ @union ?A ?H _ {} _ ] |- _ ]
       => rewrite (@empty_neutral_union A H) in I
  | [ |- context [ @union ?A ?H _ _ {} ] ] => rewrite (@empty_neutral_union_r A H)
  | [ |- context [ @union ?A ?H _ {} _ ] ] => rewrite (@empty_neutral_union A H)
  | [ I : context [ @diff ?A ?H _ _ {} ] |- _ ]
       => rewrite (@minus_empty A H) in I
  | [ |- context [ @diff ?A ?H _ _ {} ] ]
    => rewrite (@minus_empty A H)
  | [ H : {} ⊆ _ |- _ ] => clear H
  end.

Instance InA_computable X `{OrderedType X} (L:list X) x
  : Computable (InA _eq x L).
Proof.
  hnf.
  general induction L.
  - right; inversion 1.
  - decide (x === a); edestruct IHL; eauto.
    right; inversion 1; eauto.
Qed.

Instance NoDupA_computable X `{OrderedType X} (L:list X)
  : Computable (NoDupA _eq L).
Proof.
  hnf. general induction L.
  - eauto using NoDupA.
  - decide (InA _eq a L); edestruct IHL; eauto.
    right; inversion 1; eauto.
Qed.

Instance For_all_P_Equal X `{OrderedType X} (P:X->Prop) `{Proper _ (_eq ==> iff) P}
  : Proper (Equal ==> iff) (For_all P).
Proof.
  unfold Proper, respectful, For_all; split; intros; eapply H2; cset_tac.
Qed.

Instance For_all_P_Subset X `{OrderedType X} (P:X->Prop) `{Proper _ (_eq ==> iff) P}
  : Proper (Subset ==> flip impl) (For_all P).
Proof.
  unfold Proper, respectful, For_all, flip, impl; intros; eapply H2; eauto.
Qed.

Lemma of_list_drop_incl X `{OrderedType X} (n : nat) (L:list X)
  : of_list (drop n L) ⊆ of_list L.
Proof.
  general induction L; destruct n; simpl; eauto with cset.
  rewrite drop_nil; eauto.
Qed.

Lemma of_list_drop_elements_incl X `{OrderedType X} (n : nat) (s : set X)
  : of_list (drop n (elements s)) ⊆ s.
Proof.
  rewrite of_list_drop_incl.
  rewrite of_list_elements; eauto.
Qed.

Lemma filter_union X `{OrderedType X} (p:X->bool) s t `{Proper _ (_eq ==> eq) p}
  : filter p (s ∪ t) [=] filter p s ∪ filter p t.
Proof.
  cset_tac.
Qed.

Lemma nodup_to_list X `{OrderedType X} (s: set X)
  : NoDupA _eq (to_list s).
Proof.
  pose proof (elements_3w s). eauto.
Qed.

Lemma nodup_to_list_eq X `{UsualOrderedType X} (s: set X)
  : NoDupA eq (to_list s).
Proof.
  pose proof (elements_3w s). eauto.
Qed.

Lemma InA_In_eq X `{UsualOrderedType X} (L:list X) (x:X)
  : InA eq x L <-> InA _eq x L.
Proof.
  split; eauto.
Qed.

Lemma union_incl_union_swap X `{OrderedType X} s t
  : s ∪ t ⊆ t ∪ s.
Proof.
  cset_tac.
Qed.

Lemma minus_incl_comm X `{OrderedType X} s t u
  : (s \ t) \ u ⊆ (s \ u) \ t.
Proof.
  cset_tac.
Qed.

Lemma minus_union_incl_minus_minus X `{OrderedType X} s t u
  : (s \ (t ∪ u)) ⊆ (s \ t) \ u.
Proof.
  cset_tac.
Qed.

Hint Resolve union_incl_union_swap minus_incl_comm minus_union_incl_minus_minus : cset.

(* move to cardinal *)
Lemma card_inter_le_right
      (X : Type)

      `{OrderedType X}
      (s t : ⦃X⦄)
  :
    cardinal (s ∩ t) <= cardinal t
.
Proof.
  rewrite subset_cardinal with (s':=t);
    [reflexivity | cset_tac].
Qed.

(* move to cardinal *)
Lemma card_inter_le_left
      (X : Type)

      `{OrderedType X}
      (s t : ⦃X⦄)
  :
    cardinal (s ∩ t) <= cardinal s
.
Proof.
  rewrite subset_cardinal with (s':=s);
    [reflexivity | cset_tac].
Qed.

Lemma union_cardinal X `{OrderedType X} s s'
  :  disj s s'
     -> cardinal (s ∪ s') = cardinal s + cardinal s'.
Proof.
  intros. eapply union_cardinal.
  cset_tac.
Qed.

Lemma eq_empty X `{OrderedType X} (G:set X)
  : G [=] {} ∪ G.
Proof.
  cset_tac.
Qed.

Hint Resolve eq_empty : cset.

Smpl Add 30
     match goal with
     | [ I : context [ @union ?A ?H _ _ {} ] |- _ ]
       => rewrite (@empty_neutral_union_r A H) in I
     | [ I : context [ @union ?A ?H _ {} _ ] |- _ ]
       => rewrite (@empty_neutral_union A H) in I
     | [ |- context [ @union ?A ?H _ _ {} ] ] => rewrite (@empty_neutral_union_r A H)
     | [ |- context [ @union ?A ?H _ {} _ ] ] => rewrite (@empty_neutral_union A H)
     end : cset.

Lemma InA_In_eq_eq X `{OrderedType X} (L:list X) (x:X)
  : InA eq x L -> InA _eq x L.
Proof.
  intros. general induction H0; eauto using InA.
Qed.

Lemma InA_eq_of_list X `{OrderedType X} x L
  : InA eq x L -> x ∈ of_list L.
Proof.
  intros.
  eapply InA_In_eq_eq in H0; eauto.
  cset_tac.
Qed.

Smpl Add 40
     match goal with
     | [ H : InA eq ?x0 ?l |- _ ]
       => lazymatch goal with
         | [ I : x0 ∈ of_list l |- _ ]
           => fail
         | _ => pose proof (@InA_eq_of_list _ _ _ _ H)
         end
     end : cset.

Smpl Add
     match goal with
     | [ H : nil = snd ?a |- _ ] => destruct a; simpl snd in H
     | [ H : _ :: _ = snd ?a |- _ ] => destruct a; simpl snd in H
     end : inv_trivial.

Smpl Add
     match goal with
     | [ H : @_eq (@prod _ _) _ ?A ?B |- _ ] => inv_if_one_ctor H A B
     | [ H : @_eq (@list _) _ ?A ?B |- _ ] => inv_if_one_ctor H A B
     | [ H : @list_eq _ _ ?A ?B |- _ ] => inv_if_one_ctor H A B
     end : inv_trivial.

Smpl Add 100
     match goal with
     | [ H : (_, _) = (_,_) |- _ ] => invc H
     end : inv_trivial.

Lemma polyid
  : forall A:Prop, (A -> A) <-> True.
Proof.
  split; eauto.
Qed.

Smpl Add 49
     match goal with
     | [ H : context [?x -> ?x] |- _ ] => rewrite polyid in H
     | [ |- context [?x -> ?x] ] => rewrite polyid
     | [ H : context [?x -> ?x] |- _ ] => setoid_rewrite polyid in H
     | [ |- context [?x -> ?x] ] => setoid_rewrite polyid
     end : cset.

Smpl Add
    match goal with
    | [ |- @Equivalence.equiv
            _
            (@_eq _ (@SOT_as_OT _ (@eq nat) nat_OrderedType))
            (@OT_Equivalence _ (@SOT_as_OT _ (@eq nat) nat_OrderedType))
            ?x ?y ] => hnf
    | [ H : @Equivalence.equiv
              _
              (@_eq _ (@SOT_as_OT _ (@eq nat) nat_OrderedType))
              (@OT_Equivalence _ (@SOT_as_OT _ (@eq nat) nat_OrderedType))
              ?x ?y |- _ ] => hnf in H; clear_trivial_eqs
    end : cset.

Lemma disj_union_inv X `{OrderedType X} (x:X) (s t:set X)
  : disj s t
    -> x ∈ s ∪ t
    -> (x ∈ s /\ x ∉ t) \/ (x ∈ t /\ x ∉ s).
Proof.
  cset_tac.
Qed.

Lemma le_trans X `{OrderedType X} x y z
  : ~ _lt x y -> ~ _lt y z -> ~ _lt x z.
Proof.
  intros. decide (x === y).
  - rewrite e . eauto.
  - eapply le_neq in n; eauto.
    intro. eapply H1. etransitivity; eauto.
Qed.

Lemma lt_trans_eq X `{OrderedType X} x y
  : ~ _lt x y -> ~ _lt y x -> _eq x y.
Proof.
  intros. decide (x === y); eauto.
  - eapply le_neq in n; eauto.
    exfalso. eauto.
Qed.


From PLF Require Import Maps.
From Coq Require Import Bool.Bool.
From Coq Require Import Arith.Arith.
From Coq Require Import Arith.EqNat.
From Coq Require Import Arith.PeanoNat. Import Nat.
From Coq Require Import Lia.
From PLF Require Export Imp.

(* Assertions *)

Definition Assertion := state -> Prop.

Module ExAssertions.
  Definition assn1 : Assertion :=
    fun st => st X <= st Y.
  Definition assn2 : Assertion :=
    fun st => st X = 3 \/ st X <= st Y.
  Definition assn3 : Assertion :=
    fun st =>
      st Z * st Z <= st X /\ ~(((S (st Z)) * (S (st Z))) <= st X).
  Definition assn4 : Assertion :=
    fun st => st Z = max (st X) (st Y).
End ExAssertions.

(*
  Given two assertions P and Q, we say that P implies Q,
  written P ->> Q, if, whenever P holds in some state st,
  Q also holds.
*)

Definition assert_implies (P Q : Assertion) : Prop :=
  forall st, P st -> Q st.

Declare Scope hoare_spec_scope.
Notation "P ->> Q" :=
  (assert_implies P Q)
  (at level 80)
  : hoare_spec_scope.
Open Scope hoare_spec_scope.

Notation "P <<->> Q" :=
  (P ->> Q /\ Q ->> P)
  (at level 80)
  : hoare_spec_scope.

Definition Aexp : Type :=
  state -> nat.

Definition assert_of_Prop (P : Prop) : Assertion :=
  fun _ => P.

Definition Aexp_of_nat (n : nat) : Aexp :=
  fun st => n.

Definition Aexp_of_aexp (a : aexp) : Aexp :=
  fun st => aeval st a.

Coercion assert_of_Prop : Sortclass >-> Assertion.
Coercion Aexp_of_nat : nat >-> Aexp.
Coercion Aexp_of_aexp : aexp >-> Aexp.

Add Printing Coercion Aexp_of_nat Aexp_of_aexp assert_of_Prop.

Arguments assert_of_Prop /.
Arguments Aexp_of_nat /.
Arguments Aexp_of_aexp /.

Add Printing Coercion Aexp_of_nat Aexp_of_aexp assert_of_Prop.

Declare Scope assertion_scope.
Bind Scope assertion_scope with Assertion.
Bind Scope assertion_scope with Aexp.
Delimit Scope assertion_scope with assertion.

Notation assert P := (P%assertion : Assertion).
Notation mkAexp a := (a%assertion : Aexp).

Notation "~ P" :=
  (fun st => ~ assert P st) : assertion_scope.
Notation "P /\ Q" :=
  (fun st => assert P st /\ assert Q st) : assertion_scope.
Notation "P \/ Q" :=
  (fun st => assert P st \/ assert Q st) : assertion_scope.
Notation "P -> Q" :=
  (fun st => assert P st -> assert Q st) : assertion_scope.
Notation "P <-> Q" :=
  (fun st => assert P st <-> assert Q st) : assertion_scope.
Notation "a = b" :=
  (fun st => mkAexp a st = mkAexp b st) : assertion_scope.
Notation "a <> b" :=
  (fun st => mkAexp a st <> mkAexp b st) : assertion_scope.
Notation "a <= b" :=
  (fun st => mkAexp a st >= mkAexp b st) : assertion_scope.
Notation "a < b" :=
  (fun st => mkAexp a st < mkAexp b st) : assertion_scope.
Notation "a >= b" :=
  (fun st => mkAexp a st >= mkAexp b st) : assertion_scope.
Notation "a > b" :=
  (fun st => mkAexp a st > mkAexp b st) : assertion_scope.
Notation "a + b" :=
  (fun st => mkAexp a st + mkAexp b st) : assertion_scope.
Notation "a - b" :=
  (fun st => mkAexp a st - mkAexp b st) : assertion_scope.
Notation "a * b" :=
  (fun st => mkAexp a st * mkAexp b st) : assertion_scope.

Definition ap {X} (f : nat -> X) (x : Aexp) :=
  fun st => f (x st).

Definition ap2 {X} (f : nat -> nat -> X) (x : Aexp)
                   (y : Aexp) (st : state) :=
  f (x st) (y st).

Module ExamplePrettyAssertions.
  Definition ex1 : Assertion := X = 3.
  Definition ex2 : Assertion := True.
  Definition ex3 : Assertion := False.

  Definition assn1 : Assertion := X <= Y.
  Definition assn2 : Assertion := X = 3 \/ X <= Y.
  Definition assn3 : Assertion := Z = ap2 max X Y.
  Definition assn4 : Assertion :=
    Z * Z <= X /\ ~ (((ap S Z) * (ap S Z)) <= X).
End ExamplePrettyAssertions.

Definition hoare_triple (P : Assertion) (c : com) (Q : Assertion)
                      : Prop :=
  forall st st',
  st =[ c ]=> st' -> P st -> Q st'.

Notation "{{ P }} c {{ Q }}" :=
  (hoare_triple P c Q)
  (at level 90, c custom com at level 90)
  : hoare_spec_scope.

Check ({{True}} X := 0 {{True}}).

Theorem hoare_post_true :
  forall (P Q : Assertion) c, (forall st, Q st) -> {{P}} c {{Q}}.
Proof.
  intros P Q c.
  intros H st st'.
  intros H1 H2.
  apply H.
Qed.

Theorem hoare_pre_false :
  forall (P Q : Assertion) c, (forall st, ~(P st)) -> {{P}} c {{Q}}.
Proof.
  intros P Q c H st.
Admitted.

Theorem hoare_skip :
  forall P, {{P}} skip {{P}}.
Proof.
  intros P st st' H1 H2.
  inversion H1.
  subst.
  assumption.
Qed.

Theorem hoare_seq :
  forall P Q R c1 c2, {{Q}} c2 {{R}} -> {{P}} c1 {{Q}} ->
    {{P}} c1; c2 {{R}}.
Proof.
  intros P Q R c1 c2 H1 H2 st st' H HP.
  inversion H.
  subst.
  eauto.
Qed.


From hahn Require Import Hahn.
Require Import Setoid.

Set Implicit Arguments.
Remove Hints plus_n_O.

(******************************************************************************)
(** ** ifthenelse  *)
(******************************************************************************)

Definition ifthenelse T K L (c : {K} + {L}) (x y : T) :=
  if c then x else y.

Definition ifthenelse_b T (c : bool) (x y : T) :=
  if c then x else y.

Add Parametric Morphism {A} (K : Prop) (L : Prop) (c : {K} + {L}) :
  (@ifthenelse (A -> Prop) K L c) with signature
    set_equiv ==>
    set_equiv ==>
    set_equiv as ifthenelse_more.
Proof using. intros; unfold ifthenelse; desf. Qed.

Add Parametric Morphism {A} (c : bool) :
  (@ifthenelse_b (A -> Prop) c) with signature
    set_equiv ==>
    set_equiv ==>
    set_equiv as ifthenelse_b_more.
Proof using. intros; unfold ifthenelse_b; desf. Qed.

Lemma ite_alt {A} K L (c : {K} + {L}) (x y : A -> Prop) :
  (if c then x else y) ≡₁ ifthenelse c x y.
Proof using. rels. Qed.

Lemma iteb_alt {A} (c : bool) (x y : A -> Prop) :
  (if c then x else y) ≡₁ ifthenelse_b c x y.
Proof using. rels. Qed.

Lemma ite_union_t {A} K L (c : {K} + {L}) (x y z : A -> Prop) :
  ifthenelse c (x ∪₁ y) z ≡₁ ifthenelse c x z ∪₁ ifthenelse c y z.
Proof using. by rewrite <- !ite_alt; destruct c; [|rewrite set_unionK]. Qed.


Set Implicit Arguments.
From TLC Require Import LibTactics LibLogic LibProd LibEpsilon LibContainer
     LibSet LibRelation LibPer LibMonoid.
Local Notation path := rtclosure.
From iris_time.union_find.math Require Import LibNatExtra LibIter LibRewrite
     InverseNatNat Ackermann InverseAckermann MiscArith TLCBuffer
     UnionFind01Data UnionFind11Rank UnionFind21Parent.

(* Following Tarjan's course notes and Cormen-Leiserson-Rivest, we now define
   the level [k], the index [i], and the potential functions [phi] and [Phi]. *)

(* -------------------------------------------------------------------------- *)

Section Tarjan.

(* In the following, we again assume that [F] is a ranked disjoint set forest
   with domain [D] and ranks [K]. *)

Variable V : Type.
Variable D : set V.
Variable F : binary V.
Variable K : V -> nat.
Hypothesis is_rdsf_F:
  is_rdsf D F K.

Notation p := (p F).

(* -------------------------------------------------------------------------- *)

Section NonRoot.

(* Let [x] be a non-root. *)

Variable x : V.
Hypothesis x_non_root: ~ is_root F x.

(* -------------------------------------------------------------------------- *)

(* Assume the rank of [x] is at least 1. *)

Hypothesis x_has_nonzero_rank:
  0 < K x.

(* The level of [x] is defined as the largest [k] such that
   [A k (K x)] is less than or equal to [K (p x)]. *)

Definition k :=
  betaf (fun k => A k (K x)) (K (p x)).

(* The following lemma proves that [k] is well-defined. *)

Lemma k_exists:
  A 0 (K x) <= K (p x).
Proof using is_rdsf_F x_non_root.
  rewrite Abase_eq. eapply parent_has_greater_rank; eauto.
Qed.

Ltac k th :=
  eapply th with (f := fun k => A k (K x));
  eauto using k_exists with monotonic.

(* The level of [x] seems to be a measure of the distance of the rank
   of [x] and the rank of its parent. In the case where these ranks
   are closest, [K (p x)] is [K x + 1], so [k] is 0. *)

Lemma k_is_zero:
  K (p x) = K x + 1 ->
  k = 0.
Proof using x_has_nonzero_rank.
  introv h. unfold k. rewrite h. eapply beta_x_succ_x. eauto.
Qed.

(* In the case where these ranks are furthest away, [K x] is 1
   and [K (p x)] is, say, [n - 1]. (In reality, ranks are bounded
   by [log2 n], but we don't need this information here.) This
   shows that [k] is less than [alpha n]. *)

Lemma k_lt_alpha:
  forall n,
  card D <= n ->
  k < alpha n.
Proof using is_rdsf_F x_non_root x_has_nonzero_rank.
  intros.
  (* By definition of [k], it suffices to prove [K (p x) < A (alpha n) (K x)]. *)
  k betaf_spec_direct_contrapositive.
  (* Because [K x] is greater than zero, it suffices to consider the worst
     case where [K x] is 1. *)
  eapply Nat.lt_le_trans with (m := A (alpha n) 1); [ |
    eauto with monotonic lia ].
  (* By definition of [alpha], [A (alpha n) 1] is at most [n]. *)
  eapply Nat.lt_le_trans with (m := n); [ |
    alpha f_alphaf ].
  (* There remains to argue that every rank is less than [n]. *)
  eapply Nat.lt_le_trans; [ | eassumption ].
  eapply rank_is_linear; eauto using parent_in_D.
Qed.

(* -------------------------------------------------------------------------- *)

(* The index of [x] is defined as the largest [i] such that [i]
   iterations of [A k] take us from [K x] to at most [K (p x)]. *)

Definition i :=
  betaf (fun i => iter i (A k) (K x)) (K (p x)).
  (* If that sounds crazy: it is. *)

(* The following lemmas justify that [i] is well-defined. *)

Lemma i_exists:
  iter 0 (A k) (K x) <= K (p x).
Proof using is_rdsf_F x_non_root.
  clear x_has_nonzero_rank.
  simpl.
  forwards: parent_has_greater_rank; eauto.
  lia.
Qed.

Ltac i th :=
  unfold i; eapply th;
  eauto using iter_i_Akx_tends_to_infinity_along_i, iter_Ak_monotonic_in_i,
    i_exists.

(* [i] is at least 1. *)

Lemma i_ge_1:
  1 <= i.
Proof using is_rdsf_F x_non_root x_has_nonzero_rank.
  (* By definition of [i], we must show that applying [A k] once
     to [K x] takes us below or at [K (p x)]. *)
  i betaf_spec_reciprocal. simpl.
  (* And this is true by definition of [k]. *)
  k betaf_spec_direct. (* wow *)
Qed.

(* [i] is at most [K x]. *)

Lemma i_le_rank:
  i <= K x.
Proof using is_rdsf_F x_non_root x_has_nonzero_rank.
  (* By definition of [i], we must show that applying [1 + K x]
     times the function [A k] to [K x] takes us above [K (p x)]. *)
  i betaf_spec_direct_contrapositive_le.
  (* By definition of [A], the right-hand side of this goal is [A (1 + k) (K x)]. *)
  match goal with |- _ < ?rhs =>
    replace rhs with (A (1 + k) (K x)) by reflexivity
  end.
  (* This goal holds by definition of [k]. *)
  k betaf_spec_reciprocal_contrapositive. (* tchac! *)
Qed.

End NonRoot.

(* -------------------------------------------------------------------------- *)

(* We write [N] for a certain fixed upper bound on the number of vertices.
   This number is part of the definition of the potential function, which
   is why it needs to be fixed up front. The actual number of vertices [n]
   will be allowed to grow as long as it does not exceed [N]. *)

Section N.

Variable N : nat.

(* The potential of a vertex. *)

Definition phi x :=
  If is_root F x \/ K x = 0 then
     alpha N        * K x
  else
    (alpha N - k x) * K x - i x.

(* The total potential. *)

Definition Phi :=
  fold (monoid_make plus 0) phi D.

(* The following lemmas repeat the cases of the definition of [phi]. *)

Lemma phi_case_1a:
  forall x,
  is_root F x ->
  phi x = alpha N * K x.
Proof using.
  clear is_rdsf_F.
  intros. unfold phi. cases_if.
  eauto.
  { false. tauto. }
Qed.

Lemma phi_case_1b:
  forall x,
  K x = 0 ->
  phi x = 0.
Proof using.
  clear is_rdsf_F.
  introv h. unfold phi. cases_if.
  rewrite h. lia.
  { false. tauto. }
Qed.

Lemma phi_case_2:
  forall x,
  ~ is_root F x ->
  0 < K x ->
  phi x = (alpha N - k x) * K x - i x.
Proof using.
  clear is_rdsf_F.
  intros. unfold phi. cases_if.
  { false. branches. tauto. lia. }
  eauto.
Qed.

(* An upper bound on [phi x]. *)

Lemma phi_upper_bound:
  forall x,
  phi x <= alpha N * K x.
Proof using.
  clear is_rdsf_F.
  intros. unfold phi. cases_if.
  eauto.
  lia_rewrite (alpha N - k x <= alpha N).
  lia_rewrite (forall a b, a - b <= a).
  eauto.
Qed.

End N.

End Tarjan.

(* -------------------------------------------------------------------------- *)

(* When [D] is empty, [Phi] is zero. *)

Lemma Phi_empty:
  forall V F K N,
  Phi (\{} : set V) F K N = 0.
Proof using.
  intros. unfold Phi. rewrite fold_empty. reflexivity.
Qed.

(* Extending [D] with a new vertex does not affect [Phi]. This relies on
   our invariant, which guarantees that [K] is zero outside [D]. *)

Lemma Phi_extend:
  forall V D F K N r,
  @is_rdsf V D F K ->
  r \notin D ->
  Phi D F K N = Phi (D \u \{r}) F K N.
Proof using.
  intros.
  unfold Phi.
  rewrite fold_union; eauto with finite typeclass_instances. 2: rew_set in *.
  rewrite fold_single; eauto with typeclass_instances.
  simpl.
  rewrite phi_case_1b by eauto with zero_rank.
  lia.
Qed.

(* -------------------------------------------------------------------------- *)

(* Hints. *)

Hint Resolve k_exists : k.

Hint Resolve i_exists iter_i_Akx_tends_to_infinity_along_i
iter_Ak_monotonic_in_i : i.

Ltac k th :=
  match goal with |- context[k ?F ?K ?x] =>
    eapply th with (f := fun k => A k (K x)); eauto with k monotonic
  end.

Ltac i th :=
  match goal with |- context[i ?F ?K ?x] =>
    eapply th with (f := fun i => iter i (A (k F K x)) (K x)); eauto with i
  end.


From algebra Require Export cmra.
From prelude Require Import gmap.

Fixpoint big_op {A : cmraT} `{Empty A} (xs : list A) : A :=
  match xs with [] => ∅ | x :: xs => x ⋅ big_op xs end.
Arguments big_op _ _ !_ /.
Instance: Params (@big_op) 2.
Definition big_opM `{Countable K} {A : cmraT} `{Empty A} (m : gmap K A) : A :=
  big_op (snd <$> map_to_list m).
Instance: Params (@big_opM) 5.

(** * Properties about big ops *)
Section big_op.
Context `{CMRAUnit A}.

(** * Big ops *)
Lemma big_op_nil : big_op (@nil A) = ∅.
Proof. done. Qed.
Lemma big_op_cons x xs : big_op (x :: xs) = x ⋅ big_op xs.
Proof. done. Qed.
Global Instance big_op_permutation : Proper ((≡ₚ) ==> (≡)) big_op.
Proof.
  induction 1 as [|x xs1 xs2 ? IH|x y xs|xs1 xs2 xs3]; simpl; auto.
  - by rewrite IH.
  - by rewrite !assoc (comm _ x).
  - by trans (big_op xs2).
Qed.
Global Instance big_op_proper : Proper ((≡) ==> (≡)) big_op.
Proof. by induction 1; simpl; repeat apply (_ : Proper (_ ==> _ ==> _) op). Qed.
Lemma big_op_app xs ys : big_op (xs ++ ys) ≡ big_op xs ⋅ big_op ys.
Proof.
  induction xs as [|x xs IH]; simpl; first by rewrite ?left_id.
  by rewrite IH assoc.
Qed.
Lemma big_op_contains xs ys : xs `contains` ys → big_op xs ≼ big_op ys.
Proof.
  intros [xs' ->]%contains_Permutation.
  rewrite big_op_app; apply cmra_included_l.
Qed.
Lemma big_op_delete xs i x :
  xs !! i = Some x → x ⋅ big_op (delete i xs) ≡ big_op xs.
Proof. by intros; rewrite {2}(delete_Permutation xs i x). Qed.

Context `{Countable K}.
Implicit Types m : gmap K A.
Lemma big_opM_empty : big_opM (∅ : gmap K A) ≡ ∅.
Proof. unfold big_opM. by rewrite map_to_list_empty. Qed.
Lemma big_opM_insert m i x :
  m !! i = None → big_opM (<[i:=x]> m) ≡ x ⋅ big_opM m.
Proof. intros ?; by rewrite /big_opM map_to_list_insert. Qed.
Lemma big_opM_delete m i x :
  m !! i = Some x → x ⋅ big_opM (delete i m) ≡ big_opM m.
Proof.
  intros. by rewrite -{2}(insert_delete m i x) // big_opM_insert ?lookup_delete.
Qed.
Lemma big_opM_singleton i x : big_opM ({[i := x]} : gmap K A) ≡ x.
Proof.
  rewrite -insert_empty big_opM_insert /=; last auto using lookup_empty.
  by rewrite big_opM_empty right_id.
Qed.
Global Instance big_opM_proper : Proper ((≡) ==> (≡)) (big_opM : gmap K A → _).
Proof.
  intros m1; induction m1 as [|i x m1 ? IH] using map_ind.
  { by intros m2; rewrite (symmetry_iff (≡)) map_equiv_empty; intros ->. }
  intros m2 Hm2; rewrite big_opM_insert //.
  rewrite (IH (delete i m2)); last by rewrite -Hm2 delete_insert.
  destruct (map_equiv_lookup (<[i:=x]> m1) m2 i x)
    as (y&?&Hxy); auto using lookup_insert.
  rewrite Hxy -big_opM_insert; last auto using lookup_delete.
  by rewrite insert_delete.
Qed.
Lemma big_opM_lookup_valid n m i x : ✓{n} big_opM m → m !! i = Some x → ✓{n} x.
Proof.
  intros Hm ?; revert Hm; rewrite -(big_opM_delete _ i x) //.
  apply cmra_validN_op_l.
Qed.
End big_op.


(* note: T is a parameter (the same for all results of the constructors),
   but still can vary in the recursive uses *)
Inductive Expr(T: Type): Type :=
| Cst(x: T): Expr T
| Fst(e: Expr (T * T)): Expr T
| Snd(e: Expr (T * T)): Expr T.

Arguments Cst {_} _.
Arguments Fst {_} _.
Arguments Snd {_} _.

Fixpoint interp{T: Type}(e: Expr T): T :=
  match e with
  | Cst x => x
  | Fst y => fst (interp y)
  | Snd y => snd (interp y)
  end.

Eval cbv in (interp (Fst (Snd (Cst ((1, 2), (3, 4)))))).


Load LFindLoad.
From lfind Require Import LFind.
From adtind Require Import goal33.

Set Printing Depth 1000.
Definition lfind_eval  y x:=
mult x y.

Compute lfind_eval  (Succ (Succ Zero)) (Zero).

Compute lfind_eval  (Zero) (Succ (Succ (Succ (Succ Zero)))).

Compute lfind_eval  (Succ (Succ Zero)) (Succ (Succ Zero)).

Compute lfind_eval  (Zero) (Succ (Succ (Succ Zero))).

Compute lfind_eval  (Succ (Succ Zero)) (Succ Zero).

Compute lfind_eval  (Succ (Succ (Succ Zero))) (Zero).

Compute lfind_eval  (Succ (Succ Zero)) (Succ (Succ (Succ (Succ Zero)))).

Compute lfind_eval  (Zero) (Succ Zero).

Compute lfind_eval  (Succ (Succ (Succ (Succ Zero)))) (Zero).

Compute lfind_eval  (Succ Zero) (Succ Zero).

Compute lfind_eval  (Succ Zero) (Zero).

Compute lfind_eval  (Succ Zero) (Succ (Succ Zero)).

Compute lfind_eval  (Zero) (Succ (Succ Zero)).

Compute lfind_eval  (Zero) (Zero).


Require Import UsefulTypes.

Require Import Coq.Arith.Arith Coq.NArith.BinNat Coq.Strings.String Coq.Lists.List Coq.omega.Omega
  Coq.Program.Program Coq.micromega.Psatz.

Global Instance deqpos : Deq positive.
Proof.
  unfold Deq.
  intros ? ?.
  exists (Pos.eqb a b).
  split.
  - intros. apply Peqb_true_eq. assumption.
  - intros. subst. apply Pos.eqb_refl.
Defined.

Require Import varInterface.

Global Instance varClassP : VarClass positive bool :=
fun p =>
match p with
| xO _ => true (* p is even *)
| _  => false
end.

Require Import list.
Section Temp.
Local Notation seq := (seq Pos.succ).

  Lemma in_seq len start n :
    In n (seq start len) <-> ((Pos.to_nat start) <= Pos.to_nat  n < (Pos.to_nat start) +len).
  Proof.
   revert start. induction len; simpl; intros.
   - rewrite <- plus_n_O. split;[easy|].
     intros (H,H'). apply (Lt.lt_irrefl _ (Lt.le_lt_trans _ _ _ H H')).
   - rewrite IHlen, <- plus_n_Sm; simpl; split.
     * intros [H|H]; subst. intuition auto with arith.
      rewrite Pos2Nat.inj_succ in H.
      omega.
     * intros (H,H'). destruct (Lt.le_lt_or_eq _ _ H);
       rewrite Pos2Nat.inj_succ in *; intuition.
       apply Pos2Nat.inj_iff in H0. auto.
  Qed.

  Lemma in_seql len start n :
    In n (seq start len) -> (start <= n)%positive.
  Proof using.
    intros Hin.
    apply in_seq in Hin. apply proj1 in Hin.
    lia.
  Qed.

  Lemma seq_NoDup len start : NoDup (seq start len).
  Proof.
   revert start; induction len; simpl; constructor; trivial.
   rewrite in_seq. intros (H,_).
  rewrite Pos2Nat.inj_succ in *.
   apply (Lt.lt_irrefl _ H).
  Qed.
Lemma seq_maxlp : forall a v avoid n,
 LIn a (seq (maxlp avoid 1) n)
 -> LIn v avoid
 -> (v <= a)%positive.
Proof using.
  intros ? ? ? ? Hin1 Hina.
  apply in_seql in Hin1.
  pose proof (maxlp_le v avoid xH (or_intror Hina)).
  lia.
Qed.

(*
  Lemma in_seqN len start n :
    In n (seq start len) <-> (N.pos start <=  N.pos n < N.pos start + N.of_nat len)%N.
  Proof.
   revert start. induction len; simpl; intros.
   -  split;[easy|].
     intros (H,H'). omega. apply (Lt.lt_irrefl _ (Lt.le_lt_trans _ _ _ H H')).
   - rewrite IHlen, <- plus_n_Sm; simpl; split.
     * intros [H|H]; subst. intuition auto with arith.
      rewrite Pos2Nat.inj_succ in H.
      omega.
     * intros (H,H'). destruct (Lt.le_lt_or_eq _ _ H);
       rewrite Pos2Nat.inj_succ in *; intuition.
       apply Pos2Nat.inj_iff in H0. auto.
  Qed.
*)

Definition freshVarsPosAux (n:nat)
  (c : bool) (avoid original : list positive) : list positive :=
let maxn := maxlp avoid  xH in
let f := (if c then xO else xI) in
List.map f (seq (maxn) n).

End Temp.

Global Instance freshVarsPos : FreshVars positive bool:=
fun (n:nat)
  (c : option bool) (avoid original : list positive)
=>
let c : bool :=
  match c with
  |Some c => c
  |None => true
  end in
  freshVarsPosAux n c avoid original.

Require Import tactics.

Lemma freshVarsPosCorrect:
forall (n : nat) (oc : option bool) (avoid original : list positive),
let lf := freshVarsPos n oc avoid original in
(NoDup lf /\ list.disjoint lf avoid /\ Datatypes.length lf = n) /\
(forall c : bool, oc = Some c -> forall v : positive, In v lf -> varClassP v = c).
Proof.
  intros.
  split;[split;[|split]|]; subst lf; simpl; unfold freshVarsPos,freshVarsPosAux.
- apply NoDupInjectiveMap;[|apply seq_NoDup].
  destruct oc; [destruct b|]; unfold injective_fun; intros;
  cpx; inversion H; auto.
- intros ? Hin Hinc.
  apply in_map_iff in Hin. exrepnd.
  pose proof (seq_maxlp _ t avoid _ Hin1 Hinc) as Hin.
  subst. destruct oc as [c | ]; try lia.
  destruct c; lia.
- rewrite map_length. rewrite seq_length. refl.
- intros ? ?. subst. intros ? Hin. simpl.
  apply in_map_iff in Hin.
  exrepnd.
  subst.
  unfold varClassP.
  destruct c; refl.
Qed.

Global Instance vartypePos : VarType positive bool.
  apply Build_VarType.
  exact freshVarsPosCorrect.
Defined.


Inductive month : Set :=
  | January
  | February
  | March
  | April
  | May
  | June
  | July
  | August
  | September
  | October
  | November
  | December.

Inductive season : Set :=
  | Spring
  | Summer
  | Fall
  | Winter.

Section ex61.

  Definition month_to_season (m : month) : season :=
    match m with
        January => Winter
      | February => Winter
      | March => Spring
      | April => Spring
      | May => Spring
      | June => Summer
      | July => Summer
      | August => Summer
      | September => Fall
      | October => Fall
      | November => Fall
      | December => Winter
    end.

  Definition month_to_season2 (m : month) : season :=
    month_rec (fun x => season) Winter Winter
    Spring Spring Spring
    Summer Summer Summer
    Fall Fall Fall
    Winter m.

  Lemma mts_equiv : forall m: month, month_to_season m = month_to_season2 m.
  Proof.
    induction m.
    unfold month_to_season2; simpl; reflexivity.
    unfold month_to_season2; simpl; reflexivity.
    unfold month_to_season2; simpl; reflexivity.
    unfold month_to_season2; simpl; reflexivity.
    unfold month_to_season2; simpl; reflexivity.
    unfold month_to_season2; simpl; reflexivity.
    unfold month_to_season2; simpl; reflexivity.
    unfold month_to_season2; simpl; reflexivity.
    unfold month_to_season2; simpl; reflexivity.
    unfold month_to_season2; simpl; reflexivity.
    unfold month_to_season2; simpl; reflexivity.
    unfold month_to_season2; simpl; reflexivity.
  Qed.

  Check bool_ind.
  Check bool_rec.

End ex61.

Section ex63.

  Check refl_equal.
  Check or_introl.
  Check or_intror.

  Check bool_ind (fun x => x = true \/ x = false).

  Check or_introl (A:= true = true) (B:= true = false).

  Check refl_equal true.

  Check (or_introl (A:= true = true) (B:= true = false))
    (refl_equal true).

  Check (or_intror (A:= false = true) (B:= false = false))
    (refl_equal false).

  Theorem bool_equal1 : forall b : bool, b = true \/ b = false.
  Proof (bool_ind (fun x => x = true \/ x = false)
    ((or_introl (A:= true = true) (B:= true = false))
    (refl_equal true))
    ((or_intror (A:= false = true) (B:= false = false))
    (refl_equal false))).

  Theorem bool_equal2 :  forall b : bool, b = true \/ b = false.
  Proof.
    induction b.
    left; reflexivity.
    right; reflexivity.
  Qed.

End ex63.

Require Import Arith.
Require Import Bool.

Section ex65.

  Definition month_length (leap:bool) (m:month) : nat :=
    match m with
        January => 31
      | February => if leap then 29 else 28
      | March => 31
      | April => 30
      | May => 31
      | June => 30
      | July => 31
      | August => 31
      | September => 30
      | October => 31
      | November => 30
      | December => 31
    end.

  Definition month_even (leap: bool) (m:month) : bool :=
    ((month_length leap m) mod 2) =? 0.

End ex65.

Section ex66.

  Definition bool_not (a : bool) : bool :=
  match a with
      true => false
    | false => true
  end.

  Definition bool_xor (a b : bool) : bool :=
  match a with
      true => bool_not b
    | false => b
  end.

  Definition bool_and (a b : bool) : bool :=
  match a with
      true => b
    | false => false
  end.

  Definition bool_or (a b : bool) : bool :=
  match a with
      true => true
    | false => b
  end.

  Definition bool_eq (a b : bool) : bool :=
  match a with
      true => if b then true else false
    | false => if b then false else true
  end.

  Lemma xor_not_eq : forall a b : bool, bool_xor a b = bool_not (bool_eq a b).
  Proof.
    induction a.
    induction b.
    simpl; reflexivity.
    simpl; reflexivity.
    induction b.
    simpl; reflexivity.
    simpl; reflexivity.
  Qed.

  Lemma demorg_bool1 : forall a b : bool,
    bool_not (bool_and a b) = bool_or (bool_not a) (bool_not b).
  Proof.
    induction a.
    induction b.
    simpl; reflexivity.
    simpl; reflexivity.
    induction b.
    simpl; reflexivity.
    simpl; reflexivity.
  Qed.

  Lemma double_neg : forall x: bool, bool_not (bool_not x) = x.
  Proof.
    induction x.
    simpl; reflexivity.
    simpl; reflexivity.
  Qed.

  Lemma lem : forall x: bool, bool_or (bool_not x) x = true.
  Proof.
    induction x.
    simpl; reflexivity.
    simpl; reflexivity.
  Qed.

  Lemma eq_equal : forall a b : bool,
     bool_eq a b = true -> a = b.
  Proof.
    induction a.
    induction b.
    simpl; reflexivity.
    simpl; intro H0; symmetry; exact H0.
    induction b.
    simpl; intro H0; exact H0.
    simpl; reflexivity.
  Qed.

  Lemma demorg_bool2 : forall a b : bool,
    bool_not (bool_or a b) = bool_and (bool_not a) (bool_not b).
  Proof.
    induction a.
    induction b.
    simpl; reflexivity.
    simpl; reflexivity.
    induction b.
    simpl; reflexivity.
    simpl; reflexivity.
  Qed.

  Lemma right_distr : forall a b c : bool,
    bool_or (bool_and a c) (bool_and b c)
      = bool_and (bool_or a b) c.
  Proof.
    induction a.
    simpl.
    induction b.
    induction c.
    simpl; reflexivity.
    simpl; reflexivity.
    induction c.
    simpl; reflexivity.
    simpl; reflexivity.
    induction b.
    induction c.
    simpl; reflexivity.
    simpl; reflexivity.
    induction c.
    simpl; reflexivity.
    simpl; reflexivity.
  Qed.

End ex66.

Require Import ZArith.

Section ex67.

  Inductive plane : Set := point : Z -> Z -> plane.

  Check plane_rec.

  Definition manhattan (a b : plane) : Z :=
    match a with
      point x0 y0 => (match b with
        point x1 y1 => (Z.abs (x0 - x1) + Z.abs (y0 - y1))
      end)
    end.

  Compute manhattan (point 1 1) (point 2 3).

End ex67.

Section ex69.

  Inductive vehicle : Set :=
      bicycle : nat -> vehicle
    | motorized : nat -> nat -> vehicle.

  Check vehicle_rec.

  Definition nb_seats (v: vehicle) : nat :=
    vehicle_rec (fun x => nat) (fun n => n) (fun n _ => n) v.

End ex69.

Section ex610.

  Check month_rec.

  Definition is_january (m : month) : bool :=
    month_rec (fun x => bool) true false false false false false
      false false false false false false m.

End ex610.

Section ex611.
  Definition is_b_true (b : bool) : Prop :=
    bool_rect (fun x => Prop) True False b.

  Theorem true_ne_false : true <> false.
  Proof.
    unfold not.
    intros H0.
    change (is_b_true false).
    rewrite <- H0.
    simpl.
    trivial.
  Qed.

End ex611.

Section ex612.

  Definition is_bicycle (v : vehicle): Prop :=
    vehicle_rect (fun x => Prop) (fun _ => True) (fun _ _ => False) v.

  Theorem bike_new_motor : forall s w: nat, bicycle s <> motorized s w.
  Proof.
    intros s w.
    unfold not.
    intros H0.
    change (is_bicycle (motorized s w)).
    rewrite <- H0.
    simpl.
    trivial.
  Qed.

End ex612.

Section ex613.

  Record RatPlus : Set :=
    mkRat { top:nat; bottom:nat; bottom_condition: bottom <> 0}.

  Definition eq_RatPlus :=
    forall r0 r1 : RatPlus, top r0 * bottom r1 = top r1 * bottom r0 -> r0 = r1.

  Lemma two_non_zero : 2 <> 0.
  Proof.
    intros H0.
    discriminate H0.
  Qed.

  Lemma one_non_zero : 1 <> 0.
  Proof.
    intros H0.
    discriminate H0.
  Qed.

  Theorem inconsistent1 : eq_RatPlus -> False.
  Proof.
    intros H0.
    assert (H1 : (mkRat 4 2 two_non_zero) = (mkRat 2 1 one_non_zero)).
    apply H0.
    simpl; reflexivity.
    injection H1.
    intros H2 H3.
    discriminate H2.
  Qed.

End ex613.

Section ex615.

  Fixpoint smaller_than_3 (n : nat) : bool :=
    match n with
        0 => true
      | S m => match m with
          0 => true
        | S k => match k with
            0 => true
          | S _ => false
        end
      end
    end.
End ex615.

Section ex616.

  Fixpoint add_alt (n m : nat) {struct m} : nat :=
    match m with
        0 => n
      | S k => add_alt (S n) k
    end.

End ex616.

Section ex617.

  Fixpoint sum_f (f : nat -> nat) (n : nat) : nat :=
    match n with
        0 => 0
      | S m => (f m) + (sum_f f m)
    end.

End ex617.

Section ex618.

  Fixpoint two_power (n : nat) : nat :=
    match n with
        0 => 1
      | S m => 2 * (two_power m)
    end.

End ex618.

Section ex619.

  Print positive.

  Fixpoint pos_to_nat (p: positive) : nat :=
    match p with
        xH => 1
      | xO k => 2 * (pos_to_nat k)
      | xI k => 2 * (pos_to_nat k) + 1
    end.

  (*
  Compute pos_to_nat (xO (xO (xO (xI (xO (xI (xI (xI (xI xH))))))))).
  1000 but goes over stack depth
  *)
  Compute pos_to_nat (xI (xO (xO (xI xH)))).
  (*
  Compute pos_to_nat (xO (xO (xO (xO (xO (xO (xO (xO (xO xH))))))))).
  512 but goes over stack depth
  *)

End ex619.

Section ex620.

  Fixpoint pos_even_bool (p : positive) : bool :=
    match p with
        xH => true
      | xO k => false
      | xI k => true
    end.

End ex620.

Section ex621.

  Fixpoint pos_div_2 (p : positive) : Z :=
    match p with
        xH => 0
      | xO k => Z_of_nat (pos_to_nat k)
      | xI k => Z_of_nat (pos_to_nat k)
    end.

  Fixpoint pos_div_4 (p : positive) : Z :=
    match p with
        xH => 0
      | xO k => pos_div_2 k
      | xI k => pos_div_2 k
    end.

End ex621.

Section ex622.

  Hypothesis pos_mult : positive -> positive -> positive.

  Definition z_mult_alt (a b : Z) : Z :=
    match a with
        Z0 => 0
      | Zpos p => match b with
          Z0 => 0
        | Zpos q => Zpos (pos_mult p q)
        | Zneg q => Zneg (pos_mult p q)
      end
      | Zneg p => match b with
          Z0 => 0
        | Zpos q => Zneg (pos_mult p q)
        | Zneg q => Zpos (pos_mult p q)
      end
    end.

End ex622.

Section ex623.

  Inductive prop_lang : Set :=
      L_True : prop_lang
    | L_False : prop_lang
    | Conj : prop_lang -> prop_lang -> prop_lang
    | Disj : prop_lang -> prop_lang -> prop_lang
    | Impl : prop_lang -> prop_lang -> prop_lang
    | Neg : prop_lang -> prop_lang.

End ex623.

Section ex625.

  Inductive Z_btree : Set :=
      Z_leaf : Z_btree
    | Z_bnode : Z -> Z_btree -> Z_btree -> Z_btree.

  Check Z_btree.

  Fixpoint value_present (n : Z) (t : Z_btree) {struct t} : bool :=
    match t with
        Z_leaf => false
      | Z_bnode n0 l r => if (Zeq_bool n n0) then true else
          if (value_present n l) then true else value_present n r
    end.

End ex625.

Section ex626.

  Fixpoint power (z: Z) (n: nat) {struct n} : Z :=
    match n with
        0 => z
      | S m => z * (power z m)
    end.

  Fixpoint discrete_log (p:positive) : nat :=
    match p with
        xH => 0
      | xO k => 1 + discrete_log k
      | xI k => 1 + discrete_log k
    end.

End ex626.

Section ex627.

  Inductive Z_fbtree : Set :=
      Z_fleaf : Z_fbtree
    | Z_fnode : Z -> (bool -> Z_fbtree) -> Z_fbtree.

  Fixpoint fzero_present (t : Z_fbtree) : bool :=
    match t with
        Z_fleaf => false
      | Z_fnode z f => if Z.eqb z 0 then true
          else (fzero_present (f true)) || (fzero_present (f true))
    end.

End ex627.

Section ex628.

  Fixpoint any_f (n:nat) (f:nat -> bool) :=
    match n with
        0 => false
      | S m => (f m) || any_f m f
    end.

  Inductive Z_inf_branch_tree : Set :=
      Z_inf_leaf : Z_inf_branch_tree
    | Z_inf_node : Z -> (nat -> Z_inf_branch_tree) -> Z_inf_branch_tree.

  Fixpoint zero_in_first_n (n:nat)(t: Z_inf_branch_tree) {struct t} : bool :=
    match t with
        Z_inf_leaf => false
      | Z_inf_node z f => if Z.eqb z 0 then true
          else any_f n (fun m => zero_in_first_n n (f m))
    end.

End ex628.

Section ex629.

  Theorem plus_n_0_alt : forall n : nat, n = n + 0.
  Proof.
    intros n.
    elim n.
    simpl; reflexivity.
    intros n0 H0.
    simpl; rewrite <- H0; reflexivity.
  Qed.

End ex629.

Section ex630.

  Fixpoint f1 (t : Z_btree) : Z_fbtree :=
    match t with
        Z_leaf => Z_fleaf
      | Z_bnode z l r => Z_fnode z (bool_rec (fun x => Z_fbtree) (f1 l) (f1 r))
    end.

  Fixpoint f2 (t : Z_fbtree) : Z_btree :=
    match t with
        Z_fleaf => Z_leaf
      | Z_fnode z f => Z_bnode z (f2 (f true))  (f2 (f false))
    end.

  Theorem left_f_inv : forall t : Z_btree, f2 (f1 t) = t.
  Proof.
    intros t.
    elim t.
    simpl; reflexivity.
    intros z t0 H0 z1 H1.
    simpl.
    rewrite H0; rewrite H1; reflexivity.
  Qed.

  (*
  Theorem right_f_inv : forall t : Z_fbtree, f1 (f2 t) = t.
  Proof.
    intros t.
    elim t.
    simpl; reflexivity.
    intros z f0 H0.
    simpl.
    rewrite H0.
    rewrite H0.
    f_equal.
  Qed.
  Cannot complete this without extensionality.
  *)

End ex630.

Section ex631.

  Fixpoint mult2 (n:nat) : nat :=
    match n with
        0 => 0
      | S m => S(S(mult2 m))
    end.

  Search (_+_).

  Theorem nat_mult2_sum : forall n:nat, (mult2 n) = n + n.
  Proof.
    induction n.
    simpl; reflexivity.
    simpl.
    rewrite IHn.
    rewrite Nat.add_succ_r.
    reflexivity.
  Qed.

End ex631.

Section ex632.

  Fixpoint sum_n (n:nat) : nat :=
    match n with
        0 => 0
      | S m => S m + sum_n m
    end.

  Lemma times_two : forall n:nat, n+n = 2*n.
  Proof.
    induction n.
    simpl;reflexivity.
    rewrite Nat.add_succ_l.
    rewrite Nat.add_succ_r.
    rewrite IHn.
    simpl.
    rewrite Nat.add_succ_r.
    rewrite Nat.add_0_r.
    reflexivity.
  Qed.

  Check Nat.add_assoc.

  Theorem sum_n_short : forall n : nat, 2 * sum_n n = (n * n) + n.
  Proof.
    induction n.
    simpl; reflexivity.
    simpl.
    rewrite Nat.add_succ_r.
    rewrite Nat.add_assoc.
    rewrite Nat.add_assoc.
    rewrite Nat.add_0_r.
    assert (H1 : sum_n n + (n + sum_n n) = n + 2* sum_n n).
    rewrite Nat.add_assoc.
    rewrite Nat.add_comm with (m:= n) (n:=sum_n n).
    rewrite <- Nat.add_assoc.
    rewrite times_two with (n:= sum_n n).
    reflexivity.
    assert (H2 : n + sum_n n + n + sum_n n = n + n + 2* sum_n n).
    rewrite <- Nat.add_assoc.
    rewrite <- Nat.add_assoc.
    rewrite H1.
    rewrite Nat.add_assoc.
    reflexivity.
    rewrite H2.
    rewrite IHn.
    ring.
  Qed.

End ex632.

Section ex633.
  Theorem sum_n_mono : forall n : nat , n <= sum_n n.
  Proof.
    induction n.
    simpl; reflexivity.
    simpl.
    rewrite <- Nat.add_succ_l.
    apply Nat.le_add_r.
  Qed.
End ex633.

Require Import List.

Section ex634.

  Fixpoint first_two {A} (l: list A) : list A :=
    match l with
        nil => nil
      | cons h0 t0 => (match t0 with nil => (cons h0 nil) | cons h1 t1 => cons h0 (cons h1 nil) end)
    end.

End ex634.

Section ex635.

  Fixpoint first_n {A} (n:nat) (l: list A) : list A :=
    match n with
        0 => nil
      | S m =>
        match l with
            nil => nil
          | cons h0 t0 => cons h0 (first_n m t0)
          end
    end.

End ex635.

Section ex636.

  Fixpoint sum_list (l: list nat) : nat :=
    match l with
        nil => 0
      | cons h0 t0 => h0 + sum_list t0
    end.

End ex636.

Section ex637.

  Fixpoint n_ones (n: nat) : list nat :=
    match n with
        0 => nil
      | S m => cons 1 (n_ones m)
    end.

End ex637.

Section ex638.

  Fixpoint n_range (n: nat) : list nat :=
    match n with
        0 => nil
      | S m => (n_range m) ++ (cons (S m) nil)
    end.

End ex638.

Section ex639.

  Fixpoint nth_option {A} (n:nat) (l : list A) {struct l} : option A :=
    match n, l with
        0, cons a t1 => Some a
      | S p, cons a t1 => nth_option p t1
      | _, nil => None
    end.

  Definition nth_option_alt {A} (n:nat) (l : list A) : option A :=
    match n, l with
        0, cons a t1 => Some a
      | S p, cons a t1 => nth_option p t1
      | _, nil => None
    end.

  Lemma nth_same : forall (A:Set) (n:nat)(l: list A), nth_option n l = nth_option_alt n l.
  Proof.
    intros A.
    induction l.
    induction n.
    simpl; reflexivity.
    simpl; reflexivity.
    induction n.
    simpl; reflexivity.
    simpl; reflexivity.
  Qed.

End ex639.

Require Import Arith.

Section ex640.

  Lemma nth_length :
    forall (A:Set) (n:nat)(l: list A), (nth_option n l = None) -> length l <= n.
  Proof.
    intros A.
    induction n.
    induction l.
    simpl; reflexivity.
    simpl; intros H1; discriminate H1.
    induction l.
    simpl; intros H2; apply Nat.le_0_l.
    simpl nth_option.
    intros H3.
    assert (H4 : length l <= length (a :: l)).
    induction l.
    simpl; apply Nat.le_0_l.
    simpl. apply le_n_S. apply Nat.le_succ_diag_r.
    assert (H5 : length l <= n -> length (a :: l) <= S n).
    simpl; apply le_n_S; reflexivity.
    apply H5.
    apply IHn.
    exact H3.
  Qed.

End ex640.

Section ex641.

  Fixpoint first_true {A}(f: A -> bool)(l: list A) {struct l} : option A :=
    match l with
        nil => None
      | cons h0 t0 => if f h0 then Some h0 else (first_true f t0)
    end.

End ex641.

Section ex642.

  Fixpoint left_list {A B} (l : list (A * B)) : list A :=
      match l with
          nil => nil
        | cons h0 t0 => (fst h0) :: left_list t0
      end.

  Fixpoint right_list {A B} (l : list (A * B)) : list B :=
      match l with
          nil => nil
        | cons h0 t0 => (snd h0) :: right_list t0
      end.

  Definition split {A B} (l : list (A * B)) : list A * list B :=
    pair (left_list l) (right_list l).

  Fixpoint combine {A B} (l1: list A) (l2 : list B) : list (A * B) :=
    match l1, l2 with
        cons h0 t0, cons h1 t1 => (pair h0 h1) :: combine t0 t1
      | _, _ => nil
    end.

End ex642.

Section ex43.

  Inductive btree (A:Set) : Set :=
      leaf : btree A
    | bnode : A -> btree A -> btree A -> btree A.

  Fixpoint z_to_gen (t: Z_btree) : btree Z :=
    match t with
        Z_leaf => leaf Z
      | Z_bnode z l r => bnode Z z (z_to_gen l) (z_to_gen r)
    end.

  Fixpoint gen_to_z (t: btree Z) : Z_btree :=
    match t with
        leaf _ => Z_leaf
      | bnode _ z l r => Z_bnode z (gen_to_z l) (gen_to_z r)
    end.

  Lemma g_z_inv : forall  t : Z_btree, gen_to_z (z_to_gen t) = t.
  Proof.
    induction t.
    simpl; reflexivity.
    simpl.
    rewrite IHt1.
    rewrite IHt2.
    reflexivity.
  Qed.

  Lemma z_g_inv : forall  t : btree Z, z_to_gen (gen_to_z t) = t.
  Proof.
    induction t.
    simpl; reflexivity.
    simpl.
    rewrite IHt1.
    rewrite IHt2.
    reflexivity.
  Qed.

End ex43.

Section ex645.

  Inductive cmp : Set := Less : cmp | Equal : cmp | Greater : cmp.

  Definition three_way_compare (n m : nat) : cmp :=
    if n =? m then Equal else if n <=? m then Less else Greater.

  Fixpoint update_primes (n : nat) (l : list (nat * nat)) {struct l} : (list (nat*nat)) * bool :=
    match l with
        nil => pair nil false
      | cons h0 t0 => let t1 := update_primes n t0 in  pair ((if n <? snd h0
                     then h0
                     else (pair (fst h0) (snd h0 + fst h0))) :: (fst t1))
                     (if snd t1 then true else (snd h0 =? n))
    end.

  Fixpoint prime_sieve (n : nat) : list (nat*nat) :=
    match n with
        0 => nil
      | S 0 => nil
      | S (S 0) => (pair 2 4) :: nil
      | S m => let old_p := prime_sieve m in
              let new_p := update_primes (S m) old_p in
                if snd new_p then fst new_p
                  else (pair (S m) (2*S m)) :: fst new_p
    end.

  Fixpoint gcd a b :=
    match a with
     | O => b
     | S a' => gcd (b mod (S a')) (S a')
    end.

  Definition rel_nprime (a b:nat) : Prop := gcd a b = 1.

  Inductive nprime (p:nat) : Prop :=
    prime_intro : 1 < p -> (forall n:nat, 1 <= n < p -> rel_nprime n p) -> nprime p.

  (*
  Theorem made_all : forall k n : nat, k <= n /\ nprime k -> In k (left_list (prime_sieve n)).
  Proof.
    intros k n H0.
    induction n.
    simpl.
    destruct H0 as [H1 H2].
    elim H2.
    intros H3 H4.
    assert (H5 : 1 < 0).
    apply Nat.lt_le_trans with (n:=1)(m:=k)(p:=0).
    exact H3. exact H1.
    elim Nat.nlt_0_r with (n:=1).
    exact H5.
    destruct H0 as [H1 H2].
    elim H2.
    intros H3 H4.
    simpl.
  Qed.
  *)

End ex645.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

Require Export ZArith.
Require Export ZArithRing.
Require Export Morphisms Setoid Bool.

(** * Definition of [Q] and basic properties *)

(** Rationals are pairs of [Z] and [positive] numbers. *)

Record Q : Set := Qmake {Qnum : Z; Qden : positive}.

Delimit Scope Q_scope with Q.
Bind Scope Q_scope with Q.
Arguments Qmake _%Z _%positive.
Open Scope Q_scope.
Ltac simpl_mult := rewrite ?Pos2Z.inj_mul.

(** [a#b] denotes the fraction [a] over [b]. *)

Notation "a # b" := (Qmake a b) (at level 55, no associativity) : Q_scope.

Definition inject_Z (x : Z) := Qmake x 1.
Arguments inject_Z x%Z.

Notation QDen p := (Zpos (Qden p)).
Notation " 0 " := (0#1) : Q_scope.
Notation " 1 " := (1#1) : Q_scope.

Definition Qeq (p q : Q) := (Qnum p * QDen q)%Z = (Qnum q * QDen p)%Z.
Definition Qle (x y : Q) := (Qnum x * QDen y <= Qnum y * QDen x)%Z.
Definition Qlt (x y : Q) := (Qnum x * QDen y < Qnum y * QDen x)%Z.
Notation Qgt a b := (Qlt b a) (only parsing).
Notation Qge a b := (Qle b a) (only parsing).

Infix "==" := Qeq (at level 70, no associativity) : Q_scope.
Infix "<" := Qlt : Q_scope.
Infix "<=" := Qle : Q_scope.
Notation "x > y" := (Qlt y x)(only parsing) : Q_scope.
Notation "x >= y" := (Qle y x)(only parsing) : Q_scope.
Notation "x <= y <= z" := (x<=y/\y<=z) : Q_scope.

(** injection from Z is injective. *)

Lemma inject_Z_injective (a b: Z): inject_Z a == inject_Z b <-> a = b.
Proof.
 unfold Qeq. simpl. omega.
Qed.

(** Another approach : using Qcompare for defining order relations. *)

Definition Qcompare (p q : Q) := (Qnum p * QDen q ?= Qnum q * QDen p)%Z.
Notation "p ?= q" := (Qcompare p q) : Q_scope.

Lemma Qeq_alt p q : (p == q) <-> (p ?= q) = Eq.
Proof.
symmetry. apply Z.compare_eq_iff.
Qed.

Lemma Qlt_alt p q : (p<q) <-> (p?=q = Lt).
Proof.
reflexivity.
Qed.

Lemma Qgt_alt p q : (p>q) <-> (p?=q = Gt).
Proof.
symmetry. apply Z.gt_lt_iff.
Qed.

Lemma Qle_alt p q : (p<=q) <-> (p?=q <> Gt).
Proof.
reflexivity.
Qed.

Lemma Qge_alt p q : (p>=q) <-> (p?=q <> Lt).
Proof.
symmetry. apply Z.ge_le_iff.
Qed.

Hint Unfold Qeq Qlt Qle : qarith.
Hint Extern 5 (?X1 <> ?X2) => intro; discriminate: qarith.

Lemma Qcompare_antisym x y : CompOpp (x ?= y) = (y ?= x).
Proof.
 symmetry. apply Z.compare_antisym.
Qed.

Lemma Qcompare_spec x y : CompareSpec (x==y) (x<y) (y<x) (x ?= y).
Proof.
 unfold Qeq, Qlt, Qcompare. case Z.compare_spec; now constructor.
Qed.

(** * Properties of equality. *)

Theorem Qeq_refl x : x == x.
Proof.
 auto with qarith.
Qed.

Theorem Qeq_sym x y : x == y -> y == x.
Proof.
 auto with qarith.
Qed.

Theorem Qeq_trans x y z : x == y -> y == z -> x == z.
Proof.
unfold Qeq; intros XY YZ.
apply Z.mul_reg_r with (QDen y); [auto with qarith|].
now rewrite Z.mul_shuffle0, XY, Z.mul_shuffle0, YZ, Z.mul_shuffle0.
Qed.

Hint Immediate Qeq_sym : qarith.
Hint Resolve Qeq_refl Qeq_trans : qarith.

(** In a word, [Qeq] is a setoid equality. *)

Instance Q_Setoid : Equivalence Qeq.
Proof. split; red; eauto with qarith. Qed.

(** Furthermore, this equality is decidable: *)

Theorem Qeq_dec x y : {x==y} + {~ x==y}.
Proof.
 apply Z.eq_dec.
Defined.

Definition Qeq_bool x y :=
  (Zeq_bool (Qnum x * QDen y) (Qnum y * QDen x))%Z.

Definition Qle_bool x y :=
  (Z.leb (Qnum x * QDen y) (Qnum y * QDen x))%Z.

Lemma Qeq_bool_iff x y : Qeq_bool x y = true <-> x == y.
Proof.
  symmetry; apply Zeq_is_eq_bool.
Qed.

Lemma Qeq_bool_eq x y : Qeq_bool x y = true -> x == y.
Proof.
  apply Qeq_bool_iff.
Qed.

Lemma Qeq_eq_bool x y : x == y -> Qeq_bool x y = true.
Proof.
  apply Qeq_bool_iff.
Qed.

Lemma Qeq_bool_neq x y : Qeq_bool x y = false -> ~ x == y.
Proof.
  rewrite <- Qeq_bool_iff. now intros ->.
Qed.

Lemma Qle_bool_iff x y : Qle_bool x y = true <-> x <= y.
Proof.
  symmetry; apply Zle_is_le_bool.
Qed.

Lemma Qle_bool_imp_le x y : Qle_bool x y = true -> x <= y.
Proof.
  apply Qle_bool_iff.
Qed.

Theorem Qnot_eq_sym x y : ~x == y -> ~y == x.
Proof.
 auto with qarith.
Qed.

Lemma Qeq_bool_comm x y: Qeq_bool x y = Qeq_bool y x.
Proof.
 apply eq_true_iff_eq. rewrite !Qeq_bool_iff. now symmetry.
Qed.

Lemma Qeq_bool_refl x: Qeq_bool x x = true.
Proof.
  rewrite Qeq_bool_iff. now reflexivity.
Qed.

Lemma Qeq_bool_sym x y: Qeq_bool x y = true -> Qeq_bool y x = true.
Proof.
  rewrite !Qeq_bool_iff. now symmetry.
Qed.

Lemma Qeq_bool_trans x y z: Qeq_bool x y = true -> Qeq_bool y z = true -> Qeq_bool x z = true.
Proof.
  rewrite !Qeq_bool_iff; apply Qeq_trans.
Qed.

Hint Resolve Qnot_eq_sym : qarith.

(** * Addition, multiplication and opposite *)

(** The addition, multiplication and opposite are defined
   in the straightforward way: *)

Definition Qplus (x y : Q) :=
  (Qnum x * QDen y + Qnum y * QDen x) # (Qden x * Qden y).

Definition Qmult (x y : Q) := (Qnum x * Qnum y) # (Qden x * Qden y).

Definition Qopp (x : Q) := (- Qnum x) # (Qden x).

Definition Qminus (x y : Q) := Qplus x (Qopp y).

Definition Qinv (x : Q) :=
  match Qnum x with
  | Z0 => 0
  | Zpos p => (QDen x)#p
  | Zneg p => (Zneg (Qden x))#p
  end.

Definition Qdiv (x y : Q) := Qmult x (Qinv y).

Infix "+" := Qplus : Q_scope.
Notation "- x" := (Qopp x) : Q_scope.
Infix "-" := Qminus : Q_scope.
Infix "*" := Qmult : Q_scope.
Notation "/ x" := (Qinv x) : Q_scope.
Infix "/" := Qdiv : Q_scope.

(** A light notation for [Zpos] *)

Lemma Qmake_Qdiv a b : a#b==inject_Z a/inject_Z (Zpos b).
Proof.
unfold Qeq. simpl. ring.
Qed.

(** * Setoid compatibility results *)

Instance Qplus_comp : Proper (Qeq==>Qeq==>Qeq) Qplus.
Proof.
  unfold Qeq, Qplus; simpl.
  Open Scope Z_scope.
  intros (p1, p2) (q1, q2) H (r1, r2) (s1, s2) H0; simpl in *.
  simpl_mult; ring_simplify.
  replace (p1 * Zpos r2 * Zpos q2) with (p1 * Zpos q2 * Zpos r2) by ring.
  rewrite H.
  replace (r1 * Zpos p2 * Zpos q2 * Zpos s2) with (r1 * Zpos s2 * Zpos p2 * Zpos q2) by ring.
  rewrite H0.
  ring.
  Close Scope Z_scope.
Qed.

Instance Qopp_comp : Proper (Qeq==>Qeq) Qopp.
Proof.
  unfold Qeq, Qopp; simpl.
  Open Scope Z_scope.
  intros x y H; simpl.
  replace (- Qnum x * Zpos (Qden y)) with (- (Qnum x * Zpos (Qden y))) by ring.
  rewrite H;  ring.
  Close Scope Z_scope.
Qed.

Instance Qminus_comp : Proper (Qeq==>Qeq==>Qeq) Qminus.
Proof.
  intros x x' Hx y y' Hy.
  unfold Qminus. rewrite Hx, Hy; auto with qarith.
Qed.

Instance Qmult_comp : Proper (Qeq==>Qeq==>Qeq) Qmult.
Proof.
  unfold Qeq; simpl.
  Open Scope Z_scope.
  intros (p1, p2) (q1, q2) H (r1, r2) (s1, s2) H0; simpl in *.
  intros; simpl_mult; ring_simplify.
  replace (q1 * s1 * Zpos p2) with (q1 * Zpos p2 * s1) by ring.
  rewrite <- H.
  replace (p1 * r1 * Zpos q2 * Zpos s2) with (r1 * Zpos s2 * p1 * Zpos q2) by ring.
  rewrite H0.
  ring.
  Close Scope Z_scope.
Qed.

Instance Qinv_comp : Proper (Qeq==>Qeq) Qinv.
Proof.
  unfold Qeq, Qinv; simpl.
  Open Scope Z_scope.
  intros (p1, p2) (q1, q2) EQ; simpl in *.
  destruct q1; simpl in *.
  - apply Z.mul_eq_0 in EQ. destruct EQ; now subst.
  - destruct p1; simpl in *; try discriminate.
    now rewrite Pos.mul_comm, <- EQ, Pos.mul_comm.
  - destruct p1; simpl in *; try discriminate.
    now rewrite Pos.mul_comm, <- EQ, Pos.mul_comm.
  Close Scope Z_scope.
Qed.

Instance Qdiv_comp : Proper (Qeq==>Qeq==>Qeq) Qdiv.
Proof.
  intros x x' Hx y y' Hy; unfold Qdiv.
  rewrite Hx, Hy; auto with qarith.
Qed.

Instance Qcompare_comp : Proper (Qeq==>Qeq==>eq) Qcompare.
Proof.
  unfold Qeq, Qcompare.
  Open Scope Z_scope.
  intros (p1,p2) (q1,q2) H (r1,r2) (s1,s2) H'; simpl in *.
  rewrite <- (Zcompare_mult_compat (q2*s2) (p1*Zpos r2)).
  rewrite <- (Zcompare_mult_compat (p2*r2) (q1*Zpos s2)).
  change (Zpos (q2*s2)) with (Zpos q2 * Zpos s2).
  change (Zpos (p2*r2)) with (Zpos p2 * Zpos r2).
  replace (Zpos q2 * Zpos s2 * (p1*Zpos r2)) with ((p1*Zpos q2)*Zpos r2*Zpos s2) by ring.
  rewrite H.
  replace (Zpos q2 * Zpos s2 * (r1*Zpos p2)) with ((r1*Zpos s2)*Zpos q2*Zpos p2) by ring.
  rewrite H'.
  f_equal; ring.
  Close Scope Z_scope.
Qed.

Instance Qle_comp : Proper (Qeq==>Qeq==>iff) Qle.
Proof.
  intros p q H r s H'. rewrite 2 Qle_alt, H, H'; auto with *.
Qed.

Instance Qlt_compat : Proper (Qeq==>Qeq==>iff) Qlt.
Proof.
  intros p q H r s H'. rewrite 2 Qlt_alt, H, H'; auto with *.
Qed.

Instance Qeqb_comp : Proper (Qeq==>Qeq==>eq) Qeq_bool.
Proof.
 intros p q H r s H'; apply eq_true_iff_eq.
 rewrite 2 Qeq_bool_iff, H, H'; split; auto with qarith.
Qed.

Instance Qleb_comp : Proper (Qeq==>Qeq==>eq) Qle_bool.
Proof.
 intros p q H r s H'; apply eq_true_iff_eq.
 rewrite 2 Qle_bool_iff, H, H'; split; auto with qarith.
Qed.

(** [0] and [1] are apart *)

Lemma Q_apart_0_1 : ~ 1 == 0.
Proof.
  unfold Qeq; auto with qarith.
Qed.

(** * Properties of [Qadd] *)

(** Addition is associative: *)

Theorem Qplus_assoc : forall x y z, x+(y+z)==(x+y)+z.
Proof.
  intros (x1, x2) (y1, y2) (z1, z2).
  unfold Qeq, Qplus; simpl; simpl_mult; ring.
Qed.

(** [0] is a neutral element for addition: *)

Lemma Qplus_0_l : forall x, 0+x == x.
Proof.
  intros (x1, x2); unfold Qeq, Qplus; simpl; ring.
Qed.

Lemma Qplus_0_r : forall x, x+0 == x.
Proof.
  intros (x1, x2); unfold Qeq, Qplus; simpl.
  rewrite Pos.mul_comm; simpl; ring.
Qed.

(** Commutativity of addition: *)

Theorem Qplus_comm : forall x y, x+y == y+x.
Proof.
  intros (x1, x2); unfold Qeq, Qplus; simpl.
  intros; rewrite Pos.mul_comm; ring.
Qed.

(** * Properties of [Qopp] *)

Lemma Qopp_involutive : forall q, - -q == q.
Proof.
  red; simpl; intros; ring.
Qed.

Theorem Qplus_opp_r : forall q, q+(-q) == 0.
Proof.
  red; simpl; intro; ring.
Qed.

(** Injectivity of addition (uses theory about Qopp above): *)

Lemma Qplus_inj_r (x y z: Q):
  x + z == y + z <-> x == y.
Proof.
 split; intro E.
  rewrite <- (Qplus_0_r x), <- (Qplus_0_r y).
  rewrite <- (Qplus_opp_r z); auto.
  do 2 rewrite Qplus_assoc.
  rewrite E. reflexivity.
 rewrite E. reflexivity.
Qed.

Lemma Qplus_inj_l (x y z: Q):
  z + x == z + y <-> x == y.
Proof.
 rewrite (Qplus_comm z x), (Qplus_comm z y).
 apply Qplus_inj_r.
Qed.

(** * Properties of [Qmult] *)

(** Multiplication is associative: *)

Theorem Qmult_assoc : forall n m p, n*(m*p)==(n*m)*p.
Proof.
  intros; red; simpl; rewrite Pos.mul_assoc; ring.
Qed.

(** multiplication and zero *)

Lemma Qmult_0_l : forall x , 0*x == 0.
Proof.
  intros; compute; reflexivity.
Qed.

Lemma Qmult_0_r : forall x , x*0 == 0.
Proof.
  intros; red; simpl; ring.
Qed.

(** [1] is a neutral element for multiplication: *)

Lemma Qmult_1_l : forall n, 1*n == n.
Proof.
  intro; red; simpl; destruct (Qnum n); auto.
Qed.

Theorem Qmult_1_r : forall n, n*1==n.
Proof.
  intro; red; simpl.
  rewrite Z.mul_1_r with (n := Qnum n).
  rewrite Pos.mul_comm; simpl; trivial.
Qed.

(** Commutativity of multiplication *)

Theorem Qmult_comm : forall x y, x*y==y*x.
Proof.
  intros; red; simpl; rewrite Pos.mul_comm; ring.
Qed.

(** Distributivity over [Qadd] *)

Theorem Qmult_plus_distr_r : forall x y z, x*(y+z)==(x*y)+(x*z).
Proof.
  intros (x1, x2) (y1, y2) (z1, z2).
  unfold Qeq, Qmult, Qplus; simpl; simpl_mult; ring.
Qed.

Theorem Qmult_plus_distr_l : forall x y z, (x+y)*z==(x*z)+(y*z).
Proof.
  intros (x1, x2) (y1, y2) (z1, z2).
  unfold Qeq, Qmult, Qplus; simpl; simpl_mult; ring.
Qed.

(** Integrality *)

Theorem Qmult_integral : forall x y, x*y==0 -> x==0 \/ y==0.
Proof.
  intros (x1,x2) (y1,y2).
  unfold Qeq, Qmult; simpl.
  now rewrite <- Z.mul_eq_0, !Z.mul_1_r.
Qed.

Theorem Qmult_integral_l : forall x y, ~ x == 0 -> x*y == 0 -> y == 0.
Proof.
  intros (x1, x2) (y1, y2).
  unfold Qeq, Qmult; simpl.
  rewrite !Z.mul_1_r, Z.mul_eq_0. intuition.
Qed.

(** * inject_Z is a ring homomorphism: *)

Lemma inject_Z_plus (x y: Z): inject_Z (x + y) = inject_Z x + inject_Z y.
Proof.
 unfold Qplus, inject_Z. simpl. f_equal. ring.
Qed.

Lemma inject_Z_mult (x y: Z): inject_Z (x * y) = inject_Z x * inject_Z y.
Proof. reflexivity. Qed.

Lemma inject_Z_opp (x: Z): inject_Z (- x) = - inject_Z x.
Proof. reflexivity. Qed.

(** * Inverse and division. *)

Lemma Qinv_involutive : forall q, (/ / q) == q.
Proof.
intros [[|n|n] d]; red; simpl; reflexivity.
Qed.

Theorem Qmult_inv_r : forall x, ~ x == 0 -> x*(/x) == 1.
Proof.
  intros (x1, x2); unfold Qeq, Qdiv, Qmult; case x1; simpl;
    intros; simpl_mult; try ring.
  elim H; auto.
Qed.

Lemma Qinv_mult_distr : forall p q, / (p * q) == /p * /q.
Proof.
  intros (x1,x2) (y1,y2); unfold Qeq, Qinv, Qmult; simpl.
  destruct x1; simpl; auto;
    destruct y1; simpl; auto.
Qed.

Theorem Qdiv_mult_l : forall x y, ~ y == 0 -> (x*y)/y == x.
Proof.
  intros; unfold Qdiv.
  rewrite <- (Qmult_assoc x y (Qinv y)).
  rewrite (Qmult_inv_r y H).
  apply Qmult_1_r.
Qed.

Theorem Qmult_div_r : forall x y, ~ y == 0 -> y*(x/y) == x.
Proof.
  intros; unfold Qdiv.
  rewrite (Qmult_assoc y x (Qinv y)).
  rewrite (Qmult_comm y x).
  fold (Qdiv (Qmult x y) y).
  apply Qdiv_mult_l; auto.
Qed.

(** Injectivity of Qmult (requires theory about Qinv above): *)

Lemma Qmult_inj_r (x y z: Q): ~ z == 0 -> (x * z == y * z <-> x == y).
Proof.
 intro z_ne_0.
 split; intro E.
  rewrite <- (Qmult_1_r x), <- (Qmult_1_r y).
  rewrite <- (Qmult_inv_r z); auto.
  do 2 rewrite Qmult_assoc.
  rewrite E. reflexivity.
 rewrite E. reflexivity.
Qed.

Lemma Qmult_inj_l (x y z: Q): ~ z == 0 -> (z * x == z * y <-> x == y).
Proof.
 rewrite (Qmult_comm z x), (Qmult_comm z y).
 apply Qmult_inj_r.
Qed.

(** * Properties of order upon Q. *)

Lemma Qle_refl x : x<=x.
Proof.
  unfold Qle; auto with zarith.
Qed.

Lemma Qle_antisym x y : x<=y -> y<=x -> x==y.
Proof.
  unfold Qle, Qeq; auto with zarith.
Qed.

Lemma Qle_trans : forall x y z, x<=y -> y<=z -> x<=z.
Proof.
  unfold Qle; intros (x1, x2) (y1, y2) (z1, z2); simpl; intros.
  Open Scope Z_scope.
  apply Z.mul_le_mono_pos_r with (Zpos y2); [easy|].
  apply Z.le_trans with (y1 * Zpos x2 * Zpos z2).
  - rewrite Z.mul_shuffle0. now apply Z.mul_le_mono_pos_r.
  - rewrite Z.mul_shuffle0, (Z.mul_shuffle0 z1).
    now apply Z.mul_le_mono_pos_r.
  Close Scope Z_scope.
Qed.

Hint Resolve Qle_trans : qarith.

Lemma Qlt_irrefl x : ~x<x.
Proof.
 unfold Qlt. auto with zarith.
Qed.

Lemma Qlt_not_eq x y : x<y -> ~ x==y.
Proof.
  unfold Qlt, Qeq; auto with zarith.
Qed.

Lemma Zle_Qle (x y: Z): (x <= y)%Z = (inject_Z x <= inject_Z y).
Proof.
 unfold Qle. simpl. now rewrite !Z.mul_1_r.
Qed.

Lemma Zlt_Qlt (x y: Z): (x < y)%Z = (inject_Z x < inject_Z y).
Proof.
 unfold Qlt. simpl. now rewrite !Z.mul_1_r.
Qed.

(** Large = strict or equal *)

Lemma Qle_lteq x y : x<=y <-> x<y \/ x==y.
Proof.
 rewrite Qeq_alt, Qle_alt, Qlt_alt.
 destruct (x ?= y); intuition; discriminate.
Qed.

Lemma Qlt_le_weak x y : x<y -> x<=y.
Proof.
  unfold Qle, Qlt; auto with zarith.
Qed.

Lemma Qle_lt_trans : forall x y z, x<=y -> y<z -> x<z.
Proof.
  unfold Qle, Qlt; intros (x1, x2) (y1, y2) (z1, z2); simpl; intros.
  Open Scope Z_scope.
  apply Z.mul_lt_mono_pos_r with (Zpos y2); [easy|].
  apply Z.le_lt_trans with (y1 * Zpos x2 * Zpos z2).
  - rewrite Z.mul_shuffle0. now apply Z.mul_le_mono_pos_r.
  - rewrite Z.mul_shuffle0, (Z.mul_shuffle0 z1).
    now apply Z.mul_lt_mono_pos_r.
  Close Scope Z_scope.
Qed.

Lemma Qlt_le_trans : forall x y z, x<y -> y<=z -> x<z.
Proof.
  unfold Qle, Qlt; intros (x1, x2) (y1, y2) (z1, z2); simpl; intros.
  Open Scope Z_scope.
  apply Z.mul_lt_mono_pos_r with (Zpos y2); [easy|].
  apply Z.lt_le_trans with (y1 * Zpos x2 * Zpos z2).
  - rewrite Z.mul_shuffle0. now apply Z.mul_lt_mono_pos_r.
  - rewrite Z.mul_shuffle0, (Z.mul_shuffle0 z1).
    now apply Z.mul_le_mono_pos_r.
  Close Scope Z_scope.
Qed.

Lemma Qlt_trans : forall x y z, x<y -> y<z -> x<z.
Proof.
  intros.
  apply Qle_lt_trans with y; auto.
  apply Qlt_le_weak; auto.
Qed.

(** [x<y] iff [~(y<=x)] *)

Lemma Qnot_lt_le : forall x y, ~ x<y -> y<=x.
Proof.
  unfold Qle, Qlt; auto with zarith.
Qed.

Lemma Qnot_le_lt : forall x y, ~ x<=y -> y<x.
Proof.
  unfold Qle, Qlt; auto with zarith.
Qed.

Lemma Qlt_not_le : forall x y, x<y -> ~ y<=x.
Proof.
  unfold Qle, Qlt; auto with zarith.
Qed.

Lemma Qle_not_lt : forall x y, x<=y -> ~ y<x.
Proof.
  unfold Qle, Qlt; auto with zarith.
Qed.

Lemma Qle_lt_or_eq : forall x y, x<=y -> x<y \/ x==y.
Proof.
  unfold Qle, Qlt, Qeq; intros; now apply Z.lt_eq_cases.
Qed.

Hint Resolve Qle_not_lt Qlt_not_le Qnot_le_lt Qnot_lt_le
 Qlt_le_weak Qlt_not_eq Qle_antisym Qle_refl: qarith.

(** Some decidability results about orders. *)

Lemma Q_dec : forall x y, {x<y} + {y<x} + {x==y}.
Proof.
  unfold Qlt, Qle, Qeq; intros.
  exact (Z_dec' (Qnum x * QDen y) (Qnum y * QDen x)).
Defined.

Lemma Qlt_le_dec : forall x y, {x<y} + {y<=x}.
Proof.
  unfold Qlt, Qle; intros.
  exact (Z_lt_le_dec (Qnum x * QDen y) (Qnum y * QDen x)).
Defined.

(** Compatibility of operations with respect to order. *)

Lemma Qopp_le_compat : forall p q, p<=q -> -q <= -p.
Proof.
  intros (a1,a2) (b1,b2); unfold Qle, Qlt; simpl.
  rewrite !Z.mul_opp_l. omega.
Qed.

Hint Resolve Qopp_le_compat : qarith.

Lemma Qle_minus_iff : forall p q, p <= q <-> 0 <= q+-p.
Proof.
  intros (x1,x2) (y1,y2); unfold Qle; simpl.
  rewrite Z.mul_opp_l. omega.
Qed.

Lemma Qlt_minus_iff : forall p q, p < q <-> 0 < q+-p.
Proof.
  intros (x1,x2) (y1,y2); unfold Qlt; simpl.
  rewrite Z.mul_opp_l. omega.
Qed.

Lemma Qplus_le_compat :
  forall x y z t, x<=y -> z<=t -> x+z <= y+t.
Proof.
  unfold Qplus, Qle; intros (x1, x2) (y1, y2) (z1, z2) (t1, t2);
    simpl; simpl_mult.
  Open Scope Z_scope.
  intros.
  match goal with |- ?a <= ?b => ring_simplify a b end.
  rewrite Z.add_comm.
  apply Z.add_le_mono.
  match goal with |- ?a <= ?b => ring_simplify z1 t1 (Zpos z2) (Zpos t2) a b end.
  auto with zarith.
  match goal with |- ?a <= ?b => ring_simplify x1 y1 (Zpos x2) (Zpos y2) a b end.
  auto with zarith.
  Close Scope Z_scope.
Qed.

Lemma Qplus_lt_le_compat :
  forall x y z t, x<y -> z<=t -> x+z < y+t.
Proof.
  unfold Qplus, Qle, Qlt; intros (x1, x2) (y1, y2) (z1, z2) (t1, t2);
    simpl; simpl_mult.
  Open Scope Z_scope.
  intros.
  match goal with |- ?a < ?b => ring_simplify a b end.
  rewrite Z.add_comm.
  apply Z.add_le_lt_mono.
  match goal with |- ?a <= ?b => ring_simplify z1 t1 (Zpos z2) (Zpos t2) a b end.
  auto with zarith.
  match goal with |- ?a < ?b => ring_simplify x1 y1 (Zpos x2) (Zpos y2) a b end.
  do 2 (apply Z.mul_lt_mono_pos_r;try easy).
  Close Scope Z_scope.
Qed.

Lemma Qplus_le_l (x y z: Q): x + z <= y + z <-> x <= y.
Proof.
 split; intros.
  rewrite <- (Qplus_0_r x), <- (Qplus_0_r y), <- (Qplus_opp_r z).
  do 2 rewrite Qplus_assoc.
  apply Qplus_le_compat; auto with *.
 apply Qplus_le_compat; auto with *.
Qed.

Lemma Qplus_le_r (x y z: Q): z + x <= z + y <-> x <= y.
Proof.
 rewrite (Qplus_comm z x), (Qplus_comm z y).
 apply Qplus_le_l.
Qed.

Lemma Qplus_lt_l (x y z: Q): x + z < y + z <-> x < y.
Proof.
 split; intros.
  rewrite <- (Qplus_0_r x), <- (Qplus_0_r y), <- (Qplus_opp_r z).
  do 2 rewrite Qplus_assoc.
  apply Qplus_lt_le_compat; auto with *.
 apply Qplus_lt_le_compat; auto with *.
Qed.

Lemma Qplus_lt_r (x y z: Q): z + x < z + y <-> x < y.
Proof.
 rewrite (Qplus_comm z x), (Qplus_comm z y).
 apply Qplus_lt_l.
Qed.

Lemma Qmult_le_compat_r : forall x y z, x <= y -> 0 <= z -> x*z <= y*z.
Proof.
  intros (a1,a2) (b1,b2) (c1,c2); unfold Qle, Qlt; simpl.
  Open Scope Z_scope.
  intros; simpl_mult.
  rewrite Z.mul_shuffle1, (Z.mul_shuffle1 b1).
  apply Z.mul_le_mono_nonneg_r; auto with zarith.
  Close Scope Z_scope.
Qed.

Lemma Qmult_lt_0_le_reg_r : forall x y z, 0 < z  -> x*z <= y*z -> x <= y.
Proof.
  intros (a1,a2) (b1,b2) (c1,c2); unfold Qle, Qlt; simpl.
  Open Scope Z_scope.
  simpl_mult.
  rewrite Z.mul_shuffle1, (Z.mul_shuffle1 b1).
  intros LT LE.
  apply Z.mul_le_mono_pos_r in LE; trivial.
  apply Z.mul_pos_pos; [omega|easy].
  Close Scope Z_scope.
Qed.

Lemma Qmult_le_r (x y z: Q): 0 < z -> (x*z <= y*z <-> x <= y).
Proof.
 split; intro.
  now apply Qmult_lt_0_le_reg_r with z.
 apply Qmult_le_compat_r; auto with qarith.
Qed.

Lemma Qmult_le_l (x y z: Q): 0 < z -> (z*x <= z*y <-> x <= y).
Proof.
 rewrite (Qmult_comm z x), (Qmult_comm z y).
 apply Qmult_le_r.
Qed.

Lemma Qmult_lt_compat_r : forall x y z, 0 < z  -> x < y -> x*z < y*z.
Proof.
  intros (a1,a2) (b1,b2) (c1,c2); unfold Qle, Qlt; simpl.
  Open Scope Z_scope.
  intros; simpl_mult.
  rewrite Z.mul_shuffle1, (Z.mul_shuffle1 b1).
  apply Z.mul_lt_mono_pos_r; auto with zarith.
  apply Z.mul_pos_pos; [omega|reflexivity].
  Close Scope Z_scope.
Qed.

Lemma Qmult_lt_r: forall x y z, 0 < z -> (x*z < y*z <-> x < y).
Proof.
 Open Scope Z_scope.
 intros (a1,a2) (b1,b2) (c1,c2).
 unfold Qle, Qlt; simpl.
 simpl_mult.
 rewrite Z.mul_shuffle1, (Z.mul_shuffle1 b1).
 intro LT. rewrite <- Z.mul_lt_mono_pos_r. reflexivity.
 apply Z.mul_pos_pos; [omega|reflexivity].
 Close Scope Z_scope.
Qed.

Lemma Qmult_lt_l (x y z: Q): 0 < z -> (z*x < z*y <-> x < y).
Proof.
 rewrite (Qmult_comm z x), (Qmult_comm z y).
 apply Qmult_lt_r.
Qed.

Lemma Qmult_le_0_compat : forall a b, 0 <= a -> 0 <= b -> 0 <= a*b.
Proof.
intros a b Ha Hb.
unfold Qle in *.
simpl in *.
auto with *.
Qed.

Lemma Qinv_le_0_compat : forall a, 0 <= a -> 0 <= /a.
Proof.
intros [[|n|n] d] Ha; assumption.
Qed.

Lemma Qle_shift_div_l : forall a b c,
 0 < c -> a*c <= b -> a <= b/c.
Proof.
intros a b c Hc H.
apply Qmult_lt_0_le_reg_r with (c).
 assumption.
setoid_replace (b/c*c) with (c*(b/c)) by apply Qmult_comm.
rewrite Qmult_div_r; try assumption.
auto with *.
Qed.

Lemma Qle_shift_inv_l : forall a c,
 0 < c -> a*c <= 1 -> a <= /c.
Proof.
intros a c Hc H.
setoid_replace (/c) with (1*/c) by (symmetry; apply Qmult_1_l).
change (a <= 1/c).
apply Qle_shift_div_l; assumption.
Qed.

Lemma Qle_shift_div_r : forall a b c,
 0 < b -> a <= c*b -> a/b <= c.
Proof.
intros a b c Hc H.
apply Qmult_lt_0_le_reg_r with b.
 assumption.
setoid_replace (a/b*b) with (b*(a/b)) by apply Qmult_comm.
rewrite Qmult_div_r; try assumption.
auto with *.
Qed.

Lemma Qle_shift_inv_r : forall b c,
 0 < b -> 1 <= c*b -> /b <= c.
Proof.
intros b c Hc H.
setoid_replace (/b) with (1*/b) by (symmetry; apply Qmult_1_l).
change (1/b <= c).
apply Qle_shift_div_r; assumption.
Qed.

Lemma Qinv_lt_0_compat : forall a, 0 < a -> 0 < /a.
Proof.
intros [[|n|n] d] Ha; assumption.
Qed.

Lemma Qlt_shift_div_l : forall a b c,
 0 < c -> a*c < b -> a < b/c.
Proof.
intros a b c Hc H.
apply Qnot_le_lt.
intros H0.
apply (Qlt_not_le _ _ H).
apply Qmult_lt_0_le_reg_r with (/c).
 apply Qinv_lt_0_compat.
 assumption.
setoid_replace (a*c/c) with (a) by (apply Qdiv_mult_l; auto with *).
assumption.
Qed.

Lemma Qlt_shift_inv_l : forall a c,
 0 < c -> a*c < 1 -> a < /c.
Proof.
intros a c Hc H.
setoid_replace (/c) with (1*/c) by (symmetry; apply Qmult_1_l).
change (a < 1/c).
apply Qlt_shift_div_l; assumption.
Qed.

Lemma Qlt_shift_div_r : forall a b c,
 0 < b -> a < c*b -> a/b < c.
Proof.
intros a b c Hc H.
apply Qnot_le_lt.
intros H0.
apply (Qlt_not_le _ _ H).
apply Qmult_lt_0_le_reg_r with (/b).
 apply Qinv_lt_0_compat.
 assumption.
setoid_replace (c*b/b) with (c) by (apply Qdiv_mult_l; auto with *).
assumption.
Qed.

Lemma Qlt_shift_inv_r : forall b c,
 0 < b -> 1 < c*b -> /b < c.
Proof.
intros b c Hc H.
setoid_replace (/b) with (1*/b) by (symmetry; apply Qmult_1_l).
change (1/b < c).
apply Qlt_shift_div_r; assumption.
Qed.

(** * Rational to the n-th power *)

Definition Qpower_positive : Q -> positive -> Q :=
 pow_pos Qmult.

Instance Qpower_positive_comp : Proper (Qeq==>eq==>Qeq) Qpower_positive.
Proof.
intros x x' Hx y y' Hy. rewrite <-Hy; clear y' Hy.
unfold Qpower_positive.
induction y; simpl;
try rewrite IHy;
try rewrite Hx;
reflexivity.
Qed.

Definition Qpower (q:Q) (z:Z) :=
    match z with
      | Zpos p => Qpower_positive q p
      | Z0 => 1
      | Zneg p => /Qpower_positive q p
    end.

Notation " q ^ z " := (Qpower q z) : Q_scope.

Instance Qpower_comp : Proper (Qeq==>eq==>Qeq) Qpower.
Proof.
intros x x' Hx y y' Hy. rewrite <- Hy; clear y' Hy.
destruct y; simpl; rewrite ?Hx; auto with *.
Qed.