Require Import List.
Require Import QArith.
Require Import Qpower.
Require Import Orders.
Require Import Sorted.
Require Import hddivsteps_base.
Import ListNotations.

Lemma Dadd_Q : forall x y, Dadd x y == x + y.
Proof.
intros x y.
unfold Dadd.
assert (Hxy := Dalign_lr x y).
destruct (Dalign x y) as [[xm ym] e].
destruct Hxy as [<- <-].
unfold inject_D; simpl.
rewrite inject_Z_plus.
ring.
Qed.

Lemma Dsub_Q : forall x y, Dsub x y == x - y.
Proof.
intros x y.
unfold Dsub.
assert (Hxy := Dalign_lr x y).
destruct (Dalign x y) as [[xm ym] e].
destruct Hxy as [<- <-].
unfold inject_D, Z.sub; simpl.
rewrite inject_Z_plus, inject_Z_opp.
ring.
Qed.

Lemma Dmult_Q : forall x y, Dmult x y == x * y.
Proof.
intros x y.
unfold Dmult, inject_D; simpl.
rewrite inject_Z_mult, Qpower_plus by discriminate.
ring.
Qed.

Lemma Dhalf_Q : forall x, Dhalf x == x / 2.
Proof.
intros x.
unfold Dhalf, inject_D, Z.pred; simpl.
rewrite Qpower_plus, Qmult_assoc by discriminate.
reflexivity.
Qed.

Lemma Dltb_Q : forall x y, Dltb x y = true -> x < y.
Proof.
intros a b.
unfold Dltb, D_as_TTLT.leb, D_as_OrderedTypeAlt.compare.
rewrite D_as_OrderedTypeAlt.compare_sym, Dcompare_Q, Qlt_alt.
case (a ?= b);try discriminate;reflexivity.
Qed.

Definition QQ : Set := Q * Q.
Definition Qsum := fold_right Qplus 0.
Definition Qcombine :=
  fold_right (fun (qp : Q * DD) a =>
             (fst a + fst qp * fst (snd qp), snd a + fst qp * snd (snd qp)))
             (0,0).
Definition QQplus p1 p2 := (fst p1 + fst p2, snd p1 + snd p2).
Definition QQscale c p := (c * fst p, c * snd p).
Definition QQavg c p1 p2 := QQplus (QQscale c p1) (QQscale (1-c) p2).
Definition QQeq (p q : QQ) := fst p == fst q /\ snd p == snd q.
Definition inject_DD (p : DD) : QQ := (inject_D (fst p), inject_D (snd p)).
Coercion inject_DD : DD >-> QQ.

Lemma QQeq_sym : forall p q, QQeq p q -> QQeq q p.
Proof.
intros p q [H0 H1].
unfold QQeq.
auto with *.
Qed.

Hint Rewrite Dcompare_Q Dadd_Q Dmult_Q Dsub_Q : DQ.

Lemma Qsum_app : forall l1 l2, Qsum (l1 ++ l2) == Qsum l1 + Qsum l2.
Proof.
intros l1 l2.
unfold Qsum.
rewrite fold_right_app.
generalize (fold_right Qplus 0 l2); intros q.
induction l1;simpl;[ring|].
rewrite IHl1.
ring.
Qed.

Lemma Qsum_pos : forall l, (forall x, In x l -> 0 <= x) ->
 0 <= Qsum l.
Proof.
induction l;simpl;auto with *.
intros H.
change 0 with (0 + 0).
auto using Qplus_le_compat.
Qed.

Lemma Qsum_mult : forall c l, Qsum (map (Qmult c) l) == c * Qsum l.
Proof.
induction l;simpl;try rewrite IHl; ring.
Qed.

Lemma QQscale_1 : forall p, QQeq (QQscale 1 p) p.
Proof.
intros p.
split;simpl;ring.
Qed.

Lemma QQscale_mult : forall a b p,
  QQeq (QQscale a (QQscale b p)) (QQscale (a*b) p).
Proof.
intros a b p.
split;simpl;ring.
Qed.

Lemma Qcombine_app : forall l1 l2,
  QQeq (Qcombine (l1 ++ l2))
       (QQplus (Qcombine l1) (Qcombine l2)).
Proof.
intros l1 l2.
unfold Qcombine.
rewrite fold_right_app.
set (f := fun qp a => _).
generalize (fold_right f (0,0) l2); intros q.
induction l1;simpl;[split;simpl;ring|].
unfold QQeq; simpl.
destruct IHl1 as [-> ->]; simpl.
split;ring.
Qed.

Lemma Qcombine_scale : forall c l,
  QQeq (QQscale c (Qcombine l)) (Qcombine (map (fun x => (c * fst x, snd x)) l)).
Proof.
intros c l.
unfold QQeq; simpl.
induction l;[split;simpl;ring|].
simpl.
destruct IHl as [<- <-].
split;ring.
Qed.

Definition Deq (a b : D) : Prop := Dcompare a b = Eq.
Definition DDeq (a b : DD) : Prop :=
  Deq (fst a) (fst b) /\ Deq (snd a) (snd b).

Lemma Deq_Q : forall x y, Deq x y <-> x == y.
Proof.
intros x y.
unfold Deq.
rewrite Dcompare_Q.
symmetry.
apply Qeq_alt.
Qed.

Lemma DDeq_Q : forall p q : DD, DDeq p q -> QQeq p q.
Proof.
intros [x1 y1] [x2 y2] [H1 H2].
rewrite Deq_Q in *.
split; simpl in *; congruence.
Qed.

Module DD_as_OTF <: OrderedTypeFull := OT_to_Full DDOrder.

(*Opaque point*)
Definition null : DD.
exact (0:D,0:D)%Z.
Qed.

Definition DDreverse x y := DDOrder.lt y x.

Definition Qdet (p1 p2 p3 : QQ) :=
let (x1, y1) := p1 in
let (x2, y2) := p2 in
let (x3, y3) := p3 in
 (x1 * y2 - y1 * x2) +
 (x2 * y3 - y2 * x3) +
 (x3 * y1 - y3 * x1).

Lemma Qdet_opp : forall p q r, - Qdet p q r == Qdet p r q.
Proof.
intros [x1 y1] [x2 y2] [x3 y3].
simpl.
ring.
Qed.

Lemma orientation_det : forall p1 p2 p3,
orientation p1 p2 p3 = (Qdet p1 p2 p3 ?= 0).
Proof.
intros [x1 y1] [x2 y2] [x3 y3].
simpl.
autorewrite with DQ.
destruct Qcompare_spec with
  (x1 * y2 - y1 * x2 + (x2 * y3 - y2 * x3) + (x3 * y1 - y3 * x1)) 0.
* apply Qeq_alt.
  apply Qplus_inj_r with (-((y1 - y3) * (x2 - x3))).
  rewrite Qplus_opp_r.
  rewrite <- H; ring.
* apply -> Qlt_alt.
  apply Qplus_lt_l with (-((y1 - y3) * (x2 - x3))).
  rewrite Qplus_opp_r.
  eapply Qlt_compat;[|reflexivity|apply H].
  ring.
* apply -> Qgt_alt.
  apply <- Qlt_minus_iff.
  eapply Qlt_compat;[reflexivity| |apply H].
  ring.
Qed.

Lemma orientation_dup : forall p q, orientation p q q = Eq.
Proof.
intros [x1 y1] [x2 y2].
rewrite orientation_det, <- Qeq_alt.
simpl.
ring.
Qed.

Lemma orientation_rot : forall p q r,
 orientation p q r = orientation r p q.
Proof.
intros [x1 y1] [x2 y2] [x3 y3].
rewrite !orientation_det.
simpl.
set (a := _ + _).
set (b := _ + _).
setoid_replace a with b; [reflexivity|].
unfold a, b.
ring.
Qed.

Lemma orientation_opp : forall p q r, CompOpp (orientation p q r) = orientation p r q.
Proof.
intros p q r.
rewrite !orientation_det.
rewrite <- Qdet_opp.
generalize (Qdet p r q).
clear p q r.
intros x.
rewrite Qcompare_antisym.
destruct (Qcompare_spec x 0).
* apply Qeq_alt.
  rewrite H.
  ring.
* apply -> Qlt_alt.
  setoid_replace (-x) with (0 + - x) by ring.
  apply -> Qlt_minus_iff.
  assumption.
* apply -> Qgt_alt.
  apply Qlt_minus_iff.
  ring_simplify.
  assumption.
Qed.

Add Morphism orientation with signature DDOrder.eq ==> DDOrder.eq ==> DDOrder.eq ==> eq as orientation_morph.
intros [x1 y1] [x2 y2] [H12a H12b].
intros [x3 y3] [x4 y4] [H34a H34b].
intros [x5 y5] [x6 y6] [H56a H56b].
rewrite !orientation_det; simpl.
apply Deq_Q in H12a,H12b,H34a,H34b,H56a,H56b.
rewrite H12a,H12b,H34a,H34b,H56a,H56b.
reflexivity.
Qed.

Lemma In_DDSet_fromList : forall l (p : DD),
 DDSet.In p (DDSet_fromList l) <->
 exists q : DD, DDeq p q /\ In q l.
Proof.
intros l p.
unfold DDSet_fromList.
rewrite <- fold_left_rev_right.
transitivity (exists q :DD, DDeq p q /\ In q (rev l));
 [|split; intros [q Hq];exists q; assert (H0 := in_rev l q);firstorder].
change DDSet.elt with DD.
induction (rev l);[|split].
* simpl; split; [|intros [q [Hq []]]].
  intros H.
  apply DDSet.empty_spec in H.
  elim H.
* intros Hp.
  apply DDSet.add_spec in Hp.
  destruct Hp as [Hp|Hp].
  exists a;auto with *.
  apply IHl0 in Hp.
  destruct Hp as [q [Hpq Hp]].
  exists q;auto with *.
* intros [q [Hpq Hp]].
  apply DDSet.add_spec.
  destruct Hp as [->|Hp];[left;assumption|right].
  apply IHl0.
  exists q;tauto.
Qed.

Definition make_upper l :=
  fold_right addUpperPoint nil l.
Definition make_lower l :=
  fold_right addLowerPoint nil l.

Definition convexHull_alt : forall s,
 convexHull s =
 DDSet_fromList (make_upper (rev (DDSet.elements s))
              ++ make_lower (rev (DDSet.elements s))).
Proof.
intros s.
unfold convexHull.
apply f_equal.
rewrite !DDSet.fold_spec.
rewrite <- !fold_left_rev_right.
reflexivity.
Qed.

Lemma hd_addUpperPoint : forall a l,
 addUpperPoint a l = a :: tl (addUpperPoint a l).
Proof.
intros a l.
induction l.
 reflexivity.
simpl.
destruct l as [|b l].
* case (DDOrder.compare _ _); reflexivity.
* case (orientation _ _ _); try reflexivity; apply IHl.
Qed.

Lemma hd_make_upper : forall l, hd null (make_upper l) = hd null l.
Proof.
intros [|a l]; try reflexivity.
simpl.
rewrite hd_addUpperPoint.
reflexivity.
Qed.

Lemma hd_addLowerPoint : forall a l,
  addLowerPoint a l = a :: tl (addLowerPoint a l).
Proof.
intros a l.
induction l.
 reflexivity.
simpl.
destruct l as [|b l].
* case (DDOrder.compare _ _); reflexivity.
* case (orientation _ _ _); try reflexivity; apply IHl.
Qed.

Lemma hd_make_lower : forall l, hd null (make_lower l) = hd null l.
Proof.
intros [|a l]; try reflexivity.
simpl.
rewrite hd_addLowerPoint.
reflexivity.
Qed.

Fixpoint addUpperPoint_ris (p : DD) (l : list DD) : list DD :=
match l with
| [] => []
| q :: l0 => match l0 with
   | [] => match DDOrder.compare p q with
           | Eq => [q]
           | _ => []
           end
   | r :: _ => match orientation p q r with
                 | Gt => []
                 | _ => q :: addUpperPoint_ris p l0
               end
   end
end.

Fixpoint addLowerPoint_ris (p : DD) (l : list DD) : list DD :=
match l with
| [] => []
| q :: l0 => match l0 with
   | [] => match DDOrder.compare p q with
           | Eq => [q]
           | _ => []
           end
   | r :: _ => match orientation p q r with
                 | Lt => []
                 | _ => q :: addLowerPoint_ris p l0
                 end
   end
end.

Lemma tl_addUpperPoint : forall a l,
 l = addUpperPoint_ris a l ++ tl (addUpperPoint a l).
Proof.
intros a.
induction l; auto.
simpl.
destruct l as [|b l].
* case (DDOrder.compare _ _); reflexivity.
* case (orientation _ _ _); auto; cbn [app]; congruence.
Qed.

Lemma tl_addLowerPoint : forall a l,
 l = addLowerPoint_ris a l ++ tl (addLowerPoint a l).
Proof.
intros a.
induction l; auto.
simpl.
destruct l as [|b l].
* case (DDOrder.compare _ _); reflexivity.
* case (orientation _ _ _); auto; cbn [app]; congruence.
Qed.

Lemma SSorted_app : forall A R (l1 l2 : list A),
 StronglySorted R (l1 ++ l2) ->
 StronglySorted R l1 /\ StronglySorted R l2.
Proof.
intros A R l1 l2.
induction l1; simpl; intros H.
* split;auto;constructor.
* inversion_clear H.
  destruct (IHl1 H0) as [Hl1 Hl2].
  split;try constructor;auto.
  apply Forall_app in H1.
  tauto.
Qed.

Lemma Sorted_rev : forall A R (l : list A),
 Sorted R l -> Sorted (fun x y => R y x) (rev l).
Proof.
intros A R.
set (R' := fun x y => _).
assert (H : forall l l' a,
 Sorted R l -> Sorted R' l' -> HdRel R a l -> HdRel R' a l' ->
 Sorted R' (rev l ++ [a] ++ l')).
 intros l.
 induction l; try constructor;auto.
 intros l' a0 Hl Hl' Hal Hal'.
 simpl.
 rewrite <- app_assoc.
 apply IHl.
 inversion_clear Hl; auto.
 constructor; auto.
 inversion_clear Hl; auto.
 constructor; inversion_clear Hal; auto.
intros [|a l] Hl; try constructor.
simpl.
inversion_clear Hl.
apply H; try constructor; auto.
Qed.

Lemma incl_make_upper : forall l,
 incl (make_upper l) l.
Proof.
intros l.
induction l; intros x Hx; auto.
simpl in *.
rewrite hd_addUpperPoint in Hx.
destruct Hx as [<-| Hx];auto.
right.
apply IHl.
rewrite (tl_addUpperPoint a (make_upper l)).
apply in_or_app.
tauto.
Qed.

Lemma incl_make_lower : forall l,
 incl (make_lower l) l.
Proof.
intros l.
induction l; intros x Hx; auto.
simpl in *.
rewrite hd_addLowerPoint in Hx.
destruct Hx as [<-| Hx];auto.
right.
apply IHl.
rewrite (tl_addLowerPoint a (make_lower l)).
apply in_or_app.
tauto.
Qed.

Lemma SSorted_make_upper : forall R l,
 StronglySorted R l ->
 StronglySorted R (make_upper l).
