(*************************************************************)
(*      This file is distributed under the terms of the      *)
(*      GNU Lesser General Public License Version 2.1        *)
(*************************************************************)
(*    Benjamin.Gregoire@inria.fr Laurent.Thery@inria.fr      *)
(*************************************************************)

(**********************************************************************
    EGroup.v

    Given an element a, create the group {e, a, a^2, ..., a^n}
 **********************************************************************)
Require Import ZArith.
Require Import Tactic.
Require Import List.
Require Import ZCAux.
Require Import ZArith Znumtheory.
Require Import Wf_nat.
Require Import UList.
Require Import FGroup.
Require Import Lagrange.

Open Scope Z_scope.

Section EGroup.

Variable A: Set.

Variable A_dec: forall a b: A, {a = b} + {~ a = b}.

Variable op: A -> A -> A.

Variable a: A.

Variable G: FGroup op.

Hypothesis a_in_G: In a G.(s).

(**************************************
  The power function for the group
 **************************************)

Set Implicit Arguments.
Definition gpow n := match n with  Zpos p => iter_pos _ (op a) G.(e) p | _ => G.(e) end.
Unset Implicit Arguments.

Theorem gpow_0: gpow 0 = G.(e).
simpl; sauto.
Qed.

Theorem gpow_1 : gpow 1 = a.
simpl; sauto.
Qed.

(**************************************
  Some properties of the power function
 **************************************)

Theorem gpow_in: forall n, In (gpow n) G.(s).
intros n; case n; simpl; auto.
intros p; apply iter_pos_invariant with (Inv := fun x => In x G.(s)); auto.
Qed.

Theorem gpow_op: forall b p, In b G.(s) -> iter_pos _ (op a) b p = op (iter_pos _ (op a) G.(e) p) b.
intros b p; generalize b; elim p; simpl; auto; clear  b p.
intros p Rec b Hb.
assert (H: In (gpow (Zpos p)) G.(s)).
apply gpow_in.
rewrite (Rec b); try rewrite (fun x y => Rec (op x y)); try rewrite (fun x y => Rec (iter_pos A x y p)); auto.
repeat rewrite G.(assoc); auto.
intros p Rec b Hb.
assert (H: In (gpow (Zpos p)) G.(s)).
apply gpow_in.
rewrite (Rec b); try rewrite (fun x y => Rec (op x y)); try rewrite (fun x y => Rec (iter_pos A x y p)); auto.
repeat rewrite G.(assoc); auto.
intros b H; rewrite e_is_zero_r; auto.
Qed.

Theorem gpow_add: forall n m, 0 <= n -> 0 <= m -> gpow (n + m) = op (gpow n) (gpow m).
intros n; case n.
intros m _ _; simpl; apply sym_equal; apply e_is_zero_l; apply gpow_in.
2: intros p m H; contradict H; auto with zarith.
intros p1 m; case m.
intros _ _; simpl; apply sym_equal; apply e_is_zero_r.
exact (gpow_in (Zpos p1)).
2: intros p2 _ H; contradict H; auto with zarith.
intros p2 _ _; simpl.
rewrite iter_pos_plus; rewrite (fun x y => gpow_op (iter_pos A x y p2)); auto.
exact (gpow_in (Zpos p2)).
Qed.

Theorem gpow_1_more:
  forall n, 0 < n -> gpow n = G.(e) -> forall m, 0 <= m -> exists p, 0 <= p < n /\ gpow m = gpow p.
intros n H1 H2 m Hm;  generalize Hm; pattern m; apply Z_lt_induction; auto with zarith; clear m Hm.
intros m Rec Hm.
case (Zle_or_lt n m); intros H3.
case (Rec (m - n)); auto with zarith.
intros p (H4,H5); exists p; split; auto.
replace m with (n + (m - n)); auto with zarith.
rewrite gpow_add; try rewrite H2; try rewrite H5; sauto; auto with zarith.
generalize gpow_in; sauto.
exists m; auto.
Qed.

Theorem gpow_i: forall n m, 0 <= n -> 0 <= m -> gpow n = gpow (n + m) -> gpow m = G.(e).
intros n m H1 H2 H3; generalize gpow_in; intro PI.
apply g_cancel_l with (g:= G) (a := gpow n); sauto.
rewrite <- gpow_add; try rewrite <- H3; sauto.
Qed.

(**************************************
  We build the support by iterating the power function
 **************************************)

Set Implicit Arguments.

Fixpoint support_aux (b: A) (n: nat) {struct n}: list A :=
b::let c := op a b in
    match n with
       O => nil |
      (S n1) =>if A_dec c G.(e) then nil else  support_aux c n1
    end.

Definition support := support_aux G.(e) (Zabs_nat (g_order G)).

Unset Implicit Arguments.

(**************************************
  Some properties of the support that helps to prove that we have a group
 **************************************)

Theorem support_aux_gpow:
  forall n m b, 0 <=  m -> In b (support_aux (gpow m) n) ->
        exists p, (0 <= p < length (support_aux (gpow m) n))%nat  /\ b = gpow (m + Z_of_nat p).
intros n; elim n; simpl.
intros n1 b Hm [H1 | H1]; exists 0%nat; simpl; rewrite Zplus_0_r; auto; case H1.
intros n1 Rec m b Hm [H1 | H1].
exists 0%nat; simpl; rewrite Zplus_0_r; auto; auto with arith.
generalize H1; case (A_dec (op a (gpow m)) G.(e)); clear H1; simpl; intros H1 H2.
case H2.
case (Rec (1 + m) b); auto with zarith.
rewrite gpow_add; auto with zarith.
rewrite gpow_1; auto.
intros p (Hp1, Hp2); exists (S p); split; auto with zarith.
rewrite <- gpow_1.
rewrite <- gpow_add; auto with zarith.
rewrite inj_S; rewrite Hp2; eq_tac; auto with zarith.
Qed.

Theorem gpow_support_aux_not_e:
  forall n m p, 0 <= m -> m < p < m + Z_of_nat (length (support_aux (gpow m) n)) -> gpow p <> G.(e).
intros n; elim n; simpl.
intros m p Hm (H1, H2); contradict H2; auto with zarith.
intros n1 Rec m p Hm; case (A_dec (op a (gpow m)) G.(e)); simpl.
intros _ (H1, H2); contradict H2; auto with zarith.
assert (tmp: forall p, Zpos (P_of_succ_nat p) = 1 + Z_of_nat p).
intros p1; apply trans_equal with (Z_of_nat (S p1)); auto; rewrite inj_S; auto with zarith.
rewrite tmp.
intros H1 (H2, H3); case (Zle_lt_or_eq (1 + m) p); auto with zarith; intros H4; subst.
apply (Rec (1 + m)); try split; auto with zarith.
rewrite gpow_add; auto with zarith.
rewrite gpow_1; auto with zarith.
rewrite gpow_add; try rewrite gpow_1; auto with zarith.
Qed.

Theorem support_aux_not_e: forall n m b, 0 <= m -> In b (tail (support_aux (gpow m) n)) -> ~ b = G.(e).
intros n; elim n; simpl.
intros m b Hm H; case H.
intros n1 Rec m b Hm; case (A_dec (op a (gpow m)) G.(e)); intros H1 H2; simpl; auto.
assert (Hm1: 0 <= 1 + m); auto with zarith.
generalize( Rec (1 + m) b Hm1) H2; case n1; auto; clear Hm1.
intros _ [H3 | H3]; auto.
contradict H1; subst; auto.
rewrite gpow_add; simpl; try rewrite e_is_zero_r; auto with zarith.
intros n2; case (A_dec (op a (op a (gpow m))) G.(e)); intros H3.
intros _ [H4 | H4].
contradict H1; subst; auto.
case H4.
intros H4 [H5 | H5]; subst; auto.
Qed.

Theorem support_aux_length_le: forall n a, (length (support_aux a n) <= n + 1)%nat.
intros n; elim n; simpl; auto.
intros n1 Rec a1; case (A_dec (op a a1) G.(e)); simpl; auto with arith.
Qed.

Theorem support_aux_length_le_is_e:
   forall n m, 0 <= m ->  (length (support_aux (gpow m) n) <= n)%nat ->
      gpow (m + Z_of_nat (length (support_aux (gpow m) n))) = G.(e) .
intros n; elim n; simpl; auto.
intros m _ H1; contradict H1; auto with arith.
intros n1 Rec m Hm; case (A_dec (op a (gpow m)) G.(e)); simpl;  intros H1.
intros H2; rewrite Zplus_comm; rewrite gpow_add; simpl; try rewrite e_is_zero_r; auto with zarith.
assert (tmp: forall p, Zpos (P_of_succ_nat p) = 1 + Z_of_nat p).
intros p1; apply trans_equal with (Z_of_nat (S p1)); auto; rewrite inj_S; auto with zarith.
rewrite tmp; clear tmp.
rewrite <- gpow_1.
rewrite <- gpow_add; auto with zarith.
rewrite  Zplus_assoc; rewrite (Zplus_comm 1); intros H2; apply Rec; auto with zarith.
Qed.

Theorem support_aux_in:
  forall n m p, 0 <= m ->  (p < length (support_aux (gpow m) n))% nat ->
            (In (gpow (m + Z_of_nat p)) (support_aux (gpow m) n)).
intros n; elim n; simpl; auto; clear n.
intros m p Hm H1; replace p with 0%nat.
left; eq_tac; auto with zarith.
generalize H1; case p; simpl; auto with arith.
intros n H2; contradict H2; apply le_not_lt; auto with arith.
intros n1 Rec m p Hm; case (A_dec (op a (gpow m)) G.(e)); simpl; intros H1 H2; auto.
replace p with 0%nat.
left; eq_tac; auto with zarith.
generalize H2; case p; simpl; auto with arith.
intros n H3; contradict H3; apply le_not_lt; auto with arith.
generalize H2; case p; simpl; clear H2.
rewrite Zplus_0_r; auto.
intros n.
assert (tmp: forall p, Zpos (P_of_succ_nat p) = 1 + Z_of_nat p).
intros p1; apply trans_equal with (Z_of_nat (S p1)); auto; rewrite inj_S; auto with zarith.
rewrite tmp; clear tmp.
rewrite <- gpow_1; rewrite <- gpow_add; auto with zarith.
rewrite  Zplus_assoc; rewrite (Zplus_comm 1); intros H2; right; apply Rec; auto with zarith.
Qed.

Theorem support_aux_ulist:
  forall n m, 0 <= m -> (forall p, 0 <= p < m -> gpow (1 + p) <> G.(e)) -> ulist (support_aux (gpow m) n).
intros n; elim n; auto; clear n.
intros m _ _; auto.
simpl; apply ulist_cons; auto.
intros n1 Rec m Hm H.
simpl; case (A_dec (op a (gpow m)) G.(e)); auto.
intros He; apply ulist_cons; auto.
intros H1; case  (support_aux_gpow n1 (1 + m) (gpow m)); auto with zarith.
rewrite gpow_add; try rewrite gpow_1; auto with zarith.
intros p (Hp1, Hp2).
assert (H2: gpow (1 + Z_of_nat p) = G.(e)).
apply gpow_i with m; auto with zarith.
rewrite Hp2; eq_tac; auto with zarith.
case (Zle_or_lt m  (Z_of_nat p)); intros H3; auto.
2: case (H (Z_of_nat p)); auto with zarith.
case (support_aux_not_e (S n1) m (gpow (1 + Z_of_nat p))); auto.
rewrite gpow_add; auto with zarith; simpl; rewrite e_is_zero_r; auto.
case (A_dec (op a (gpow m)) G.(e)); auto.
intros _; rewrite <- gpow_1; repeat rewrite <- gpow_add; auto with zarith.
replace (1 + Z_of_nat p) with ((1 + m) + (Z_of_nat (p - Zabs_nat m))); auto with zarith.
apply support_aux_in; auto with zarith.
rewrite inj_minus1; auto with zarith.
rewrite inj_Zabs_nat; auto with zarith.
rewrite Zabs_eq; auto with zarith.
apply inj_le_rev.
rewrite inj_Zabs_nat; auto with zarith.
rewrite Zabs_eq; auto with zarith.
rewrite <- gpow_1; repeat rewrite <- gpow_add; auto with zarith.
apply (Rec (1 + m)); auto with zarith.
intros p H1; case (Zle_lt_or_eq p m); intros; subst; auto with zarith.
rewrite  gpow_add; auto with zarith.
rewrite gpow_1; auto.
Qed.

Theorem support_gpow: forall b, (In b support) -> exists p, 0 <= p < Z_of_nat (length support) /\ b = gpow p.
intros b H; case (support_aux_gpow  (Zabs_nat (g_order G)) 0 b); auto with zarith.
intros p ((H1, H2), H3); exists (Z_of_nat p); repeat split; auto with zarith.
apply inj_lt; auto.
Qed.

Theorem support_incl_G: incl support G.(s).
intros a1 H; case (support_gpow a1); auto; intros p (H1, H2); subst; apply gpow_in.
Qed.

Theorem gpow_support_not_e: forall p, 0 < p < Z_of_nat (length support) -> gpow p <> G.(e).
intros p (H1, H2); apply gpow_support_aux_not_e with (m := 0) (n := length G.(s)); simpl;
  try split; auto with zarith.
