(* Copyright 2012-2015 by Adam Petcher.				*
 * Use of this source code is governed by the license described	*
 * in the LICENSE file at the root of the source tree.		*)

(* A theory of limits of a sequence *)

Set Implicit Arguments.

Require Import Arith.
Require Import FCF.Fold.
Require Import List.

Require Import FCF.StdNat.
Require Import FCF.Rat.

Section Limit.

  Variable A : Set.
  Variable eq : A -> A -> Prop.
  Hypothesis eq_dec : forall (a1 a2 : A),
    {eq a1 a2} + {~eq a1 a2}.
  Hypothesis eq_refl : forall (a : A),
    eq a a.
  Hypothesis eq_symm : forall a1 a2,
    eq a1 a2 ->
    eq a2 a1.

  Variable distance : A -> A -> A.
  Hypothesis distance_comm : forall a1 a2,
    eq (distance a1 a2) (distance a2 a1).
  Variable half : A -> A.
  Variable zero : A.
  Hypothesis half_nz : forall (a : A),
    ~eq a zero ->
    ~eq (half a) zero.

  Hypothesis distance_eq_zero : forall (a1 a2 : A),
    eq a1 a2 <->
    eq (distance a1 a2) zero.
  Hypothesis distance_eq_compat : forall a1 a2 a3 a4,
    eq a1 a3 ->
    eq a2 a4 ->
    eq (distance a1 a2) (distance a3 a4).

  Variable le : A -> A -> Prop.
  Hypothesis le_eq : forall (a1 a2 : A),
    eq a1 a2 ->
    le a1 a2.
  Hypothesis le_trans : forall (a1 a2 a3 : A),
    le a1 a2 ->
    le a2 a3 ->
    le a1 a3.

  (* all numbers positive *)
  Hypothesis all_pos : forall (a : A),
    le zero a.
  Hypothesis le_impl_eq : forall (a1 a2 : A),
    le a1 a2 ->
    le a2 a1 ->
    eq a1 a2.

  Variable plus : A -> A -> A.
  Variable plus_0_eq : forall (a1 a2 : A),
    eq a2 zero ->
    eq a1 (plus a1 a2).
  Variable plus_le_compat : forall a1 a2 a3 a4,
    le a1 a2 ->
    le a3 a4 ->
    le (plus a1 a3) (plus a2 a4).

  Hypothesis triangle_inequality : forall (a1 a2 a3 : A),
    le (distance a1 a2) (plus (distance a1 a3) (distance a3 a2)).
  Hypothesis half_plus : forall (a : A),
    eq (plus (half a) (half a)) a.
  Hypothesis le_half : forall (a : A),
    le a (half a) ->
    eq a zero.

  Theorem le_epsilon_zero : forall (a : A),
    (forall (epsilon : A), ~eq epsilon zero -> le a epsilon) ->
    eq a zero.

    intuition.

    destruct (eq_dec a zero).
    trivial.

    exfalso.
    specialize (H (half a)).
    apply f.
    eapply le_half.
    apply H.
    eapply half_nz.
    trivial.
  Qed.

  Definition left_total(r : nat -> A -> Prop) :=
    forall n, exists a, r n a.

  Definition functional(r : nat -> A -> Prop) :=
    forall n a1 a2,
      r n a1 ->
      r n a2 ->
      eq a1 a2.

  Definition inf_limit(f : nat -> A -> Prop)(a : A) :=
    forall (epsilon : A),
      ~eq epsilon zero ->
      exists n : nat,
        forall (n' : nat),
          n' >= n ->
          forall a',
            f n' a' ->
            le (distance a' a) epsilon.

    (* Note: if the codomain of the relation is empty (after any point), then we can assign any limit to it. *)

  (* We could define inf_limit in terms of inf_limit_2, but inf_limit_2 only shows up in proofs, while inf_limit shows up in top-level definitions. *)
  Definition inf_limit_2(f f' : nat -> A -> Prop) :=
    forall (epsilon : A),
      ~eq epsilon zero ->
      exists n : nat,
        forall (n' : nat),
          n' >= n ->
          forall a a',
            f n' a ->
            f' n' a' ->
            le (distance a a') epsilon.

  Theorem inf_limit_2_const : forall (f : nat -> A -> Prop)(a : A),
    inf_limit_2 f (fun x => eq a) <->
    inf_limit f a.

    intuition.
  Abort.

(*  limits are unique for left-total relations *)
  Theorem limit_eq_h : forall f epsilon a1 a2,
    left_total f ->
    ~eq epsilon zero ->
    inf_limit f a1 ->
    inf_limit f a2 ->
    le (distance a1 a2) epsilon.

   (*  remember half as h. *)

    intuition.
    unfold inf_limit in *.
    intuition.
    specialize (H1 (half epsilon)).
    specialize (H2 (half epsilon)).

    destruct H1.
    intuition.
    eapply half_nz; eauto.

    destruct H2.
    intuition.
    eapply half_nz; eauto.

    destruct (H (max x x0)).
    specialize (H1 (max x x0)).
    specialize (H2 (max x x0)).

    eapply le_trans.
    eapply (triangle_inequality _ _ x1).
    eapply le_trans.
    eapply plus_le_compat.
    eapply le_trans.
    eapply le_eq.
    eapply distance_comm.
    eapply H1.
    eapply Max.max_lub_l; eauto.
    trivial.
    eapply H2.
    eapply Max.max_lub_r; eauto.
    trivial.
    eapply le_eq.
    eapply half_plus.
  Qed.

  Theorem limits_eq : forall f a1 a2,
    left_total f ->
    inf_limit f a1 ->
    inf_limit f a2 ->
    eq a1 a2.

    intuition.
    eapply distance_eq_zero.

    eapply le_epsilon_zero.
    intuition.

    eapply limit_eq_h; eauto.
  Qed.

  Theorem limit_f_eq : forall f1 f2 a,
    inf_limit f1 a ->
    (forall n a', (f1 n a' <-> f2 n a')) ->
    inf_limit f2 a.

    unfold inf_limit; intuition.

    destruct (H epsilon).
    trivial.
    exists x.
    intuition.
    eapply H2.
    eapply H3.
    eapply H0.
    trivial.
  Qed.

End Limit.

(* limits for Rat *)
Local Open Scope rat_scope.

Definition rat_inf_limit(f : nat -> Rat -> Prop)(r : Rat) :=
  inf_limit eqRat ratDistance rat0 leRat f r.

Definition rat_inf_limit_2(f1 f2 : nat -> Rat -> Prop) :=
  inf_limit_2 eqRat ratDistance rat0 leRat f1 f2.

Definition rat_limits_eq :=
  limits_eq eq_Rat_dec ratDistance_comm ratHalf ratHalf_ne_0 ratIdentityIndiscernables eqRat_impl_leRat leRat_trans ratAdd ratAdd_leRat_compat ratTriangleInequality ratHalf_add le_ratHalf_0.

Require Import Arith.

Theorem rat_inf_limit_2_trans : forall f1 f2 f3,
  rat_inf_limit_2 f1 f2 ->
  rat_inf_limit_2 f2 f3 ->
  left_total f2 ->
  rat_inf_limit_2 f1 f3.

  unfold rat_inf_limit_2, inf_limit_2; intuition.
  edestruct (H (ratHalf epsilon)).
  eapply ratHalf_ne_0; intuition.
  edestruct (H0 (ratHalf epsilon)); eauto.
  eapply ratHalf_ne_0.
  intuition.
  exists (max x x0).
  intuition.
  destruct (H1 n').
  eapply leRat_trans.
  eapply ratDistance_le_trans.
  eapply H3.
  eapply Max.max_lub_l.
  eapply H5.
  trivial.
  eapply H8.
  eapply H4.
  eapply Max.max_lub_r.
  eapply H5.
  eauto.
  trivial.
  eapply eqRat_impl_leRat.
  eapply ratHalf_add.
Qed.

Lemma rat_inf_limit_squeeze : forall (f1 f2 f: nat -> Rat -> Prop) c (v : Rat),
  rat_inf_limit f1 v ->
  rat_inf_limit f2 v ->
  (forall n a a1, n >= c -> f n a -> f1 n a1 -> a1 <= a) ->
  (forall n a a2, n >= c -> f n a -> f2 n a2 -> a <= a2) ->
  left_total f1 ->
  left_total f2 ->
  rat_inf_limit f v.

  unfold rat_inf_limit, inf_limit in *.
  intuition.
  destruct (H epsilon); intuition.
  destruct (H0 epsilon); intuition.
  exists (max c (max x x0)).
  intuition.

  destruct (H3 n').
  destruct (H4 n').
  eapply leRat_trans.
  eapply ratDistance_le_max.
  eapply H1.
  eapply Max.max_lub_l.
  eauto.
  eapply H9.
  eapply H10.

  eapply H2.
  eapply Max.max_lub_l.
  eauto.
  eapply H9.
  eapply H11.

  eapply maxRat_leRat_same; eauto using Max.max_lub_l, Max.max_lub_r.

Qed.

Lemma rat_inf_limit_div_2 : forall (f : nat -> Rat -> Prop)(v : Rat),
  rat_inf_limit f v ->
  rat_inf_limit (fun n => (f (div2 n))) v.

  unfold rat_inf_limit, inf_limit.
  intuition.
  destruct (H epsilon); intuition.

  econstructor.
  intuition.
  specialize (H1 (div2 n')).
  eapply H1.

  eapply div2_ge; eauto.
  eauto.
Qed.

Lemma rat_inf_limit_sum : forall (f1 f2 : nat -> Rat -> Prop) v1 v2,
  left_total f1 ->
  left_total f2 ->
  rat_inf_limit f1 v1 ->
  rat_inf_limit f2 v2 ->
  rat_inf_limit (fun n => (ratAdd_rel (f1 n) (f2 n))) (v1 + v2).

  unfold rat_inf_limit, inf_limit in *.
  intuition.
  edestruct (H1 (ratHalf epsilon)).
  eapply ratHalf_ne_0.
  intuition.
  edestruct (H2 (ratHalf epsilon)).
  eapply ratHalf_ne_0.
  intuition.
  exists (Max.max x x0).
  intuition.
  unfold ratAdd_rel in *.
  destruct (H n').
  destruct (H0 n').
  rewrite H7; eauto.
  eapply leRat_trans.
  eapply rat_distance_of_sum.
  rewrite H4.
  rewrite H5.
  rewrite ratHalf_add.
  intuition.
  eapply Max.max_lub_r.
  eauto.
  trivial.
  eapply Max.max_lub_l.
  eauto.
  trivial.
Qed.

Lemma rat_inf_limit_difference : forall (f1 f2 : nat -> Rat -> Prop) c1 c2,
  left_total f1 ->
  left_total f2 ->
  rat_inf_limit f1 c1 ->
  rat_inf_limit f2 c2 ->
  rat_inf_limit (fun n => (ratSubtract_rel (f1 n) (f2 n))) (ratSubtract c1 c2).

  unfold rat_inf_limit, inf_limit in *.
  intuition.

  destruct (le_Rat_dec c1 c2).

  edestruct (H1 (ratHalf epsilon)).
  eapply ratHalf_ne_0.
  intuition.
  edestruct (H2 (ratHalf epsilon)).
  eapply ratHalf_ne_0.
  intuition.
  exists (Max.max x x0).
  intuition.
  unfold ratSubtract_rel in *.
  destruct (H n').
  destruct (H0 n').
  rewrite H7; eauto.
  rewrite (ratSubtract_0 l).
  eapply ratDistance_0_r_le.

  eapply leRat_trans.
  eapply ratSubtract_partition_leRat.

  eapply ratSubtract_ratDistance_le.
  2:{
    rewrite H4.
    rewrite ratHalf_add.
    intuition.
    eapply Max.max_lub_l.
    eauto.
    trivial.
  }
  eapply leRat_trans.
  eapply ratSubtract_partition_leRat.
  rewrite ratSubtract_0.
  eapply leRat_refl.
  eapply l.
  eapply ratSubtract_ratDistance_le.
  rewrite ratDistance_comm.
  rewrite H5.
  rewrite <- ratAdd_0_l.
  intuition.
  eapply Max.max_lub_r.
  eauto.
  trivial.

  edestruct (H1 (minRat (ratHalf epsilon) (ratHalf (ratSubtract c1 c2)))).
  intuition.
  unfold minRat in *.
  destruct (bleRat (ratHalf epsilon) (ratHalf (ratSubtract c1 c2))).
  eapply ratHalf_ne_0 in H4;
  intuition.
  eapply ratHalf_ne_0 in H4;
  intuition.
  eapply n.
  eapply ratSubtract_0_inv.
  trivial.

  edestruct (H2 (minRat (ratHalf epsilon) (ratHalf (ratSubtract c1 c2)))).
  intuition.
  unfold minRat in *.
  destruct (bleRat (ratHalf epsilon) (ratHalf (ratSubtract c1 c2))).
  eapply ratHalf_ne_0 in H5;
  intuition.
  eapply ratHalf_ne_0 in H5;
  intuition.
  eapply n.
  eapply ratSubtract_0_inv.
  trivial.

  exists (Max.max x x0).
  intuition.
  destruct (H n').
  destruct (H0 n').
  unfold ratSubtract_rel in *.
  rewrite H7; eauto.
  assert (x2 <= x1).
  eapply leRat_trans.
  eapply ratDistance_le_sum.
  eapply H5.
  eapply Max.max_lub_r.
  eauto.
  trivial.
  eapply leRat_trans.
  eapply ratAdd_leRat_compat.
  eapply leRat_refl.

  eapply minRat_le_r.
  eapply (leRat_ratAdd_same_r (ratHalf (ratSubtract c1 c2))).
  rewrite ratAdd_assoc.
  rewrite ratHalf_add.
  rewrite ratSubtract_ratAdd_inverse_2.
  eapply ratDistance_le_sum.
  eapply leRat_trans.
  rewrite ratDistance_comm.
  eapply H4.
  eapply Max.max_lub_l.
  eauto.
  trivial.
  eapply minRat_le_r.
  case_eq (bleRat c1 c2); intuition.
  eapply bleRat_total.
  trivial.

  eapply leRat_trans.
  eapply rat_distance_of_difference.
  trivial.
  case_eq (bleRat c1 c2); intuition.
  eapply bleRat_total.
  trivial.

  eapply H4.
  eapply Max.max_lub_l.
  eauto.
  trivial.

  eapply H5.
  eapply Max.max_lub_r.
  eauto.
  trivial.

  rewrite minRat_le_l.
  rewrite ratHalf_add.
  intuition.
Qed.

Lemma rat_inf_limit_product : forall (f1 f2 : nat -> Rat -> Prop) c1 c2,
  left_total f1 ->
  left_total f2 ->
  rat_inf_limit f1 c1 ->
  rat_inf_limit f2 c2 ->
  rat_inf_limit (fun n => (ratMult_rel (f1 n) (f2 n))) (c1 * c2).

  (* This is the proof found at http://planetmath.org/ProofOfLimitRuleOfProduct.html *)

  unfold rat_inf_limit, inf_limit in *.
  intuition.

  edestruct (H1 ((ratInverse (1 + c2)) * epsilon * (1/ 2))).
  intuition.
  apply ratMult_0 in H4.
  intuition.
  apply ratMult_0 in H5.
  intuition.
  eapply ratInverse_nz.
  eauto.

  edestruct (H2 ((ratInverse (1 + c1)) * epsilon * (1 / 2))).
  intuition.
  apply ratMult_0 in H5.
  intuition.
  apply ratMult_0 in H6.
  intuition.
  eapply ratInverse_nz.
  eauto.

  edestruct (H2 1).
  intuition.

  exists (maxList (x :: x0 :: x1 :: nil)).
  intuition.
  unfold ratMult_rel in *.
  edestruct H.
  edestruct H0.
  rewrite H8; eauto.
  eapply leRat_trans.
  eapply (ratTriangleInequality _ _ (c1 * x3)).

  rewrite ratMult_ratDistance_factor_r.
  rewrite ratMult_ratDistance_factor_l.
  rewrite ratMult_comm.
  eapply leRat_trans.
  eapply ratAdd_leRat_compat.
  eapply ratMult_leRat_compat.
  eapply ratDistance_le_sum.
  eapply H6; [idtac | eapply H10].
  eapply le_trans.
  eapply (maxList_correct (x :: x0 :: x1 :: nil)).
  simpl.
  intuition.
  trivial.
  eapply H4; [idtac | eapply H9].
  eapply le_trans.
  eapply (maxList_correct (x :: x0 :: x1 :: nil)).
  simpl.
  intuition.
  trivial.
  eapply ratMult_leRat_compat.
  eapply (ratAdd_any_leRat_l 1).
  eapply leRat_refl.
  eapply H5; [idtac | eapply H10].
  eapply le_trans.
  eapply (maxList_correct (x :: x0 :: x1 :: nil)).
  simpl.
  intuition.
  trivial.
  eapply eqRat_impl_leRat.
  repeat rewrite <- ratMult_assoc.
  rewrite (ratAdd_comm c2).
  rewrite (ratAdd_comm c1).
  rewrite (ratMult_assoc ((1 + c2) * (ratInverse (1 + c2)))).
  rewrite (ratMult_assoc ((1 + c1) * (ratInverse (1 + c1)))).
  rewrite <- ratMult_distrib_r.
  rewrite (ratMult_comm (1 + c2)).
  rewrite (ratMult_comm (1 + c1)).
  repeat rewrite ratInverse_prod_1.
  rewrite ratMult_2.
  rewrite ratMult_1_l.
  rewrite ratMult_comm.
  rewrite ratMult_assoc.

  rewrite ratMult_eq_rat1.
  eapply ratMult_1_r.

  intuition.
  assert (1 <= 0).
  eapply leRat_trans.
  eapply (ratAdd_any_leRat_r c1).
  eapply leRat_refl.
  eapply eqRat_impl_leRat.
  rewrite ratAdd_comm.
  trivial.
  intuition.

  intuition.
  assert (1 <= 0).
  eapply leRat_trans.
  eapply (ratAdd_any_leRat_r c2).
  eapply leRat_refl.
  eapply eqRat_impl_leRat.
  rewrite ratAdd_comm.
  trivial.
  intuition.

Qed.

Definition rat_limit(f : Rat -> Rat -> Prop)(p L : Rat) :=
  forall epsilon,
    ~ (epsilon == 0) ->
    exists delta, (~delta == 0) /\
      forall x v,
        f x v ->
        (ratDistance x p) <= delta ->
        (ratDistance v L) <= epsilon.

Definition continuous_at(f : Rat -> Rat -> Prop)(c : Rat) :=
  forall v, f c v ->
    rat_limit f c v.

Lemma rat_inf_limit_comp : forall (f : nat -> Rat -> Prop)(g : Rat -> Rat -> Prop) a v,
  rat_inf_limit f a ->
  g a v ->
  continuous_at g a ->
  left_total f ->
  rat_inf_limit (fun n r => forall v', (f n v' -> g v' r)) v.

  unfold continuous_at, rat_limit, rat_inf_limit, inf_limit in *.
  intuition.
  edestruct H1; eauto.
  intuition.
  destruct (H x).
  trivial.
  exists x0.
  intuition.
  destruct (H2 n').
  eapply H6.
  eauto.
  eapply H4.
  eapply H7.
  trivial.
Qed.

Lemma rat_inf_limit_trans : forall (f1 f2 : nat -> Rat -> Prop) a,
  rat_inf_limit_2 f1 f2 ->
  rat_inf_limit f2 a ->
  left_total f2 ->
  rat_inf_limit f1 a.

  intuition.
  unfold rat_inf_limit_2, inf_limit_2, rat_inf_limit, inf_limit in *.
  intuition.
  edestruct (H (ratHalf epsilon)).
  eapply ratHalf_ne_0.
  intuition.
  edestruct (H0 (ratHalf epsilon)).
  eapply ratHalf_ne_0.
  intuition.
  exists (Max.max x x0).
  intuition.
  destruct (H1 n').
  eapply leRat_trans.
  eapply ratTriangleInequality.
  rewrite H3.
  rewrite H4.
  rewrite ratHalf_add.
  intuition.
  eapply Max.max_lub_r.
  eauto.
  eauto.
  eapply Max.max_lub_l.
  eauto.
  trivial.
  trivial.
Qed.

Lemma rat_inf_limit_eq : forall f a1 a2,
  rat_inf_limit f a1 ->
  a1 == a2 ->
  rat_inf_limit f a2.

  unfold rat_inf_limit, inf_limit in *.
  intuition.
  edestruct H; eauto.
  exists x.
  intuition.
  rewrite <- H0.
  eapply H2.
  eapply H3.
  trivial.
Qed.

Lemma rat_inf_limit_const : forall (f : Rat -> Prop) a,
  f a ->
  (forall a1 a2, f a1 -> f a2 -> a1 == a2) ->
  rat_inf_limit (fun _ => f) a.

  unfold rat_inf_limit, inf_limit in *.
  intuition.
  exists O.
  intuition.
  eapply leRat_trans.
  eapply eqRat_impl_leRat.
  rewrite <- ratIdentityIndiscernables.
  eauto.
  eapply rat0_le_all.

Qed.

Lemma rat_inf_limit_summation : forall (A : Set)(f1 : A -> nat -> Rat -> Prop)(f2 : A -> Rat)(ls : list A),
  (forall a, rat_inf_limit (f1 a) (f2 a)) ->
  (forall a, left_total (f1 a)) ->
  (forall a n r1 r2, f1 a n r1 -> f1 a n r2 -> r1 == r2) ->
  rat_inf_limit
  (fun n : nat => sumList_rel (fun a0 : A => f1 a0 n) ls)
  (sumList ls f2).

  induction ls; intuition.
  unfold rat_inf_limit, inf_limit.
  intuition.
  exists O.
  intuition.
  inversion H4; clear H4; subst.
  unfold sumList.
  simpl.
  rewrite H5.
  eapply leRat_trans.
  eapply eqRat_impl_leRat.
  rewrite <- ratIdentityIndiscernables.
  intuition.
  eapply rat0_le_all.

  eapply (@rat_inf_limit_trans _ (fun n : nat => ratAdd_rel (f1 a n) (sumList_rel (fun a0 : A => f1 a0 n) ls))).
  unfold rat_inf_limit_2, inf_limit_2.
  intuition.
  exists O.
  intuition.
  inversion H5; clear H5; subst.
  unfold ratAdd_rel in *.
  rewrite H6.
  rewrite H12.
  eapply leRat_trans.
  eapply eqRat_impl_leRat.
  rewrite <- ratIdentityIndiscernables.
  eapply eqRat_refl.
  eapply rat0_le_all.
  trivial.
  trivial.
  eapply rat_inf_limit_eq.
  eapply rat_inf_limit_sum.
  eauto.
  unfold left_total; intuition.
  eapply sumList_rel_left_total.
  intuition.
  eapply H0.
  eapply H.
  eauto.
  unfold sumList.
  simpl.
  symmetry.
  rewrite fold_add_body_eq; [idtac | eapply ratAdd_comm | idtac].
  rewrite fold_add_init.
  eapply eqRat_refl.
  intuition.

  unfold left_total; intuition.
  eapply ratAdd_rel_left_total.
  eapply H0.
  eapply sumList_rel_left_total.
  intuition.
  eapply H0.
  eauto.
  intuition.
  eapply sumList_rel_func; eauto.
  intuition.
  eauto.
Qed.

Lemma ratInverse_continuous : forall c,
  ~ c == 0 ->
  continuous_at (fun v' r : Rat => r == ratInverse v') c.

  unfold continuous_at, rat_limit in *.
  intuition.

  exists (minRat (c * (1 / 2)) (c * (1/2) * c * epsilon)).
  intuition.
  unfold minRat in *.
  destruct (bleRat (c * (1 / 2)) (c * (1 / 2) * c * epsilon)).
  apply ratMult_0 in H2; intuition.
  apply ratMult_0 in H2; intuition.
  apply ratMult_0 in H3; intuition.
  apply ratMult_0 in H2; intuition.

  rewrite H2.
  rewrite H0.

  assert (ratDistance x c <= c * (1/2)).
  eapply leRat_trans.
  eapply H3.
  eapply minRat_le_l.

  assert (ratSubtract c (c * (1/2)) <= x).
  eapply ratDistance_ge_difference.
  rewrite ratDistance_comm.
  trivial.
  assert (x <= c + (c * (1/2))).
  eapply ratDistance_le_sum.
  trivial.
  assert (c * (1/2) <= x).

  rewrite <- (ratSubtract_half).
  trivial.

  clear H5.
  assert (x <= c * (3/2)).

  rewrite ratMult_ratAdd_cd in H6.
  simpl in *.
  trivial.

  clear H6.
  assert (ratInverse x <= ratInverse (c * (1 / 2))).
  apply ratInverse_leRat.
  intuition.
  apply ratMult_0 in H6; intuition.
  trivial.

  rewrite ratDistance_ratInverse.
  rewrite H3.
  rewrite minRat_le_r.

  rewrite ratInverse_ratMult; intuition.
  rewrite H6.
  rewrite ratInverse_ratMult; intuition.
  rewrite ratMult_comm.
  repeat rewrite <- ratMult_assoc.
  rewrite (ratMult_assoc ((ratInverse c) * (ratInverse (1/2)))).
  rewrite ratInverse_prod_1; intuition.
  rewrite ratMult_1_r.
  rewrite (ratMult_assoc (ratInverse c)).
  rewrite ratInverse_prod_1; intuition.
  rewrite ratMult_1_r.
  rewrite ratInverse_prod_1; intuition.
  rewrite ratMult_1_l.
  intuition.
  rewrite H8 in H7.
  assert (c * (1 / 2) == 0).
  eapply leRat_impl_eqRat.
  trivial.
  eapply rat0_le_all.
  apply ratMult_0 in H9; intuition.
  intuition.
  rewrite H8 in H7.
  assert (c * (1 / 2) == 0).
  eapply leRat_impl_eqRat.
  trivial.
  eapply rat0_le_all.
  apply ratMult_0 in H9; intuition.
  intuition.
Qed.

Lemma rat_inf_limit_ratInverse : forall (f : nat -> Rat -> Prop) a v,
  rat_inf_limit f a ->
  ~ a == 0 ->
  ratInverse a == v ->
  left_total f ->
  rat_inf_limit (fun n => ratInverse_rel (f n)) v.

  intuition.
  eapply rat_inf_limit_comp.
  eauto.
  symmetry.
  trivial.
  eapply ratInverse_continuous.
  trivial.
  trivial.

Qed.

Lemma rat_inf_limit_exp_0 : forall (f : nat -> Rat -> Prop) a,
  rat_inf_limit f a ->
  ~ 1 <= a ->
  (forall n, exists r, f n r) ->
  rat_inf_limit (fun n => (expRat_rel (f n) n)) 0.

  intuition.
  unfold rat_inf_limit, inf_limit in *.
  intuition.
  edestruct (H (1 / 2 * (ratSubtract 1 a))); eauto.
  intuition.
  apply ratMult_0 in H3.
  intuition.
  eapply H0.
  eapply ratSubtract_0_inv.
  trivial.

  edestruct (@expRat_le_exp_exists (a + (1 / 2) * (ratSubtract 1 a)) epsilon).
  eapply half_distance_1_le; trivial.
  trivial.

  exists (Max.max x x0).
  intuition.
  unfold expRat_rel in *.
  destruct (H1 n').
  rewrite H6; eauto.

  apply ratDistance_0_r_le.
  eapply leRat_trans.
  eapply expRat_leRat_compat.
  eapply ratDistance_le_sum.
  eapply H3.
  eapply Max.max_lub_l.
  eauto.
  trivial.

  eapply expRat_le'.
  eauto.
  eapply half_distance_1_le; trivial.
  eapply Max.max_lub_r.
  eauto.

Qed.

Lemma power_series_limit_2 : forall (f : nat -> Rat -> Prop) a,
  rat_inf_limit f a ->
  (forall n v, f n v -> ~ 1 <= v) ->
  ~ 1 <= a ->
  (forall n, exists v, f n v) ->
  (forall n v1 v2, f n v1 -> f n v2 -> v1 == v2) ->
  rat_inf_limit
  (fun n => sumList_rel
    (fun i => expRat_rel (f n) i)
    (getNats O n))
  (ratInverse (ratSubtract 1 a)).

  intuition.

  eapply (@rat_inf_limit_trans _ (fun n => (ratMult_rel (ratSubtract_rel (eqRat 1) (expRat_rel (f n) n)) (ratInverse_rel (ratSubtract_rel (eqRat 1) (f n)))))).
  unfold rat_inf_limit_2, inf_limit_2.
  intuition.
  exists (S O).
  intuition.
  destruct (H2 n').
  eapply leRat_trans.
  eapply eqRat_impl_leRat.
  rewrite <- ratIdentityIndiscernables.
  eapply sum_power_series.
  assert (n' > O).
  lia.
  eapply H9.
  econstructor.
  eapply H8.
  eapply H3.
  intuition.
  eapply H0.
  eapply H9.
  trivial.
  trivial.
  trivial.
  eapply rat0_le_all.

  eapply rat_inf_limit_eq.
  eapply rat_inf_limit_product.

  unfold left_total, ratSubtract_rel, expRat_rel. intuition.
  destruct (H2 n).
  exists (ratSubtract 1 (expRat x n)).
  intuition.
  eapply ratSubtract_eqRat_compat; eauto.
  symmetry.
  eapply H6.
  trivial.

  unfold left_total, ratInverse_rel, ratSubtract_rel. intuition.
  destruct (H2 n).
  exists (ratInverse (ratSubtract 1 x)).
  intuition.
  eapply ratInverse_eqRat_compat.
  intuition.
  eapply H0.
  eauto.
  eapply ratSubtract_0_inv.
  trivial.

  symmetry.
  eapply H5; intuition.

  eapply rat_inf_limit_difference.

  unfold left_total; intuition.
  exists 1; intuition.

  unfold left_total, expRat_rel; intuition.
  destruct (H2 n).
  exists (expRat x n).
  intuition.

  eapply expRat_eqRat_compat; eauto.

  eapply rat_inf_limit_const.
  eapply eqRat_refl.
  intuition.
  rewrite <- H4.
  rewrite H5.
  intuition.

  eapply rat_inf_limit_exp_0.
  eauto.
  trivial.
  trivial.

  eapply rat_inf_limit_ratInverse.
  eapply rat_inf_limit_difference.
  unfold left_total; intuition.
  econstructor.
  eapply eqRat_refl.
  unfold left_total; intuition.

  eapply rat_inf_limit_const.
  eapply eqRat_refl.
  intuition.
  rewrite <- H4.
  rewrite H5.
  intuition.
  eauto.
  intuition.
  eapply H1.
  eapply ratSubtract_0_inv.
  trivial.

  eapply eqRat_refl.
  unfold left_total; intuition.
  destruct (H2 n).
  exists (ratSubtract 1 x).
  unfold ratSubtract_rel; intuition.
  eapply ratSubtract_eqRat_compat; eauto.
  rewrite ratSubtract_0_r.
  rewrite ratMult_1_l.
  intuition.

  unfold left_total, ratMult_rel, ratSubtract_rel, expRat_rel, ratInverse_rel.
  intuition.
  destruct (H2 n).
  exists ((ratSubtract 1 (expRat x n)) * (ratInverse (ratSubtract 1 x))).
  intuition.
  eapply ratMult_eqRat_compat.
  symmetry.
  eapply H5;
  intuition.
  eapply expRat_eqRat_compat.
  eauto.
  symmetry.
  eapply H6.
  intuition.
  eapply ratSubtract_eqRat_compat; intuition.
  eauto.
Qed.

Lemma rat_inf_limit_mono  : forall (f : nat -> Rat -> Prop) (g : nat -> nat)(v : Rat),
    rat_inf_limit f v ->
    (forall n1 n2, n1 <= n2 -> g n1 <= g n2)%nat ->
    (forall y, exists x, g x = y) ->
    rat_inf_limit (fun n => f (g n)) v.

  unfold rat_inf_limit, inf_limit.
  intuition.
  destruct (H epsilon); intuition.
  destruct (H1 x).
  econstructor.
  intuition.
  eapply (H3 (g n')).
  eapply le_trans.
  2:{
    eapply H0.
    eapply H5.
  }
  rewrite <- H4.
  eapply le_refl.
  trivial.
Qed.

Lemma rat_inf_limit_sqrt:
  forall (f : nat -> Rat -> Prop) (v : Rat),
    rat_inf_limit f v ->
    rat_inf_limit (fun n => f (Nat.sqrt n)) v.

  intuition.
  eapply rat_inf_limit_mono.
  trivial.
  intuition.
  eapply Nat.sqrt_le_mono.
  trivial.
  intuition.
  econstructor.
  eapply Nat.sqrt_square.
Qed.


(*************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(*************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(*************************************************************)

Require Import List Arith Max Lia Wellfounded Bool.

From Undecidability.Shared.Libs.DLW.Utils
  Require Import list_focus utils_tac utils_list utils_nat.

Set Implicit Arguments.

(* We show that unbounded decidable predicates are exactly
    the direct images of strictly increasing sequences nat -> nat

    Hence, this gives an easy construction of the sequence
    of all primes ...

*)

Section list_choose_d.

  Variable (X : Type) (P Q : X -> Prop).

  Theorem list_choose_d l : (forall x, In x l -> P x \/ Q x)
                           -> (exists x, In x l /\ P x)
                           \/ forall x, In x l -> Q x.
  Proof.
    induction l as [ | x l IHl ]; intros Hl.
    + right; intros _ [].
    + destruct (Hl x) as [ H1 | H1 ].
      * left; auto.
      * left; exists x; simpl; auto.
      * destruct IHl as [ (y & H2 & H3) | H2 ].
        - intros; apply Hl; right; auto.
        - left; exists y; simpl; auto.
        - right; intros ? [ <- | ]; auto.
  Qed.

End list_choose_d.

Section bounded_choose_d.

  Variable (P Q : nat -> Prop).

  Theorem bounded_choose_d n : (forall x, x < n -> P x \/ Q x)
                           -> (exists x, x < n /\ P x)
                           \/ forall x, x < n -> Q x.
  Proof.
    intros H.
    destruct list_choose_d with (P := P) (Q := Q) (l := list_an 0 n)
      as [ (x & H1 & H2) | H1 ].
    + intro; rewrite list_an_spec; intro; apply H; lia.
    + left; exists x; split; auto.
      apply list_an_spec in H1; lia.
    + right; intros x Hx; apply H1, list_an_spec; lia.
  Qed.

End bounded_choose_d.

Section bounded_min.

  Variable (P Q : nat -> Prop).

  Theorem bounded_min_d n :   (forall x, x < n -> P x \/ Q x)
                           -> (exists x, x < n /\ P x /\ forall y, y < x -> Q y)
                           \/ forall x, x < n -> Q x.
  Proof.
    induction n as [ | n IHn ]; intros Hn.
    + right; intros; lia.
    + destruct IHn as [ (x & H1 & H2 & H3) | H1 ].
      * intros; apply Hn; lia.
      * left; exists x; msplit 2; auto; lia.
      * destruct (Hn n); auto.
        - left; exists n; msplit 2; auto.
        - right; intros x Hx.
          destruct (eq_nat_dec x n); subst; auto.
          apply H1; lia.
  Qed.

End bounded_min.

Section list_choose_dep.

  Variable (X : Type) (P Q : X -> Prop).

  Theorem list_choose_dep l : (forall x, In x l -> { P x } + { Q x })
                           -> { x | In x l /\ P x }
                            + { forall x, In x l -> Q x }.
  Proof.
    induction l as [ | x l IHl ]; intros Hl.
    + right; intros _ [].
    + destruct (Hl x) as [ H1 | H1 ].
      * left; auto.
      * left; exists x; simpl; auto.
      * destruct IHl as [ (y & H2 & H3) | H2 ].
        - intros; apply Hl; right; auto.
        - left; exists y; simpl; auto.
        - right; intros ? [ <- | ]; auto.
  Qed.

End list_choose_dep.

Section sinc_decidable.

  Variable (P : nat -> Prop)
           (f : nat -> nat)
           (Hf : forall n, f n < f (S n))
           (HP : forall n, P n <-> exists k, n = f k).

  Let f_mono x y : x <= y -> f x <= f y.
  Proof.
    induction 1 as [ | y H IH ]; auto.
    apply le_trans with (1 := IH), lt_le_weak, Hf.
  Qed.

  Let f_smono x y : x < y -> f x < f y.
  Proof.
    intros H; apply f_mono in H.
    apply lt_le_trans with (2 := H), Hf.
  Qed.

  Let f_ge_n n : n <= f n.
  Proof.
    induction n as [ | n IHn ]; try lia.
    apply le_trans with (2 := Hf _); lia.
  Qed.

  Let unbounded n : exists k, n <= k /\ P k.
  Proof. exists (f n); split; auto; rewrite HP; exists n; auto. Qed.

  Let decidable n : { P n } + { ~ P n }.
  Proof.
    destruct (@bounded_search (S n) (fun i => f i = n))
      as [ (i & H1 & H2) | H1 ].
    + intros i _; destruct (eq_nat_dec (f i) n); tauto.
    + left; rewrite HP; eauto.
    + right; rewrite HP; intros (k & Hk).
      symmetry in Hk; generalize Hk; apply H1.
      rewrite <- Hk; apply le_n_S; auto.
  Qed.

  Theorem sinc_decidable : (forall n, exists k, n <= k /\ P k)
                         * (forall n, { P n } + { ~ P n }).
  Proof. split; auto. Qed.

End sinc_decidable.

Section decidable_sinc.

  Variable (P    : nat -> Prop)
           (Punb : forall n, exists k, n <= k /\ P k)
           (Pdec : forall n, { P n } + { ~ P n }).

  Let next n : { k | P k /\ n <= k /\ forall x, P x -> x < n \/ k <= x }.
  Proof.
    destruct min_dec with (P := fun k => P k /\ n <= k)
      as (k & (H1 & H2) & H3).
    + intros i; destruct (Pdec i); destruct (le_lt_dec n i); try tauto; right; intro; lia.
    + destruct (Punb (S n)) as (k & H1 & H2).
      exists k; split; auto; lia.
    + exists k; repeat (split; auto).
      intros x Hx.
      destruct (le_lt_dec n x); try lia.
      right; apply H3; auto.
  Qed.

  Let f := fix f n := match n with
    | 0   => proj1_sig (next 0)
    | S n => proj1_sig (next (S (f n)))
  end.

  Let f_sinc n : f n < f (S n).
  Proof.
    simpl.
    destruct (next (S (f n))) as (?&?&?&?); auto.
  Qed.

  Let f_select x : { n | f n <= x < f (S n) } + { x < f 0 }.
  Proof.
    induction x as [ | x IHx ].
    + destruct (eq_nat_dec 0 (f 0)) as [ H | H ].
      * left; exists 0; rewrite H at 2 3; split; auto.
      * right; lia.
    + destruct IHx as [ (n & Hn) | Hx ].
      * destruct (eq_nat_dec (S x) (f (S n))) as [ H | H ].
        - left; exists (S n); rewrite H; split; auto.
        - left; exists n; lia.
      * destruct (eq_nat_dec (S x) (f 0)) as [ H | H ].
        - left; exists 0; rewrite H; split; auto.
        - right; lia.
  Qed.

  Let f_P n : P n <-> exists k, n = f k.
  Proof.
    split.
    + intros Hn.
      destruct (f_select n) as [ (k & Hk) | C ].
      * simpl in Hk.
        destruct (next (S (f k))) as (m & H1 & H2 & H3); simpl in Hk.
        apply H3 in Hn.
        destruct Hn as [ Hn | Hn ]; try lia.
        exists k; lia.
      * simpl in C.
        destruct (next 0) as (m & H1 & H2 & H3); simpl in C.
        apply H3 in Hn; lia.
    + intros (k & Hk); subst.
      induction k as [ | k IHk ]; simpl.
      * destruct (next 0) as (m & H1 & H2 & H3); simpl; auto.
      * destruct (next (S (f k))) as (m & H1 & H2 & H3); simpl; auto.
  Qed.

  Theorem decidable_sinc : { f | (forall n, f n < f (S n))
                              /\ (forall n, P n <-> exists k, n = f k) }.
  Proof. exists f; auto. Qed.

End decidable_sinc.

(*
Check sinc_decidable.
Check decidable_sinc.
*)


Require Export GeoCoq.Elements.OriginalProofs.lemma_sameside2.
Require Export GeoCoq.Elements.OriginalProofs.lemma_10_12.
Require Export GeoCoq.Elements.OriginalProofs.proposition_07.

Section Euclid.

Context `{Ax:euclidean_neutral_ruler_compass}.

Lemma lemma_erectedperpendicularunique :
   forall A B C E,
   Per A B C -> Per A B E -> OS C E A B ->
   Out B C E.
Proof.
intros.
let Tf:=fresh in
assert (Tf:exists D, (BetS A B D /\ Cong A B D B /\ Cong A C D C /\ neq B C)) by (conclude_def Per );destruct Tf as [D];spliter.
assert (neq B E) by (conclude_def Per ).
rename_H H;let Tf:=fresh in
assert (Tf:exists H, (Out B E H /\ Cong B H B C)) by (conclude lemma_layoff);destruct Tf as [H];spliter.
assert (eq B B) by (conclude cn_equalityreflexive).
assert (Col A B B) by (conclude_def Col ).
assert (OS C H A B) by (conclude lemma_sameside2).
assert (Per A B H) by (conclude lemma_8_3).
assert (Cong B C B H) by (conclude lemma_congruencesymmetric).
assert (Cong A C A H) by (conclude lemma_10_12).
assert (Cong C A H A) by (forward_using lemma_congruenceflip).
assert (Cong C B H B) by (forward_using lemma_congruenceflip).
assert (~ eq A B).
 {
 intro.
 assert (Col A B C) by (conclude_def Col ).
 assert (nCol A B C) by (conclude lemma_rightangleNC).
 contradict.
 }
assert (eq C H) by (conclude proposition_07).
assert (Out B E C) by (conclude cn_equalitysub).
assert (Out B C E) by (conclude lemma_ray5).
close.
Qed.

End Euclid.


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

(**********************************************************************
    Proth.v

    Proth's Test

    Definition: ProthTest
 **********************************************************************)
Require Import ZArith.
Require Import ZCAux.
Require Import Pocklington.

Open Scope Z_scope.

Theorem ProthTest: forall h k a, let n := h * 2 ^ k + 1 in 1 < a -> 0 < h < 2 ^k -> (a ^ ((n - 1) / 2) + 1) mod n = 0 -> prime n.
intros h k a n; unfold n; intros H H1 H2.
assert (Hu: 0 < h * 2 ^ k).
apply Zmult_lt_O_compat; auto with zarith.
assert (Hu1: 0 < k).
case (Zle_or_lt k 0); intros Hv; auto.
generalize H1 Hv; case k; simpl.
intros (Hv1, Hv2); contradict Hv2; auto with zarith.
intros p1 _ Hv1; contradict Hv1; auto with zarith.
intros   p (Hv1, Hv2); contradict Hv2; auto with zarith.
apply PocklingtonCorollary1 with (F1 := 2 ^ k) (R1 := h); auto with zarith.
ring.
apply Zlt_le_trans with ((h + 1) * 2 ^ k); auto with zarith.
rewrite Zmult_plus_distr_l; apply Zplus_lt_compat_l.
rewrite Zmult_1_l; apply Zlt_le_trans with 2; auto with zarith.
intros p H3 H4.
generalize H2; replace (h * 2 ^ k + 1 - 1) with (h * 2 ^k); auto with zarith; clear H2; intros H2.
exists a; split; auto; split.
pattern (h * 2 ^k) at 1; rewrite (Zdivide_Zdiv_eq  2 (h * 2 ^ k)); auto with zarith.
rewrite (Zmult_comm 2); rewrite Zpower_mult; auto with zarith.
rewrite Zpower_mod; auto with zarith.
assert (tmp: forall p, p = (p + 1) -1); auto with zarith; rewrite (fun x => (tmp (a ^ x))).
rewrite Zminus_mod; auto with zarith.
rewrite H2.
rewrite (Zmod_small 1); auto with zarith.
rewrite <- Zpower_mod; auto with zarith.
rewrite Zmod_small; auto with zarith.
simpl; unfold Zpower_pos; simpl; auto with zarith.
apply Z_div_pos; auto with zarith.
apply Zdivide_trans with (2 ^ k).
apply Zpower_divide; auto with zarith.
apply Zdivide_factor_l; auto with zarith.
apply Zis_gcd_gcd; auto with zarith.
apply Zis_gcd_intro; auto with zarith.
intros x HD1 HD2.
assert (Hd1: p = 2).
apply prime_div_Zpower_prime with (4 := H4); auto with zarith.
apply prime_2.
assert (Hd2: (x | 2)).
replace 2 with ((a ^ (h * 2 ^ k / 2) + 1) - (a ^ (h * 2 ^ k/ 2) - 1)); auto with zarith.
apply Zdivide_minus_l; auto.
apply Zdivide_trans with (1 := HD2).
apply Zmod_divide; auto with zarith.
pattern 2 at 2; rewrite <- Hd1; auto.
replace 1 with ((h * 2 ^k + 1) - (h * 2 ^ k)); auto with zarith.
apply Zdivide_minus_l; auto.
apply Zdivide_trans with (1 := Hd2); auto.
apply Zdivide_trans with (2 ^ k).
apply Zpower_divide; auto with zarith.
apply Zdivide_factor_l; auto with zarith.
Qed.

Definition proth_test h k a :=
  let n := h * 2 ^ k + 1 in
   if (Z_lt_dec 1  a) then
      if (Z_lt_dec 0 h) then
        if (Z_lt_dec h (2 ^k)) then
            if Z_eq_dec (Zpow_mod a  ((n - 1) / 2) n) (n - 1) then true
            else false else false else false else false.

Theorem ProthTestOp: forall h k a, proth_test h k a = true -> prime (h * 2 ^ k + 1).
intros h k a; unfold proth_test.
repeat match goal with |- context[if ?X then _ else _] => case X end; try (intros; discriminate).
intros H1 H2 H3 H4 _.
assert (Hu: 0 < h * 2 ^ k).
apply Zmult_lt_O_compat; auto with zarith.
apply ProthTest with (a := a); auto.
rewrite Zplus_mod; auto with zarith.
rewrite <- Zpow_mod_Zpower_correct; auto with zarith.
rewrite H1.
rewrite (Zmod_small 1); auto with zarith.
replace (h * 2 ^ k + 1 - 1 + 1) with (h * 2 ^ k + 1); auto with zarith.
apply Zdivide_mod; auto with zarith.
apply Z_div_pos; auto with zarith.
Qed.

Theorem prime5: prime 5.
exact (ProthTestOp 1 2 2 (refl_equal _)).
Qed.

Theorem prime17: prime 17.
exact (ProthTestOp 1 4 3 (refl_equal _)).
Qed.

Theorem prime257:  prime 257.
exact (ProthTestOp 1 8 3 (refl_equal _)).
Qed.

Theorem prime65537:  prime 65537.
exact (ProthTestOp 1 16 3 (refl_equal _)).
Qed.

(* Too tough !!
Theorem prime4294967297:  prime 4294967297.
exact (ProthTestOp 1 32 3 (refl_equal _)).
Qed.
*)


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

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

Unset Positivity Checking.
Unset Guard Checking.

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

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

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

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

Definition synth (y : natural) (lf2 : natural) (lf1 : natural) : natural :=
  plus Zero lf1.


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

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

Unset Positivity Checking.
Unset Guard Checking.

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

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

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

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

Definition synth (z : natural) (y : natural) (lf1 : natural) (lf2 : natural)
  : natural := plus Zero (plus z lf2).


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

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

Unset Positivity Checking.
Unset Guard Checking.

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

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

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

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

Definition synth (lf1 : natural) (y : natural) (x : natural) : natural :=
  plus (Succ y) Zero.


Require Import Reals Gappa_tactic.
Open Scope R_scope.

Goal -10 <= 12 * powerRZ 2 (-3) <= 10.
Proof. gappa. Qed.

Goal -10 <= 150 * powerRZ 10 (-2) <= 10.
Proof. gappa. Qed.

Goal -10 <= 24 * powerRZ 2 (-3) <= 10.
Proof. gappa. Qed.

Goal -10 <= 0 * powerRZ 10 (-3) <= 10.
Proof. gappa. Qed.

Goal -10 <= -300 * powerRZ 10 (-2) <= 10.
Proof. gappa. Qed.

Goal -10 <= -12 * powerRZ 2 (-3) <= 10.
Proof. gappa. Qed.

Goal -10 <= -150 * powerRZ 10 (-2) <= 10.
Proof. gappa. Qed.


Set Implicit Arguments.
Unset Strict Implicit.

Require Import mathcomp.ssreflect.ssreflect.
From mathcomp Require Import all_ssreflect.
From mathcomp Require Import all_algebra.

Import GRing.Theory Num.Def Num.Theory.

Local Open Scope ring_scope.

(** This file defines generic notions of extrema. *)

Section Extrema.
(** The primary parameters are:
      - [rty : realFieldType]    A real field
      - [I : finType]            A finite type
      - [P : pred I]             A subset of [I]
      - [F : I -> rty]           A "valuation" function over [I]
    The module implements the following functions:
      - [arg_min]                An [i : I \in P] that minimizes [F]
      - [arg_max]                An [i : I \in P] that maximizes [F]
      - [min]                    := [F arg_min]
      - [max]                    := [F arg_max]
*)
  Variable rty : realFieldType.
  Variables (I : finType) (P : pred I) (F : I -> rty).

  Section getOrd.
    Variable ord : rel rty.
    Hypothesis ord_refl : reflexive ord.
    Hypothesis ord_trans : transitive ord.
    Hypothesis ord_total : total ord.

    Fixpoint getOrd (i0 : I) (l : list I) : I :=
      if l is (i :: l') then
        if ord (F i0) (F i) then getOrd i0 l' else getOrd i l'
      else i0.

    Lemma getOrd_mono i1 i2 l :
      ord (F i1) (F i2) ->
      ord (F (getOrd i1 l)) (F (getOrd i2 l)).
    Proof.
      move: i1 i2; elim: l=> // a l IH i1 i2 H /=.
      case H2: (ord (F i1) (F a)).
      { by case H3: (ord (F i2) (F a)); apply: IH.
      }
      case H3: (ord (F i2) _)=> //.
      apply: IH.
      have H4: ord (F i1) (F a).
      { by apply: ord_trans; first by apply: H.
      }
      by rewrite H4 in H2.
    Qed.

    Lemma getOrd_minimalIn i0 l :
      [&& ord (F (getOrd i0 l)) (F i0)
        & [forall (t | t \in l), ord (F (getOrd i0 l)) (F t)]].
    Proof.
      move: i0; elim: l.
      { move=> i0; apply/andP; split=> //.
        by apply/forallP.
      }
      move=> a l IH i0.
      apply/andP; split.
      { simpl; case H2: (ord (F i0) _)=> //.
        by case: (andP (IH i0)).
        apply: ord_trans.
        case: (andP (IH a))=> H3 _; apply: H3.
        by case: (orP (ord_total (F i0) (F a))); first by rewrite H2.
      }
      apply/forallP=> x; apply/implyP.
      move: (in_cons a l x)=> ->; case/orP.
      { move/eqP=> ?; subst x=> /=.
        case H4: (ord (F i0) _).
        case: (andP (IH i0))=> H2 _.
        by apply: ord_trans; first by apply: H2.
        by case: (andP (IH a)).
      }
      move=> H /=.
      case H2: (ord (F i0) _).
      { case: (andP (IH i0))=> H0; move/forallP; move/(_ x).
        by move/implyP; move/(_ H)=> H3.
      }
      case: (andP (IH a))=> H3; move/forallP; move/(_ x).
      by move/implyP; move/(_ H)=> H4.
    Qed.

    Definition getOrd_tot i0 := getOrd i0 (enum I).

    Lemma getOrd_totP i0 : [forall i, ord (F (getOrd_tot i0)) (F i)].
    Proof.
      case: (andP (getOrd_minimalIn i0 (enum I)))=> H H2.
      apply/forallP=> x; apply/implyP=> H3.
      suff H4: false by [].
      apply: H3; move: (forallP H2 x); move/implyP; apply.
      by rewrite mem_enum.
    Qed.

    Definition getOrd_sub i0 := getOrd i0 (filter P (enum I)).

    Lemma getOrd_sub_hasP i0 (Hi0 : P i0) : P (getOrd_sub i0).
    Proof.
      rewrite /getOrd_sub; move: (enum I)=> l.
      elim: l=> // a l /=.
      case H: (P a)=> //=.
      case: (ord _ _)=> //.
      elim: l a H i0 Hi0 => //= a0 l IH a H i0 Hi0.
      case H2: (P a0)=> //=.
      case: (ord _ _).
      case: (ord _ _)=> //.
      by apply: IH.
      by apply: IH.
      case: (ord _ _)=> //.
      by apply: IH.
      by apply: IH.
    Qed.

    Lemma getOrd_subP i0 (Hi0 : P i0) :
      [&& P (getOrd_sub i0)
        & [forall (i | P i), ord (F (getOrd_sub i0)) (F i)]].
    Proof.
      case: (andP (getOrd_minimalIn i0 (filter P (enum I))))=> H H2.
      apply/andP; split; first by apply: getOrd_sub_hasP.
      apply/forallP=> x; apply/implyP=> H3.
      move: (forallP H2 x); move/implyP; apply.
      by rewrite mem_filter; apply/andP; split=> //; rewrite mem_enum.
    Qed.
  End getOrd.

  Section default.
    Variable i0 : I.
    Hypothesis H : P i0.

    Definition arg_max := getOrd_sub ger i0.

    Lemma arg_maxP : [&& P arg_max & [forall (i | P i), F arg_max >= F i]].
    Proof.
      apply: getOrd_subP=> //; rewrite /ger.
      by apply: lerr.
      by move=> x y z /= H2 H3; apply: (ler_trans H3 H2).
      by move=> x y /=; move: (ler_total x y); rewrite orbC.
    Qed.

    Definition max := F arg_max.

    Lemma maxP : [forall (i | P i), max >= F i].
    Proof.
      rewrite /max.
      by case: (andP arg_maxP).
    Qed.

    Definition arg_min := getOrd_sub ler i0.

    Lemma arg_minP : [&& P arg_min & [forall (i | P i), F arg_min <= F i]].
    Proof.
      apply: getOrd_subP=> //.
      by apply: ler_trans.
      by apply: ler_total.
    Qed.

    Definition min := F arg_min.

    Lemma minP : [forall (i | P i), min <= F i].
    Proof.
      rewrite /min.
      by case: (andP arg_minP).
    Qed.

    Lemma min_le_max : min <= max.
    Proof.
      rewrite /min /max.
      case: (andP arg_minP)=> H2; move/forallP=> H3.
      case: (andP arg_maxP)=> H4; move/forallP=> H5.
      move: (implyP (H3 i0)); move/(_ H)=> Hx.
      move: (implyP (H5 i0)); move/(_ H)=> Hy.
      apply: ler_trans.
      apply: Hx.
      apply: Hy.
    Qed.
  End default.
End Extrema.

Arguments arg_min [rty I] P F i0.
Arguments arg_max [rty I] P F i0.

Arguments arg_minP [rty I P] F [i0] _.
Arguments arg_maxP [rty I P] F [i0] _.

Arguments min [rty I] P F i0.
Arguments max [rty I] P F i0.

Arguments minP [rty I P] F [i0] _.
Arguments maxP [rty I P] F [i0] _.

Arguments min_le_max [rty I P] F [i0] _.

Lemma max_ge (rty : realFieldType) (I : finType) (f : I -> rty) (def i : I) :
  f i <= max xpredT f def.
Proof.
  have H: xpredT i by [].
  move: (forallP (@maxP rty I xpredT f def H)); move/(_ i).
  by move/implyP; apply.
Qed.

Lemma min_le (rty : realFieldType) (I : finType) (f : I -> rty) (def i : I) :
  min xpredT f def <= f i.
Proof.
  have H: xpredT i by [].
  move: (forallP (@minP rty I xpredT f def H)); move/(_ i).
  by move/implyP; apply.
Qed.


Require Import Coq.Strings.String.
Require Import Coq.Lists.List.
Require Import Coq.Arith.Compare_dec.
Require Import Coq.Arith.Lt.
Require Import Coq.Arith.Gt.
Require Import Arith.Wf_nat.
Require Import Helpers.
Require Import Recdef.
Require Import Tree.

Open Scope nat_scope.

Import ListNotations.

Inductive s_inc : (list tree) -> Prop :=
    | s_inc_nil  : s_inc nil
    | s_inc_sin  : forall (x : tree), s_inc (x :: nil)
    | s_inc_two  : forall (x y : tree), ht x < ht y -> s_inc (x :: y :: nil)
    | s_inc_cons : forall (x y : tree) (ys : list tree),
                          ht x < ht y /\ s_inc (y :: ys) -> s_inc (x :: y :: ys).

Fixpoint join_until_smaller (t : tree) (ts : list tree) :=
    match ts with
    | nil     => [t]
    | x :: xs =>
        match nat_compare (ht t) (ht x) with
        | Eq => join_until_smaller (join t x) xs
        | Lt => t :: x :: xs
        | Gt => join_until_smaller (join t x) xs
        end
    end.

Theorem join_until_smaller_produces: forall (ts : list tree) (t : tree),
    join_until_smaller t ts <> [].
Proof.
    induction ts. simpl. intros t contra. inversion contra.
    intros t. remember (nat_compare (ht t) (ht a)) as R. destruct R.
        simpl. rewrite <- HeqR. apply IHts.
        simpl. rewrite <- HeqR. intros contra. inversion contra.
        simpl. rewrite <- HeqR. apply IHts.
Qed.

Theorem join_until_smaller_inc: forall (ts : list tree) (t : tree),
    s_inc ts -> s_inc (join_until_smaller t ts).
Proof.
    induction ts.
        intros t s_inc_nil.
        simpl. apply s_inc_sin.
        intros t s_inc_ats.
        remember (nat_compare (ht t) (ht a)) as R.
        destruct R.
            simpl. rewrite <- HeqR. apply IHts. inversion s_inc_ats.
            apply s_inc_nil. apply s_inc_sin. destruct H0. assumption.

            simpl. rewrite <- HeqR. apply s_inc_cons. split.
            apply nat_compare_lt. symmetry. assumption. assumption.

            simpl. rewrite <- HeqR. apply IHts. inversion s_inc_ats.
            apply s_inc_nil. apply s_inc_sin. destruct H0. assumption.
Qed.

Fixpoint step (t : tree) (xs : list tree) : list tree :=
    match xs with
    | nil  => [t]
    | u :: vs =>
        match vs with
            | nil =>
                match nat_compare (ht t) (ht u) with
                | Lt => t :: u :: nil
                | _  => (join t u) :: nil
                end
            | v :: ts =>
                match nat_compare (ht t) (ht u) with
                | Lt => t :: u :: v :: ts
                | _  =>
                    match nat_compare (ht t) (ht v) with
                    | Lt => step (join t u) vs
                    | _  => join_until_smaller t (join_until_smaller (join u v) ts)
                    end
                end
        end
    end.

Theorem step_not_nil : forall (xs : list tree) (t : tree),
  step t xs <> [].
Proof.
    (* match xs with*) induction xs as [|u].
    (* | nil  => [t]*) simpl. intuition. inversion H.
    (* | u :: vs =>*)
      (* match vs with *) remember xs as vs. induction vs as [|v]; intros t.
        (* | nil => *)
          (* match nat_compare (ht t) (ht u) with*) remember (nat_compare (ht t) (ht u)) as R1. destruct R1.
          (* | Eq => (join t u) :: nil*) simpl. rewrite <- HeqR1. intros contra. inversion contra.
          (* | Lt => t :: u :: nil*) simpl. rewrite <- HeqR1. intros contra. inversion contra.
          (* | Gt => (join t u) :: nil*) simpl. rewrite <- HeqR1. intros contra. inversion contra.
          (* end*)
        (* | v :: ts =>*)
         (* match nat_compare (ht t) (ht u) with *) remember (nat_compare (ht t) (ht u)) as R1. destruct R1.
         (* | Eq => *)
              (* match nat_compare (ht t) (ht v) with *) remember (nat_compare (ht t) (ht v)) as R2. destruct R2.
              (* | Eq =>  join_until_smaller t (join u v :: ts) *) unfold step. rewrite <- HeqR1. rewrite <- HeqR2. apply join_until_smaller_produces.
              (* | Lt => step (join t u) vs *) rewrite Heqvs. simpl. rewrite <- Heqvs. rewrite <- HeqR1. rewrite <- HeqR2. apply IHxs.
              (* | Gt =>  join_until_smaller t (join u v :: ts) *) unfold step. rewrite <- HeqR1. rewrite <- HeqR2. apply join_until_smaller_produces.
              (* end *)
         (* | Lt => t :: u :: v :: ts *) simpl.  rewrite <- HeqR1. intros contra. inversion contra.
         (* | Gt => *)
              (* match nat_compare (ht t) (ht v) with *) remember (nat_compare (ht t) (ht v)) as R2. destruct R2.
              (* | Eq =>  join_until_smaller t (join u v :: ts) *) unfold step. rewrite <- HeqR1. rewrite <- HeqR2. apply join_until_smaller_produces.
              (* | Lt => step (join t u) vs *)  rewrite Heqvs. simpl. rewrite <- Heqvs. rewrite <- HeqR1. rewrite <- HeqR2. apply IHxs.
              (* | Gt =>  join_until_smaller t (join u v :: ts) *) unfold step. rewrite <- HeqR1. rewrite <- HeqR2. apply join_until_smaller_produces.
              (* end *)
      (* end*)
    (* end.*)
Qed.

Theorem step_inc : forall (xs : list tree) (t : tree),
  s_inc xs -> s_inc (step t xs).
Proof.
    (* match xs with*) induction xs as [|u].
    (* | nil  => [t]*) simpl. intuition. apply s_inc_sin.
    (* | u :: vs =>*)
      (* match vs with *) remember xs as vs. induction vs as [|v]; intros t H.
        (* | nil => *)
          (* match nat_compare (ht t) (ht u) with*) remember (nat_compare (ht t) (ht u)) as R1. destruct R1.
          (* | Eq => (join t u) :: nil*) simpl. rewrite <- HeqR1. apply s_inc_sin.
          (* | Lt => t :: u :: nil*) simpl. rewrite <- HeqR1. apply s_inc_two. apply nat_compare_lt. symmetry. assumption.
          (* | Gt => (join t u) :: nil*) simpl. rewrite <- HeqR1. apply s_inc_sin.
          (* end*)
        (* | v :: ts =>*)
         (* match nat_compare (ht t) (ht u) with *) remember (nat_compare (ht t) (ht u)) as R1. destruct R1.
         (* | Eq => *)
              (* match nat_compare (ht t) (ht v) with *) remember (nat_compare (ht t) (ht v)) as R2. destruct R2.
              (* | Eq =>  join_until_smaller t (join u v :: ts) *) inversion H. contradict H1. apply not_eq_r. apply eq_ge. apply eq_nmo_mo with (n := ht t); assumption.
                                                                   inversion H1. contradict H4. apply not_eq_r. apply eq_ge. apply eq_nmo_mo with (n := ht t); assumption.
              (* | Lt => step (join t u) vs *) rewrite Heqvs. simpl. rewrite <- Heqvs. rewrite <- HeqR1. rewrite <- HeqR2. apply IHxs. inversion H. apply s_inc_sin. inversion H1. assumption.
              (* | Gt =>  join_until_smaller t (join u v :: ts) *) inversion H. contradict H1. apply not_eq_r. apply gt_ge. apply gt_nmo_mo with (n := ht t); assumption.
                                                                   inversion H1. contradict H4. apply not_eq_r. apply gt_ge. apply gt_nmo_mo with (n := ht t); assumption.
              (* end *)
         (* | Lt => t :: u :: v :: ts *) simpl.  rewrite <- HeqR1. apply s_inc_cons. split. apply nat_compare_lt. symmetry. assumption. assumption.
         (* | Gt => *)
              (* match nat_compare (ht t) (ht v) with *) remember (nat_compare (ht t) (ht v)) as R2. destruct R2.
              (* | Eq =>  join_until_smaller t (join u v :: ts) *) simpl. rewrite <- HeqR1. rewrite <- HeqR2. remember (nat_compare (ht t) (max (ht u) (ht v) + 1)) as R3. destruct R3.
                                                                     apply join_until_smaller_inc. apply join_until_smaller_inc. inversion H. apply s_inc_nil. inversion H1. inversion H5. apply s_inc_nil. apply s_inc_sin. inversion H7. assumption.
                                                                     apply join_until_smaller_inc. apply join_until_smaller_inc. inversion H. apply s_inc_nil. inversion H1. inversion H5. apply s_inc_nil. apply s_inc_sin. inversion H7. assumption.
                                                                     apply join_until_smaller_inc. apply join_until_smaller_inc. inversion H. apply s_inc_nil. inversion H1. inversion H5. apply s_inc_nil. apply s_inc_sin. inversion H7. assumption.
              (* | Lt => step (join t u) vs *)  rewrite Heqvs. simpl. rewrite <- Heqvs. rewrite <- HeqR1. rewrite <- HeqR2. apply IHxs. inversion H. apply s_inc_sin. inversion H1. assumption.
              (* | Gt =>  join_until_smaller t (join u v :: ts) *)  simpl. rewrite <- HeqR1. rewrite <- HeqR2. remember (nat_compare (ht t) (max (ht u) (ht v) + 1)) as R3. destruct R3.
                                                                     apply join_until_smaller_inc. apply join_until_smaller_inc. inversion H. apply s_inc_nil. inversion H1. inversion H5. apply s_inc_nil. apply s_inc_sin. inversion H7. assumption.
                                                                     apply join_until_smaller_inc. apply join_until_smaller_inc. inversion H. apply s_inc_nil. inversion H1. inversion H5. apply s_inc_nil. apply s_inc_sin. inversion H7. assumption.
                                                                     apply join_until_smaller_inc. apply join_until_smaller_inc. inversion H. apply s_inc_nil. inversion H1. inversion H5. apply s_inc_nil. apply s_inc_sin. inversion H7. assumption.
              (* end *)
      (* end*)
    (* end.*)
Qed.

Theorem fold_right_not_nil : forall (l : list tree),
  l <> [] -> fold_right (fun (a : tree) (xs : list tree) => step a xs) [] l <> [].
Proof.
  induction l. intros LNNil. simpl. assumption.
  (* step *) intros alNNil. simpl. apply step_not_nil.
Qed.

Theorem fold_step_not_nil : forall (l : list tree),
  l <> nil -> (fold_right (fun (a : tree) (xs : list tree) => step a xs) nil l) <> nil.
Proof.
  intros l NNil. apply fold_right_not_nil. assumption.
Qed.

Theorem fold_step_inc : forall (l : list tree),
  s_inc (fold_right (fun (a : tree) (xs : list tree) => step a xs) nil l).
Proof.
  induction l as [|l']. simpl. apply s_inc_nil. simpl. apply step_inc. assumption.
Qed.


(** Formal Reasoning About Programs <http://adam.chlipala.net/frap/>
  * Chapter 4: Transition Systems
  * Author: Adam Chlipala
  * License: https://creativecommons.org/licenses/by-nc-nd/4.0/ *)

Require Import Frap.

Set Implicit Arguments.
(* This command will treat type arguments to functions as implicit, like in
 * Haskell or ML. *)

(* Here's a classic recursive, functional program for factorial. *)
Fixpoint fact (n : nat) : nat :=
  match n with
  | O => 1
  | S n' => fact n' * S n'
  end.

(* But let's reformulate factorial relationally, as an example to explore
 * treatment of inductive relations in Coq.  First, these are the states of our
 * state machine. *)
Inductive fact_state :=
| AnswerIs (answer : nat)
| WithAccumulator (input accumulator : nat).

(* *Initial* states *)
Inductive fact_init (original_input : nat) : fact_state -> Prop :=
| FactInit : fact_init original_input (WithAccumulator original_input 1).

(** *Final* states *)
Inductive fact_final : fact_state -> Prop :=
| FactFinal : forall ans, fact_final (AnswerIs ans).

(** The most important part: the relation to step between states *)
Inductive fact_step : fact_state -> fact_state -> Prop :=
| FactDone : forall acc,
  fact_step (WithAccumulator O acc) (AnswerIs acc)
| FactStep : forall n acc,
  fact_step (WithAccumulator (S n) acc) (WithAccumulator n (acc * S n)).

(* We care about more than just single steps.  We want to run factorial to
 * completion, for which it is handy to define a general relation of
 * *transitive-reflexive closure*, like so. *)
Inductive trc {A} (R : A -> A -> Prop) : A -> A -> Prop :=
| TrcRefl : forall x, trc R x x
| TrcFront : forall x y z,
  R x y
  -> trc R y z
  -> trc R x z.

(* Transitive-reflexive closure is so common that it deserves a shorthand notation! *)
Notation "R ^*" := (trc R) (at level 0).

(* Now let's use it to execute the factorial program. *)
Example factorial_3 : fact_step^* (WithAccumulator 3 1) (AnswerIs 6).
Proof.
Admitted.

(* It will be useful to give state machines more first-class status, as
 * *transition systems*, formalized by this record type.  It has one type
 * parameter, [state], which records the type of states. *)
Record trsys state := {
  Initial : state -> Prop;
  Step : state -> state -> Prop
}.

(* The example of our factorial program: *)
Definition factorial_sys (original_input : nat) : trsys fact_state := {|
  Initial := fact_init original_input;
  Step := fact_step
|}.

(* A useful general notion for transition systems: reachable states *)
Inductive reachable {state} (sys : trsys state) (st : state) : Prop :=
| Reachable : forall st0,
  sys.(Initial) st0
  -> sys.(Step)^* st0 st
  -> reachable sys st.

(* To prove that our state machine is correct, we rely on the crucial technique
 * of *invariants*.  What is an invariant?  Here's a general definition, in
 * terms of an arbitrary transition system. *)
Definition invariantFor {state} (sys : trsys state) (invariant : state -> Prop) :=
  forall s, sys.(Initial) s
            -> forall s', sys.(Step)^* s s'
                          -> invariant s'.
(* That is, when we begin in an initial state and take any number of steps, the
 * place we wind up always satisfies the invariant. *)

(* Here's a simple lemma to help us apply an invariant usefully,
 * really just restating the definition. *)
Lemma use_invariant' : forall {state} (sys : trsys state)
  (invariant : state -> Prop) s s',
  invariantFor sys invariant
  -> sys.(Initial) s
  -> sys.(Step)^* s s'
  -> invariant s'.
Proof.
  unfold invariantFor.
  simplify.
  eapply H.
  eassumption.
  assumption.
Qed.

Theorem use_invariant : forall {state} (sys : trsys state)
  (invariant : state -> Prop) s,
  invariantFor sys invariant
  -> reachable sys s
  -> invariant s.
Proof.
  simplify.
  invert H0.
  eapply use_invariant'.
  eassumption.
  eassumption.
  assumption.
Qed.

(* What's the most fundamental way to establish an invariant?  Induction! *)
Lemma invariant_induction' : forall {state} (sys : trsys state)
  (invariant : state -> Prop),
  (forall s, invariant s -> forall s', sys.(Step) s s' -> invariant s')
  -> forall s s', sys.(Step)^* s s'
     -> invariant s
     -> invariant s'.
Proof.
  induct 2; propositional.
  (* [propositional]: simplify the goal according to the rules of propositional
   *   logic. *)

  apply IHtrc.
  eapply H.
  eassumption.
  assumption.
Qed.

Theorem invariant_induction : forall {state} (sys : trsys state)
  (invariant : state -> Prop),
  (forall s, sys.(Initial) s -> invariant s)
  -> (forall s, invariant s -> forall s', sys.(Step) s s' -> invariant s')
  -> invariantFor sys invariant.
Proof.
  unfold invariantFor; intros.
  eapply invariant_induction'.
  eassumption.
  eassumption.
  apply H.
  assumption.
Qed.

Definition fact_invariant (original_input : nat) (st : fact_state) : Prop :=
  True.
(* We must fill in a better invariant. *)

Theorem fact_invariant_ok : forall original_input,
  invariantFor (factorial_sys original_input) (fact_invariant original_input).
Proof.
Admitted.

(* Therefore, every reachable state satisfies this invariant. *)
Theorem fact_invariant_always : forall original_input s,
  reachable (factorial_sys original_input) s
  -> fact_invariant original_input s.
Proof.
  simplify.
  eapply use_invariant.
  apply fact_invariant_ok.
  assumption.
Qed.

(* Therefore, any final state has the right answer! *)
Lemma fact_ok' : forall original_input s,
  fact_final s
  -> fact_invariant original_input s
  -> s = AnswerIs (fact original_input).
Admitted.

Theorem fact_ok : forall original_input s,
  reachable (factorial_sys original_input) s
  -> fact_final s
  -> s = AnswerIs (fact original_input).
Proof.
  simplify.
  apply fact_ok'.
  assumption.
  apply fact_invariant_always.
  assumption.
Qed.

(** * A simple example of another program as a state transition system *)

(* We'll formalize this pseudocode for one thread of a concurrent, shared-memory program.
  lock();
  local = global;
  global = local + 1;
  unlock();
*)

(* This inductive state effectively encodes all possible combinations of two
 * kinds of *local*state* in a thread:
 * - program counter
 * - values of local variables that may be read eventually *)
Inductive increment_program :=
| Lock
| Read
| Write (local : nat)
| Unlock
| Done.

(* Next, a type for state shared between threads. *)
Record inc_state := {
  Locked : bool; (* Does a thread hold the lock? *)
  Global : nat   (* A shared counter *)
}.

(* The combined state, from one thread's perspective, using a general
 * definition. *)
Record threaded_state shared private := {
  Shared : shared;
  Private : private
}.

Definition increment_state := threaded_state inc_state increment_program.

(* Now a routine definition of the three key relations of a transition system.
 * The most interesting logic surrounds saving the counter value in the local
 * state after reading. *)

Inductive increment_init : increment_state -> Prop :=
| IncInit :
  increment_init {| Shared := {| Locked := false; Global := O |};
                    Private := Lock |}.

Inductive increment_step : increment_state -> increment_state -> Prop :=
| IncLock : forall g,
  increment_step {| Shared := {| Locked := false; Global := g |};
                    Private := Lock |}
                 {| Shared := {| Locked := true; Global := g |};
                    Private := Read |}
| IncRead : forall l g,
  increment_step {| Shared := {| Locked := l; Global := g |};
                    Private := Read |}
                 {| Shared := {| Locked := l; Global := g |};
                    Private := Write g |}
| IncWrite : forall l g v,
  increment_step {| Shared := {| Locked := l; Global := g |};
                    Private := Write v |}
                 {| Shared := {| Locked := l; Global := S v |};
                    Private := Unlock |}
| IncUnlock : forall l g,
  increment_step {| Shared := {| Locked := l; Global := g |};
                    Private := Unlock |}
                 {| Shared := {| Locked := false; Global := g |};
                    Private := Done |}.

Definition increment_sys := {|
  Initial := increment_init;
  Step := increment_step
|}.

(** * Running transition systems in parallel *)

(* That last example system is a cop-out: it only runs a single thread.  We want
 * to run several threads in parallel, sharing the global state.  Here's how we
 * can do it for just two threads.  The key idea is that, while in the new
 * system the type of shared state remains the same, we take the Cartesian
 * product of the sets of private state. *)

Inductive parallel1 shared private1 private2
  (init1 : threaded_state shared private1 -> Prop)
  (init2 : threaded_state shared private2 -> Prop)
  : threaded_state shared (private1 * private2) -> Prop :=
| Pinit : forall sh pr1 pr2,
  init1 {| Shared := sh; Private := pr1 |}
  -> init2 {| Shared := sh; Private := pr2 |}
  -> parallel1 init1 init2 {| Shared := sh; Private := (pr1, pr2) |}.

Inductive parallel2 shared private1 private2
          (step1 : threaded_state shared private1 -> threaded_state shared private1 -> Prop)
          (step2 : threaded_state shared private2 -> threaded_state shared private2 -> Prop)
          : threaded_state shared (private1 * private2)
            -> threaded_state shared (private1 * private2) -> Prop :=
| Pstep1 : forall sh pr1 pr2 sh' pr1',
  (* First thread gets to run. *)
  step1 {| Shared := sh; Private := pr1 |} {| Shared := sh'; Private := pr1' |}
  -> parallel2 step1 step2 {| Shared := sh; Private := (pr1, pr2) |}
               {| Shared := sh'; Private := (pr1', pr2) |}
| Pstep2 : forall sh pr1 pr2 sh' pr2',
  (* Second thread gets to run. *)
  step2 {| Shared := sh; Private := pr2 |} {| Shared := sh'; Private := pr2' |}
  -> parallel2 step1 step2 {| Shared := sh; Private := (pr1, pr2) |}
               {| Shared := sh'; Private := (pr1, pr2') |}.

Definition parallel shared private1 private2
           (sys1 : trsys (threaded_state shared private1))
           (sys2 : trsys (threaded_state shared private2)) := {|
  Initial := parallel1 sys1.(Initial) sys2.(Initial);
  Step := parallel2 sys1.(Step) sys2.(Step)
|}.

(* Example: composing two threads of the kind we formalized earlier *)
Definition increment2_sys := parallel increment_sys increment_sys.

(* Let's prove that the counter is always 2 when the composed program terminates. *)

(** We must write an invariant. *)
Inductive increment2_invariant :
  threaded_state inc_state (increment_program * increment_program) -> Prop :=
| Inc2Inv : forall sh pr1 pr2,
  increment2_invariant {| Shared := sh; Private := (pr1, pr2) |}.
(* This isn't it yet! *)

(* Now, to show it really is an invariant. *)
Theorem increment2_invariant_ok : invariantFor increment2_sys increment2_invariant.
Proof.
Admitted.

(* Now, to prove our final result about the two incrementing threads, let's use
 * a more general fact, about when one invariant implies another. *)
Theorem invariant_weaken : forall {state} (sys : trsys state)
  (invariant1 invariant2 : state -> Prop),
  invariantFor sys invariant1
  -> (forall s, invariant1 s -> invariant2 s)
  -> invariantFor sys invariant2.
Proof.
  unfold invariantFor; simplify.
  apply H0.
  eapply H.
  eassumption.
  assumption.
Qed.

(* Here's another, much weaker invariant, corresponding exactly to the overall
 * correctness property we want to establish for this system. *)
Definition increment2_right_answer
  (s : threaded_state inc_state (increment_program * increment_program)) :=
  s.(Private) = (Done, Done)
  -> s.(Shared).(Global) = 2.

(** Now we can prove that the system only runs to happy states. *)
Theorem increment2_sys_correct : forall s,
  reachable increment2_sys s
  -> increment2_right_answer s.
Proof.
Admitted.
(*simplify.
  eapply use_invariant.
  apply invariant_weaken with (invariant1 := increment2_invariant).
  (* Note the use of a [with] clause to specify a quantified variable's
   * value. *)

  apply increment2_invariant_ok.

  simplify.
  invert H0.
  unfold increment2_right_answer; simplify.
  invert H0.
  (* Here we use inversion on an equality, to derive more primitive
   * equalities. *)
  simplify.
  equality.

  assumption.
Qed.*)