Proof.
intros R l.
induction l; auto.
intros H.
inversion_clear H.
specialize (IHl H0).
simpl.
rewrite hd_addUpperPoint.
rewrite (tl_addUpperPoint a) in IHl.
apply SSorted_app in IHl.
constructor;try tauto.
eapply incl_Forall;[|apply H1].
eapply incl_tran;[|apply incl_make_upper].
rewrite (tl_addUpperPoint a).
auto with *.
Qed.

Lemma SSorted_make_lower : forall R l,
 StronglySorted R l ->
 StronglySorted R (make_lower l).
Proof.
intros R l.
induction l; auto.
intros H.
inversion_clear H.
specialize (IHl H0).
simpl.
rewrite hd_addLowerPoint.
rewrite (tl_addLowerPoint a) in IHl.
apply SSorted_app in IHl.
constructor;try tauto.
eapply incl_Forall;[|apply H1].
eapply incl_tran;[|apply incl_make_lower].
rewrite (tl_addLowerPoint a).
auto with *.
Qed.

Definition in_between p a b :=
 exists c, 0 <= c <= 1 /\ QQeq p (QQavg c a b).

Definition in_convex_hull (x : QQ) (s : DDSet.t) : Prop :=
exists l : list (Q * DD),
 (forall q p, In (q, p) l -> 0 <= q /\ DDSet.In p s) /\
 Qsum (map fst l) == 1 /\
 QQeq (Qcombine l) x.

Lemma in_convex_hull_Empty : forall {x}, ~in_convex_hull x DDSet.empty.
Proof.
intros s [[|[q d]] [H0 [H1 [H2 H3]]]];[discriminate|].
destruct (H0 q d); auto with *.
auto using (@DDSet.empty_spec d).
Qed.

Lemma in_convex_hull_morph1 : forall p1 p2 s,
 QQeq p1 p2 ->
 in_convex_hull p1 s ->
 in_convex_hull p2 s.
Proof.
intros p1 p2 s [Hp1 Hp2] [l Hl].
exists l.
split; try tauto.
split; try tauto.
unfold QQeq.
rewrite <- Hp1, <- Hp2.
fold (QQeq (Qcombine l) p1).
tauto.
Qed.

Lemma in_convex_hull_morph2 : forall p s1 s2,
 DDSet.eq s1 s2 ->
 in_convex_hull p s1 ->
 in_convex_hull p s2.
Proof.
intros p s1 s2 Hs [l Hl].
exists l.
split; try tauto.
intros a b H.
destruct Hl as [Hl _].
destruct (Hl a b H).
split; try tauto.
apply Hs.
assumption.
Qed.

Lemma in_in_convex_hull : forall (p:DD) s,
 DDSet.In p s -> in_convex_hull p s.
Proof.
intros p s Hp.
exists ((1,p)::nil);split;[|split].
* intros q0 p0 [Hqp|[]].
  injection Hqp; intros <- <-; clear Hqp.
  split; auto with *.
* reflexivity.
* unfold QQeq in *.
  simpl;split;ring.
Qed.

Lemma in_convex_hull_subset : forall q s1 s2,
 DDSet.Subset s1 s2 -> in_convex_hull q s1 ->
 in_convex_hull q s2.
Proof.
intros q s1 s2 Hs [l H].
unfold DDSet.Subset in Hs.
exists l;split;[|split]; firstorder.
Qed.

Lemma in_convex_hull_singleton : forall q (p:DD),
 in_convex_hull q (DDSet.add p DDSet.empty) ->
 QQeq q p.
Proof.
intros q p [l [H0 [H1 H2]]].
unfold QQeq.
destruct H2 as [<- <-].
setoid_replace (fst p:Q) with (1*(fst p)) by ring.
setoid_replace (snd p:Q) with (1*(snd p)) by ring.
rewrite <- H1; clear H1.
induction l;simpl;[split;ring|].
destruct IHl as [-> ->]; auto with *.
specialize (H0 (fst a) (snd a) (or_introl (surjective_pairing a))).
destruct H0 as [_ H0].
apply DDSet.add_spec in H0.
destruct H0 as [[H0 H1]|H0];
 [apply Deq_Q in H0, H1; rewrite H0, H1; split; ring|].
apply DDSet.mem_spec in H0.
discriminate.
Qed.

Lemma QQavg_in_convex_hull : forall c p1 p2 s,
  0 <= c <= 1 ->
  in_convex_hull p1 s ->
  in_convex_hull p2 s ->
  in_convex_hull (QQavg c p1 p2) s.