rewrite  <- (Zabs_nat_Z_of_nat (length G.(s))); auto.
Qed.

Theorem support_not_e: forall b, In b (tail support) -> ~ b = G.(e).
intros b H; apply (support_aux_not_e (Zabs_nat (g_order G)) 0); auto with zarith.
Qed.

Theorem support_ulist:  ulist support.
apply (support_aux_ulist (Zabs_nat (g_order G)) 0); auto with zarith.
Qed.

Theorem support_in_e:  In G.(e) support.
unfold support; case (Zabs_nat (g_order G)); simpl; auto with zarith.
Qed.

Theorem gpow_length_support_is_e: gpow (Z_of_nat (length support)) = G.(e).
apply (support_aux_length_le_is_e (Zabs_nat (g_order G)) 0); simpl; auto with zarith.
unfold g_order; rewrite Zabs_nat_Z_of_nat; apply ulist_incl_length.
rewrite  <- (Zabs_nat_Z_of_nat (length G.(s))); auto.
exact support_ulist.
rewrite  <- (Zabs_nat_Z_of_nat (length G.(s))); auto.
exact support_incl_G.
Qed.

Theorem support_in:  forall p, 0 <= p < Z_of_nat (length support) ->  In (gpow p) support.
intros p (H, H1); unfold support.
rewrite <-  (Zabs_eq p); auto with zarith.
rewrite <-  (inj_Zabs_nat p); auto.
generalize (support_aux_in (Zabs_nat (g_order G)) 0); simpl; intros H2; apply H2; auto with zarith.
rewrite <-  (fun x => Zabs_nat_Z_of_nat (@length A x)); auto.
apply Zabs_nat_lt; split; auto.
Qed.

Theorem support_internal: forall a b, In a support -> In b support -> In (op a b) support.
intros a1 b1 H1 H2.
case support_gpow with (1 := H1); auto; intros p1 ((H3, H4), H5); subst.
case support_gpow with (1 := H2); auto; intros p2 ((H5, H6), H7); subst.
rewrite <- gpow_add; auto with zarith.
case gpow_1_more with (m:= p1 + p2)   (2 := gpow_length_support_is_e); auto with zarith.
intros p3 ((H8, H9), H10); rewrite H10; apply support_in; auto with zarith.
Qed.

Theorem support_i_internal: forall a, In a support -> In (G.(i) a) support.
generalize gpow_in; intros Hp.
intros a1 H1.
case support_gpow with (1 := H1); auto.
intros p1 ((H2, H3), H4); case Zle_lt_or_eq with (1 := H2); clear H2; intros H2; subst.
2: rewrite gpow_0; rewrite i_e; apply support_in_e.
replace (G.(i) (gpow p1)) with (gpow (Z_of_nat (length support - Zabs_nat p1))).
apply support_in; auto with zarith.
rewrite inj_minus1.
rewrite inj_Zabs_nat; auto with zarith.
rewrite Zabs_eq; auto with zarith.
apply inj_le_rev; rewrite inj_Zabs_nat; auto with zarith.
rewrite Zabs_eq; auto with zarith.
apply g_cancel_l with (g:= G) (a := gpow p1); sauto.
rewrite <- gpow_add; auto with zarith.
replace (p1 + Z_of_nat (length support - Zabs_nat p1)) with (Z_of_nat (length support)).
rewrite gpow_length_support_is_e; sauto.
rewrite inj_minus1; auto with zarith.
rewrite inj_Zabs_nat; auto with zarith.
rewrite Zabs_eq; auto with zarith.
apply inj_le_rev; rewrite inj_Zabs_nat; auto with zarith.
rewrite Zabs_eq; auto with zarith.
Qed.

(**************************************
  We are now ready to build the group
 **************************************)

Definition Gsupport: (FGroup op).
generalize support_incl_G; unfold incl; intros Ho.
apply mkGroup with support G.(e) G.(i); sauto.
apply support_ulist.
apply support_internal.
intros a1 b1 c1 H1 H2 H3; apply G.(assoc); sauto.
apply support_in_e.
apply support_i_internal.
Defined.

(**************************************
  Definition of the order of an element
 **************************************)
Set Implicit Arguments.

Definition e_order := Z_of_nat (length support).

Unset Implicit Arguments.

(**************************************
 Some properties of the order of an element
 **************************************)

Theorem gpow_e_order_is_e: gpow e_order = G.(e).
apply (support_aux_length_le_is_e (Zabs_nat (g_order G)) 0); simpl; auto with zarith.
unfold g_order; rewrite Zabs_nat_Z_of_nat; apply ulist_incl_length.
rewrite  <- (Zabs_nat_Z_of_nat (length G.(s))); auto.
exact support_ulist.
rewrite  <- (Zabs_nat_Z_of_nat (length G.(s))); auto.
exact support_incl_G.
Qed.

Theorem gpow_e_order_lt_is_not_e: forall n, 1 <= n < e_order -> gpow n <> G.(e).
intros n (H1, H2); apply gpow_support_not_e; auto with zarith.
Qed.

Theorem e_order_divide_g_order:  (e_order | g_order G).
change ((g_order Gsupport) | g_order G).
apply lagrange; auto.
exact support_incl_G.
Qed.

Theorem e_order_pos: 0 < e_order.
unfold e_order, support; case (Zabs_nat (g_order G)); simpl; auto with zarith.
Qed.

Theorem e_order_divide_gpow: forall n, 0 <= n -> gpow n = G.(e) -> (e_order | n).
generalize gpow_in; intros Hp.
generalize e_order_pos; intros Hp1.
intros n Hn; generalize Hn; pattern n; apply Z_lt_induction; auto; clear n Hn.
intros n Rec Hn H.
case (Zle_or_lt  e_order n); intros H1.
case (Rec (n - e_order)); auto with zarith.
apply g_cancel_l with (g:= G) (a := gpow e_order); sauto.
rewrite G.(e_is_zero_r); auto with zarith.
rewrite <- gpow_add; try (rewrite gpow_e_order_is_e; rewrite <- H; eq_tac); auto with zarith.
intros k Hk; exists (1 + k).
rewrite Zmult_plus_distr_l; rewrite <- Hk; auto with zarith.
case (Zle_lt_or_eq 0 n); auto with arith; intros H2; subst.
contradict H; apply support_not_e.
generalize H1; unfold e_order, support.
case (Zabs_nat (g_order G)); simpl; auto.
intros H3; contradict H3; auto with zarith.
intros n1; case (A_dec (op a G.(e)) G.(e)); simpl; intros _ H3.
contradict H3; auto with zarith.
generalize H3; clear H3.
assert (tmp: forall p, Zpos (P_of_succ_nat p) = 1 + Z_of_nat p).
intros p1; apply trans_equal with (Z_of_nat (S p1)); auto; rewrite inj_S; auto with zarith.
rewrite tmp; clear tmp; intros H3.
change (In (gpow n) (support_aux (gpow 1) n1)).
replace n with (1 + Z_of_nat (Zabs_nat n - 1)).
apply support_aux_in; auto with zarith.
rewrite <- (fun x => Zabs_nat_Z_of_nat (@length A x)).
replace (Zabs_nat n - 1)%nat  with (Zabs_nat (n - 1)).
apply Zabs_nat_lt; split; auto with zarith.
rewrite G.(e_is_zero_r) in H3; try rewrite gpow_1; auto with zarith.
apply inj_eq_rev; rewrite inj_Zabs_nat; auto with zarith.
rewrite Zabs_eq; auto with zarith.
rewrite inj_minus1; auto with zarith.
rewrite inj_Zabs_nat; auto with zarith.
rewrite Zabs_eq; auto with zarith.
apply inj_le_rev; rewrite inj_Zabs_nat; simpl; auto with zarith.
rewrite Zabs_eq; auto with zarith.
rewrite inj_minus1; auto with zarith.
rewrite inj_Zabs_nat; auto with zarith.
rewrite Zabs_eq; auto with zarith.
rewrite Zplus_comm; simpl; auto with zarith.
apply inj_le_rev; rewrite inj_Zabs_nat; simpl; auto with zarith.
rewrite Zabs_eq; auto with zarith.
exists 0; auto with arith.
Qed.

End EGroup.

Theorem gpow_gpow: forall (A : Set) (op : A -> A -> A) (a : A) (G : FGroup op),
       In a (s G) -> forall n m, 0 <= n -> 0 <= m -> gpow a G (n * m ) = gpow (gpow a G n) G m.
intros A op a G H n m; case n.
simpl; intros _ H1; generalize H1.
pattern m; apply natlike_ind; simpl; auto.
intros x H2 Rec _; unfold Zsucc; rewrite gpow_add; simpl; auto with zarith.
repeat rewrite G.(e_is_zero_r); auto with zarith.
apply gpow_in; sauto.
intros p1 _; case m; simpl; auto.
assert(H1: In (iter_pos A (op a) (e G) p1) (s G)).
refine (gpow_in _ _ _ _ _ (Zpos p1)); auto.
intros p2 _;  pattern p2; apply Pind; simpl; auto.
rewrite Pmult_1_r; rewrite G.(e_is_zero_r); try rewrite G.(e_is_zero_r); auto.
intros p3 Rec; rewrite Pplus_one_succ_r; rewrite Pmult_plus_distr_l.
rewrite Pmult_1_r.
simpl; repeat rewrite iter_pos_plus; simpl.
rewrite G.(e_is_zero_r); auto.
rewrite gpow_op with (G:= G); try rewrite Rec; auto.
apply sym_equal; apply gpow_op; auto.
intros p Hp; contradict Hp; auto with zarith.
Qed.

Theorem gpow_e: forall (A : Set) (op : A -> A -> A) (G : FGroup op) n, 0 <= n -> gpow G.(e) G n = G.(e).
intros A op G n; case n; simpl; auto with zarith.
intros p _; elim p; simpl; auto; intros p1 Rec; repeat rewrite Rec; auto.
Qed.

Theorem gpow_pow: forall (A : Set) (op : A -> A -> A) (a : A) (G : FGroup op),
       In a (s G) -> forall n, 0 <= n -> gpow a G (2 ^ n) = G.(e) -> forall m, n <= m -> gpow a G (2 ^ m) = G.(e).
intros A op a G H n H1 H2 m Hm.
replace m with (n + (m - n)); auto with zarith.
rewrite Zpower_exp; auto with zarith.
rewrite gpow_gpow; auto with zarith.
rewrite H2; apply gpow_e.
apply Zpower_ge_0; auto with zarith.
Qed.

Theorem gpow_mult: forall (A : Set) (op : A -> A -> A) (a b: A) (G : FGroup op)
       (comm: forall a b,  In a (s G) -> In b (s G) -> op a b = op b a),
       In a (s G) -> In b (s G) -> forall n, 0 <= n -> gpow (op a b) G n = op (gpow a G n) (gpow b G n).
intros A op a  b G comm Ha Hb n; case n; simpl; auto.
intros _; rewrite G.(e_is_zero_r); auto.
2: intros p Hp; contradict Hp; auto with zarith.
intros p _; pattern p; apply Pind; simpl; auto.
repeat rewrite G.(e_is_zero_r); auto.
intros p3 Rec; rewrite Pplus_one_succ_r.
repeat rewrite iter_pos_plus; simpl.
repeat rewrite (fun x y H z => gpow_op A  op x G H (op y z)) ; auto.
rewrite Rec.
repeat rewrite G.(e_is_zero_r); auto.
assert(H1: In (iter_pos A (op a) (e G) p3) (s G)).
refine (gpow_in _ _ _ _ _ (Zpos p3)); auto.
assert(H2: In (iter_pos A (op b) (e G) p3) (s G)).
refine (gpow_in _ _ _ _ _ (Zpos p3)); auto.
repeat rewrite <- G.(assoc); try eq_tac; auto.
rewrite (fun x y => comm (iter_pos A x y p3) b); auto.
rewrite (G.(assoc) a); try apply comm; auto.
Qed.

Theorem Zdivide_mult_rel_prime:  forall a b c : Z, (a | c) -> (b | c) -> rel_prime a b -> (a * b | c).
intros a b c (q1, H1) (q2, H2) H3.
assert (H4: (a | q2)).
apply Gauss with (2 := H3).
exists q1; rewrite <- H1; rewrite H2; auto with zarith.
case H4; intros q3 H5; exists q3; rewrite H2; rewrite H5; auto with zarith.
Qed.

Theorem order_mult: forall (A : Set) (op : A -> A -> A) (A_dec: forall a b: A, {a = b} + {~ a = b}) (G : FGroup op)
       (comm: forall a b,  In a (s G) -> In b (s G) -> op a b = op b a) (a b: A),
       In a (s G) -> In b (s G) -> rel_prime (e_order A_dec a G) (e_order A_dec b G) ->
        e_order A_dec (op a b) G = e_order A_dec a G * e_order A_dec b G.
intros A op A_dec G comm a b Ha Hb Hab.
assert (Hoat: 0 < e_order A_dec a G); try apply e_order_pos.
assert (Hobt: 0 < e_order A_dec b G); try apply e_order_pos.
assert (Hoabt: 0 < e_order A_dec (op a b) G); try apply e_order_pos.
assert (Hoa: 0 <= e_order A_dec a G); auto with zarith.
assert (Hob: 0 <= e_order A_dec b G); auto with zarith.
apply Zle_antisym; apply Zdivide_le; auto with zarith.
apply Zmult_lt_O_compat; auto.
apply e_order_divide_gpow; sauto; auto with zarith.
rewrite gpow_mult; auto with zarith.
rewrite gpow_gpow; auto with zarith.
rewrite gpow_e_order_is_e; auto with zarith.
rewrite gpow_e; auto.
rewrite Zmult_comm.
rewrite gpow_gpow; auto with zarith.
rewrite gpow_e_order_is_e; auto with zarith.
rewrite gpow_e; auto.
apply Zdivide_mult_rel_prime; auto.
apply Gauss with (2 := Hab).
apply e_order_divide_gpow; auto with zarith.
rewrite <- (gpow_e _ _ G (e_order A_dec b G)); auto.
rewrite <- (gpow_e_order_is_e _ A_dec  _ (op a b) G); auto with zarith.
rewrite <- gpow_gpow; auto with zarith.
rewrite (Zmult_comm (e_order A_dec (op a b) G)).
rewrite gpow_mult; auto with zarith.
rewrite gpow_gpow with (a := b); auto with zarith.
rewrite gpow_e_order_is_e; auto with zarith.
rewrite gpow_e; auto with zarith.
rewrite G.(e_is_zero_r); auto with zarith.
apply gpow_in; auto.
apply Gauss with (2 := rel_prime_sym _ _ Hab).
apply e_order_divide_gpow; auto with zarith.
rewrite <- (gpow_e _ _ G (e_order A_dec a G)); auto.
rewrite <- (gpow_e_order_is_e _ A_dec  _ (op a b) G); auto with zarith.
rewrite <- gpow_gpow; auto with zarith.
rewrite (Zmult_comm (e_order A_dec (op a b) G)).
rewrite gpow_mult; auto with zarith.
rewrite gpow_gpow with (a := a); auto with zarith.
rewrite gpow_e_order_is_e; auto with zarith.
rewrite gpow_e; auto with zarith.
rewrite G.(e_is_zero_l); auto with zarith.
apply gpow_in; auto.
Qed.

Theorem fermat_gen: forall (A : Set) (A_dec: forall (a b: A), {a = b} + {a <>b}) (op : A -> A -> A) (a: A) (G : FGroup op),
       In a G.(s) ->  gpow a G (g_order G) = G.(e).
intros A A_dec op a G H.
assert (H1: (e_order A_dec a G | g_order G)).
apply e_order_divide_g_order; auto.
case H1; intros q; intros Hq; rewrite Hq.
assert (Hq1: 0 <= q).
apply Zmult_le_reg_r with (e_order A_dec a G); auto with zarith.
apply Zlt_gt; apply e_order_pos.
rewrite Zmult_0_l; rewrite <- Hq; apply Zlt_le_weak; apply g_order_pos.
rewrite Zmult_comm; rewrite gpow_gpow; auto with zarith.
rewrite gpow_e_order_is_e; auto with zarith.
apply gpow_e; auto.
apply Zlt_le_weak; apply e_order_pos.
Qed.

Theorem order_div: forall (A : Set) (A_dec: forall (a b: A), {a = b} + {a <>b}) (op : A -> A -> A) (a: A) (G : FGroup op) m,
 0 < m -> (forall p, prime p -> (p | m) -> gpow a G (m / p) <> G.(e)) ->
 In a G.(s) -> gpow a G m = G.(e) -> e_order A_dec a G = m.
intros A Adec op a G m Hm H H1 H2.
assert (F1: 0 <= m); auto with zarith.
case (e_order_divide_gpow A Adec op a G H1 m F1 H2); intros q Hq.
assert (F2: 1 <= q).
  case (Zle_or_lt 0 q); intros HH.
    case (Zle_lt_or_eq _ _ HH); auto with zarith.
    intros HH1; generalize Hm; rewrite Hq; rewrite <- HH1;
      auto with zarith.
  assert (F2: 0 <= (- q) * e_order Adec a G); auto with zarith.
    apply Zmult_le_0_compat; auto with zarith.
    apply Zlt_le_weak; apply e_order_pos.
  generalize F2; rewrite Zopp_mult_distr_l_reverse;
      rewrite <- Hq; auto with zarith.
case (Zle_lt_or_eq _ _ F2); intros H3; subst; auto with zarith.
case (prime_dec q); intros Hq.
  case (H q); auto with zarith.
    rewrite Zmult_comm; rewrite Z_div_mult; auto with zarith.
  apply gpow_e_order_is_e; auto.
case (Zdivide_div_prime_le_square _ H3 Hq); intros r (Hr1, (Hr2, Hr3)).
case (H _ Hr1); auto.
  apply Zdivide_trans with (1 := Hr2).
  apply Zdivide_factor_r.
case Hr2; intros q1 Hq1; subst.
assert (F3: 0 < r).
  generalize (prime_ge_2 _ Hr1); auto with zarith.
rewrite <- Zmult_assoc; rewrite Zmult_comm; rewrite <- Zmult_assoc;
  rewrite Zmult_comm; rewrite Z_div_mult; auto with zarith.
rewrite gpow_gpow; auto with zarith.
  rewrite gpow_e_order_is_e; try rewrite gpow_e; auto.
  apply Zmult_le_reg_r with r; auto with zarith.
  apply Zlt_le_weak; apply e_order_pos.
apply Zmult_le_reg_r with r; auto with zarith.
Qed.


(* Adapt nat paths in the TLC style. *)

Set Implicit Arguments.
Require Import TLC.LibTactics TLC.LibReflect TLC.LibBool TLC.LibOperation TLC.LibRelation TLC.LibOrder  TLC.LibNat.

(* ********************************************************************** *)
(** * Inhabited and comparable *)

Inductive IPE: Set :=
 | zero_pe
 | one_pe.

Inductive PE : Set :=
 | i_pe      : IPE -> PE
 | u_pe      : PE.

Definition Path : Set := list PE.
Definition pdot : Path := nil.

Instance path_inhab : Inhab Path.
Proof using. intros. apply (prove_Inhab (cons u_pe nil)). Qed.

Fixpoint path_compare (x y : Path) :=
  match x, y with
    | nil, nil => true
    | (cons _ _), nil => false
    | nil, (cons _ _) => false
    | (cons a x'), (cons b y') =>
      If a = b (* The trick is to USE equality at each step! *)
      then path_compare x' y'
      else false
  end.

(* And this proves equality is valid in classical logic! *)
Instance path_comparable : Comparable Path.
Proof using.
  applys (comparable_beq path_compare).
  induction x; destruct y; simpl; autos*; auto_false.
  destruct (classicT (a = p));  split; intros; try solve[inversion H].
  apply IHx in H.
  subst.
  reflexivity.
  inversion H; subst.
  apply IHx.
  reflexivity.
  inversion H.
  contradiction.
Qed.


Require Export GeoCoq.Elements.OriginalProofs.lemma_8_3.
Require Export GeoCoq.Elements.OriginalProofs.lemma_8_2.

Section Euclid.