Proof.
intros c p1 p2 s Hc [l1 Hp1] [l2 Hp2].
pose (f := fun c (x : Q * DD) => (c * fst x, snd x)).
pose (l1' := map (f c) l1).
pose (l2' := map (f (1-c)) l2).
exists (l1' ++ l2').
split;[|split].
assert (Hc' : 0 <= 1 - c) by
 (apply -> Qle_minus_iff; tauto).
* intros q p Hqp.
  apply in_app_or in Hqp.
  destruct Hp1 as [Hp1 _].
  destruct Hp2 as [Hp2 _].
  destruct Hqp as [Hqp|Hqp];split;
    apply in_map_iff in Hqp;
    destruct Hqp as [[x y] [Hx1 Hx2]];
    injection Hx1; intros <- <-;
    try apply Qmult_le_0_compat; firstorder.
* destruct Hp1 as [_ [Hp1 _]].
  destruct Hp2 as [_ [Hp2 _]].
  rewrite map_app.
  unfold l1', l2'.
  rewrite !map_map.
  change (fun x => fst (f c x)) with (fun x : Q * DD => c * fst x).
  change (fun x => fst (f (1 - c) x)) with (fun x : Q * DD => (1 - c) * fst x).
  rewrite <- (map_map _ (Qmult (1-c))), <- map_map.
  rewrite Qsum_app, !Qsum_mult, Hp1, Hp2.
  ring.
* unfold QQeq; simpl.
  destruct Hp1 as [_ [_ [<- <-]]].
  destruct Hp2 as [_ [_ [<- <-]]].
  destruct (Qcombine_app l1' l2') as [-> ->].
  simpl.
  destruct (Qcombine_scale c l1) as [-> ->].
  destruct (Qcombine_scale (1-c) l2) as [-> ->].
  fold (f c) (f (1-c)) l1' l2'.
  split; ring.
Qed.

Inductive OnPath (p : QQ) : list DD -> Prop :=
| OnPathTl : forall a l, OnPath p l -> OnPath p (a::l)
| OnPathBetween : forall (a b : DD) l, in_between p (a:QQ) (b:QQ) -> OnPath p (a::b::l).

Lemma incl_DDSet_fromList : forall l1 l2,
 incl l1 l2 ->
 DDSet.Subset (DDSet_fromList l1) (DDSet_fromList l2).
Proof.
intros p l1 l2 H Hq.
rewrite In_DDSet_fromList in *.
destruct Hq as [r [Hqr Hr]].
exists r;split;auto with *.
Qed.

Lemma OnPathConvex : forall p l,
  OnPath p l -> in_convex_hull p (DDSet_fromList l).
Proof.
intros p l H.
induction H.
* eapply in_convex_hull_subset;[|apply IHOnPath].
  apply incl_DDSet_fromList.
  auto with *.
* destruct H as [c [Hc Hp]].
  exists [(c,a);((1-c),b)];split;[intros q r [Hqr|[Hqr|[]]];injection Hqr; intros <- <-; clear Hqr|split].
  + split; try tauto.
    rewrite In_DDSet_fromList.
    exists a;repeat split;auto with *.
  + split;[apply -> Qle_minus_iff;tauto|].
    rewrite In_DDSet_fromList.
    exists b;repeat split;auto with *.
  + simpl;ring.
  + unfold QQeq;destruct Hp as [-> ->].
    simpl;split;ring.
Qed.

Definition under p l := exists q, OnPath q l /\ fst p == fst q /\ snd p <= snd q.

Lemma in_under : forall (p : DD) (l : list DD),
 In p l -> under (p:QQ) l \/ l = [p].
Proof.
intros p l.
induction l;try contradiction.
intros [->|H].
* destruct l;[right;reflexivity|].
  left.
  exists p; repeat split; auto with *.
  apply OnPathBetween.
  exists 1; repeat split;auto with *;simpl;ring.
* left.
  specialize (IHl H).
  destruct IHl as [[q H0]| ->].
   exists q;split;[apply OnPathTl|]; tauto.
  exists p; repeat split; auto with *.
  apply OnPathBetween.
  exists 0; repeat split;auto with *;simpl;ring.
Qed.

Lemma DDorder_fst : forall a b, DDOrder.lt a b -> fst a <= fst b.
Proof.
intros a b H.
rewrite Qle_lteq.
destruct H as [H|[H _]];[left|right].
* rewrite Qlt_alt, <- Dcompare_Q; auto.
* rewrite Qeq_alt, <- Dcompare_Q; auto.
Qed.

Lemma DDorder_snd : forall a b, DDOrder.lt a b -> fst a == fst b -> snd a < snd b.
Proof.
intros a b H H0.
destruct H as [H|[H H']].
* change (Dcompare (fst a) (fst b) = Lt) in H.
  rewrite Dcompare_Q, <- Qlt_alt in H.
  apply Qlt_not_eq in H.
  contradiction.
* rewrite Qlt_alt, <- Dcompare_Q; auto.
Qed.

Lemma under_addUpperPoint : forall p a l,
 StronglySorted DDreverse (a :: l) ->
 under p (a::l) -> under p (addUpperPoint a l).
Proof.
intros p a l.
induction l.
* intros Hsort [q [HPath [Hpq1 Hpq2]]].
  inversion_clear HPath;inversion H.
* rename a0 into b.
  intros Hsort H.
  simpl.
  destruct l as [|c l].
   simpl.
   destruct (DDOrder.compare_spec a b); auto.
   inversion_clear Hsort.
   inversion_clear H2.
   change (DDOrder.lt b a) in H3.
   rewrite H0 in H3.
   destruct DDOrder.lt_strorder.
   elim (StrictOrder_Irreflexive b H3).
  compare (orientation a b c) Gt;[intros ->; auto|].
   intros Horient.
   cut (under p (addUpperPoint a (c :: l))).
    intros;case (orientation a b c);try contradiction; auto.
   apply IHl.
    inversion_clear Hsort.
    inversion_clear H0.
    inversion_clear H1.
    constructor; auto.
   destruct H as [q [HPath [Hpq1 Hpq2]]].
     cut (under q (a :: c :: l)).
     intros [r [Hr [Heq1 Heq2]]].
     exists r;repeat split;auto;eauto with *.
    clear Hpq1 Hpq2 p IHl.
    change DD in a,b,c.
    assert (Hb : under (b:QQ) [a;c]).
     inversion_clear Hsort.
     inversion_clear H0.
     inversion_clear H2.
     clear H3.
     inversion_clear H.
     clear H2.
     inversion_clear H3.
     clear H2.
     assert (Hac : fst c <= fst a).
      apply DDorder_fst.
      assumption.
     rewrite Qle_lteq in Hac.
     destruct Hac as [Hac|Hac].
     + rewrite Qlt_minus_iff in Hac.
       pose (d := ((fst b - fst c)/(fst a - fst c))).
       assert (Hd0 : 0 <= d).
        apply Qle_shift_div_l; auto.
        ring_simplify (0 * (fst a - fst c)).
        apply -> Qle_minus_iff.
        auto using DDorder_fst.
       assert (Hd1 : d <= 1).
        apply Qle_shift_div_r; auto.
        ring_simplify (1 * (fst a - fst c)).
        apply Qle_minus_iff.
        ring_simplify.
        apply -> Qle_minus_iff.
        auto using DDorder_fst.
       exists (QQavg d (a:QQ) (c:QQ)).
       simpl; repeat split.
         apply OnPathBetween.
         exists d;repeat split;auto.
        unfold d;field;auto with *.
       rewrite orientation_rot in Horient.
       destruct a as [a1 a2]; destruct b as [b1 b2]; destruct c as [c1 c2].
       unfold orientation in Horient.
       autorewrite with DQ in Horient.
       rewrite <- Qle_alt in Horient.
       simpl in *.
       setoid_replace (d * a2 + (1 - d) * c2) with (((b1 - c1)*a2 + (a1 - b1)*c2)/(a1 - c1))
         by (unfold d;field;auto with *).
       apply Qle_shift_div_l; auto with *.
       rewrite Qle_minus_iff in *.
       eapply Qle_trans;[apply Horient|].
       rewrite Qle_minus_iff.
       ring_simplify.
       auto with *.
     + exists a.
       split.
        apply OnPathBetween.
        exists 1;repeat split;simpl;auto with *; ring.
       assert (Hab : fst b == fst a).
        apply Qle_antisym.
         apply DDorder_fst; auto.
        rewrite <- Hac.
        apply DDorder_fst; auto.
       split;auto.
       apply Qlt_le_weak.
       apply DDorder_snd; auto.
  + destruct Hb as [r [Hr [Hr1 Hr2]]].
    inversion_clear Hr;[inversion_clear H; inversion_clear H0|].
    inversion_clear HPath;[inversion_clear H0|].
    - exists q;split;auto with *.
      apply OnPathTl; assumption.
    - destruct H as [x [Hx Hr]].
      destruct H1 as [y [Hy Hq]].
      exists (QQavg y (r:QQ) (c:QQ)); split;simpl.
        apply OnPathBetween.
        destruct Hx as [Hx0 Hx1].
        destruct Hy as [Hy0 Hy1].
        exists (x*y).
        unfold QQeq; simpl.
        destruct Hr as [-> ->]; simpl.
        repeat split; try ring; auto using Qmult_le_0_compat.
        rewrite Qle_lteq in Hx0.
        destruct Hx0 as [Hx0|<-];[|ring_simplify;auto with *].
        rewrite <- (Qmult_le_l _ _ x) in Hy1 by assumption.
        ring_simplify in Hy1.
        eauto with *.
       destruct Hq as [-> ->]; simpl.
       split;[rewrite Hr1;ring|].
       rewrite Qle_minus_iff in Hr2|-*.
       ring_simplify.
       setoid_replace (y * snd r + -1 * y * snd b) with (y * (snd r + - snd b)) by ring.
       destruct Hy;apply Qmult_le_0_compat; auto with *.
    - destruct H as [x [Hx Hr]].
      destruct H0 as [y [Hy Hq]].
      exists (QQavg y (a:QQ) (r:QQ)); split;simpl.
        apply OnPathBetween.
        destruct Hx as [Hx0 Hx1].
        destruct Hy as [Hy0 Hy1].
        exists (x + y*(1 - x)).
        unfold QQeq; simpl.
        destruct Hr as [-> ->]; simpl.
        repeat split; try ring.
         change 0 with (0 + 0).
         apply Qplus_le_compat; auto.
         apply Qmult_le_0_compat; auto.
         rewrite Qle_minus_iff in Hx1; auto.
        rewrite Qle_minus_iff.
        setoid_replace (1 + - (x + y * (1 - x))) with ((1 - x)*(1 - y)) by ring.
        rewrite Qle_minus_iff in Hx1, Hy1.
        apply Qmult_le_0_compat; auto.
       destruct Hq as [-> ->]; simpl.
       split;[rewrite Hr1;ring|].
       rewrite Qle_minus_iff in Hr2|-*.
       ring_simplify.
       setoid_replace (-1 * y * snd r + y * snd b + snd r + -1 * snd b) with ((1-y) * (snd r + - snd b)) by ring.
       destruct Hy as [Hy0 Hy1].
       rewrite Qle_minus_iff in Hy1.
       apply Qmult_le_0_compat; auto with *.
Qed.

Lemma under_make_upper : forall (p:DD) l,
 StronglySorted DDreverse l ->
 In p l ->
 under (p:QQ) (make_upper l) \/ l = [p].
Proof.
intros p.
induction l; try contradiction.
intros Hsort H.
simpl.
destruct l as [|b l].
 destruct H as [->|[]].
 right;reflexivity.
left.
apply under_addUpperPoint.
 inversion_clear Hsort.
 constructor; auto using SSorted_make_upper.
 eapply incl_Forall;[|apply H1].
 apply incl_make_upper.
destruct l as [|c l].
 simpl.
 apply in_under in H.
 destruct H;auto;discriminate.
destruct H as [->|H].
 assert (H0 : In p (p :: make_upper (b :: c :: l))) by auto with *.
 apply in_under in H0.
 destruct H0 as [H0|H0];auto.
 simpl in H0.
 rewrite hd_addUpperPoint in H0.
 discriminate.
inversion_clear Hsort.
specialize (IHl H0 H).
destruct IHl as [[q Hq]|IHl];try discriminate.
exists q;split;[apply OnPathTl|]; tauto.
Qed.

Definition over p l := exists q, OnPath q l /\ fst p == fst q /\ snd q <= snd p.

Lemma in_over : forall (p : DD) (l : list DD),
 In p l -> over (p:QQ) l \/ l = [p].
Proof.
intros p l.
induction l;try contradiction.
intros [->|H].
* destruct l;[right;reflexivity|].
  left.
  exists p; repeat split; auto with *.
  apply OnPathBetween.
  exists 1; repeat split;auto with *;simpl;ring.
* left.
  specialize (IHl H).
  destruct IHl as [[q H0]| ->].
   exists q;split;[apply OnPathTl|]; tauto.
  exists p; repeat split; auto with *.
  apply OnPathBetween.
  exists 0; repeat split;auto with *;simpl;ring.
Qed.

Lemma over_addLowerPoint : forall p a l,
 StronglySorted DDreverse (a :: l) ->
 over p (a::l) -> over p (addLowerPoint a l).
Proof.
intros p a l.
induction l.
* intros Hsort [q [HPath [Hpq1 Hpq2]]].
  inversion_clear HPath;inversion H.
* rename a0 into b.
  intros Hsort H.
  simpl.
  destruct l as [|c l].
   simpl.
   destruct (DDOrder.compare_spec a b); auto.
   inversion_clear Hsort.
   inversion_clear H2.
   change (DDOrder.lt b a) in H3.
   rewrite H0 in H3.
   destruct DDOrder.lt_strorder.
   elim (StrictOrder_Irreflexive b H3).
  compare (orientation a b c) Lt;[intros ->; auto|].
   intros Horient.
   cut (over p (addLowerPoint a (c :: l))).
    intros;case (orientation a b c);try contradiction; auto.
   apply IHl.
    inversion_clear Hsort.
    inversion_clear H0.
    inversion_clear H1.
    constructor; auto.
   destruct H as [q [HPath [Hpq1 Hpq2]]].
     cut (over q (a :: c :: l)).
     intros [r [Hr [Heq1 Heq2]]].
     exists r;repeat split;auto;eauto with *.
    clear Hpq1 Hpq2 p IHl.
    change DD in a,b,c.
    assert (Hb : over (b:QQ) [a;c]).
     inversion_clear Hsort.
     inversion_clear H0.
     inversion_clear H2.
     clear H3.
     inversion_clear H.
     clear H2.
     inversion_clear H3.
     clear H2.
     assert (Hac : fst c <= fst a).
      apply DDorder_fst.
      assumption.
     rewrite Qle_lteq in Hac.
     destruct Hac as [Hac|Hac].
     + rewrite Qlt_minus_iff in Hac.
       pose (d := ((fst b - fst c)/(fst a - fst c))).
       assert (Hd0 : 0 <= d).
        apply Qle_shift_div_l; auto.
        ring_simplify (0 * (fst a - fst c)).
        apply -> Qle_minus_iff.
        auto using DDorder_fst.
       assert (Hd1 : d <= 1).
        apply Qle_shift_div_r; auto.
        ring_simplify (1 * (fst a - fst c)).
        apply Qle_minus_iff.
        ring_simplify.
        apply -> Qle_minus_iff.
        auto using DDorder_fst.
       exists (QQavg d (a:QQ) (c:QQ)).
       simpl; repeat split.
         apply OnPathBetween.
         exists d;repeat split;auto.
        unfold d;field;auto with *.
       rewrite orientation_rot in Horient.
       destruct a as [a1 a2]; destruct b as [b1 b2]; destruct c as [c1 c2].
       unfold orientation in Horient.
       autorewrite with DQ in Horient.
       rewrite <- Qge_alt in Horient.
       simpl in *.
       setoid_replace (d * a2 + (1 - d) * c2) with (((b1 - c1)*a2 + (a1 - b1)*c2)/(a1 - c1))
         by (unfold d;field;auto with *).
       apply Qle_shift_div_r; auto with *.
       rewrite Qle_minus_iff in *.
       eapply Qle_trans;[apply Horient|].
       rewrite Qle_minus_iff.
       ring_simplify.
       auto with *.
     + exists c.
       split.
        apply OnPathBetween.
        exists 0;repeat split;simpl;auto with *; ring.
       assert (Hab : fst c == fst b).
        apply Qle_antisym.
         apply DDorder_fst; auto.
        rewrite Hac.
        apply DDorder_fst; auto.
       split;auto with *.
       apply Qlt_le_weak.
       apply DDorder_snd; auto.
  + destruct Hb as [r [Hr [Hr1 Hr2]]].
    inversion_clear Hr;[inversion_clear H; inversion_clear H0|].
    inversion_clear HPath;[inversion_clear H0|].
    - exists q;split;auto with *.
      apply OnPathTl; assumption.
    - destruct H as [x [Hx Hr]].
      destruct H1 as [y [Hy Hq]].
      exists (QQavg y (r:QQ) (c:QQ)); split;simpl.
        apply OnPathBetween.
        destruct Hx as [Hx0 Hx1].
        destruct Hy as [Hy0 Hy1].
        exists (x*y).
        unfold QQeq; simpl.
        destruct Hr as [-> ->]; simpl.
        repeat split; try ring; auto using Qmult_le_0_compat.
        rewrite Qle_lteq in Hx0.
        destruct Hx0 as [Hx0|<-];[|ring_simplify;auto with *].
        rewrite <- (Qmult_le_l _ _ x) in Hy1 by assumption.
        ring_simplify in Hy1.
        eauto with *.
       destruct Hq as [-> ->]; simpl.
       split;[rewrite Hr1;ring|].
       rewrite Qle_minus_iff in Hr2|-*.
       ring_simplify.
       setoid_replace (y * snd b + -1 * y * snd r) with (y * (snd b + - snd r)) by ring.
       destruct Hy;apply Qmult_le_0_compat; auto with *.
    - destruct H as [x [Hx Hr]].
      destruct H0 as [y [Hy Hq]].
      exists (QQavg y (a:QQ) (r:QQ)); split;simpl.
        apply OnPathBetween.
        destruct Hx as [Hx0 Hx1].
        destruct Hy as [Hy0 Hy1].
        exists (x + y*(1 - x)).
        unfold QQeq; simpl.
        destruct Hr as [-> ->]; simpl.
        repeat split; try ring.
         change 0 with (0 + 0).
         apply Qplus_le_compat; auto.
         apply Qmult_le_0_compat; auto.
         rewrite Qle_minus_iff in Hx1; auto.
        rewrite Qle_minus_iff.
        setoid_replace (1 + - (x + y * (1 - x))) with ((1 - x)*(1 - y)) by ring.
        rewrite Qle_minus_iff in Hx1, Hy1.
        apply Qmult_le_0_compat; auto.
       destruct Hq as [-> ->]; simpl.
       split;[rewrite Hr1;ring|].
       rewrite Qle_minus_iff in Hr2|-*.
       ring_simplify.
       setoid_replace (-1 * y * snd b + y * snd r + snd b + -1 * snd r) with
         ((1-y) * (snd b + - snd r)) by ring.
       destruct Hy as [Hy0 Hy1].
       rewrite Qle_minus_iff in Hy1.
       apply Qmult_le_0_compat; auto with *.
Qed.

Lemma over_make_lower : forall (p:DD) l,
 StronglySorted DDreverse l ->
 In p l ->
 over (p:QQ) (make_lower l) \/ l = [p].
Proof.
intros p.
induction l; try contradiction.
intros Hsort H.
simpl.
destruct l as [|b l].
 destruct H as [->|[]].
 right;reflexivity.
left.
apply over_addLowerPoint.
 inversion_clear Hsort.
 constructor; auto using SSorted_make_lower.
 eapply incl_Forall;[|apply H1].
 apply incl_make_lower.
destruct l as [|c l].
 simpl.
 apply in_over in H.
 destruct H;auto;discriminate.
destruct H as [->|H].
 assert (H0 : In p (p :: make_lower (b :: c :: l))) by auto with *.
 apply in_over in H0.
 destruct H0 as [H0|H0];auto.
 simpl in H0.
 rewrite hd_addLowerPoint in H0.
 discriminate.
inversion_clear Hsort.
specialize (IHl H0 H).
destruct IHl as [[q Hq]|IHl];try discriminate.
exists q;split;[apply OnPathTl|]; tauto.
Qed.

Lemma over_under : forall p l1 l2,
 under p l1 ->
 over p l2 ->
 in_convex_hull p (DDSet_fromList (l1 ++ l2)).
Proof.
intros p l1 l2 [p1 [Hl1 [Hp11 Hp12]]] [p2 [Hl2 [Hp21 Hp22]]].
apply OnPathConvex in Hl1.
apply OnPathConvex in Hl2.
pose (c := (snd p - snd p2)/(snd p1 - snd p2)).
assert (Hp0 := Qle_trans _ _ _ Hp22 Hp12).
apply Qle_lt_or_eq in Hp0.
assert (Hp : QQeq (QQavg c p1 p2) p).
 unfold QQeq; simpl.
 rewrite <- Hp11, <- Hp21.
 split;[ring|].
 destruct Hp0 as [Hp0|Hp0].
  rewrite Qlt_minus_iff in Hp0.
  unfold c; field; auto with *.
 unfold c; simpl.
 rewrite Hp0; ring_simplify.
 apply Qle_antisym; auto.
 rewrite <- Hp0.
 auto.
eapply in_convex_hull_morph1;[apply Hp|].
apply QQavg_in_convex_hull.
* destruct Hp0 as [Hp0|Hp0].
   rewrite Qlt_minus_iff in Hp0.
   unfold c;split.
    apply Qle_shift_div_l; auto.
    ring_simplify (0 * (snd p1 - snd p2)).
    apply -> Qle_minus_iff; auto.
   apply Qle_shift_div_r; auto.
   rewrite Qle_minus_iff in * .
   ring_simplify.
   assumption.
  unfold c.
  rewrite Hp0.
  setoid_replace (snd p1 - snd p1) with 0 by ring.
  unfold Qdiv.
  change (/0) with 0.
  split;ring_simplify; auto with *.
* eapply in_convex_hull_subset;[|apply Hl1].
  apply incl_DDSet_fromList; auto with *.
* eapply in_convex_hull_subset;[|apply Hl2].
  apply incl_DDSet_fromList; auto with *.
Qed.

Lemma convexHull_sound : forall s (p : DD), DDSet.In p s ->
  in_convex_hull p (convexHull s).
Proof.
intros s p H.
apply DDSet.elements_spec1 in H.
apply SetoidList.InA_rev in H.
apply SetoidList.InA_alt in H.
destruct H as [p0 [Hp H]].
symmetry in Hp.
change DD in p0.
destruct Hp as [Hp0 Hp1].
apply Deq_Q in Hp0,Hp1.
apply in_convex_hull_morph1 with (p0:QQ);[split;auto|].
clear -H.
rename p0 into p.
rewrite convexHull_alt.
assert (HSorted0 := DDSet.elements_spec2 s).
change (Sorted (DDOrder.lt) (DDSet.elements s)) in HSorted0.
assert (HSorted1 := Sorted_rev _ _ _ HSorted0).
set (l := (rev _)) in *.
set (l1 := make_upper _).
set (l2 := make_lower _).
change (Sorted DDreverse l) in HSorted1.
clear HSorted0.
destruct l as [|a [|b l]]; try contradiction.
 apply in_in_convex_hull.
 destruct H as [->|[]].
 simpl.
 apply In_DDSet_fromList.
 exists p;split;auto with *.
 change (DDOrder.eq p p).
 reflexivity.
set (l0 := a :: b :: l) in *.
apply Sorted_StronglySorted in HSorted1;
[|intros x y z Hx Hy;unfold DDreverse in *;simpl;transitivity y;auto].
assert (Hunder := under_make_upper p l0 HSorted1 H).
assert (Hover := over_make_lower p l0 HSorted1 H).
destruct Hunder as [Hunder|Hunder];try discriminate.
destruct Hover as [Hover|Hover];try discriminate.
apply over_under; auto.
Qed.


(* --------------------------------------------------------------------
 * Copyright (c) - 2006--2012 - IMDEA Software Institute
 * Copyright (c) - 2006--2012 - Inria
 * Copyright (c) - 2006--2012 - Microsoft Coprporation
 *
 * Distributed under the terms of the CeCILL-B-V1 license
 * -------------------------------------------------------------------- *)

(*************************************************************)
(*      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      *)
(*************************************************************)

(**********************************************************************
    PGroup.v

    Build the group of pairs modulo needed for the theorem of
      lucas lehmer

    Definition: PGroup
 **********************************************************************)
Require Import ZArith.
Require Import ZAux.
Require Import Tactic.
Require Import Wf_nat.
Require Import ListAux.
Require Import UList.
Require Import FGroup.
Require Import EGroup.
Require Import IGroup.

Open Scope Z_scope.

Definition base := 3.

(**************************************
  Equality is decidable on pairs
 **************************************)

Definition P_dec: forall p q: Z * Z, {p = q} + {p <> q}.
intros p1 q1; case p1; case q1; intros z t x y; case (Z_eq_dec x z); intros H1.
case (Z_eq_dec y t); intros H2.
left; eq_tac; auto.
right; contradict H2; injection H2; auto.
right; contradict H1; injection H1; auto.
Defined.

(**************************************
  Addition of two pairs
 **************************************)

Definition pplus (p q: Z * Z) := let (x ,y) := p in let (z,t) := q in (x + z, y + t).

(**************************************
  Properties of addition
 **************************************)

Theorem pplus_assoc: forall p q r, (pplus p (pplus q r)) = (pplus (pplus p q) r).
intros p q r; case p; case q; case r; intros r1 r2 q1 q2 p1 p2; unfold pplus.
eq_tac; ring.
Qed.

Theorem pplus_comm: forall p q, (pplus p q) = (pplus q p).
intros p q; case p; case q; intros q1 q2 p1 p2; unfold pplus.
eq_tac; ring.
Qed.

(**************************************
  Multiplication of two pairs
 **************************************)

Definition pmult (p q: Z * Z) := let (x ,y) := p in let (z,t) := q in (x * z + base * y * t, x * t + y * z).

(**************************************
  Properties of multiplication
 **************************************)

Theorem pmult_assoc: forall p q r, (pmult p (pmult q r)) = (pmult (pmult p q) r).
intros p q r; case p; case q; case r; intros r1 r2 q1 q2 p1 p2; unfold pmult.
eq_tac; ring.
Qed.

Theorem pmult_0_l: forall p, (pmult (0, 0) p) = (0, 0).
intros p; case p; intros x y; unfold pmult; eq_tac; ring.
Qed.

Theorem pmult_0_r: forall p, (pmult p (0, 0)) = (0, 0).
intros p; case p; intros x y; unfold pmult; eq_tac; ring.
Qed.

Theorem pmult_1_l: forall p, (pmult (1, 0) p) = p.
intros p; case p; intros x y; unfold pmult; eq_tac; ring.
Qed.

Theorem pmult_1_r: forall p, (pmult p (1, 0)) = p.
intros p; case p; intros x y; unfold pmult; eq_tac; ring.
Qed.

Theorem pmult_comm: forall p q, (pmult p q) = (pmult q p).
intros p q; case p; case q; intros q1 q2 p1 p2; unfold pmult.
eq_tac; ring.
Qed.

Theorem pplus_pmult_dist_l: forall p q r, (pmult p (pplus q r)) = (pplus (pmult p q) (pmult p r)).
intros p q r; case p; case q; case r; intros r1 r2 q1 q2 p1 p2; unfold pplus, pmult.
eq_tac; ring.
Qed.

Theorem pplus_pmult_dist_r: forall p q r, (pmult (pplus q r) p) = (pplus (pmult q p) (pmult r p)).
intros p q r; case p; case q; case r; intros r1 r2 q1 q2 p1 p2; unfold pplus, pmult.
eq_tac; ring.
Qed.

(**************************************
  In this section we create the group PGroup of inversible elements {(p, q) | 0 <= p < m /\ 0 <= q < m}
 **************************************)
Section Mod.

Variable m : Z.

Hypothesis m_pos: 1 < m.

(**************************************
  mkLine creates {(a, p) | 0 <= p < n}
 **************************************)

Fixpoint mkLine (a: Z) (n: nat) {struct n} : list (Z * Z) :=
  (a, Z_of_nat n) :: match n with O => nil | (S n1) => mkLine a n1 end.

(**************************************
  Some properties of mkLine
 **************************************)

Theorem mkLine_length: forall a n, length (mkLine a n) = (n + 1)%nat.
intros a n; elim n; simpl; auto.
Qed.

Theorem mkLine_in: forall a n p, 0 <= p <= Z_of_nat n -> (In (a, p) (mkLine a n)).
intros a n; elim n.
simpl; auto with zarith.
intros p (H1, H2); replace p with 0; auto with zarith.
intros n1 Rec p (H1, H2).
case (Zle_lt_or_eq p  (Z_of_nat (S n1))); auto with zarith.
rewrite inj_S in H2; auto with zarith.
rewrite inj_S; auto with zarith.
intros H3; right; apply Rec; auto with zarith.
intros H3; subst; simpl; auto.
Qed.

Theorem in_mkLine: forall a n p, In p (mkLine  a n) ->  exists  q, 0 <= q <= Z_of_nat n  /\ p = (a, q).
intros a n p; elim n; clear n.
simpl; intros [H1 | H1]; exists 0; auto with zarith; case H1.
simpl; intros n Rec [H1 | H1]; auto.
exists (Z_of_nat (S n)); auto with zarith.
case Rec; auto; intros q ((H2, H3), H4); exists q; repeat split; auto with zarith.
change (q <= Z_of_nat (S n)).
rewrite inj_S; auto with zarith.
Qed.

Theorem mkLine_ulist: forall a n, ulist (mkLine a n).
intros a n; elim n; simpl; auto.
intros n1 H; apply ulist_cons; auto.
change (~ In (a, Z_of_nat (S n1)) (mkLine a n1)).
rewrite inj_S; intros H1.
case in_mkLine with (1 := H1); auto with zarith.
intros x ((H2, H3), H4); injection H4.
intros H5; subst; auto with zarith.
Qed.

(**************************************
  mkRect creates the list  {(p, q) | 0 <= p < n /\ 0 <= q < m}
 **************************************)

Fixpoint mkRect (n m: nat) {struct n} : list (Z * Z) :=
  (mkLine (Z_of_nat n) m) ++ match n with O => nil | (S n1) => mkRect n1 m end.

(**************************************
  Some properties of mkRect
 **************************************)

Theorem mkRect_length: forall n m, length (mkRect n m) = ((n + 1) * (m + 1))%nat.
intros n; elim n; simpl; auto.
intros n1; rewrite <- app_nil_end; rewrite mkLine_length; rewrite plus_0_r; auto.
intros n1 Rec m1; rewrite length_app; rewrite Rec; rewrite mkLine_length; auto.
Qed.

Theorem mkRect_in: forall n m p q, 0 <= p <= Z_of_nat n -> 0 <= q <= Z_of_nat m -> (In (p, q) (mkRect n m)).
intros n m1; elim n; simpl.
intros p  q  (H1, H2) (H3, H4); replace p with 0; auto with zarith.
rewrite <- app_nil_end; apply mkLine_in; auto.
intros n1 Rec p q (H1, H2) (H3, H4).
case (Zle_lt_or_eq p  (Z_of_nat (S n1))); auto with zarith; intros H5.
rewrite inj_S in H5; apply in_or_app; auto with zarith.
apply in_or_app; left; subst; apply mkLine_in; auto with zarith.
Qed.

Theorem in_mkRect: forall n m p, In p (mkRect n  m) ->  exists p1, exists  p2, 0 <= p1 <= Z_of_nat n  /\ 0 <= p2 <= Z_of_nat m  /\ p = (p1, p2).
intros n m1 p; elim n; clear n; simpl.
rewrite <- app_nil_end; intros H1.
case in_mkLine with (1 := H1).
intros p2 (H2, H3); exists 0; exists p2; auto with zarith.
intros n Rec H1.
case in_app_or with (1 := H1); intros H2.
case in_mkLine with (1 := H2).
intros p2 (H3, H4); exists (Z_of_nat (S n)); exists p2; subst; simpl; auto with zarith.
case Rec with (1 := H2); auto.
intros p1 (p2, (H3, (H4, H5))); exists p1; exists p2; repeat split; auto with zarith.
change (p1 <= Z_of_nat (S n)).
rewrite inj_S; auto with zarith.
Qed.

Theorem mkRect_ulist: forall n m, ulist (mkRect n m).
intros n; elim n; simpl; auto.
intros n1; rewrite <- app_nil_end; apply mkLine_ulist; auto.
intros n1 Rec m1; apply ulist_app; auto.
apply mkLine_ulist.
intros a H1 H2.
case in_mkLine with (1 := H1); intros p1 ((H3, H4), H5).
case in_mkRect with (1 := H2); intros p2 (p3, ((H6, H7), ((H8, H9), H10))).
subst; injection H10; clear H10; intros; subst.
contradict H7.
change (~ Z_of_nat (S n1) <= Z_of_nat  n1).
rewrite inj_S; auto with zarith.
Qed.

(**************************************
  mL is the list  {(p, q) | 0 <= p < m-1 /\ 0 <= q < m - 1}
 **************************************)
Definition mL := mkRect (Zabs_nat (m - 1)) (Zabs_nat (m -1)).

(**************************************
  Some properties of mL
 **************************************)

Theorem mL_length : length mL = Zabs_nat (m * m).
unfold mL; rewrite mkRect_length; simpl; apply inj_eq_inv.
repeat (rewrite inj_mult || rewrite inj_plus || rewrite Z_of_nat_Zabs_nat); simpl; auto with zarith.
eq_tac; auto with zarith.
Qed.

Theorem mL_in: forall p q, 0 <= p < m -> 0 <= q <  m -> (In (p, q) mL).
intros p q (H1, H2) (H3, H4); unfold mL; apply mkRect_in; rewrite Z_of_nat_Zabs_nat; auto with zarith.
Qed.

Theorem in_mL: forall p, In p mL->  exists p1, exists  p2, 0 <= p1 < m  /\ 0 <= p2 < m  /\ p = (p1, p2).
unfold mL; intros p H1; case in_mkRect with (1 := H1).
repeat rewrite Z_of_nat_Zabs_nat; auto with zarith.
intros p1 (p2, ((H2, H3), ((H4, H5), H6))); exists p1; exists p2; repeat split; auto with zarith.
Qed.

Theorem mL_ulist:  ulist mL.
unfold mL; apply mkRect_ulist; auto.
Qed.

(**************************************
  We define zpmult the multiplication of pairs module m
 **************************************)

Definition zpmult (p q: Z * Z) := let (x ,y) := pmult p q in (Zmod x m, Zmod y m).

(**************************************
  Some properties of zpmult
 **************************************)

Theorem zpmult_internal: forall p q, (In (zpmult p q) mL).
intros p q; unfold zpmult; case (pmult p q); intros z y; apply mL_in; auto with zarith.
apply Z_mod_lt; auto with zarith.
apply Z_mod_lt; auto with zarith.
Qed.

Theorem zpmult_assoc: forall p q r, (zpmult p (zpmult q r)) = (zpmult (zpmult p q) r).
assert (U: 0 < m); auto with zarith.
intros p q r; unfold zpmult.
generalize (pmult_assoc p q r).
case (pmult p q); intros x1 x2.
case (pmult q r); intros y1 y2.
case p; case r; unfold pmult.
intros z1 z2 t1 t2 H.
match goal with
  H: (?X, ?Y) = (?Z, ?T) |- _ =>
   assert (H1: X = Z); assert (H2: Y = T); try (injection H; simpl; auto; fail); clear H
end.
eq_tac.
generalize (f_equal (fun x => x mod m) H1).
repeat rewrite <- Zmult_assoc.
repeat (rewrite (fun x  => Zmod_plus (t1 * x))); auto.
repeat (rewrite (fun x  => Zmod_plus (x1 * x))); auto.
repeat (rewrite (fun x  => Zmod_plus (x1 mod m * x))); auto.
repeat (rewrite (Zmod_mult t1)); auto.
repeat (rewrite (Zmod_mult x1)); auto.
repeat (rewrite (Zmod_mult base)); auto.
repeat (rewrite (Zmod_mult t2)); auto.
repeat (rewrite (Zmod_mult x2)); auto.
repeat (rewrite (Zmod_mult (t2 mod m))); auto.
repeat (rewrite (Zmod_mult (x1 mod m))); auto.
repeat (rewrite (Zmod_mult (x2 mod m))); auto.
repeat (rewrite Zmod_mod); auto.
generalize (f_equal (fun x => x mod m) H2).
repeat (rewrite (fun x  => Zmod_plus (t1 * x))); auto.
repeat (rewrite (fun x  => Zmod_plus (x1 * x))); auto.
repeat (rewrite (fun x  => Zmod_plus (x1 mod m * x))); auto.
repeat (rewrite (Zmod_mult t1)); auto.
repeat (rewrite (Zmod_mult x1)); auto.
repeat (rewrite (Zmod_mult t2)); auto.
repeat (rewrite (Zmod_mult x2)); auto.
repeat (rewrite (Zmod_mult (t2 mod m))); auto.
repeat (rewrite (Zmod_mult (x1 mod m))); auto.
repeat (rewrite (Zmod_mult (x2 mod m))); auto.
repeat (rewrite Zmod_mod); auto.
Qed.

Theorem zpmult_0_l: forall p, (zpmult (0, 0) p) = (0, 0).
intros p; case p; intros x y; unfold zpmult, pmult; simpl.
rewrite Zmod_def_small; auto with zarith.
Qed.

Theorem zpmult_1_l: forall p, In p mL -> zpmult (1, 0) p = p.
intros p H; case in_mL with (1 := H); clear H; intros p1 (p2, ((H1, H2), (H3, H4))); subst.
unfold zpmult; rewrite pmult_1_l.
repeat rewrite Zmod_def_small; auto with zarith.
Qed.

Theorem zpmult_1_r: forall p, In p mL -> zpmult p (1, 0) = p.
intros p H; case in_mL with (1 := H); clear H; intros p1 (p2, ((H1, H2), (H3, H4))); subst.
unfold zpmult; rewrite pmult_1_r.
repeat rewrite Zmod_def_small; auto with zarith.
Qed.

Theorem zpmult_comm: forall p q, zpmult p q = zpmult q p.
intros p q; unfold zpmult; rewrite pmult_comm; auto.
Qed.

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

Definition PGroup : (FGroup zpmult).
apply IGroup with (support := mL) (e:= (1, 0)).
exact P_dec.
apply mL_ulist.
apply mL_in; auto with zarith.
intros; apply zpmult_internal.
intros; apply zpmult_assoc.
exact zpmult_1_l.
exact zpmult_1_r.
Defined.

End Mod.


(*
  Author(s):
    Dominique Larchey-Wendling (1)
    Andrej Dudenhefner (2)
  Affiliation(s):
    (1) LORIA -- CNRS
    (2) TU Dortmund University, Dortmund, Germany
*)

(*
  Problem(s):
    Two-counter Machine Halting (MM2_HALTING)
    Two-counter Machine Halting starting from (0, 0) (MM2_ZERO_HALTING)
    Two-counter Machine Halting ending in (0, 0) (MM2_HALTS_ON_ZERO)
    Two-counter Machine Reversibility (MM2_REV)
    Reversible Two-counter Machine Halting (MM2_REV_HALT)
    Two-counter Machine Uniform Boundedness (MM2_UBOUNDED)
    Two-counter Machine Uniform Mortality (MM2_UMORTAL)
*)

(*
  Literature:
  [1] Certified Undecidability of Intuitionistic Linear Logic via Binary Stack Machines and Minsky Machines.
      Yannick Forster and Dominique Larchey-Wendling. CPP '19. http://uds-psl.github.io/ill-undecidability/
*)

Require Import List Relations.Relation_Operators.

#[local] Set Implicit Arguments.

(* Two counters Minsky machines. Counters are named A and B

    For instructions: INC{A,B} | DEC{A,B} j

    j is a conditional jump PC index which occurs
    when the counter has non-zero value
*)

Inductive mm2_instr : Set :=
  | mm2_inc_a : mm2_instr
  | mm2_inc_b : mm2_instr
  | mm2_dec_a : nat -> mm2_instr
  | mm2_dec_b : nat -> mm2_instr.

Reserved Notation "i '//' r '⇢' s" (at level 70, no associativity).
Reserved Notation "P '//' r '→' s" (at level 70, no associativity).
Reserved Notation "P '//' r '↠' s" (at level 70, no associativity).
Reserved Notation "P '//' r ↓" (at level 70, no associativity).

#[local] Notation mm2_state := (nat*(nat*nat))%type.

(* Instruction step semantics:

    ρ // x ⇢ y : instruction ρ transforms state x into state y

    Notice that the jump occurs on the non-zero case when DEC

  *)

Inductive mm2_atom : mm2_instr -> mm2_state -> mm2_state -> Prop :=
  | in_mm2s_inc_a  : forall i   a b, mm2_inc_a   // (i,(  a,  b)) ⇢ (1+i,(S a,  b))
  | in_mm2s_inc_b  : forall i   a b, mm2_inc_b   // (i,(  a,  b)) ⇢ (1+i,(  a,S b))
  | in_mm2s_dec_aS : forall i j a b, mm2_dec_a j // (i,(S a,  b)) ⇢ (  j,(  a,  b))
  | in_mm2s_dec_bS : forall i j a b, mm2_dec_b j // (i,(  a,S b)) ⇢ (  j,(  a,  b))
  | in_mm2s_dec_a0 : forall i j   b, mm2_dec_a j // (i,(  0,  b)) ⇢ (1+i,(  0,  b))
  | in_mm2s_dec_b0 : forall i j a,   mm2_dec_b j // (i,(  a,  0)) ⇢ (1+i,(  a,  0))
where "ρ // x ⇢ y" := (mm2_atom ρ x y).

(* instruction ρ occurs at PC index i in the program (1,P) *)

Definition mm2_instr_at (ρ : mm2_instr) i P := exists l r, P = l++ρ::r /\ 1+length l = i.

(* Program step semantics:

    program P with first instruction at PC index 1 transforms
    state x into state y in one step, using instruction a PC index (fst x) *)

Definition mm2_step P x y := exists ρ, mm2_instr_at ρ (fst x) P /\ ρ // x ⇢ y.
#[local] Notation "P // x → y" := (mm2_step P x y).

(* Halting condition: program P cannot progress from s *)
Definition mm2_stop P s := forall s', not (P // s → s').

(* reflexive and transitive closure of program step semantics *)
#[local] Notation "P // x ↠ y" := (clos_refl_trans _ (mm2_step P) x y).

Definition mm2_terminates P s := exists s', P // s ↠ s' /\ mm2_stop P s'.
#[local] Notation "P // s ↓" := (mm2_terminates P s).

Definition MM2_PROBLEM := (list mm2_instr * nat * nat)%type.

(* Two-counter Machine Halting *)
Definition MM2_HALTING (P : MM2_PROBLEM) :=
  match P with (P,a,b) => P // (1,(a,b)) ↓ end.

(* Two-counter Machine Halting starting from (0, 0) *)
Definition MM2_ZERO_HALTING : list mm2_instr -> Prop :=
  fun P => P // (1,(0,0)) ↓.

(* Two-counter Machine Halting ending in (0, 0) *)
Definition MM2_HALTS_ON_ZERO (P : MM2_PROBLEM) :=
  match P with (P,a,b) => P // (1,(a,b)) ↠ (0,(0,0)) end.

(* injectivity of the step relation *)
Definition mm2_reversible (P : list mm2_instr) : Prop :=
  forall x y z, mm2_step P x z -> mm2_step P y z -> x = y.

(* k bounds the number of reachable configurations from x *)
Definition mm2_bounded (P : list mm2_instr) (k: nat) (x: mm2_state) : Prop :=
  exists (L: list mm2_state), (length L <= k) /\
    (forall (y: mm2_state), P // x ↠ y -> In y L).

(* uniform bound for number of reachable configurations *)
Definition mm2_uniformly_bounded (P : list mm2_instr) : Prop :=
  exists k, forall x, mm2_bounded P k x.

(* configuration trace P // x → x1 → x2 → ... → xn *)
Fixpoint mm2_trace (P : list mm2_instr) (x : mm2_state) (xs : list mm2_state) : Prop :=
  match xs with
  | nil => True
  | y::ys => P // x → y /\ mm2_trace P y ys
  end.

(* k bounds the number of steps in any run from x *)
Definition mm2_mortal (P : list mm2_instr) (k: nat) (x: mm2_state) : Prop :=
  forall (L: list mm2_state), mm2_trace P x L -> length L <= k.

(* uniform bound for number of steps until termination *)
Definition mm2_uniformly_mortal (P : list mm2_instr) : Prop :=
  exists k, forall x, mm2_mortal P k x.

(* Two-counter Machine Reversibility:
   Given a two-counter machine P,
   is the step function of P injective? *)
Definition MM2_REV : list mm2_instr -> Prop :=
  fun P => mm2_reversible P.

(* Reversible Two-counter Machine Halting:
   Given a reversible two-counter machine P and a configucation x,
   does a run in M starting from x eventually halt? *)
Definition MM2_REV_HALT : { P: list mm2_instr | mm2_reversible P } * mm2_state -> Prop :=
  fun '((exist _ P _), x) => P // x ↓.

(* Two-counter Machine Uniform Boundedness:
   Given a two-counter machine P,
   is there a uniform bound n,
   such that for any configuration x,
   the number of reacheable configurations from x in P is bounded by n? *)
Definition MM2_UBOUNDED : list mm2_instr -> Prop :=
  fun P => mm2_uniformly_bounded P.

(* Two-counter Machine Uniform Mortality:
   Given a two-counter machine P,
   is there a uniform bound n,
   such that for any configuration x,
   a run in P starting from x halts after at most n steps? *)
Definition MM2_UMORTAL : list mm2_instr -> Prop :=
  fun P => mm2_uniformly_mortal P.

Module MM2Notations.
  Notation mm2_state := (nat*(nat*nat))%type.
  Notation index x := (@fst nat (nat*nat) x).
  Notation value1 x := (fst (@snd nat (nat*nat) x)).
  Notation value2 x := (snd (@snd nat (nat*nat) x)).
  Notation "ρ // x ⇢ y" := (mm2_atom ρ x y).
  Notation "P // x → y" := (mm2_step P x y).
  Notation "P // x ↠ y" := (clos_refl_trans _ (mm2_step P) x y).
  Notation "P // s ↓" := (mm2_terminates P s).
End MM2Notations.


(**********************************************LISTS*********************************************************)
Require Import List.
Import ListNotations.

Module MyList.

Inductive list (A : Type) : Type :=
| nil : list A
| cons : A -> list A -> list A.

End MyList.

Check list.

Definition is_empty (A : Type) (lst : list A) :=
  match lst with
  | nil => true
  | cons _ _ => false
  end.

Definition is_empty_sugar (A : Type) (lst : list A) :=
  match lst with
  | [] => true
  | _::_ => false
  end.

Compute is_empty nat [1].

Compute is_empty nat [].

Definition is_empty' {A : Type} (lst : list A) :=
  match lst with
  | [] => true
  | _::_ => false
  end.

Compute is_empty' [1].

Compute @is_empty' nat [1].

Module MyLength.

Fixpoint length {A : Type} (lst : list A) :=
  match lst with
  | nil => 0
  | _::t => 1 + length t
  end.

Compute length [1;2].

End MyLength.

(************************************************OPTIONS******************************************************)

Module MyOption.

Inductive option (A:Type) : Type :=
  | Some : A -> option A
  | None : option A.

End MyOption.

Definition hd_opt {A : Type} (lst : list A) : option A :=
  match lst with
  | nil => None
  | x :: xs => Some x
  end.

Compute hd_opt [1].

Compute @hd_opt nat [].

Theorem length0_implies_hdopt_is_none :
  forall A : Type, forall lst : list A,
    length lst = 0 -> hd_opt lst = None.
Proof.
  intros A lst length_lst_is_0.
  destruct lst.
    trivial.
    discriminate.
Qed.

Theorem length0_implies_hdopt_is_none' :
forall A : Type, forall lst : list A,
  length lst = 0 -> hd_opt lst = None.
Proof.
  intros A lst length_lst_is_0.
  destruct lst.
    - trivial.
    - discriminate.
Qed.


Require Import XR_R0.
Require Import XR_Rle_dec.
Require Import XR_Rnot_le_lt.

Local Open Scope R_scope.

Lemma Rcase_abs : forall r, {r < R0} + {R0 <= r}.
Proof.
  intro x.
  assert (h := Rle_dec).
  specialize (h R0 x).
  destruct h as [ hl | hr ].
  {
    right.
    exact hl.
  }
  {
    left.
    apply Rnot_le_lt.
    exact hr.
  }
Qed.


Require Import Lia.
Require Import Nat.
Require Import List.
Require Import Classes.DecidableClass.

From Cyclic_PA.Maths Require Import naturals.
From Cyclic_PA.Logic Require Import definitions.

Require Import Coq.Arith.Wf_nat.

Open Scope bool_scope.
Open Scope list_scope.

Import ListNotations.

Notation nat_eq_dec := PeanoNat.Nat.eq_dec.

Lemma concat_map_remove_eq {A B : Type} {DEC : forall (a b : A), {a = b} + {a <> b}} :
forall (f : A -> list B) (a : A) (L1 L2 : list A),
    concat (map f L1) = concat (map f L2) ->
        concat (map f (remove DEC a L1)) = concat (map f (remove DEC a L2)).
intros f a L1.
induction L1 as [L1 IND1] using (induction_ltof1 _ (@length _));
unfold ltof in IND1.
intros L2 EQ;
induction L2 as [L2 IND2] using (induction_ltof1 _ (@length _));
unfold ltof in IND2.
destruct L1 as [| hd1 L1];
destruct L2 as [| hd2 L2].
- reflexivity.
- unfold map, remove in *;
  fold (map f) (remove DEC) in *.
  symmetry in EQ.
  apply app_eq_nil in EQ as [EQ1 EQ2].
  fold (@concat B) in *.
  case DEC as [EQ | NE];
  unfold map;
  fold (map f);
  try rewrite EQ1;
  try rewrite IND2;
  try apply le_n;
  symmetry;
  try apply EQ2.
- unfold flat_map, remove in *;
  fold (flat_map f) (remove DEC) in *.
  apply app_eq_nil in EQ as [EQ1 EQ2].
  case DEC as [EQ | NE];
  unfold flat_map;
  fold (flat_map f);
  try rewrite EQ1;
  try rewrite app_nil_l;
  refine (IND1 _ _ [] _);
  try apply le_n;
  apply EQ2.
- unfold remove;
  fold (remove DEC).
  unfold flat_map in *;
  fold (flat_map f) in *.
  case DEC as [EQ' | NE].
  + rewrite flat_map_concat_map.
Qed.
*)
Lemma flat_map_remove_eq {A B : Type} {DEC : forall (a b : A), {a = b} + {a <> b}} :
  forall (f : A -> list B) (a : A) (L1 L2 : list A),
      flat_map f L1 = flat_map f L2 ->
          flat_map f (remove DEC a L1) = flat_map f (remove DEC a L2).
Proof.
intros f a L1 L2 EQ.
repeat rewrite flat_map_concat_map in *.
apply concat_map_remove_eq, EQ.
Qed.

Fixpoint list_eqb (l1 l2 : list nat) : bool :=
match l1,l2 with
| [],[] => true
| m :: l1',[] => false
| [], n :: l2' => false
| m :: l1', n :: l2' => nat_eqb m n && list_eqb l1' l2'
end.

Lemma list_eqb_eq :
    forall (l1 l2 : list nat),
        list_eqb l1 l2 = true ->
            l1 = l2.
Proof.
induction l1;
intros l2 EQ.
- destruct l2.
  + reflexivity.
  + inversion EQ.
- destruct l2.
  + inversion EQ.
  + unfold list_eqb in EQ; fold list_eqb in EQ.
    destruct (and_bool_prop _ _ EQ) as [EQ1 EQ2].
    rewrite (IHl1 l2 EQ2).
    rewrite (nat_eqb_eq _ _ EQ1).
    reflexivity.
Qed.

Lemma list_eqb_refl :
    forall (l : list nat),
        list_eqb l l = true.
Proof.
induction l.
- reflexivity.
- unfold list_eqb; fold list_eqb.
  rewrite nat_eqb_refl.
  apply IHl.
Qed.

Fixpoint member (n : nat) (l : list nat) : bool :=
match l with
| nil => false
| m :: l' =>
  (match nat_eqb m n with
  | true => true
  | false => member n l'
  end)
end.

Lemma member_in (n : nat) (l : list nat) : member n l = true <-> In n l.
Proof.
induction l;
split;
intros IN.
- inversion IN.
- inversion IN.
- unfold In; fold (@In nat).
  unfold member in IN;
  fold member in IN.
  case (nat_eqb a n) eqn:EQB.
  + apply nat_eqb_eq in EQB.
    left.
    apply EQB.
  + right.
    apply IHl, IN.
- unfold member;
  fold member.
  destruct IN as [EQ | IN].
  + destruct EQ.
    rewrite nat_eqb_refl.
    reflexivity.
  + case (nat_eqb a n).
    * reflexivity.
    * apply IHl, IN.
Qed.

Lemma not_member_nin (n : nat) (l : list nat) : member n l = false <-> ~In n l.
Proof.
destruct (in_dec nat_eq_dec n l) as [IN | NIN];
split;
intros NIN'.
- rewrite (proj2 (member_in _ _) IN) in NIN'.
  inversion NIN'.
- contradict (NIN' IN).
- apply NIN.
- case (member n l) eqn:IN.
  + contradict (NIN (proj1 (member_in _ _) IN)).
  + reflexivity.
Qed.

Lemma remove_dups_empty :
    forall (l : list nat),
        nodup nat_eq_dec l = [] -> l = [].
Proof.
intros l lE.
induction l.
- reflexivity.
- unfold nodup in lE.
  fold (nodup nat_eq_dec) in lE.
  case (in_dec nat_eq_dec a l) as [IN | NIN].
  + rewrite (IHl lE) in IN.
    inversion IN.
  + inversion lE.
Qed.

Lemma remove_dups_order :
    forall (l : list nat) (n : nat),
        remove nat_eq_dec n (nodup nat_eq_dec l) = nodup nat_eq_dec (remove nat_eq_dec n l).
Proof.
intros l n.
induction l.
- reflexivity.
- unfold nodup; fold (nodup nat_eq_dec);
  unfold remove; fold (remove nat_eq_dec).
  case (nat_eq_dec a n) as [EQ | NE];
  try destruct EQ;
  destruct nat_eq_dec as [EQ | NE'];
  unfold nodup; fold (nodup nat_eq_dec);
  unfold remove; fold (remove nat_eq_dec).
  + rewrite <- IHl.
    case (in_dec nat_eq_dec a l) as [IN | NIN].
    * reflexivity.
    * apply remove_cons.
  + contradict (NE' eq_refl).
  + contradict NE.
    destruct EQ.
    reflexivity.
  + rewrite <- IHl.
    case (in_dec nat_eq_dec a l) as [IN | NIN];
    case (in_dec nat_eq_dec a (remove nat_eq_dec n l)) as [IN' | NIN'].
    * reflexivity.
    * contradict (NIN' (in_in_remove nat_eq_dec _ NE IN)).
    * contradict (NIN (proj1 (in_remove nat_eq_dec _ _ _ IN'))).
    * unfold remove; fold (remove nat_eq_dec).
      case nat_eq_dec as [EQ | _].
      --  contradict (NE' EQ).
      --  reflexivity.
Qed.

Lemma remove_n_dups_empty :
    forall (l : list nat) (n : nat),
        remove nat_eq_dec n (nodup nat_eq_dec l) = [] ->
            nodup nat_eq_dec l = [n] \/ nodup nat_eq_dec l = [].
Proof.
intros l n RlE.
induction l.
- right.
  reflexivity.
- unfold nodup; fold (nodup nat_eq_dec).
  rewrite remove_dups_order in *.
  unfold remove in *; fold (remove nat_eq_dec) in *.
  case (nat_eq_dec n a) as [EQ | NE].
  + destruct EQ.
    destruct (IHl RlE) as [Ln | Le];
    case (in_dec nat_eq_dec n l) as [IN | NIN].
    * left.
      apply Ln.
    * contradict NIN.
      refine ((proj1 (nodup_incl nat_eq_dec [n] _)) _ _ (in_eq _ _)).
      rewrite Ln.
      apply incl_refl.
    * right.
      apply Le.
    * left.
      rewrite Le.
      reflexivity.
  + unfold nodup in RlE; fold (nodup nat_eq_dec) in RlE.
    case in_dec as [IN | NIN].
    * rewrite <- nodup_In, RlE in IN.
      inversion IN.
    * inversion RlE.
Qed.

Lemma remove_dups_twice : forall (l : list nat),
  nodup nat_eq_dec (nodup nat_eq_dec l) = nodup nat_eq_dec l.
Proof.
intros l.
apply nodup_fixed_point, NoDup_nodup.
Qed.

Lemma member_remove' : forall (l : list nat) (m n : nat),
  nat_eqb m n = false ->
  member n l = true ->
  member n (remove nat_eq_dec m l) = true.
Proof.
intros l m n NE' IN.
induction l.
- apply IN.
- unfold member in IN.
  fold member in IN.
  unfold remove.
  fold (remove nat_eq_dec).
  case (nat_eq_dec m a) as [EQ | NE].
  + destruct EQ.
    case (nat_eqb m n) eqn:EQB.
    * inversion NE'.
    * apply IHl, IN.
  + unfold member.
    fold member.
    case (nat_eqb a n) eqn:EQB.
    * reflexivity.
    * apply IHl, IN.
Qed.

Lemma member_remove : forall (l : list nat) (m n : nat),
  nat_eqb m n = false ->
  member n (remove nat_eq_dec m l) = false ->
  member n l = false.
Proof.
intros l m n NEB NMEM.
case (member n l) eqn:MEM.
- rewrite (member_remove' _ _ _ NEB MEM) in NMEM. apply NMEM.
- reflexivity.
Qed.

Lemma member_remove_dups : forall (l : list nat) (n : nat),
  member n (nodup nat_eq_dec l) = false -> member n l = false.
Proof.
intros. induction l; auto.
simpl. simpl in H.
case in_dec as [IN | NIN];
destruct (nat_eqb a n) eqn:EQB.
- apply nat_eqb_eq in EQB.
  destruct EQB.
  apply not_member_nin in H.
  contradict H.
  apply nodup_In, IN.
- apply IHl, H.
- apply nat_eqb_eq in EQB.
  destruct EQB.
  unfold member in H.
  rewrite nat_eqb_refl in H.
  inversion H.
- apply IHl.
  unfold member in H.
  rewrite EQB in H.
  apply H.
Qed.

Lemma member_concat' : forall (l1 l2 : list nat) (n : nat),
  member n (l1 ++ l2) = true ->
  member n l1 = true \/ member n l2 = true.
Proof.
intros. induction l1.
- right. apply H.
- simpl in H. simpl. destruct (nat_eqb a n) eqn:Hx.
  + left. auto.
  + destruct (IHl1 H).
    * left. apply H0.
    * right. apply H0.
Qed.

Lemma member_concat : forall (l1 l2 : list nat) (n : nat),
  member n (l1 ++ l2) = false ->
  member n l1 = false /\ member n l2 = false.
Proof.
intros. induction l1; auto.
simpl. case_eq (nat_eqb a n); intros; simpl in H; rewrite H0 in H.
- inversion H.
- apply (IHl1 H).
Qed.

Lemma member_remove_dups_concat : forall (l1 l2 : list nat) (n : nat),
  member n (nodup nat_eq_dec (l1 ++ l2)) = false ->
  member n l1 = false /\ member n l2 = false.
Proof.
intros.
apply member_concat.
apply member_remove_dups.
apply H.
Qed.

Lemma concat_member : forall (l l' : list nat) (n : nat),
  member n l = true -> member n (l ++ l') = true.
Proof.
intros. destruct (member n (l ++ l')) eqn:Hn; auto.
destruct (member_concat _ _ _ Hn). rewrite H0 in H. inversion H.
Qed.

Lemma remove_dups_member : forall (l : list nat) (n : nat),
  member n l = true -> member n (nodup nat_eq_dec l) = true.
Proof.
intros. destruct (member n (nodup nat_eq_dec l)) eqn:Hn; auto.
apply member_remove_dups in Hn. rewrite Hn in H. inversion H.
Qed.

Fixpoint repeated_element_n (l : list nat) (n : nat) : bool :=
match l with
| [] => true
| m :: l' => nat_eqb m n && repeated_element_n l' n
end.

Lemma in_reapeated_is : forall (m n : nat) (L : list nat), repeated_element_n L n = true -> In m L -> m = n.
Proof.
induction L;
intros RL IN.
- inversion IN.
- destruct IN as [EQ | IN].
  + destruct EQ.
    apply (nat_eqb_eq _ _ (proj1 (and_bool_prop _ _ RL))).
  + apply (IHL (proj2 (and_bool_prop _ _ RL)) IN).
Qed.

Lemma remove_dups_repeated_element : forall (l : list nat) (n : nat),
  repeated_element_n l n = true ->
  sum (nodup nat_eq_dec l = [n]) (l = []).
Proof.
intros.
induction l; auto.
left.
apply and_bool_prop in H as [X1 X2].
fold repeated_element_n in X2.
destruct (IHl X2) as [H3 | H3].
- simpl. rewrite H3.
  apply nat_eqb_eq in X1.
  destruct X1.
  unfold repeated_element_n in X2.
  destruct l.
  + inversion H3.
  + apply and_bool_prop in X2 as [X1 X2].
    apply nat_eqb_eq in X1.
    destruct X1.
    case (in_dec nat_eq_dec n (n :: l)) as [_ | FAL].
    * reflexivity.
    * contradict FAL.
      left.
      reflexivity.
- rewrite H3. rewrite (nat_eqb_eq _ _ X1). reflexivity.
Qed.

Lemma nodup_nil : forall l : list nat, nodup nat_eq_dec l = [] -> l = [].
Proof.
induction l;
intros EQ.
- reflexivity.
- unfold nodup in EQ.
  fold (nodup nat_eq_dec) in EQ.
  case in_dec as [IN | NIN].
  + rewrite (IHl EQ) in IN.
    inversion IN.
  + inversion EQ.
Qed.

Lemma remove_dups_repeated_element' : forall (l : list nat) (n : nat),
  nodup nat_eq_dec l = [n] ->
  repeated_element_n l n = true.
Proof.
intros. induction l; auto.
simpl. inversion H.
case in_dec as [IN | NIN].
- pose proof (IHl H1).
  destruct (in_reapeated_is _ _ _ H0 IN).
  rewrite nat_eqb_refl.
  apply H0.
- inversion H1.
  destruct H2.
  rewrite nat_eqb_refl.
  rewrite (nodup_nil _ H3).
  reflexivity.
Qed.

Lemma repeated_element_n_concat_aux : forall (l1 l2 : list nat) (m n : nat),
  repeated_element_n (l1 ++ (m :: l2)) n = true ->
  nat_eqb m n && repeated_element_n l2 n = true.
Proof.
intros. induction l1; simpl in H.
- apply H.
- apply IHl1. destruct (and_bool_prop _ _ H). apply H1.
Qed.

Lemma repeated_element_n_concat : forall (l1 l2 : list nat) (n : nat),
  repeated_element_n (l1 ++ l2) n = true ->
  repeated_element_n l1 n = true /\ repeated_element_n l2 n = true.
Proof.
intros. split.
- induction l1; auto.
  simpl. simpl in H. destruct (and_bool_prop _ _ H).
  rewrite H0, (IHl1 H1). auto.
- induction l2; auto. simpl.
  apply (repeated_element_n_concat_aux l1 l2 a n), H.
Qed.

Lemma remove_dup_single_right : forall l1 l2 m, nodup nat_eq_dec (l1 ++ l2) = [m] -> nodup nat_eq_dec l2 = [m] \/ nodup nat_eq_dec l2 = [].
Proof.
intros. pose proof (remove_dups_repeated_element' _ _ H). pose proof (repeated_element_n_concat _ _ _ H0). destruct H1. destruct (remove_dups_repeated_element _ _ H2); auto. rewrite e. auto.
Qed.

Lemma remove_dup_single_left : forall l1 l2 m, nodup nat_eq_dec (l1 ++ l2) = [m] -> nodup nat_eq_dec l1 = [m] \/ nodup nat_eq_dec l1 = [].
Proof.
intros. pose proof (remove_dups_repeated_element' _ _ H). pose proof (repeated_element_n_concat _ _ _ H0). destruct H1. destruct (remove_dups_repeated_element _ _ H1); auto. rewrite e. auto.
Qed.

Lemma remove_not_in : forall l n, list_eqb (remove nat_eq_dec n l) [n] = false.
Proof.
intros. induction l. auto. simpl. case (nat_eq_dec n a) as [EQ | NE].
- auto.
- simpl.
  case (nat_eqb a n) eqn:Y.
  + contradict NE.
    symmetry.
    apply nat_eqb_eq, Y.
  + reflexivity.
Qed.

Lemma remove_not_member : forall l n, member n (remove nat_eq_dec n l) = false.
Proof.
intros. induction l. auto. simpl.  case (nat_eq_dec n a) as [EQ | NE].
- auto.
- simpl.
  case (nat_eqb a n) eqn:Y.
  + contradict NE.
    symmetry.
    apply nat_eqb_eq, Y.
  + apply IHl.
Qed.

Lemma member_remove_true : forall l n m, member n (remove nat_eq_dec m l) = true -> member n l = true.
Proof.
intros. induction l; inversion H. rewrite H1. simpl. case (nat_eqb a n) eqn:X; auto.
case (nat_eq_dec m a) as [EQ | NE]; auto.
- simpl in H1. rewrite X in H1. auto.
Qed.

Lemma remove_member_false : forall l n m, member n l = false -> member n (remove nat_eq_dec m l) = false.
Proof.
intros. case (nat_eqb n m) eqn:X.
- apply nat_eqb_eq in X. destruct X. apply remove_not_member.
- induction l. auto. simpl. inversion H. case (nat_eqb a n) eqn:X1; auto. inversion H1. rewrite H1. case (nat_eq_dec m a) as [EQ | NE]; auto. simpl. rewrite X1. auto.
Qed.

Lemma member_remove_dups_true : forall l n, member n (nodup nat_eq_dec l) = true -> member n l = true.
Proof.

intros. induction l; inversion H. simpl. case (nat_eqb a n) eqn:X; auto.
case in_dec as [IN | NIN];
rewrite H1; apply IHl.
- apply H1.
- unfold member in H1.
  rewrite X in H1.
  apply H1.
Qed.

Lemma nodups_incl_app : forall L1 L2, (forall m, In m L1 -> In m L2) -> nodup nat_eq_dec (L1 ++ L2) = nodup nat_eq_dec L2.
Proof.
induction L1; intros.
- rewrite app_nil_l. reflexivity.
- rewrite <- app_comm_cons.
  unfold nodup; fold (nodup nat_eq_dec).
  case in_dec as [IN | NIN].
  + apply IHL1.
    apply (fun m HY => H m (or_intror HY)).
  + contradict NIN.
    apply in_or_app.
    right.
    apply H.
    left.
    reflexivity.
Qed.

Lemma remove_dups_concat_self : forall L, nodup nat_eq_dec (L ++ L) = nodup nat_eq_dec L.
Proof.
intros.
apply nodups_incl_app.
auto.
Qed.

Lemma remove_dups_double_cons_ne : forall n m l, nodup nat_eq_dec (n :: m :: l) = n :: m :: l -> nat_eqb m n = false.
Proof.
intros.
case (nat_eqb m n) eqn:EQB.
- apply nat_eqb_eq in EQB.
  destruct EQB.
  pose proof (NoDup_nodup nat_eq_dec (m :: m :: l)).
  rewrite H in H0.
  inversion H0.
  contradict H3.
  left.
  reflexivity.
- reflexivity.
Qed.

Lemma remove_idem_not_mem : forall l n, remove nat_eq_dec n l = l -> member n l = false.
Proof.
intros. induction l. auto. simpl in *. case (nat_eqb a n) eqn:X.
- apply nat_eqb_eq in X. destruct X. pose proof (remove_not_member l a).
  case nat_eq_dec as [_ | FAL].
  + rewrite H in H0. simpl in H0. rewrite nat_eqb_refl in H0. apply H0.
  + contradict FAL.
    reflexivity.
- case nat_eq_dec as [FAL | _].
+ destruct FAL.
  rewrite nat_eqb_refl in X.
  inversion X.
+ inversion H.
  rewrite H1.
  apply IHl, H1.
Qed.

Lemma remove_not_mem_idem : forall l n, member n l = false -> remove nat_eq_dec n l = l.
Proof.
intros. induction l. auto. simpl in *. case (nat_eqb a n) eqn:X. inversion H. rewrite IHl; auto.
case (nat_eq_dec n a) as [FAL | _].
- destruct FAL.
  rewrite nat_eqb_refl in X.
  inversion X.
- reflexivity.
Qed.

Lemma remove_dups_idem_remove_false : forall l n, nodup nat_eq_dec (n :: l) = n :: l -> member n l = false.
Proof.
intros.
apply nodup_inv in H.
apply not_member_nin, H.
Qed.

Lemma not_mem_dupes : forall l n, member n l = false -> member n (nodup nat_eq_dec l) = false.
Proof.
intros.
apply not_member_nin.
apply not_member_nin in H.
intros FAL.
apply H.
apply nodup_In in FAL.
apply FAL.
Qed.

Lemma remove_dups_idem_remove_triv : forall l n, nodup nat_eq_dec (n :: l) = n :: l -> remove nat_eq_dec n (n :: l) = l.
Proof.
intros.
pose proof (remove_dups_idem_remove_false _ _ H).
unfold remove; fold (remove nat_eq_dec).
case nat_eq_dec as [_ | FAL].
- apply notin_remove, not_member_nin, H0.
- contradict FAL.
  reflexivity.
Qed.

Lemma remove_idem_tail : forall l n, nodup nat_eq_dec (n :: l) = n :: l -> nodup nat_eq_dec l = l.
Proof.
intros.
pose proof (remove_dups_idem_remove_false _ _ H).
unfold nodup in H.
fold (nodup nat_eq_dec) in H.
case in_dec as [FAL | _].
- apply member_in in FAL.
  rewrite H0 in FAL.
  inversion FAL.
- inversion H.
  repeat rewrite H2.
  reflexivity.
Qed.

Lemma member_split : forall l n, member n l = true -> exists l1 l2, l = l1 ++ (n :: l2).
Proof.
intros. induction l. inversion H. simpl in H. case (nat_eqb a n) eqn:X.
- apply nat_eqb_eq in X. destruct X. exists [], l. auto.
- destruct (IHl H) as [l1 [l2 HL]]. exists (a :: l1), l2. rewrite HL. auto.
Qed.

Lemma member_split_first : forall l n, member n l = true -> exists l1 l2, l = l1 ++ (n :: l2) /\ member n l1 = false.
Proof.
intros. induction l. inversion H. simpl in H. case (nat_eqb a n) eqn:X.
- apply nat_eqb_eq in X. destruct X. exists [], l. auto.
- destruct (IHl H) as [l1 [l2 [HL1 Hl2]]]. exists (a :: l1), l2. split. rewrite HL1. auto. simpl. rewrite X. auto.
Qed.

Lemma split_member : forall l1 l2 n, member n (l1 ++ (n :: l2)) = true.
Proof.
intros l1. induction l1. intros. simpl. rewrite nat_eqb_refl. auto. intros. simpl. case (nat_eqb a n); auto.
Qed.


Check refl_equal.
(* ===>
eq_refl
     : forall (A : Type) (x : A), x = x
*)

Check eq_ind.
(* ===>
eq_ind
     : forall (A : Type) (x : A) (P : A -> Prop),
       P x -> forall y : A, x = y -> P y
*)

Definition eq_sym' (A:Type)(x y:A)(h : x=y) : y=x :=
  eq_ind x (fun z => z=x) (refl_equal x) y h.

Definition eq_trans' (A:Type)(x y z:A)(h : x=y)(g : y=z) : x=z :=
  eq_ind y (fun z => x=z) h z g.

Definition eq_subst' (A:Type)(B: A -> Prop)(x y:A)(h : x=y)(g : B x) : B y :=
  eq_ind x (fun z => B z) g y h.

Definition eq_resp' (A:Type)(B: Prop)(x y:A)(h : x=y)(g: A -> B) : g x = g y :=
  eq_ind x (fun z => g x = g z) (refl_equal (g x)) y h.

Inductive id' (A:Type) : A -> A -> Prop :=
  refl': forall x, id' A x x.

Check id'_ind.
(* ===>
id'_ind
     : forall (A : Type) (P : A -> A -> Prop),
       (forall x : A, P x x) -> forall y y0 : A, id' A y y0 -> P y y0
*)

Definition J (A:Type)(x y: A)(h: id' A x y)(P: A -> A -> Prop)(Q: forall x : A, P x x): P x y :=
  id'_ind A P Q x y h.

Definition id'_sym (A:Type)(x y:A)(h : id' A x y) : id' A y x :=
  J A x y h (fun u v => id' A v u) (fun z => refl' A z).

Definition id'_trans (A:Type)(x y z:A)(h : id' A x y)(g : id' A y z) : id' A x z :=
  J A x y h (fun u v => id' A v z -> id' A u z) (fun z i => i) g.

Definition id'_subst (A:Type)(B: A -> Prop)(x y:A)(h : id' A x y)(g : B x) : B y :=
  J A x y h (fun u v => B u -> B v) (fun z i => i) g.

Definition id'_resp' (A:Type)(B: Prop)(x y:A)(h : id' A x y)(g: A -> B) : id' B (g x) (g y) :=
  J A x y h (fun u v => forall q, id' B (q u) (q v)) (fun z q => refl' B (q z)) g.


(* 5_folding-left-and-right-over-peano-numbers.v *)
(* FPP 2020 - YSC3236 2020-2011, Sem1 *)
(* Olivier Danvy <danvy@yale-nus.edu.sg> *)
(* Liu Zhang <zhangliu@u.yale-nus.edu.sg>*)
(* Version of 05 Sep 2020 *)

(* ********** *)

(* Paraphernalia: *)

Ltac fold_unfold_tactic name := intros; unfold name; fold name; reflexivity.

Require Import Arith Bool.

Notation "A =n= B" :=
  (beq_nat A B) (at level 70, right associativity).

(* ********** *)

Definition specification_of_power (power : nat -> nat -> nat) :=
  (forall x : nat,
      power x 0 = 1)
  /\
  (forall (x : nat)
          (n' : nat),
      power x (S n') = x * power x n').

(* ***** *)

Proposition there_is_at_most_one_function_satisfying_the_specification_of_power :
  forall power1 power2 : nat -> nat -> nat,
    specification_of_power power1 ->
    specification_of_power power2 ->
    forall x n : nat,
      power1 x n = power2 x n.
Proof.
  intros power1 power2.
  unfold specification_of_power.
  intros [S1_O S1_S] [S2_O S2_S] x n.
  induction n as [ | n' IHn'].
  - rewrite -> (S2_O x).
    exact (S1_O x).
  - rewrite -> (S1_S x n').
    rewrite -> (S2_S x n').
    rewrite -> IHn'.
    reflexivity.
Qed.

(* ***** *)

Definition test_power (candidate : nat -> nat -> nat) : bool :=
  (candidate 2 0 =? 1) &&
  (candidate 10 2 =? 10 * 10) &&
  (candidate 3 2 =? 3 * 3).

(* ***** *)

Fixpoint power_v0_aux (x n : nat) : nat :=
  match n with
  | O =>
    1
  | S n' =>
    x * power_v0_aux x n'
  end.

Definition power_v0 (x n : nat) : nat :=
  power_v0_aux x n.

Compute (test_power power_v0).

Lemma fold_unfold_power_v0_aux_O :
  forall x : nat,
    power_v0_aux x 0 = 1.
Proof.
  fold_unfold_tactic power_v0_aux.
Qed.

Lemma fold_unfold_power_v0_aux_S :
  forall x n' : nat,
    power_v0_aux x (S n') = x * power_v0_aux x n'.
Proof.
  fold_unfold_tactic power_v0_aux.
Qed.

Proposition power_v0_safisfies_the_specification_of_power :
  specification_of_power power_v0.
Proof.
  unfold specification_of_power, power_v0.
  split.
  - exact fold_unfold_power_v0_aux_O.
  - exact fold_unfold_power_v0_aux_S.
Qed.

(* ***** *)

Fixpoint power_v1_aux (x n a : nat) : nat :=
  match n with
  | O =>
    a
  | S n' =>
    power_v1_aux x n' (x * a)
  end.

Definition power_v1 (x n : nat) : nat :=
  power_v1_aux x n 1.

Compute (test_power power_v1).

Lemma fold_unfold_power_v1_aux_O :
  forall x a : nat,
    power_v1_aux x 0 a =
    a.
Proof.
  fold_unfold_tactic power_v1_aux.
Qed.

Lemma fold_unfold_power_v1_aux_S :
  forall x n' a : nat,
    power_v1_aux x (S n') a =
    power_v1_aux x n' (x * a).
Proof.
  fold_unfold_tactic power_v1_aux.
Qed.

(* ***** *)

(* Eureka lemma: *)

Lemma about_power_v0_aux_and_power_v1_aux :
  forall x n a : nat,
    power_v0_aux x n * a = power_v1_aux x n a.
Proof.
  intros x n.
  induction n as [ | n' IHn'].
  - intro a.
    rewrite -> (fold_unfold_power_v0_aux_O x).
    rewrite -> (fold_unfold_power_v1_aux_O x a).
    exact (Nat.mul_1_l a).
  - intro a.
    rewrite -> (fold_unfold_power_v0_aux_S x n').
    rewrite -> (fold_unfold_power_v1_aux_S x n' a).
    Check (IHn' (x * a)).
    rewrite <- (IHn' (x * a)).
    rewrite -> (Nat.mul_comm x (power_v0_aux x n')).
    Check (Nat.mul_assoc).
    symmetry.
    exact (Nat.mul_assoc (power_v0_aux x n') x a).
Qed.

Theorem power_v0_and_power_v1_are_equivalent :
  forall x n : nat,
    power_v0 x n = power_v1 x n.
Proof.
  intros x n.
  unfold power_v0, power_v1.
  Check (about_power_v0_aux_and_power_v1_aux x n 1).
  rewrite <- (Nat.mul_1_r (power_v0_aux x n)).
  exact (about_power_v0_aux_and_power_v1_aux x n 1).
Qed.

(* ********** *)

Fixpoint nat_fold_right (V : Type) (z : V) (s : V -> V) (n : nat) : V :=
  match n with
  | O =>
    z
  | S n' =>
    s (nat_fold_right V z s n')
  end.

Lemma fold_unfold_nat_fold_right_O :
  forall (V : Type)
         (z : V)
         (s : V -> V),
    nat_fold_right V z s O =
    z.
Proof.
  fold_unfold_tactic nat_fold_right.
Qed.

Lemma fold_unfold_nat_fold_right_S :
  forall (V : Type)
         (z : V)
         (s : V -> V)
         (n' : nat),
    nat_fold_right V z s (S n') =
    s (nat_fold_right V z s n').
Proof.
  fold_unfold_tactic nat_fold_right.
Qed.

(* ***** *)

Fixpoint nat_fold_left (V : Type) (z : V) (s : V -> V) (n : nat) : V :=
  match n with
  | O =>
    z
  | S n' =>
    nat_fold_left V (s z) s n'
  end.

Lemma fold_unfold_nat_fold_left_O :
  forall (V : Type)
         (z : V)
         (s : V -> V),
    nat_fold_left V z s O =
    z.
Proof.
  fold_unfold_tactic nat_fold_left.
Qed.

Lemma fold_unfold_nat_fold_left_S :
  forall (V : Type)
         (z : V)
         (s : V -> V)
         (n' : nat),
    nat_fold_left V z s (S n') =
    nat_fold_left V (s z) s n'.
Proof.
  fold_unfold_tactic nat_fold_left.
Qed.

(* ********** *)

Definition power_v0_alt (x n : nat) : nat :=
  nat_fold_right nat 1 (fun ih => x * ih) n.

Compute (test_power power_v0_alt).

Proposition power_v0_alt_safisfies_the_specification_of_power :
  specification_of_power power_v0_alt.
Proof.
  unfold specification_of_power, power_v0_alt.
  split.
  - intro x.
    rewrite -> (fold_unfold_nat_fold_right_O nat 1 (fun ih : nat => x * ih)).
    reflexivity.
  - intros x n'.
    rewrite -> (fold_unfold_nat_fold_right_S nat 1 (fun ih : nat => x * ih) n').
    reflexivity.
Qed.

Corollary power_v0_and_power_v0_alt_are_equivalent :
  forall x n : nat,
    power_v0 x n = power_v0_alt x n.
Proof.
  intros x n.
  Check (there_is_at_most_one_function_satisfying_the_specification_of_power
           power_v0
           power_v0_alt
           power_v0_safisfies_the_specification_of_power
           power_v0_alt_safisfies_the_specification_of_power
           x
           n).
  exact (there_is_at_most_one_function_satisfying_the_specification_of_power
           power_v0
           power_v0_alt
           power_v0_safisfies_the_specification_of_power
           power_v0_alt_safisfies_the_specification_of_power
           x
           n).
Qed.

(* ***** *)

Definition power_v1_alt (x n : nat) : nat :=
  nat_fold_left nat 1 (fun ih => x * ih) n.

Compute (test_power power_v1_alt).

Lemma power_v1_and_power_v1_alt_are_equivalent_aux :
  forall x n a : nat,
    power_v1_aux x n a = nat_fold_left nat a (fun ih : nat => x * ih) n.
Proof.
  intros x n.
  induction n as [ | n' IHn'].
  - intro a.
    rewrite -> (fold_unfold_power_v1_aux_O x a).
    rewrite -> (fold_unfold_nat_fold_left_O nat a (fun ih : nat => x * ih)).
    reflexivity.
  - intro a.
    rewrite -> (fold_unfold_power_v1_aux_S x n' a).
    rewrite -> (fold_unfold_nat_fold_left_S nat a (fun ih : nat => x * ih) n').
    Check (IHn' (x * a)).
    exact (IHn' (x * a)).
Qed.

Proposition power_v1_and_power_v1_alt_are_equivalent :
  forall x n : nat,
    power_v1 x n = power_v1_alt x n.
Proof.
  intros x n.
  unfold power_v1, power_v1_alt.
  exact (power_v1_and_power_v1_alt_are_equivalent_aux x n 1).
Qed.

(* ********** *)

Lemma about_nat_fold_left :
  forall (V : Type) (z : V) (s : V -> V) (n : nat),
    nat_fold_left V (s z) s n = s (nat_fold_left V z s n).
Proof.
Admitted.

Lemma about_nat_fold_right :
  forall (V : Type) (z : V) (s : V -> V) (n : nat),
    nat_fold_right V (s z) s n = s (nat_fold_right V z s n).
Proof.
Admitted.

Theorem folding_left_and_right :
  forall (V : Type) (z : V) (s : V -> V) (n : nat),
    nat_fold_left V z s n = nat_fold_right V z s n.
Proof.
  intros V z s n.
  revert z.
  induction n as [ | n' IHn'].
  - intro z.
    rewrite -> (fold_unfold_nat_fold_left_O V z s).
    rewrite -> (fold_unfold_nat_fold_right_O V z s).
    reflexivity.
  - intro z.
    rewrite -> (fold_unfold_nat_fold_left_S V z s n').
    rewrite -> (fold_unfold_nat_fold_right_S V z s n').
(*
    rewrite -> (about_nat_fold_left V z s n').
    rewrite -> (IHn' z).
    reflexivity.
*)
    rewrite <- (about_nat_fold_right V z s n').
    Check (IHn' (s z)).
    exact (IHn' (s z)).
Qed.

(* ********** *)

Corollary power_v0_and_power_v1_are_equivalent_alt :
  forall x n : nat,
    power_v0 x n = power_v1 x n.
Proof.
  intros x n.
  rewrite -> (power_v0_and_power_v0_alt_are_equivalent x n).
  rewrite -> (power_v1_and_power_v1_alt_are_equivalent x n).
  unfold power_v0_alt, power_v1_alt.
  symmetry.
  exact (folding_left_and_right nat 1 (fun ih : nat => x * ih) n).
Qed.

(* ********** *)

(* Exercise 2a *)

Definition recursive_specification_of_multiplication (mul : nat -> nat -> nat) :=
    ((forall j : nat,
         mul O j = 0)
     /\
     (forall i' j : nat,
         mul (S i') j = j + (mul i' j))).

Proposition there_is_at_most_one_function_satisfying_the_recursive_specification_of_multiplication :
  forall mul1 mul2 : nat -> nat -> nat,
    recursive_specification_of_multiplication mul1 ->
    recursive_specification_of_multiplication mul2 ->
    forall i j : nat,
      mul1 i j = mul2 i j.
Proof.
  intros mul1 mul2.
  unfold recursive_specification_of_multiplication.
  intros [S1_O S1_S] [S2_O S2_S] i j.
  induction i as [ | i' IHi'].
  - rewrite -> (S2_O j).
    exact (S1_O j).
  - rewrite -> (S2_S i' j).
    rewrite -> (S1_S i' j).
    rewrite -> IHi'.
    reflexivity.
Qed.

Definition test_mul (candidate: nat -> nat -> nat) : bool :=
  (candidate 0 0 =n= 0)
  &&
  (candidate 0 1 =n= 0)
  &&
  (candidate 1 0 =n= 0)
  &&
  (candidate 1 1 =n= 1)
  &&
  (candidate 1 2 =n= 2)
  &&
  (candidate 2 1 =n= 2)
  &&
  (candidate 2 2 =n= 4)
  &&
  (candidate 2 3 =n= 6)
  &&
  (candidate 3 2 =n= 6)
  &&
  (candidate 6 4 =n= 24)
  &&
  (candidate 4 6 =n= 24)
  (* etc. *)
  .

Fixpoint mul_v0_aux (i j : nat) : nat :=
  match i with
    | O => 0
    | S i' => j + (mul_v0_aux i' j)
  end.

Lemma fold_unfold_mul_v0_aux_O :
  forall j : nat,
    mul_v0_aux O j = 0.
Proof.
  fold_unfold_tactic mul_v0_aux.
Qed.

Lemma fold_unfold_mul_v0_aux_S :
  forall i' j : nat,
    mul_v0_aux (S i') j = j + (mul_v0_aux i' j).
Proof.
  fold_unfold_tactic mul_v0_aux.
Qed.

Definition mul_v0 (i j : nat) : nat :=
  mul_v0_aux i j.

Proposition mul_v0_safisfies_the_specification_of_multiplication :
  recursive_specification_of_multiplication mul_v0.
Proof.
  unfold recursive_specification_of_multiplication, mul_v0.
  split.
  - exact fold_unfold_mul_v0_aux_O.
  - exact fold_unfold_mul_v0_aux_S.
Qed.

Compute (test_mul mul_v0).

Definition mul_v0_alt (i j : nat) : nat :=
  nat_fold_right nat 0 (fun ih => j + ih) i.

Proposition mul_v0_alt_safisfies_the_specification_of_multiplication :
  recursive_specification_of_multiplication mul_v0_alt.
Proof.
  unfold recursive_specification_of_multiplication, mul_v0_alt.
  split.
  - intro j.
    rewrite -> (fold_unfold_nat_fold_right_O nat 0 (fun ih : nat => j + ih)).
    reflexivity.
  - intros i' j.
    rewrite -> (fold_unfold_nat_fold_right_S nat 0 (fun ih : nat => j + ih) i').
    reflexivity.
Qed.

Compute (test_mul mul_v0_alt).

Corollary mul_v0_and_mul_v0_alt_are_equivalent :
  forall i j : nat,
    mul_v0 i j = mul_v0_alt i j.
Proof.
  - intros i j.
    Check (there_is_at_most_one_function_satisfying_the_recursive_specification_of_multiplication
             mul_v0
             mul_v0_alt
             mul_v0_safisfies_the_specification_of_multiplication
             mul_v0_alt_safisfies_the_specification_of_multiplication
             i
             j
          ).
    exact (there_is_at_most_one_function_satisfying_the_recursive_specification_of_multiplication
             mul_v0
             mul_v0_alt
             mul_v0_safisfies_the_specification_of_multiplication
             mul_v0_alt_safisfies_the_specification_of_multiplication
             i
             j
          ).
Qed.

(* Exercise 2b *)

Fixpoint mul_v1_aux (i j a : nat) : nat :=
  match i with
    | O => a
    | S i' => mul_v1_aux i' j (j + a)
  end.

Lemma fold_unfold_mul_v1_aux_O :
  forall j a : nat,
    mul_v1_aux O j a = a.
Proof.
  fold_unfold_tactic mul_v1_aux.
Qed.

Lemma fold_unfold_mul_v1_aux_S :
  forall i' j a : nat,
    mul_v1_aux (S i') j a = mul_v1_aux i' j (j + a).
Proof.
  fold_unfold_tactic mul_v1_aux.
Qed.

Definition mul_v1 (i j : nat) : nat :=
  mul_v1_aux i j 0.

Compute (test_mul mul_v1).

Definition mul_v1_alt (i j : nat) : nat :=
  nat_fold_left nat 0 (fun ih => j + ih) i.

Compute (test_mul mul_v1_alt).

Lemma mul_v1_and_mul_v1_alt_are_equivalent_aux :
  forall i j a : nat,
    mul_v1_aux i j a = nat_fold_left nat a (fun ih : nat => j + ih) i.
Proof.
  intros i j.
  induction i as [ | i' IHi'].
  - intro a.
    rewrite -> (fold_unfold_mul_v1_aux_O j a).
    rewrite -> (fold_unfold_nat_fold_left_O nat a (fun ih : nat => j + ih)).
    reflexivity.
  - intro a.
    rewrite -> (fold_unfold_mul_v1_aux_S i' j a).
    rewrite -> (fold_unfold_nat_fold_left_S nat a (fun ih : nat => j + ih) i').
    Check (IHi' (j + a)).
    exact (IHi' (j + a)).
Qed.

Proposition mul_v1_and_mul_v1_alt_are_equivalent :
  forall i j : nat,
    mul_v1 i j = mul_v1_alt i j.
Proof.
  intros i j.
  unfold mul_v1, mul_v1_alt.
  exact (mul_v1_and_mul_v1_alt_are_equivalent_aux i j 0).
Qed.

(* Exercise 2c *)

Corollary mul_v0_and_mul_v1_are_equivalent_alt :
  forall i j : nat,
    mul_v0 i j = mul_v1 i j.
Proof.
  intros i j.
  rewrite -> (mul_v0_and_mul_v0_alt_are_equivalent i j).
  rewrite -> (mul_v1_and_mul_v1_alt_are_equivalent i j).
  unfold mul_v0_alt, mul_v1_alt.
  symmetry.
  exact (folding_left_and_right nat 0 (fun ih : nat => j + ih) i).
Qed.

(* ********** *)

(* Exercise 3 *)

(* The sumtorial function *)

Definition specification_of_sum_n (sum_n :  nat -> nat) :=
  (sum_n 0 = 0)
  /\
  (forall n' : nat,
      sum_n (S n') = (S n') + sum_n n').

(* ***** *)

Proposition there_is_at_most_one_function_satisfying_the_specification_of_sum_n :
  forall sum_n1 sum_n2 :  nat -> nat,
    specification_of_sum_n sum_n1 ->
    specification_of_sum_n sum_n2 ->
    forall n : nat,
      sum_n1 n = sum_n2 n.
Proof.
  intros sum_n1 sum_n2.
  unfold specification_of_sum_n.
  intros [S1_O S1_S] [S2_O S2_S] n.
  induction n as [ | n' IHn'].
  - rewrite -> (S2_O).
    exact (S1_O).
  - rewrite -> (S1_S n').
    rewrite -> (S2_S n').
    rewrite -> IHn'.
    reflexivity.
Qed.
(* ***** *)

Definition test_sum_n (candidate : nat  -> nat) : bool :=
  (candidate 1 =? 1) &&
  (candidate 2 =? 3) &&
  (candidate 3 =? 6) &&
  (candidate 10 =? 55)
.

(* ***** *)

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

Definition sum_n_v0 (n : nat) : nat :=
  sum_n_v0_aux n.

Compute (test_sum_n sum_n_v0).

Lemma fold_unfold_sum_n_v0_aux_O :
   sum_n_v0_aux 0 = 0.
Proof.
  fold_unfold_tactic sum_n_v0_aux.
Qed.

Lemma fold_unfold_sum_n_v0_aux_S :
  forall n' : nat,
    sum_n_v0_aux (S n') = (S n') + sum_n_v0_aux n'.
Proof.
  fold_unfold_tactic sum_n_v0_aux.
Qed.

Proposition sum_n_v0_safisfies_the_specification_of_sum_n :
  specification_of_sum_n sum_n_v0.
Proof.
  unfold specification_of_sum_n, sum_n_v0.
  split.
  - exact fold_unfold_sum_n_v0_aux_O.
  - exact fold_unfold_sum_n_v0_aux_S.
Qed.

(* ***** *)

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

Definition sum_n_v1 (n : nat) : nat :=
  sum_n_v1_aux n 0.

Compute (test_sum_n sum_n_v1).

Lemma fold_unfold_sum_n_v1_aux_O :
  forall a : nat,
    sum_n_v1_aux 0 a =
    a.
Proof.
  fold_unfold_tactic sum_n_v1_aux.
Qed.

Lemma fold_unfold_sum_n_v1_aux_S :
  forall n' a : nat,
    sum_n_v1_aux (S n') a =
    sum_n_v1_aux n' ((S n') + a).
Proof.
  fold_unfold_tactic sum_n_v1_aux.
Qed.

(* ***** *)

(* Eureka lemma: *)

Lemma about_sum_n_v0_aux_and_sum_n_v1_aux :
  forall n a : nat,
    sum_n_v0_aux n + a = sum_n_v1_aux n a.
Proof.
  intro n.
  induction n as [ | n' IHn'].
  - intro a.
    rewrite -> (fold_unfold_sum_n_v0_aux_O).
    rewrite -> (fold_unfold_sum_n_v1_aux_O a).
    Search(0+_).
    exact (Nat.add_0_l a).
  - intro a.
    rewrite -> (fold_unfold_sum_n_v0_aux_S n').
    rewrite -> (fold_unfold_sum_n_v1_aux_S n' a).
    Check (IHn' ((S n') + a)).
    rewrite <- (IHn' ((S n') + a)).
    rewrite -> (Nat.add_comm (S n') (sum_n_v0_aux n')).
    Check (Nat.add_assoc).
    symmetry.
    exact (Nat.add_assoc (sum_n_v0_aux n') (S n') a).
Qed.

Theorem sum_n_v0_and_sum_n_v1_are_equivalent :
  forall n : nat,
    sum_n_v0 n = sum_n_v1 n.
Proof.
  intros n.
  unfold sum_n_v0, sum_n_v1.
  Check (about_sum_n_v0_aux_and_sum_n_v1_aux n 0).
  rewrite <- (Nat.add_0_r (sum_n_v0_aux n)).
  exact (about_sum_n_v0_aux_and_sum_n_v1_aux n 0).
Qed.

(* ********** *)
(* ********** *)

(* Remark: partitially inspired by Section 2.4 of Prof Danvy's paper "Folding left and right over Peano numbers" *)

(* <OD> *)

(*
Definition sum_n_v0_alt_helper (n : nat) : nat * nat :=
  nat_fold_right (nat * nat)
                 (0,0)
                 (fun c => let (ind, sum) := c in (ind + 1, sum + ind + 1))
                 n.
*)

Definition sum_n_v0_alt_helper (n : nat) : nat * nat :=
  nat_fold_right (nat * nat)
                 (0, 0)
                 (fun c => let (ind, sum) := c in (S ind, S ind + sum))
                 n.

Definition sum_n_v0_alt (n : nat) : nat :=
   let (ind, sum) := sum_n_v0_alt_helper n in sum.

Compute (test_sum_n sum_n_v0_alt).

Lemma about_sum_n_v0_alt_helper :
  forall n ind res: nat,
    nat_fold_right (nat * nat)
                   (0, 0)
                   (fun c => let (ind, sum) := c in (S ind, S ind + sum))
                   n = (ind, res) ->
    n = ind.
Proof.
  intro n.
  induction n as [ | n' IHn'].
  - intros ind res.
    rewrite -> (fold_unfold_nat_fold_right_O (nat * nat) (0, 0) (fun c : nat * nat => let (ind, sum) := c in (S ind, S ind + sum))).
    intros H_tmp.
    injection H_tmp as H_ind H_res.
    exact H_ind.
  - intros ind res.
    rewrite -> (fold_unfold_nat_fold_right_S (nat * nat) (0, 0) (fun c : nat * nat => let (ind, sum) := c in (S ind, S ind + sum)) n').
    case (nat_fold_right (nat * nat) (0, 0) (fun c : nat * nat => let (ind0, sum) := c in (S ind0, S ind0 + sum)) n') as (x, y).
    intro H_tmp.
    injection H_tmp as H_ind H_res.
    rewrite <- H_ind.
    Check (IHn' x y).
    Check (IHn' x y (eq_refl (x, y))).
    rewrite <- (IHn' x y (eq_refl (x, y))).
    reflexivity.
Qed.

(* NO PROBLEM HERE *)

Proposition sum_n_v0_alt_safisfies_the_specification_of_sum_n :
  specification_of_sum_n sum_n_v0_alt.
Proof.
  unfold specification_of_sum_n, sum_n_v0_alt.
  Check specification_of_sum_n.
  split.
  - destruct (sum_n_v0_alt_helper 0) as (_, sum_n_O).
    rewrite <- (sum_n_v0_alt 0).
    Check sum_n_O.
    Check (fold_unfold_nat_fold_right_O (nat * nat) (_,sum_n_O) (fun c => let (_, sum_n_O) := c in (_, sum_n_O +_+ 1))).
=======
  unfold specification_of_sum_n, sum_n_v0_alt, sum_n_v0_alt_helper.
  split.
  - rewrite -> (fold_unfold_nat_fold_right_O (nat * nat) (0, 0) (fun c : nat * nat => let (ind, sum) := c in (S ind, S ind + sum))).
    reflexivity.
>>>>>>> 98035c6356c96242f70ffd7a101fd8d1c8d19331
=======
  unfold specification_of_sum_n, sum_n_v0_alt, sum_n_v0_alt_helper.
  split.
  - rewrite -> (fold_unfold_nat_fold_right_O (nat * nat) (0, 0) (fun c : nat * nat => let (ind, sum) := c in (S ind, S ind + sum))).
    reflexivity.
>>>>>>> 98035c6356c96242f70ffd7a101fd8d1c8d19331
  - intro n'.
    rewrite -> (fold_unfold_nat_fold_right_S (nat * nat) (0, 0) (fun c : nat * nat => let (ind, sum) := c in (S ind, S ind + sum)) n').
    destruct (nat_fold_right (nat * nat) (0, 0) (fun c : nat * nat => let (ind, sum) := c in (S ind, S ind + sum)) n') as (ind, res) eqn:H_witness.
    Check (about_sum_n_v0_alt_helper n' ind res H_witness).
    rewrite <- (about_sum_n_v0_alt_helper n' ind res H_witness).
    reflexivity.
Qed.

Corollary sum_n_v0_and_sum_n_v0_alt_are_equivalent :
  forall n : nat,
    sum_n_v0 n = sum_n_v0_alt n.
Proof.
  intros n.
  exact (there_is_at_most_one_function_satisfying_the_specification_of_sum_n
           sum_n_v0
           sum_n_v0_alt
           sum_n_v0_safisfies_the_specification_of_sum_n
           sum_n_v0_alt_safisfies_the_specification_of_sum_n
           n).
Qed.
(* ***** *)

Definition sum_n_v1_alt_helper (n : nat) : nat * nat :=
  nat_fold_left (nat * nat)
                 (0,0)
                 (fun c => let (ind, sum) := c in (ind + 1, sum + ind + 1))
                 n.
Definition sum_n_v1_alt (n : nat) : nat :=
   let (ind,sum) := sum_n_v0_alt_helper n in sum.

Compute (test_sum_n sum_n_v1_alt).

Lemma sum_n_v1_and_sum_n_v1_alt_are_equivalent_aux :
  forall n a : nat,
    sum_n_v1_aux n a = sum_n_v1_alt n.
Proof.
Admitted.

Proposition sum_n_v1_and_sum_n_v1_alt_are_equivalent :
  forall n : nat,
    sum_n_v1 n = sum_n_v1_alt n.
Proof.
  intro  n.
  unfold sum_n_v1, sum_n_v1_alt.
  exact (sum_n_v1_and_sum_n_v1_alt_are_equivalent_aux n 0).
Qed.

(* ********** *)

Corollary sum_n_v0_and_sum_n_v1_are_equivalent_alt :
  forall n : nat,
    sum_n_v0 n = sum_n_v1 n.
Proof.
  intros n.
  rewrite -> (sum_n_v0_and_sum_n_v0_alt_are_equivalent n).
  rewrite -> (sum_n_v1_and_sum_n_v1_alt_are_equivalent n).
  unfold sum_n_v0_alt, sum_n_v1_alt.
  symmetry.
  reflexivity.
Qed.

(* end of week-05_folding-left-and-right-over-peano-numbers.v *)