Context `{Ax:euclidean_neutral_ruler_compass}.

Lemma lemma_equaltorightisright :
   forall A B C a b c,
   Per A B C -> CongA a b c A B C ->
   Per a b c.
Proof.
intros.
assert (CongA A B C a b c) by (conclude lemma_equalanglessymmetric).
let Tf:=fresh in
assert (Tf:exists E F e f, (Out B A E /\ Out B C F /\ Out b a e /\ Out b c f /\ Cong B E b e /\ Cong B F b f /\ Cong E F e f /\ nCol A B C)) by (conclude_def CongA );destruct Tf as [E[F[e[f]]]];spliter.
assert (Per A B F) by (conclude lemma_8_3).
assert (Per F B A) by (conclude lemma_8_2).
assert (Per F B E) by (conclude lemma_8_3).
assert (Per E B F) by (conclude lemma_8_2).
assert (neq B E) by (conclude lemma_raystrict).
assert (neq E B) by (conclude lemma_inequalitysymmetric).
let Tf:=fresh in
assert (Tf:exists W, (BetS E B W /\ Cong E B W B /\ Cong E F W F /\ neq B F)) by (conclude_def Per );destruct Tf as [W];spliter.
assert (neq b e) by (conclude axiom_nocollapse).
assert (neq e b) by (conclude lemma_inequalitysymmetric).
let Tf:=fresh in
assert (Tf:exists w, (BetS e b w /\ Cong b w e b)) by (conclude lemma_extension);destruct Tf as [w];spliter.
assert (Cong e b E B) by (forward_using lemma_doublereverse).
assert (Cong b w E B) by (conclude lemma_congruencetransitive).
assert (Cong E B B W) by (forward_using lemma_congruenceflip).
assert (Cong b w B W) by (conclude lemma_congruencetransitive).
assert (Cong b f B F) by (conclude lemma_congruencesymmetric).
assert (Cong e f E F) by (conclude lemma_congruencesymmetric).
assert (Cong e w E W) by (conclude cn_sumofparts).
assert (Cong f w F W) by (conclude (axiom_5_line e b w f E B W F)).
assert (Cong e b B W) by (conclude lemma_congruencetransitive).
assert (Cong B W b w) by (conclude lemma_congruencesymmetric).
assert (Cong e b b w) by (conclude lemma_congruencetransitive).
assert (Cong e b w b) by (forward_using lemma_congruenceflip).
assert (Cong e f W F) by (conclude lemma_congruencetransitive).
assert (Cong W F w f) by (forward_using lemma_doublereverse).
assert (Cong e f w f) by (conclude lemma_congruencetransitive).
assert (neq b f) by (conclude lemma_raystrict).
assert (Per e b f) by (conclude_def Per ).
assert (Out b f c) by (conclude lemma_ray5).
assert (Per e b c) by (conclude lemma_8_3).
assert (Per c b e) by (conclude lemma_8_2).
assert (Out b e a) by (conclude lemma_ray5).
assert (Per c b a) by (conclude lemma_8_3).
assert (Per a b c) by (conclude lemma_8_2).
close.
Qed.

End Euclid.


(* generated by Ott 0.31, locally-nameless lngen from: ../ott/rules.ott *)
Require Import Bool.
Require Import Metalib.Metatheory.
Require Import List.
(** syntax *)

Inductive nexp : Set :=  (*r expressions *)
 | ne_var_b (_:nat) (*r variables *)
 | ne_var_f (x:var) (*r variables *)
 | ne_lit (i:nat): nexp (*r lit *)
 | ne_abs (e:nexp) (*r abstractions *)
 | ne_app (e1:nexp) (e2:nexp) (*r applications *).

(* EXPERIMENTAL *)
(** auxiliary functions on the new list types *)
(** library functions *)
(** subrules *)
(** arities *)
(** opening up abstractions *)
Fixpoint open_nexp_wrt_nexp_rec (k:nat) (e_5:nexp) (e__6:nexp) {struct e__6}: nexp :=
  match e__6 with
  | (ne_var_b nat) =>
      match lt_eq_lt_dec nat k with
        | inleft (left _) => ne_var_b nat
        | inleft (right _) => e_5
        | inright _ => ne_var_b (nat - 1)
      end
  | (ne_var_f x) => ne_var_f x
  | ne_lit i => ne_lit i
  | (ne_abs e) => ne_abs (open_nexp_wrt_nexp_rec (S k) e_5 e)
  | (ne_app e1 e2) => ne_app (open_nexp_wrt_nexp_rec k e_5 e1) (open_nexp_wrt_nexp_rec k e_5 e2)
end.

Definition open_nexp_wrt_nexp e_5 e__6 := open_nexp_wrt_nexp_rec 0 e__6 e_5.

(** terms are locally-closed pre-terms *)
(** definitions *)

(* defns LC_nexp *)
Inductive lc_nexp : nexp -> Prop :=    (* defn lc_nexp *)
 | lc_ne_var_f : forall (x:var),
     (lc_nexp (ne_var_f x))
 | lc_ne_lit : forall i,
     (lc_nexp (ne_lit i))
 | lc_ne_abs : forall (e:nexp),
      ( forall x , lc_nexp  ( open_nexp_wrt_nexp e (ne_var_f x) )  )  ->
     (lc_nexp (ne_abs e))
 | lc_ne_app : forall (e1 e2:nexp),
     (lc_nexp e1) ->
     (lc_nexp e2) ->
     (lc_nexp (ne_app e1 e2)).
(** free variables *)
Fixpoint fv_nexp (e_5:nexp) : vars :=
  match e_5 with
  | (ne_var_b nat) => {}
  | (ne_var_f x) => {{x}}
  | ne_lit i => {}
  | (ne_abs e) => (fv_nexp e)
  | (ne_app e1 e2) => (fv_nexp e1) \u (fv_nexp e2)
end.

(** substitutions *)
Fixpoint subst_nexp (e_5:nexp) (x5:var) (e__6:nexp) {struct e__6} : nexp :=
  match e__6 with
  | (ne_var_b nat) => ne_var_b nat
  | (ne_var_f x) => (if eq_var x x5 then e_5 else (ne_var_f x))
  | ne_lit i => ne_lit i
  | (ne_abs e) => ne_abs (subst_nexp e_5 x5 e)
  | (ne_app e1 e2) => ne_app (subst_nexp e_5 x5 e1) (subst_nexp e_5 x5 e2)
end.

(** definitions *)

(** infrastructure *)
Hint Constructors lc_nexp : core.


(* NEXT: ===> Core                                                              *)

Require Import Le.
Require Import List.

Require Import Logic.Nat.Max.

Require Import Logic.Set.Set.

(* Now that we have a type to represent our universe of sets, we shall need     *)
(* to define various notions in relation to it. For example we shall need to    *)
(* define what it means for a set x to belong to a set y (denoted x :: y), or   *)
(* what it means for a set x to be a subset of y (denoted x <== y), or what it  *)
(* means for a set x to be equal to y (denoted x == y). These relations can be  *)
(* defined in coq in any way we like. However, if we want our model of set      *)
(* theory to be interesting, we shall need to use definitions which are more    *)
(* complex than simple recursive definitions. In particular, we shall need to   *)
(* reason on the 'complexity' of the arguments, as measured by the 'order'.     *)
Fixpoint order (xs:set) : nat :=
    match xs with
    | Nil       =>  0
    | Cons x xs =>  S (max (order x) (order xs))
    end.

(* This lemma will be used on many occasions. If a set x is one of the elements *)
(* of the list of sets associated with a set y, then the 'complexity' of x      *)
(* cannot be greater to that of y. In fact a stronger result with a strict      *)
(* inequality can be obtained, but this has not been needed so far.             *)
Lemma orderToList : forall (x y:set),
    In x (toList y) -> order x <= order y.
Proof.
    intros x. induction y as [|y _ ys IH]; intros H.
    - inversion H.
    - destruct H as [H|H].
        + rewrite <- H. simpl. apply le_S. apply n_le_max.
        + simpl. apply le_S. apply le_trans with (order ys).
            { apply IH. assumption. }
            { apply m_le_max. }
Qed.

(* The only set with order 0 is Nil.                                            *)
Lemma order_0 : forall (xs:set), order xs = 0 -> xs = Nil.
Proof.
    intros [|x xs].
    - intros _. reflexivity.
    - intros H. inversion H.
Qed.


Require Import Reals.
Require Import Lra.
Require Import Psatz.
(*Require Import SeqSeries.*)
Local Open Scope R_scope.

Definition harmonic_squrd (n : nat) := 1 / (((INR n) + 1) ^ 2).

(*decreasing*)
Lemma harmonic_squrd_decreasing : Un_decreasing harmonic_squrd.
Proof.
  unfold Un_decreasing, harmonic_squrd.
  intros n.
  induction n as [| n' IHn'].
  - field_simplify; simpl; lra.
  - field_simplify.

Admitted.

Lemma harmonic_squrd_convergent : Un_cv harmonic_squrd 0.
  unfold Un_cv, harmonic_squrd.
  intros eps H.
  remember (sqrt eps) as sqrt_eps.
  (*exists nat.ceil (1 / sqrt_eps)*)
Admitted.

Ltac abs_lra :=
  unfold R_dist, Rabs; destruct Rcase_abs; try lra.

Lemma Rdist_ident :
  forall x, x >= 0 -> R_dist x 0 = x.
Proof.
  intros x H.
  unfold R_dist, Rabs.
  destruct Rcase_abs; try lra.
Qed.

Lemma sqrt_preserves_convergence_to0 : forall (Xn : nat -> R),
    (*exericse 2.3.1 in Stephen Abbott Understanding Analysis*)
    Un_cv Xn 0 -> forall k, Xn k >= 0 -> Un_cv (fun n => sqrt (Xn n)) 0.
Proof.
  intros Xn H k H'.
  unfold Un_cv in *.
  intros eps H__eps.
  assert (0<eps*eps). apply Rmult_lt_compat_r with (r:=eps) in H__eps;
                        try (rewrite Rmult_comm in H__eps;
                             rewrite Rmult_0_r in H__eps);
                        apply H__eps.
  specialize (H (eps*eps) H0).
  destruct H as [N H].
  exists N.
  intros n0 H2.
  specialize (H n0 H2).
  unfold sqrt.
  destruct Rcase_abs as [G | G].
  - abs_lra.
  - unfold Rsqrt; simpl.
    destruct Rsqrt_exists as [x0 [F1 F2]].
    abs_lra.
    inversion F1 as [F1' | F1']; try lra.
    rewrite Rminus_0_r in *.
    apply Rsqr_incrst_0; unfold Rsqr; try lra.
    unfold Rsqr in F2.
    rewrite <- F2.
    rewrite Rdist_ident in H; try lra.
Qed.


Require Import List.
Import ListNotations.

Fixpoint penU {X : Type} (ls: list X): option X :=
match ls with
| [] => None
| [x;y] => Some x
| x::xs => penU xs
end.

Theorem penUNone {X : Type} : forall (ls : list X),
  length ls < 2 -> penU ls = None.
Proof.
  destruct ls.
  auto.
  destruct ls.
  auto.
  intro.
  inversion H.
  inversion H1.
  inversion H3.
Qed.

Theorem penUCorrect {X : Type} : forall (ls : list X) x y, penU (ls ++ [x;y]) = Some x.
Proof.
  intros.
  induction ls.
  + reflexivity.
  + destruct ls.
    - auto.
    - destruct ls.
      * auto.
      * assert (penU ((a :: x0 :: x1 :: ls) ++ [x; y]) =  penU ((x0 :: x1 :: ls) ++ [x; y])).
        { reflexivity. }
        rewrite H.
        exact IHls.
Qed.


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

(* Axiom replace_with_your_solution_here : forall {A : Type}, A. *)

Section InsertionSort.

Variable T : eqType.
Variable leT : rel T.
Implicit Types x y z : T.

(** Insert an element [e] into a sorted list [s] *)
Fixpoint insert e s : seq T :=
  if s is x :: s' then
    if leT e x then e :: s
    else x :: (insert e s')
  else [:: e].

(** Sort input list [s] *)
Fixpoint sort s : seq T :=
  if s is x :: s' then insert x (sort s')
  else [::].

Hypothesis leT_total : total leT.
Hypothesis leT_tr : transitive leT.

(* from lection *)
Lemma insert_path z e s :
    leT z e ->
    path leT z s ->
    path leT z (insert e s).
Proof.
elim: s z=> [/= | x1 s IHs] z; first by move=> ->.
move=> z_le_e /=.
case/andP=> z_le_x1 path_x1_s.
case: ifP.
- by rewrite /= z_le_e path_x1_s => ->.
move=> /= e_gt_x1.
rewrite z_le_x1.
have:= leT_total e x1.
rewrite {}e_gt_x1 /= => x1_le_e.
exact: IHs.
Qed.

(* from lection *)
Lemma insert_sorted e s :
    sorted leT s ->
    sorted leT (insert e s).
Proof.
rewrite /sorted.
case: s=> // x s.
move=> /=.
case: ifP; first by move=> /= ->->.
move=> e_gt_x.
apply: insert_path.
have:= leT_total e x.
by rewrite e_gt_x /=.
Qed.

(* from lection *)
Lemma sort_sorted s :
  sorted leT (sort s).
Proof.
elim: s=> //= x s IHs.
by rewrite insert_sorted.
Qed.

Lemma all_expands s e x :
    leT x e ->
    all (leT e) s ->
    all (leT x) s.
Proof.
move=> x_le_e.
elim: s=> // y s IHs /=.
case/andP.
move=> e_le_y all_es.
apply/andP.
split.
exact: (leT_tr x_le_e e_le_y).
by apply: IHs.
Qed.

Lemma where_are_all_lemmas_about_all e y s :
    all (leT e) (y :: s) -> leT e y.
Proof.
elim: s => //=.
by case/andP.
move=> x s IHs.
by case/andP.
Qed.

Lemma insert_with_all s e :
    sorted leT s ->
    all (leT e) s ->
    e :: s = insert e s.
Proof.
elim: s=> // y s IHs sorted_ys all_ys /=.
case: ifP => //.
move=> e_le_y_false.
move: (where_are_all_lemmas_about_all all_ys).
rewrite e_le_y_false //.
Qed.

Lemma filter_doesnt_break_all (p all_p : pred T) s :
    all all_p s -> all all_p (filter p s).
Proof.
elim: s=> // x s IHs /=.
case/andP=> all_px all_ps.
case: ifP=> px_info.
move=> /=.
apply/andP ; split ; first done.
by rewrite IHs.
by rewrite IHs.
Qed.

Lemma take_insert_from_filter (p : pred T) s x :
    p x ->
    sorted leT s ->
    filter p (insert x s) = insert x (filter p s).
Proof.
move=> px.
elim: s=> //=.
move=> _.
case: ifP => //.
rewrite px //.
move=> e s IHs path_e_s.
case: ifP.
case: ifP.
move=> pe x_le_e /=.
case: ifP => //.
case: ifP => //.
case: ifP => //.
rewrite x_le_e //.
rewrite pe //.
rewrite px //.
move=> pe_false x_le_e /=.
case: ifP.
case: ifP.
rewrite pe_false //.
move: (order_path_min leT_tr path_e_s).
move=> all_le_e_s _ _ /=.
Search all transitive.
move: (all_expands x_le_e all_le_e_s).
move=> all_le_x_s.
rewrite insert_with_all //.
rewrite sorted_filter //.
rewrite (path_sorted path_e_s) //.
by rewrite filter_doesnt_break_all.
rewrite px //.
move=> x_le_e_false.
case: ifP=> pe_info /=.
case: ifP.
case: ifP.
rewrite x_le_e_false //.
move=> _ _.
rewrite IHs //.
rewrite (path_sorted path_e_s) //.
rewrite pe_info //.
case: ifP.
rewrite pe_info //.
move=> _.
rewrite IHs //.
rewrite (path_sorted path_e_s) //.
Qed.

Lemma absurd_insert_filter (p : pred T) s x :
    p x = false ->
    filter p (insert x s) = filter p s.
Proof.
elim: s=> //=.
case: ifP=> //.
move=> e s IHs.
case: ifP=> //.
move=> le_x_e px_false.
case: ifP=> //=.
case: ifP.
rewrite px_false //.
move=> _ pe.
case: ifP => //.
rewrite pe //.
move=> pe_false.
case: ifP => //.
rewrite px_false //.
move=> _.
case: ifP => //.
rewrite pe_false //.
move=> le_x_e_false px_false.
case: ifP => // pe.
rewrite -IHs //=.
case: ifP => //.
rewrite pe //.
rewrite -IHs //=.
case: ifP => //.
rewrite pe //.
Qed.

(** * Exercise *)
Lemma filter_sort (p : pred T) s :
  filter p (sort s) = sort (filter p s).
Proof.
elim: s=> //= x s IHs.
case: ifP=> px /=.
rewrite take_insert_from_filter.
rewrite IHs.
move=> //.
done.
exact: sort_sorted.
by rewrite absurd_insert_filter.
Qed.

(** Hint: you will probably need to introduce a number of helper lemmas *)

End InsertionSort.

Section AccPredicate.

(* To help you understand the meaning of the `Acc` predicate, here is how
 it can be used to write recursive functions without explicitly using recursion: *)

(** * Exercise:  understand how `addn_f` works *)
Section AdditionViaFix_F.

(* First, let's redefine the addition on natural numbers
   using the `Fix_F` combinator: *)
About Fix_F.
Print Fix_F.

(* Fix_F =
     fun (A : Type) (R : A -> A -> Prop) (P : A -> Type)
         (F : forall x : A, (forall y : A, R y x -> P y) -> P x) =>
 fix Fix_F (x : A) (a : Acc R x) {struct a} : P x :=
   F x (fun (y : A) (h : R y x) => Fix_F y (Acc_inv a h))
	  : forall (A : Type) (R : A -> A -> Prop) (P : A -> Type),
        (forall x : A, (forall y : A, R y x -> P y) -> P x) ->
        forall x : A, Acc R x -> P x *)

(* notice we do recursion on the `a : Acc R x` argument *)
Print Acc_inv.
(* To define addition, we first need to choose the relation `R`
   which "connects" successive value.
   In the case of addition `R x y` can simply mean `y = x.+1` *)

Definition R m n := n = m.+1.
Print R.

(* This definition has to be transparent, otherwise
   evaluation will get stuck *)
Definition esucc_inj : injective succn. by move=> n m []. Defined.

(* Every natural number is accessible w.r.t. R defined above *)
Fixpoint acc (n : nat) : Acc R n :=
  if n is n'.+1 then
      Acc_intro n'.+1 (fun y (pf : n'.+1 = y.+1) =>
                         eq_ind n' _ (acc n') y (esucc_inj pf))
  else Acc_intro 0 (fun y contra => False_ind _ (O_S y contra)).

Check acc.
(*
By the way, `forall n : nat, Acc R n` means that `R` is a well-founded
relation: https://en.wikipedia.org/wiki/Well-founded_relation.
*)
Print well_founded.
Print acc.
(* Addition via `Fix_F` *)
Definition addn_f : nat -> nat -> nat :=
  fun m =>
    @Fix_F (nat : Type)
           (R : nat -> nat -> Prop)
           ((fun=> nat -> nat) : (nat -> Type))
           (fun (m : nat) (rec : (forall y : nat, R y m -> (fun=> nat -> nat) y)) =>
              match m return (_ = m -> nat -> nat) with
              | m'.+1 => fun (eq : m = m'.+1) => succn \o rec m' eq
              | 0 => fun=> id
              end erefl)
           (m : nat)
           ((acc m) : Acc R m).

(* This would get stuck if esucc *)
Check erefl : addn_f 2 4 = 6.

Lemma addn_equiv_addn_f :
  addn =2 addn_f.
Proof. by elim=> // m IHm n; rewrite addSn IHm. Qed.

End AdditionViaFix_F.

(** Exercise: implement multiplication on natural numbers using `Fix_F`:
    no explicit recursion, Program Fixpoint or things like that! *)
Section MultiplicationViaFix_F.

Definition eaddn_inj n : injective (addn n).
Proof.
elim: n=> // n IHn x y.
rewrite !addSnnS.
rewrite /injective in IHn.
move=> eqxy.
move: (IHn x.+1 y.+1 eqxy).
apply: esucc_inj.
Defined.

Definition muln_f : nat -> nat -> nat :=
  fun m =>
    @Fix_F (nat : Type)
           (R : nat -> nat -> Prop)
           ((fun=> nat -> nat) : (nat -> Type))
           (fun (m : nat) (rec : (forall y : nat, R y m -> (fun=> nat -> nat) y)) =>
              match m return (_ = m -> nat -> nat) with
              | 0 => fun=> (fun x => 0)
              | m'.+1 => fun (eq : m = m'.+1) => (fun x => x + (rec m' eq) x)
              end erefl)
           (m : nat)
           ((acc m) : Acc R m).

(* this should not fail *)
Compute muln_f 2 33.
Compute muln_f 1 33.
Compute muln_f 0 33.
Compute muln_f 0 0.
Compute muln_f 123 0.
Check erefl : muln_f 21 2 = 42.

Lemma muln_equiv_muln_f :
  muln =2 muln_f.
Proof. by elim=> // y IHy x ; rewrite mulSn IHy. Qed.

End MultiplicationViaFix_F.

End AccPredicate.


(*|
#################################################################
Coq: destruct (co)inductive hypothesis without losing information
#################################################################

:Link: https://stackoverflow.com/q/45151308
|*)

(*|
Question
********

Consider the following development:
|*)

Require Import Relation_Definitions RelationClasses.

Set Implicit Arguments.

CoInductive stream (A : Type) : Type :=
| scons : A -> stream A -> stream A.

CoInductive stream_le (A : Type) {eqA R : relation A}
            `{PO : PartialOrder A eqA R} :
  stream A -> stream A -> Prop :=
| le_step : forall h1 h2 t1 t2, R h1 h2 ->
                                (eqA h1 h2 -> stream_le t1 t2) ->
                                stream_le (scons h1 t1) (scons h2 t2).

(*|
If I have a hypothesis ``stream_le (scons h1 t1) (scons h2 t2)``, it
would be reasonable for the ``destruct`` tactic to turn it into a pair
of hypotheses ``R h1 h2`` and ``eqA h1 h2 -> stream_le t1 t2``. But
that's not what happens, because ``destruct`` loses information
whenever doing anything non-trivial. Instead, new terms ``h0``,
``h3``, ``t0``, ``t3`` are introduced into the context, with no recall
that they are respectively equal to ``h1``, ``h2``, ``t1``, ``t2``.

I would like to know if there is a quick and easy way to do this kind
of "smart ``destruct``". Here is what i have right now:
|*)

Theorem stream_le_destruct :
  forall (A : Type) eqA R
         `{PO : PartialOrder A eqA R} (h1 h2 : A) (t1 t2 : stream A),
    stream_le (scons h1 t1) (scons h2 t2) ->
    R h1 h2 /\ (eqA h1 h2 -> stream_le t1 t2).
Proof.
  intros.
  destruct H eqn:Heq. Undo.
  remember (scons h1 t1) as s1 eqn:Heqs1.
  remember (scons h2 t2) as s2 eqn:Heqs2.
  destruct H.
  inversion Heqs1. inversion Heqs2. subst.
  split; assumption.
Qed.

(*|
Answer (Arthur Azevedo De Amorim)
*********************************

Calling ``destruct`` will not directly give you what you want. You
need to use ``inversion`` instead.
|*)

Reset stream_le_destruct. (* .none *)
Theorem stream_le_destruct :
  forall (A : Type) eqA R
         `{PO : PartialOrder A eqA R} (h1 h2 : A) (t1 t2 : stream A),
    stream_le (scons h1 t1) (scons h2 t2) ->
    R h1 h2 /\ (eqA h1 h2 -> stream_le t1 t2).
Proof.
  intros.
  inversion H. subst.
  split; assumption.
Qed.

(*|
Unfortunately, the ``inversion`` tactic is quite ill behaved, as it
tends to generate a lot of spurious equality hypotheses, making it
hard to name them consistently. One (somewhat heavyweight, admittedly)
alternative is to use ``inversion`` only to prove a lemma like the one
you did, and apply this lemma in proofs instead of calling
``inversion``.
|*)

(*|
Answer (ejgallego)
******************

Indeed, ``inversion`` basically does what you want, however as Arthur
pointed out it is a bit unstable, mainly due to the different
congruence steps.

Under the hood, ``inversion`` just calls a version of ``destruct``,
but remembering some equalities first. As you have well discovered,
pattern matching in Coq will "forget" arguments of constructors,
except if these are variables, then, all the variables *under the
scope* of the destruct will be instantiated.

What does that mean? It means that in order to properly destruct an
inductive ``I : Idx -> Prop``, you want to get your goal of the form:
``I x -> Q x``, so that destructing the ``I x`` will also refine the
``x`` in ``Q``. Thus, a standard transformation for an inductive ``I
term`` and goal ``Q (f term)`` is to rewrite it to ``I x -> x = term
-> Q (f x)``. Then, destructing ``I x`` will get you ``x``
instantiated to the proper index.

With that in mind, it may be a good exercise to implement inversion
manually using the ``case:`` tactic of Coq 8.7;
|*)

Reset stream_le_destruct. (* .none *)
From Coq Require Import ssreflect.

Theorem stream_le_destruct A eqA R
        `{PO : PartialOrder A eqA R} (h1 h2 : A) (t1 t2 : stream A) :
  stream_le (scons h1 t1) (scons h2 t2) ->
  R h1 h2 /\ (eqA h1 h2 -> stream_le t1 t2).
Proof.
  move E1: (scons h1 t1) => sc1. move E2: (scons h2 t2) => sc2 H.
  by case: sc1 sc2 / H E1 E2 => h1' h2' t1' t2' hr ih [? ?] [? ?]; subst.
Qed.

(*|
You can read the manual for more details, but basically with the first
line, we create the equalities we need; then, in the second we can
destruct the term and get the proper instantiations solving the goal.
A good effect of the ``case:`` tactic is that, contrary to destruct,
it will try to prevent us from destructing a term without first
bringing its dependencies into scope.
|*)


Require Import Lib BinPosDef BinNatDef BinIntDef.

(** Instead of list of digits as in [Deci.v], we try here
    an ad-hoc specialized list-like datatype. Moreover, the conversion
    to digits are done via Horner-style computations in base 10 instead
    of division+modulo in the other base.
*)

Inductive dec :=
 | Stop
 | D0 : dec -> dec
 | D1 : dec -> dec
 | D2 : dec -> dec
 | D3 : dec -> dec
 | D4 : dec -> dec
 | D5 : dec -> dec
 | D6 : dec -> dec
 | D7 : dec -> dec
 | D8 : dec -> dec
 | D9 : dec -> dec.

Definition ten := D1 (D0 Stop). (** For example... *)

(** This representation favors simplicity over canonicity :
    we might need later to normalize by removing the leading zeros *)

Fixpoint norm l :=
  match l with
  | D0 l => norm l
  | _ => l
  end.

(** A few easy operations. For more advanced computations, use the conversions
    with other Coq numeral datatypes (e.g. Z) and the operations on them. *)

(** For conversions with binary numbers, it is easier to operate
    on little-endian numbers. *)

Fixpoint rev (l l' : dec) :=
  match l with
  | Stop => l'
  | D0 l => rev l (D0 l')
  | D1 l => rev l (D1 l')
  | D2 l => rev l (D2 l')
  | D3 l => rev l (D3 l')
  | D4 l => rev l (D4 l')
  | D5 l => rev l (D5 l')
  | D6 l => rev l (D6 l')
  | D7 l => rev l (D7 l')
  | D8 l => rev l (D8 l')
  | D9 l => rev l (D9 l')
  end.

Module Little.

(** Successor of little-endian numbers *)

Fixpoint succ d :=
  match d with
  | Stop => D1 Stop
  | D0 l => D1 l
  | D1 l => D2 l
  | D2 l => D3 l
  | D3 l => D4 l
  | D4 l => D5 l
  | D5 l => D6 l
  | D6 l => D7 l
  | D7 l => D8 l
  | D8 l => D9 l
  | D9 l => D0 (succ l)
  end.

(** Doubling little-endian numbers *)

Fixpoint double d :=
  match d with
  | Stop => Stop
  | D0 l => D0 (double l)
  | D1 l => D2 (double l)
  | D2 l => D4 (double l)
  | D3 l => D6 (double l)
  | D4 l => D8 (double l)
  | D5 l => D0 (succ_double l)
  | D6 l => D2 (succ_double l)
  | D7 l => D4 (succ_double l)
  | D8 l => D6 (succ_double l)
  | D9 l => D8 (succ_double l)
  end

with succ_double d :=
  match d with
  | Stop => D1 Stop
  | D0 l => D1 (double l)
  | D1 l => D3 (double l)
  | D2 l => D5 (double l)
  | D3 l => D7 (double l)
  | D4 l => D9 (double l)
  | D5 l => D1 (succ_double l)
  | D6 l => D3 (succ_double l)
  | D7 l => D5 (succ_double l)
  | D8 l => D7 (succ_double l)
  | D9 l => D9 (succ_double l)
  end.

End Little.

(** Conversion between decimal and Peano nat representations *)

Module DecNat.

Local Notation ten := (S (S (S (S (S (S (S (S (S (S O)))))))))).
Local Notation tenfold := (TailNat.mul ten).

Fixpoint of_dec_acc (d:dec)(acc:nat) :=
  match d with
  | Stop => acc
  | D0 d => of_dec_acc d (tenfold acc)
  | D1 d => of_dec_acc d (S (tenfold acc))
  | D2 d => of_dec_acc d (S (S (tenfold acc)))
  | D3 d => of_dec_acc d (S (S (S (tenfold acc))))
  | D4 d => of_dec_acc d (S (S (S (S (tenfold acc)))))
  | D5 d => of_dec_acc d (S (S (S (S (S (tenfold acc))))))
  | D6 d => of_dec_acc d (S (S (S (S (S (S (tenfold acc)))))))
  | D7 d => of_dec_acc d (S (S (S (S (S (S (S (tenfold acc))))))))
  | D8 d => of_dec_acc d (S (S (S (S (S (S (S (S (tenfold acc)))))))))
  | D9 d => of_dec_acc d (S (S (S (S (S (S (S (S (S (tenfold acc))))))))))
  end.

Definition of_dec (d:dec) := of_dec_acc d O.

Fixpoint to_little_dec n acc :=
  match n with
  | O => acc
  | S n => to_little_dec n (Little.succ acc)
  end.

Definition to_dec n :=
  rev (to_little_dec n Stop) Stop.

End DecNat.

(** Same for decimal and binary N numbers *)

Module DecPos.

Local Open Scope positive.

Fixpoint to_dec_rev p :=
  match p with
  | 1 => D1 Stop
  | p~1 => Little.succ_double (to_dec_rev p)
  | p~0 => Little.double (to_dec_rev p)
  end.

Definition to_dec p := rev (to_dec_rev p) Stop.

Local Notation ten := 1~0~1~0.
Local Notation tenfold := (Pos.mul ten).

Fixpoint of_dec_acc (d:dec)(acc:positive) :=
  match d with
  | Stop => acc
  | D0 l => of_dec_acc l (tenfold acc)
  | D1 l => of_dec_acc l (Pos.add 1 (tenfold acc))
  | D2 l => of_dec_acc l (Pos.add 2 (tenfold acc))
  | D3 l => of_dec_acc l (Pos.add 3 (tenfold acc))
  | D4 l => of_dec_acc l (Pos.add 4 (tenfold acc))
  | D5 l => of_dec_acc l (Pos.add 5 (tenfold acc))
  | D6 l => of_dec_acc l (Pos.add 6 (tenfold acc))
  | D7 l => of_dec_acc l (Pos.add 7 (tenfold acc))
  | D8 l => of_dec_acc l (Pos.add 8 (tenfold acc))
  | D9 l => of_dec_acc l (Pos.add 9 (tenfold acc))
  end.

Fixpoint of_dec (d:dec) : N :=
  match d with
  | Stop => N0
  | D0 l => of_dec l
  | D1 l => Npos (of_dec_acc l 1)
  | D2 l => Npos (of_dec_acc l 1~0)
  | D3 l => Npos (of_dec_acc l 1~1)
  | D4 l => Npos (of_dec_acc l 1~0~0)
  | D5 l => Npos (of_dec_acc l 1~0~1)
  | D6 l => Npos (of_dec_acc l 1~1~0)
  | D7 l => Npos (of_dec_acc l 1~1~1)
  | D8 l => Npos (of_dec_acc l 1~0~0~0)
  | D9 l => Npos (of_dec_acc l 1~0~0~1)
  end.

End DecPos.

Module DecN.

Local Open Scope N.

Definition of_dec := DecPos.of_dec.

Definition to_dec (n:N) :=
  match n with
  | N0 => Stop
  | Npos p => DecPos.to_dec p
  end.

End DecN.

Module DecZ.

Definition dec2z d :=
 match DecN.of_dec d with
 | N0 => Z0
 | Npos p => Zpos p
 end.

Definition z2dec z :=
 match z with
 | Zpos p => DecPos.to_dec p
 | _ => Stop (* TODO : for now, we discard negative numbers *)
 end.

End DecZ.

(** A successor on decimal. Not really mandatory, just to state
    that our conversions preserve the order of numbers *)

Definition succ d := rev (Little.succ (rev d Stop)) Stop.

(** The strict order on decimal numbers is the transitive
    closure of the successor *)

Inductive lt : dec -> dec -> Prop :=
 | Succ x : lt x (succ x)
 | Trans x y z : lt x y -> lt y z -> lt x z.


Add LoadPath "." as OPAT.
Require Import OPAT.aula3 OPAT.aula4 OPAT.aula5 OPAT.aula6 OPAT.aula7.

(** Complete the definitions of [nonzeros], [oddmembers] and
    [countoddmembers] below. Have a look at the tests to understand
    what these functions should do. *)

(** **** Exercise: 2 star  *)
Fixpoint nonzeros (l:natlist) : natlist :=
  match l with
  | nil => nil
  | 0 :: t => nonzeros t
  | n :: t => n :: nonzeros t
  end.

(** **** Exercise: 1 star  *)
Example test_nonzeros:
  nonzeros [0;1;0;2;3;0;0] = [1;2;3].
Proof. simpl. reflexivity. Qed.

(* GRADE_THEOREM 0.5: NatList.test_nonzeros *)

(** **** Exercise: 2 star  *)
Fixpoint oddmembers (l:natlist) : natlist :=
  match l with
  | nil => nil
  | n :: t => match oddb n with
              | true => n :: oddmembers t
              | false => oddmembers t
              end
  end.

(** **** Exercise: 1 star  *)
Example test_oddmembers:
  oddmembers [0;1;0;2;3;0;0] = [1;3].
Proof. simpl. reflexivity. Qed.
(* GRADE_THEOREM 0.5: NatList.test_oddmembers *)

(** **** Exercise: 2 star  *)
Definition countoddmembers (l:natlist) : nat :=
  length (oddmembers l).

(** **** Exercise: 1 star  *)
Example test_countoddmembers1:
  countoddmembers [1;0;3;1;4;5] = 4.
Proof. reflexivity. Qed.

(** **** Exercise: 1 star  *)
Example test_countoddmembers2:
  countoddmembers [0;2;4] = 0.
Proof. reflexivity. Qed.

(** **** Exercise: 1 star  *)
Example test_countoddmembers3:
  countoddmembers nil = 0.
Proof. reflexivity. Qed.

(** [] *)

(** **** Exercise: 3 stars, advanced (alternate)  *)
(** Complete the definition of [alternate], which "zips up" two lists
    into one, alternating between elements taken from the first list
    and elements from the second.  See the tests below for more
    specific examples.

    Note: one natural and elegant way of writing [alternate] will fail
    to satisfy Coq's requirement that all [Fixpoint] definitions be
    "obviously terminating."  If you find yourself in this rut, look
    for a slightly more verbose solution that considers elements of
    both lists at the same time.  (One possible solution requires
    defining a new kind of pairs, but this is not the only way.)  *)

Fixpoint alternate (l1 l2 : natlist) : natlist :=
  match l1 with
  | nil => l2
  | n1 :: t1 => match l2 with
                | nil => n1 :: t1
                | n2 :: t2 => n1 :: n2 :: alternate t1 t2
                end
  end.

Example test_alternate1:
  alternate [1;2;3] [4;5;6] = [1;4;2;5;3;6].
Proof. reflexivity. Qed.

Example test_alternate2:
  alternate [1] [4;5;6] = [1;4;5;6].
Proof. reflexivity. Qed.

Example test_alternate3:
  alternate [1;2;3] [4] = [1;4;2;3].
Proof. reflexivity. Qed.

Example test_alternate4:
  alternate [] [20;30] = [20;30].
Proof. reflexivity. Qed.
(** [] *)


(* Do not edit this file, it was generated automatically *)
(* This file tests:
    forward_for_simple_bound on 64-bit long integers,
    forward load with 64-bit integer array subscript, and
    forward store with 64-bit integer array subscript.
*)

Require Import VST.floyd.proofauto.
Require Import VST.progs64.min64.
#[export] Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs.  mk_varspecs prog. Defined.

Require Import ZArith.
Require Import List.
Import ListNotations.
Open Scope Z.

Theorem fold_min_general:
  forall (al: list Z)(i: Z),
  In i (al) ->
  forall x, List.fold_right Z.min x al <= i.
Proof.
induction al; intros.
inversion H.
destruct H.
subst a.
simpl.
apply Z.le_min_l.
simpl. rewrite Z.le_min_r.
apply IHal.
apply H.
Qed.

Theorem fold_min:
  forall (al: list Z)(i: Z),
  In i (al) ->
  List.fold_right Z.min (hd 0 al) al <= i.
Proof.
intros.
apply fold_min_general.
apply H.
Qed.

Lemma Forall_fold_min:
  forall (f: Z -> Prop) (x: Z) (al: list Z),
    f x -> Forall f al -> f (fold_right Z.min x al).
Proof.
 intros.
 induction H0.
 simpl. auto.
 simpl.
 unfold Z.min at 1.
 destruct (Z.compare x0 (fold_right Z.min x l)) eqn:?; auto.
Qed.

Lemma fold_min_another:
  forall x al y,
    fold_right Z.min x (al ++ [y]) = Z.min (fold_right Z.min x al) y.
Proof.
 intros.
 revert x; induction al; simpl; intros.
 apply Z.min_comm.
 rewrite <- Z.min_assoc. f_equal.
 apply IHal.
Qed.

Lemma is_int_I32_Znth_map_Vint:
 forall i s al,
  0 <= i < Zlength al ->
  is_int I32 s (Znth i (map Vint al)).
Proof.
intros. rewrite Znth_map; auto.
Qed.
#[export] Hint Extern 3 (is_int I32 _ (Znth _ (map Vint _))) =>
  (apply  is_int_I32_Znth_map_Vint; rewrite ?Zlength_map; lia) : core.

Definition minimum_spec :=
 DECLARE _minimum
  WITH a: val, n: Z, al: list Z
  PRE [ tptr tint , tlong ]
    PROP  (1 <= n <= Int64.max_signed; Forall repable_signed al)
    PARAMS (a; Vlong (Int64.repr n))
    SEP   (data_at Ews (tarray tint n) (map Vint (map Int.repr al)) a)
  POST [ tint ]
    PROP ()
    RETURN (Vint (Int.repr (fold_right Z.min (hd 0 al) al)))
    SEP   (data_at Ews (tarray tint n) (map Vint (map Int.repr al)) a).

Definition Gprog : funspecs :=
      ltac:(with_library prog [minimum_spec]).

(* First approach from "Modular Verification for Computer Security",
  proved using forward_for_simple_bound *)

Lemma body_min: semax_body Vprog Gprog f_minimum minimum_spec.
Proof.
start_function.
assert_PROP (Zlength al = n) by (entailer!; list_solve).
forward.  (* min = a[0]; *)
forward_for_simple_bound n
  (EX i:Z,
    PROP()
    LOCAL(temp _min (Vint (Int.repr (fold_right Z.min (Znth 0 al) (sublist 0 i al))));
          temp _a a;
          temp _n (Vlong (Int64.repr n)))
    SEP(data_at Ews (tarray tint n) (map Vint (map Int.repr al)) a)).
* (* Prove that the precondition implies the loop invariant *)
  entailer!!.
* (* Prove that the loop body preserves the loop invariant *)
 forward. (* j = a[i]; *)
 forward. (* a[i] = j; *)
 assert (repable_signed (Znth i al))
     by (apply Forall_Znth; auto; lia).
 assert (repable_signed (fold_right Z.min (Znth 0 al) (sublist 0 i al)))
   by (apply Forall_fold_min;
          [apply Forall_Znth; auto; lia
          |apply Forall_sublist; auto]).
 autorewrite with sublist.
 subst POSTCONDITION; unfold abbreviate.
 rewrite (sublist_split 0 i (i+1)) by lia.
 rewrite (sublist_one i (i+1) al) by lia.
 rewrite fold_min_another.
 replace  (upd_Znth i (map Vint (map Int.repr al)) (Vint (Int.repr (Znth i al))))
  with (map Vint (map Int.repr al))
  by list_solve.
 forward_if.
 +
 forward. (* min = j; *)
 entailer!.
 rewrite Z.min_r; auto; lia.
 +
 forward. (* skip; *)
 entailer!.
 rewrite Z.min_l; auto; lia.
* (* After the loop *)
 forward. (* return *)
 entailer!!.
 autorewrite with sublist.
 destruct al; simpl; auto.
Qed.


Require Import Nat_utils.
Require Import Validity.
Require Import ZArith.
Require Import Coeff_utils.
Require Import Coeff.
Require Import Values.
Require Import Arith.

Fixpoint minus_base (p : poly) {struct p} : poly :=
  match p with
  |Cst (Z0) => Cst (Z0)
  |Cst (Z.pos z) => Cst (Z.neg z)
  |Cst (Z.neg z) => Cst (Z.pos z)
  |Poly p1 i p2 => Poly (minus_base p1) i (minus_base p2)
end.

Lemma minus_isnull (p : poly) :
  is_null p = is_null (minus_base p).
Proof.
  induction p.
  - induction z.
    + simpl minus_base.
      reflexivity.
    + simpl is_null.
      reflexivity.
    + simpl is_null.
      reflexivity.
  - simpl is_null.
    reflexivity.
Qed.

Lemma minus_valid_i (p : poly) :
  forall i : nat, valid_bool_i p i = true -> valid_bool_i (minus_base p) i = true.
Proof.
  induction p.
  induction z; simpl valid_bool_i; trivial.

  intros.
  simpl valid_bool_i in H.
  apply Bool.andb_true_iff in H.
  destruct H.
  apply Bool.andb_true_iff in H0.
  destruct H0.
  apply Bool.andb_true_iff in H1.
  destruct H1.

  simpl valid_bool_i.
  apply Bool.andb_true_iff.
  split.
  assumption.

  apply Bool.andb_true_iff.
  split.
  rewrite <- minus_isnull.
  assumption.

  apply Bool.andb_true_iff.
  split.
  apply IHp1.
  assumption.

  apply IHp2.
  assumption.

Qed.

Lemma minus_valid (p : poly) :
  valid_bool p = true -> valid_bool (minus_base p) = true.
Proof.
  unfold valid_bool.
  apply minus_valid_i with (i := 0).

Qed.

Definition minus_poly (p : valid_poly) : valid_poly :=
{| VP_value := minus_base (VP_value p) ;
   VP_prop := minus_valid (VP_value p) (VP_prop p) |}.

Theorem eval_minus (p : valid_poly) (f : nat -> Z) :
  eval (minus_poly p) f = Z.opp (eval p f).
Proof.
  destruct p as [p p'].
  unfold eval.
  simpl VP_value.
  induction p.

  - simpl.
    induction z;reflexivity.
  - unfold valid_bool in p'.
    simpl valid_bool_i in p'.
    apply Bool.andb_true_iff in p'.
    destruct p' as [p' p1'].
    apply Bool.andb_true_iff in p1'.
    destruct p1' as [p1' p2'].

    simpl eval_base.
    rewrite IHp1.
    rewrite IHp2.
    Lia.lia.

    unfold valid_bool; apply valid_leb with (n := n); trivial;assumption.
    unfold valid_bool; apply valid_leb with (n := S n); trivial;assumption.
Qed.


(** Author: Floris van Doorn, december 2017 *)
Require Import UniMath.Combinatorics.Lists.
Require Import UniMath.MoreFoundations.Subtypes.

(** Graphs.

Contents:
- paths in a graph (called gpaths to disambiguate from the identity type)
- operations on paths
*)

(** In this file we consider graphs with a type of vertices and a type of edges between any pair of
   vertices. We could restrict to sets, but there is no reason to do that here. *)

Definition issymmetric {V : UU} (E : V → V → UU) : UU :=
  ∏u v, E u v ≃ E v u.

Definition gpaths_of_length {V : UU} (E : V → V → UU) (v w : V) (n : nat) : UU.
Proof.
  revert v. induction n as [|n IH].
  - intro v. exact (v = w).
  - intro v. exact (∑u, E v u × IH u).
Defined.

Definition gpaths {V : UU} (E : V → V → UU) (v w : V) : UU :=
  ∑n, gpaths_of_length E v w n.

Definition nil {V : UU} {E : V → V → UU} (v : V) : gpaths E v v :=
  (0,, idpath v).

Definition cons {V : UU} {E : V → V → UU} {w u v : V} (e : E u v) (p : gpaths E v w) : gpaths E u w :=
  (S (pr1 p),, (v,, (e,, pr2 p))).

Local Notation "[]" := (nil _) (at level 0, format "[]").
Local Infix "::" := cons.

Lemma gpaths_ind {V : UU} {E : V → V → UU} {w : V} (P : ∏{u}, gpaths E u w → UU)
      (H1 : P []) (H2 : ∏{u v} (e : E u v) (p : gpaths E v w), P p → P (e :: p))
      {u : V} (p : gpaths E u w) : P p.
Proof.
  induction p as [n p]. revert u p. induction n as [|n IH].
  - induction p. exact H1.
  - induction p as [v x]. induction x as [e p]. apply (H2 _ _ _ (n,, p)).
    apply IH.
Defined.

Definition foldr {V : UU} {E : V → V → UU} {w : V} {B : V → UU} (f : ∏{u v}, E u v → B v → B u)
           (b : B w) : ∏{u : V}, gpaths E u w → B u.
Proof. apply gpaths_ind. exact b. exact (λ u v e _ b, f u v e b). Defined.

Definition concat {V : UU} {E : V → V → UU} {u v w : V} (p : gpaths E u v) (q : gpaths E v w) :
  gpaths E u w :=
  foldr (λ _ _ , cons) q p.

Local Infix "++" := concat.

Definition append {V : UU} {E : V → V → UU} {u v w : V} (p : gpaths E u v) (e : E v w) :
  gpaths E u w :=
  p ++ e::[].

Definition reverse {V : UU} {E : V → V → UU} (H : issymmetric E) {u v : V} (p : gpaths E u v) :
  gpaths E v u.
Proof.
  revert u p. apply gpaths_ind.
  - exact [].
  - intros u u' e p q. exact (append q (invmap (H u' u) e)).
Defined.

Definition symmetric_closure {V : UU} (E : V → V → UU) (u v : V) : UU :=
E u v ⨿ E v u.

Definition issymmetric_symmetric_closure {V : UU} (E : V → V → UU) :
  issymmetric (symmetric_closure E) :=
  λ u v, weqcoprodcomm (E u v) (E v u).

Definition reverse_in_closure {V : UU} {E : V → V → UU} {u v : V}
           (p : gpaths (symmetric_closure E) u v) : gpaths (symmetric_closure E) v u :=
  reverse (issymmetric_symmetric_closure E) p.


(* Copyright (C) 2005-2008 Sebastien Briais *)
(* http://lamp.epfl.ch/~sbriais/ *)

(* This library is free software; you can redistribute it and/or modify *)
(* it under the terms of the GNU Lesser General Public License as *)
(* published by the Free Software Foundation; either version 2.1 of the *)
(* License, or (at your option) any later version. *)

(* This library is distributed in the hope that it will be useful, but *)
(* WITHOUT ANY WARRANTY; without even the implied warranty of *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU *)
(* Lesser General Public License for more details. *)

(* You should have received a copy of the GNU Lesser General Public *)
(* License along with this library; if not, write to the Free Software *)
(* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA *)
(* 02110-1301 USA *)

Require Import missing.
Require Import division.
Require Import Wf_nat.

Unset Standard Proposition Elimination Names.

(** lemmae about divisibility *)
Lemma divides_le : forall (a b:nat),(a<>O)->(divides a b)->(b<=a).
  intros.
  elim H0;intro q;intro.
  replace b with (b*1);try ring.
  rewrite H1.
  apply mult_le_compat;try omega.
  destruct q;omega.
Qed.

(** Euclide theorem (existence) *)
Theorem euclide : forall (a b:nat),(b<>O)->{q:nat & { r:nat | (a=b*q+r) /\ (r < b)}}.
  intros.
  apply (lt_wf_rec a (fun a:nat =>{q : nat &  {r : nat | a = b * q + r /\ r < b}})).
  intros.
  case (le_lt_dec b n);intro.
  elim (H0 (n-b)).
  intro q;intro.
  elim p;intro r;intro.
  exists (q+1);exists r.
  split;try tauto.
  rewrite (le_plus_minus b n);trivial.
  elim p0;intros.
  rewrite H1;ring.
  omega.
  exists 0;exists n.
  split;try tauto.
  ring.
Qed.

Definition quotient_euclide (a b:nat)(H:(b<>O)) := let (q,_) := (euclide a b H) in q.

Definition remainder_euclide (a b:nat)(H:(b<>O)) := let (_,e0) := (euclide a b H) in let (r,_) := e0 in r.

(** a div b where b<>0 *)
Lemma quo_rem_euclide : forall (a b:nat)(H:(b<>O)),a=b*(quotient_euclide a b H)+(remainder_euclide a b H).
  unfold quotient_euclide;unfold remainder_euclide;intros.
  generalize (euclide a b H);intros.
  elim s;intro q;intro.
  elim p;intro r;intro.
  tauto.
Qed.

(** a mod b where b<>0 *)
Lemma rem_euclide : forall (a b:nat)(H:(b<>O)),(remainder_euclide a b H)<b.
  unfold remainder_euclide;intros.
  generalize (euclide a b H);intros.
  elim s;intro q;intro.
  elim p;intro r;intro.
  tauto.
Qed.

(** Euclide division is unique *)
Lemma euclide_unique : forall (a b q r q' r':nat),(b<>O)->a=b*q+r->a=b*q'+r'->r<b->r'<b->(q=q')/\(r=r').
  intros.
  rewrite H1 in H0.
  case (lt_eq_lt_dec q q');intro.
  case s;intro.
  rewrite (le_plus_minus q q') in H0;try (auto with arith).
  rewrite mult_plus_distr_l in H0.
  assert (b*(q'-q)+r' = r).
  apply plus_reg_l with (b*q).
  rewrite plus_assoc;trivial.
  assert (0<(q'-q));try omega.
  assert (b<=b*(q'-q));try omega.
  case (mult_O_le b (q'-q));intro;try omega.
  rewrite mult_comm;trivial.
  split;try tauto.
  rewrite <- e in H0.
  symmetry;apply plus_reg_l with (b*q);trivial.
  rewrite (le_plus_minus q' q) in H0;try (auto with arith).
  rewrite mult_plus_distr_l in H0.
  assert (r'=(b*(q-q')+r)).
  apply plus_reg_l with (b*q').
  rewrite plus_assoc;trivial.
  assert (0<(q-q'));try omega.
  assert (b<=b*(q-q'));try omega.
  case (mult_O_le b (q-q'));intro;try omega.
  rewrite mult_comm;trivial.
Qed.

(** if b<>0, then b | a iff a mod b = 0 *)
Lemma divides_euclide : forall (a b:nat)(H:(b<>O)),((divides a b)<->((remainder_euclide a b H)=O)).
  intros.
  red.
  split;intro.
  generalize (quo_rem_euclide a b H);intro.
  generalize (rem_euclide a b H);intro.
  elim H0;intro q;intro.
  assert (a=b*q+0).
  rewrite plus_comm;simpl;trivial.
  assert (0<b);try omega.
  generalize (euclide_unique a b (quotient_euclide a b H) (remainder_euclide a b H) q 0 H H1 H4 H2 H5).
  intros;tauto.
  generalize (quo_rem_euclide a b H).
  rewrite H0;rewrite plus_comm;simpl.
  intro;exists (quotient_euclide a b H);trivial.
Qed.

(** divisibility is decidable *)
Lemma divides_dec : forall (a b:nat),{divides a b}+{~(divides a b)}.
  intros.
  case (eq_nat_dec b 0).
  case (eq_nat_dec a 0);intros.
  rewrite e;left;apply zero_max_div.
  right;rewrite e;intro.
  elim H;intro q;intro.
  simpl in H0;apply n;trivial.
  intro.
  case (eq_nat_dec (remainder_euclide a b n) 0);[left | right];intros;elim (divides_euclide a b n);auto.
Qed.

(** if a property about integer is decidable then it is decidable if there is an integer less than n that satisfies this property *)
Lemma dec_impl_lt_dec : forall (P:nat->Prop),(forall (n:nat),{(P n)}+{~(P n)})->(forall (m:nat),{n:nat | (n<m)/\(P(n))}+{(forall (n:nat),(n<m)->~(P n))}).
  intros.
  induction m.
  right;intros;inversion H0.
  case (H m);intro.
  left;exists m;split;try (auto with arith).
  case IHm;intro.
  elim s;intro n0;intro.
  left;exists n0;split;[omega | tauto].
  right;intros.
  inversion H0;trivial.
  apply n0;omega.
Qed.

(** forall n, either forall p, p<>1 /\ p<>n -> not(p | n) or there is p such that p<>1 and p<>n and p | n *)
Lemma divides_nat : forall (n:nat),{p:nat | (p<>1)/\(p<>n)/\(divides n p)}+{forall (p:nat),(p<>1)->(p<>n)->~(divides n p)}.
  intros.
  case (dec_impl_lt_dec (fun p => (p<>1)/\(divides n p))) with n;intros.
  case (divides_dec n n0);intro.
  case (eq_nat_dec n0 1);intros.
  right;intro;tauto.
  left;tauto.
  right;tauto.
  elim s;intros.
  left;exists x.
  split;try tauto.
  split;try tauto.
  omega.
  case (eq_nat_dec n 0);intro.
  rewrite e;left;exists 2.
  split;try (intro;discriminate).
  split;try (intro;discriminate).
  apply zero_max_div.
  right;intros.
  case (lt_eq_lt_dec p n);intro.
  case s;intro;[red in n0;intro;apply n0 with p;tauto | auto].
  intro;generalize (divides_le n p n1 H1);omega.
Qed.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(*i $Id: Relation_Definitions.v 14641 2011-11-06 11:59:10Z herbelin $ i*)

Section Relation_Definition.

  Variable A : Type.

  Definition relation := A -> A -> Prop.

  Variable R : relation.

  Section General_Properties_of_Relations.

    Definition reflexive : Prop := forall x:A, R x x.
    Definition transitive : Prop := forall x y z:A, R x y -> R y z -> R x z.
    Definition symmetric : Prop := forall x y:A, R x y -> R y x.
    Definition antisymmetric : Prop := forall x y:A, R x y -> R y x -> x = y.

    (* for compatibility with Equivalence in  ../PROGRAMS/ALG/  *)
    Definition equiv := reflexive /\ transitive /\ symmetric.

  End General_Properties_of_Relations.

  Section Sets_of_Relations.

    Record preorder : Prop :=
      { preord_refl : reflexive; preord_trans : transitive}.

    Record order : Prop :=
      { ord_refl : reflexive;
	ord_trans : transitive;
	ord_antisym : antisymmetric}.

    Record equivalence : Prop :=
      { equiv_refl : reflexive;
	equiv_trans : transitive;
	equiv_sym : symmetric}.

    Record PER : Prop :=  {per_sym : symmetric; per_trans : transitive}.

  End Sets_of_Relations.

  Section Relations_of_Relations.

    Definition inclusion (R1 R2:relation) : Prop :=
      forall x y:A, R1 x y -> R2 x y.

    Definition same_relation (R1 R2:relation) : Prop :=
      inclusion R1 R2 /\ inclusion R2 R1.

    Definition commut (R1 R2:relation) : Prop :=
      forall x y:A,
	R1 y x -> forall z:A, R2 z y ->  exists2 y' : A, R2 y' x & R1 z y'.

  End Relations_of_Relations.

End Relation_Definition.

Hint Unfold reflexive transitive antisymmetric symmetric: sets v62.

Hint Resolve Build_preorder Build_order Build_equivalence Build_PER
  preord_refl preord_trans ord_refl ord_trans ord_antisym equiv_refl
  equiv_trans equiv_sym per_sym per_trans: sets v62.

Hint Unfold inclusion same_relation commut: sets v62.


Set Implicit Arguments.

Require Import Arith.
Require Import Div2.
Require Import Recdef.

Function ceil_log2_S (n: nat) {wf lt n}: nat :=
  match n with
  | 0 => 0
  | S _ => S (ceil_log2_S (div2 n))
  end.
Proof.
  intros.
  apply lt_div2; auto with arith.
  apply lt_wf.
Defined.

Lemma ceil_log2_S_def n: ceil_log2_S n =
  match n with
  | 0 => 0
  | S _ => S (ceil_log2_S (div2 n))
  end.
Proof. functional induction (ceil_log2_S n); auto. Qed.


Require Export lecture2.
Require Import EqNat.

(* # Contents *)
(*
In the next lecture, we will be defining a program logic in the form of a
separation logic for our ML-like language. The crucial feature of separation
logic is that it allows one to talk about _disjointness_ of memories. In this
part of the lecture, we will prepare for the next lecture by defining the
following operations on maps, and proving properties about them:

  munion : map A -> map A -> map A
  mdisjoint : map A -> map A -> Prop

A crucial thing that you will learn now is reuse existing lemmas on finite maps
to prove derived properties.
*)

(* # The union operation on finite maps *)
(*
In order to model separation logic in Coq, we need to have an operation that
takes the union of two finite maps:

  munion : map A -> map A -> map A

That satisfies

  mlookup (munion m1 m2) i =
    option_union (mlookup m1 i) (mlookup m2 i)

Where `option_union` is the (left-biased) union operation on the `option` type,
which is defined as follows:
*)
Definition option_union {A} (mx my : option A) : option A :=
  match mx with
  | Some x => Some x
  | None => my
  end.

(*
As is usual, we define the union operation in several stages: 1.) we define it
on raw maps, 2.) we prove that it preserves well-formedness of maps, 3.) lift
the operation to maps (which are bundled with a proof of well-formedness) 4.) we
prove the lookup property on raw maps, and finally 5.) lift that property from
raw maps to maps.
*)
Fixpoint munion_raw {A} (m1 m2 : map_raw A) : map_raw A :=
  match m1, m2 with
  | mx :: m1, my :: m2 => option_union mx my :: munion_raw m1 m2
  | [], m2 => m2
  | m1, [] => m1
  end.

Lemma munion_raw_wf {A} b c (m1 m2 : map_raw A) :
  map_wf b m1 -> map_wf c m2 -> map_wf (b || c)%bool (munion_raw m1 m2).
Proof.
revert b c m2.
induction m1; destruct m2; trivial.
destruct b; trivial.
simpl.
replace (is_Some (option_union a o)) with (is_Some a || is_Some o)%bool.
apply IHm1.
destruct a, o; trivial.
Qed.

Lemma option_union_r {A} (a : option A) : a = option_union a None.
Proof.
destruct a; trivial.
Qed.

Lemma munion_lookup_raw {A} (m1 m2 : map_raw A) (i : nat) :
  mlookup_raw (munion_raw m1 m2) i =
    option_union (mlookup_raw m1 i) (mlookup_raw m2 i).
Proof.
revert i m2.
induction m1; destruct m2, i; simpl; trivial.
apply option_union_r.
apply option_union_r.
Qed.

Definition munion {A} (m1 m2 : map A) : map A :=
  let (m1,Hm1) := m1 in
  let (m2,Hm2) := m2 in
  make_map (munion_raw m1 m2) (munion_raw_wf _ _ m1 m2 Hm1 Hm2).

Lemma munion_lookup {A} (m1 m2 : map A) (i : nat) :
  mlookup (munion m1 m2) i =
    option_union (mlookup m1 i) (mlookup m2 i).
Proof.
destruct m1, m2.
apply munion_lookup_raw.
Qed.

(* ## Properties of the union operation *)
(*
Now that we have defined the operation `munion` and have proven the lemma
`munion_lookup`, we prove some properties. The crucial thing to notice is that
the lemma `munion_lookup` fully specifies the behavior of the union operation,
after we have proven that, we never have to unfold the definition again. Let us
take a look at an example.
*)
Lemma munion_empty_l {A} (m : map A) : munion mempty m = m.
Proof.
  (* Note that apply also works with bi-implications, like `map_eq`:

    m1 = m2 <-> (forall i : nat, mlookup m1 i = mlookup m2 i)

  *)
  apply map_eq. intros i.
  rewrite munion_lookup.
  rewrite mempty_lookup.
  simpl.
  reflexivity.
Qed.

Lemma munion_insert_l {A} (m : map A) i x :
  minsert i x m = munion (msingleton i x) m.
Proof.
  apply map_eq. intros j. rewrite munion_lookup.
  (* In order to proceed, we need to make a case distinction between whether
  the natural numbers `i` and `j` are equal or not. For this we use the lemma:

    Nat.eq_dec: forall n m : nat, {n = m} + {n <> m}

  The lemma says that for any two natural numbers, we have either a proof
  of `x = y` that they are equal, or a proof of `n <> m` that they are unequal.
  The result of the lemma is a `sumbool`:

    Inductive sumbool (A B : Prop) : Set :=
      left : A -> {A} + {B} | right : B -> {A} + {B}

  On which we will perform a case analysis using the `destruct` tactic.
  *)
  destruct (Nat.eq_dec i j) as [Heq|Hneq].
  - subst i.
    rewrite minsert_lookup. rewrite msingleton_lookup.
    simpl. reflexivity.
  - (* In this case, we will use the lemma `insert_lookup_ne`:

        i <> j -> mlookup (minsert i y m) j = mlookup m j

    Note that contrary to most lemmas we have used for rewriting so far, this
    lemma has a premise `i <> j`. As a result, when we say:

      rewrite minsert_lookup_ne

    We will get an additional goal for proving the premise `i <> j`. In this
    case, however, it is trivial to prove the premise `i <> j`, after all, we
    already have a hypothesis `Hneq : i <> j`. As such, we can make use of the
    `by` argument of the `rewrite` tactic as follows:
    *)
    rewrite minsert_lookup_ne by assumption.
    (*
    This causes the `assumption` tactic to be used for proving the premise of
    the lemma that we wish to rewrite with.
    *)
    rewrite msingleton_lookup_ne by assumption.
    (*
    Note that `msingleton_lookup_ne` has a similar premise.
    *)
    simpl. reflexivity.
Qed.

(* ### Exercise *)
(*
Prove the following properties. In order to prove the properties about maps, you
should make use of the lemma `map_eq`, and the lookup lemmas for the various
operations involved.
*)
Lemma munion_empty_r {A} (m : map A) : munion mempty m = m.
Proof.
apply map_eq.
destruct m.
trivial.
Qed.

Lemma option_union_assoc {A} (mx my mz : option A) :
  option_union mx (option_union my mz) = option_union (option_union mx my) mz.
Proof.
destruct mx, my, mz; trivial.
Qed.

Ltac kongresen := intros; subst; repeat ( rewrite minsert_lookup
                        || rewrite minsert_lookup_ne
                        || rewrite munion_lookup
                        || rewrite mdelete_lookup
                        || rewrite mdelete_lookup_ne
                        || rewrite msingleton_lookup
                        || rewrite msingleton_lookup_ne); intuition eauto.

Lemma munion_assoc {A} (m1 m2 m3 : map A) :
  munion m1 (munion m2 m3) = munion (munion m1 m2) m3.
Proof.
apply map_eq.
intro i.
kongresen.
apply option_union_assoc.
Qed.

Lemma minsert_union {A} (m1 m2 : map A) i x :
  minsert i x (munion m1 m2) = munion (minsert i x m1) m2.
Proof.
apply map_eq.
intro j.
compare i j; intro H.
- rewrite H. kongresen.
- kongresen.
Qed.

Lemma mdelete_union {A} (m1 m2 : map A) i :
  mdelete i (munion m1 m2) = munion (mdelete i m1) (mdelete i m2).
Proof.
apply map_eq.
intro j.
compare i j; intro H.
- rewrite H. kongresen.
- kongresen.
Qed.

(* ## Disjointness of finite maps *)
(*
So far, we have proved associativity of the union operation on finite maps, but
not yet commutativity. Unfortunately, this property does not hold
unconditionally. In case `m1` and `m2` both contain the key `i`, but with
different values, we do not have `munion m1 m2 = munion m2 m1`. To deal with
this issue, we define a relation:

  mdisjoint : map  A -> map A -> Prop

Which states that two maps are _disjoint_, i.e. they do not have any keys in
common. We can then state commutativity as:

  mdisjoint m1 m2 -> munion m1 m2 = munion m2 m1.
*)
Definition mdisjoint {A} (m1 m2 : map A) : Prop :=
  forall i, mlookup m1 i = None \/ mlookup m2 i = None.

Lemma option_union_None_r {A} (mx : option A) : option_union mx None = mx.
Proof. destruct mx; simpl; reflexivity. Qed.

Lemma munion_comm {A} (m1 m2 : map A) :
  mdisjoint m1 m2 -> munion m1 m2 = munion m2 m1.
Proof.
  intros Hdisj. apply map_eq; intros i.
  rewrite !munion_lookup. (* Using the modifier `!` of the rewrite tactic, we
  can rewrite using a lemma as many times as possible. *)
  destruct (Hdisj i) as [Hi | Hi].
  - rewrite Hi. simpl. rewrite option_union_None_r. reflexivity.
  - rewrite Hi. simpl. rewrite option_union_None_r. reflexivity.
Qed.

(*
Let us prove some more properties about disjointness of finite maps.
*)
Lemma mdisjoint_empty_l {A} (m : map A) : mdisjoint mempty m.
Proof.
  intros i. left.
  rewrite mempty_lookup. reflexivity.
Qed.

Lemma mdisjoint_sym {A} (m1 m2 : map A) : mdisjoint m1 m2 -> mdisjoint m2 m1.
Proof.
  intros Hm i.
  unfold mdisjoint in Hm.
  (* As we see now, we have a hypothesis

    Hm : forall i : nat, mlookup m1 i = None \/ mlookup m2 i = None

  Which contains a disjunction below a universal quantifier. As we have seen
  before, we can use the `destruct` tactic to eliminate disjunctions. But how
  can we deal with disjunctions below a universal quantifier?

  Well, the answer is simple: we first have to instantiate the universal
  quantifier. But how do we do that? By the Curry-Howard correspondence, we
  know that `forall` quantifiers are in fact dependent functions, which means
  that when we have `H : forall x : A, P x`, we just write `H a` to obtain
  something of type `P a`.

  So, in this case, we have:

    Hm i : mlookup m1 i = None \/ mlookup m2 i = None

  On which we can then do a case analysis.
  *)
  destruct (Hm i) as [Hm1|Hm2].
  - right. assumption.
  - left. assumption.
Qed.

(* ### Exercise *)
(* Prove the properties below. Do not forget that you can use

  destruct (Nat.eq_dec i j) as [Heq|Hneq].

To make a case analysis between whether `i` and `j` are equal or not.
*)
Lemma mdisjoint_singleton {A} (m : map A) i x :
  mlookup m i = None -> mdisjoint (msingleton i x) m.
Proof.
intros H j.
compare i j.
- right. replace j with i. trivial.
- left. rewrite (msingleton_lookup_ne i j x). trivial. trivial.
Qed.

Lemma mdisjoint_singleton_inv {A} (m : map A) i x :
  mdisjoint (msingleton i x) m -> mlookup m i = None.
Proof.
intro H.
specialize (H i) as []; trivial.
contradict H. rewrite msingleton_lookup. discriminate.
Qed.

Lemma mdisjoint_union_l {A} (m1 m2 m3 : map A) :
  mdisjoint m1 m3 ->
  mdisjoint m2 m3 ->
  mdisjoint (munion m1 m2) m3.
Proof.
intros m1m3 m2m3 i.
rewrite munion_lookup.
specialize (m1m3 i) as [-> | ->]; intuition.
specialize (m2m3 i) as [-> | ->]; intuition.
Qed.

Lemma mdisjoint_union_inv_ll {A} (m1 m2 m3 : map A) :
  mdisjoint (munion m1 m2) m3 ->
  mdisjoint m1 m3.
Proof.
intros H i.
specialize (H i) as []; intuition.
rewrite munion_lookup in H.
destruct (mlookup m1 i); intuition.
Qed.

Lemma mdisjoint_union_inv_lr {A} (m1 m2 m3 : map A) :
  mdisjoint (munion m1 m2) m3 ->
  mdisjoint m2 m3.
Proof.
intros H i.
specialize (H i) as []; intuition.
rewrite munion_lookup in H.
destruct (mlookup m1 i), (mlookup m2 i); intuition.
discriminate.
Qed.

(*
Note that the properties below can be derived from the properties you have just
proven. You should not unfold the definition `mdisjoint`.
*)
Lemma mdisjoint_union_r {A} (m1 m2 m3 : map A) :
  mdisjoint m3 m1 ->
  mdisjoint m3 m2 ->
  mdisjoint m3 (munion m1 m2).
Proof.
intros.
apply mdisjoint_sym.
apply mdisjoint_union_l; apply mdisjoint_sym; assumption.
Qed.

Lemma mdisjoint_union_inv_rl {A} (m1 m2 m3 : map A) :
  mdisjoint m3 (munion m1 m2) ->
  mdisjoint m3 m1.
Proof.
intro H.
eapply mdisjoint_sym, mdisjoint_union_inv_ll, mdisjoint_sym.
eassumption.
Qed.

Lemma mdisjoint_union_inv_rr {A} (m1 m2 m3 : map A) :
  mdisjoint m3 (munion m1 m2) ->
  mdisjoint m3 m2.
Proof.
intro H.
eapply mdisjoint_sym, mdisjoint_union_inv_lr, mdisjoint_sym.
eassumption.
Qed.

(* ### Exercise *)
(*
And finally, some more properties about finite maps that will need later.
*)
Lemma minsert_singleton {A} i (x y : A) :
  minsert i x (msingleton i y) = msingleton i x.
Proof.
apply map_eq.
intro j.
compare i j; kongresen.
Qed.

Lemma mdelete_singleton {A} i (x : A) :
  mdelete i (msingleton i x) = mempty.
Proof.
apply map_eq.
intro j.
compare i j; kongresen.
Qed.

Lemma mdelete_None {A} (m : map A) i :
  mlookup m i = None -> mdelete i m = m.
Proof.
intros.
apply map_eq.
intro j.
compare i j; kongresen.
Qed.