Require Import Qnn.

Local Open Scope Qnn.

Require Import FunctionalExtensionality.

(** Nonnegative lower reals *)
(** The nonnegative lower real numbers are encoded here
    by lower Dedekind cuts. That is, they are predicates
    on non-negative rational numbers, and can be viewed
    essentially as subsets of rational numbers. They
    are downward-closed ([dclosed]) and upward-open ([uopen]),
    which means that if the predicate holds for some rational
    number [q], it holds for all rationals which are less, and
    some rational which is greater.

    We show that [LPReal] forms a semiring, and then we can use
    the [ring] tactic with them.

    These guys are interesting because we can have proofy
    bits in them. For example, we can create a real number
    which is 0 if P = NP and 1 if P /= NP. [LPRindicator]
    allows us, for any proposition, to create a real number
    which is 1 iff the proposition is true, and 0 iff it
    is false.

    We also have a definition of suprema ([LPRsup]) over an
    arbitrary indexing type.

    The lower real numbers are closed under addition, multiplication,
    min, max, supremum, but not (necessarily) under subtraction
    or infima.

    If LEM is admitted, the lower reals are simply the real numbers
    as Dedekind cuts.

 *)
Record LPReal :=
  { lbound :> Qnn -> Prop
  ; dclosed : forall q, lbound q -> forall q', q' <= q -> lbound q'
  ; uopen   : forall q, lbound q -> exists q', q < q' /\ lbound q'
  }.

Definition LPRle (r s : LPReal) : Prop :=
  forall q, r q -> s q.

Definition LPRge (r s : LPReal) : Prop := LPRle s r.

Definition LPRlt (r s : LPReal) : Prop :=
  exists q, ~ r q /\ s q.

Definition LPRgt (r s : LPReal) : Prop := LPRlt s r.

Definition LPReq (r s : LPReal) : Prop :=
  LPRle r s /\ LPRle s r.

Definition LPRQnn (q : Qnn) : LPReal.
Proof.
refine (
  {| lbound := fun q' => (q' < q)%Qnn |}
).
- abstract (intros; subst; eapply Qnnle_lt_trans; eassumption).
- abstract (intros q0 H; destruct (Qnnbetween q0 q H) as [x xbetween];
  eexists; eassumption).
Defined.

Inductive LPRplusT {x y : LPReal} : Qnn -> Prop :=
  | LPRplusL : forall q, x q -> LPRplusT q
  | LPRplusR : forall q, y q -> LPRplusT q
  | LPRplusB : forall q q' sum , x q -> y q' -> sum <= q + q' -> LPRplusT sum.

Arguments LPRplusT : clear implicits.

Lemma LPRplus_dclosed : forall x y q,
  LPRplusT x y q -> forall q', q' <= q -> LPRplusT x y q'.
Proof.
intros.
inversion H; subst;
[apply LPRplusL | apply LPRplusR | eapply LPRplusB].
eapply dclosed; eassumption.
eapply dclosed; eassumption.
eassumption. eassumption.
eapply Qnnle_trans; eassumption.
Qed.

Lemma LPRplus_uopen : forall x y q,
  LPRplusT x y q -> exists q', q < q' /\ LPRplusT x y q'.
Proof.
intros. destruct H.
  + pose proof (uopen _ _ H). destruct H0.
    exists x0. intuition. apply LPRplusL. assumption.
  + pose proof (uopen _ _ H). destruct H0.
    exists x0. intuition. apply LPRplusR. assumption.
  + pose proof (uopen _ _ H). destruct H2.
    exists (x0 + q'). intuition. eapply Qnnle_lt_trans. eassumption.
    rewrite (SRadd_comm Qnnsrt).
    rewrite (SRadd_comm Qnnsrt x0).
    apply Qnnplus_le_lt_compat. apply Qnnle_refl. assumption.
    eapply LPRplusB. eassumption. eassumption. apply Qnnle_refl.
Qed.

Definition LPRplus (x y : LPReal) : LPReal :=
  {| lbound := LPRplusT x y
   ; dclosed := LPRplus_dclosed x y
   ; uopen := LPRplus_uopen x y
  |}.

Inductive LPRmultT {x y : LPReal} {q : Qnn} : Prop :=
  MkLPRmultT : forall a b, lbound x a -> lbound y b -> (q <= a * b) -> LPRmultT.

Arguments LPRmultT : clear implicits.

Lemma LPRmult_dclosed : forall x y q,
  LPRmultT x y q -> forall q', q' <= q -> LPRmultT x y q'.
Proof.
intros.
destruct H.
econstructor; try eassumption.
eapply Qnnle_trans; eassumption.
Qed.

Lemma LPRmult_uopen : forall x y q,
  LPRmultT x y q -> exists q', q < q' /\ LPRmultT x y q'.
Proof.
intros. destruct H as [a b pa pb prod].
  pose proof (uopen _ _ pa). destruct H as [a' [pa' xa']].
  pose proof (uopen _ _ pb). destruct H as [b' [pb' yb']].
  exists (a' * b'). split. eapply Qnnle_lt_trans. eassumption.
  apply Qnnle_lt_trans with (a * b').
  rewrite pb'. reflexivity.
  apply Qnnmult_lt_compat_r.
  eapply Qnnle_lt_trans. apply (nonneg b). assumption. assumption.
  constructor 1 with a' b'; intuition.
Qed.

Definition LPRmult (x y : LPReal) : LPReal :=
  {| lbound := LPRmultT x y
  ;  uopen := LPRmult_uopen x y
  ;  dclosed := LPRmult_dclosed x y
  |}.

Lemma LPReq_prop : forall r s, LPReq r s ->
  forall q, lbound r q <-> lbound s q.
Proof.
intros. destruct H. split. apply H. apply H0.
Qed.

(** Import the Ensemble Extensionality Axiom *)
Require Import Coq.Sets.Ensembles.

(** Import the Proof Irrelevance Axiom *)
Require Import Coq.Logic.ProofIrrelevance.

Lemma LPReq_compat : forall r s, LPReq r s -> r = s.
Proof.
intros. pose proof H as eq. destruct H.
unfold LPRle in *.
assert (lbound r = lbound s).
apply Extensionality_Ensembles. intuition.
destruct r, s.
simpl in *. induction H1.
f_equal; apply proof_irrelevance.
Qed.

Ltac LPRsrttac :=
repeat match goal with
| [ |- _ /\ _ ] => split
| [ |- forall _, _] => intros
| [ H : lbound (LPRQnn _) _ |- _ ] => simpl in H
| [ H : lbound (LPRplus _ _) _ |- _ ] => destruct H
| [ H : lbound (LPRmult _ _) _ |- _ ] => destruct H
| [ H : exists x, _ |- _ ] => destruct H
| [ H : _ /\ _ |- _ ] => destruct H
| [ H : _ < 0 |- _ ] => apply Qnnlt_not_le in H; unfold not in H;
  apply False_rect; apply H; apply nonneg
| [ |- lbound (LPRplus (LPRQnn 0) _) _ ] => apply LPRplusR
| [ |- lbound (LPRplus _ (LPRQnn 0)) _ ] => apply LPRplusL
| [ Hm : lbound ?m _, Hn : lbound ?n _ |- lbound (LPRplus ?m ?n) _ ]
   => eapply LPRplusB; [ eassumption | eassumption | ]
| [ Hm : lbound ?m ?q |- lbound (LPRplus ?m _) ?q ]
   => apply LPRplusL
| [ Hn : lbound ?n ?q |- lbound (LPRplus _ ?n) ?q ]
   => apply LPRplusR
| [ |- _ ] => assumption
end.

Theorem LPRsrt : semi_ring_theory (LPRQnn 0) (LPRQnn 1)
  LPRplus LPRmult eq.
Proof.
constructor; intros; apply LPReq_compat; unfold LPReq, LPRle;
LPRsrttac.
- rewrite H1. ring_simplify. reflexivity.
- rewrite H1. ring_simplify. reflexivity.
- apply LPRplusL. LPRsrttac.
- apply LPRplusL. LPRsrttac.
- eapply LPRplusB; try eassumption. LPRsrttac.
- apply LPRplusL. LPRsrttac.
- eapply LPRplusB; try eassumption. LPRsrttac.
- eapply LPRplusB with (q + q0) (q'). eapply LPRplusB with q q0.
  eassumption. eassumption. reflexivity. assumption.
  rewrite H1, H3. ring_simplify. reflexivity.
- apply LPRplusR. LPRsrttac.
- eapply LPRplusB; try eassumption. LPRsrttac.
- eapply LPRplusR. LPRsrttac.
- eapply LPRplusB; try eassumption. LPRsrttac.
- apply LPRplusR. LPRsrttac.
- eapply LPRplusB with q (q'0 + q'). assumption.
  eapply LPRplusB with q'0 q'; try assumption.
  reflexivity. rewrite H1, H3. ring_simplify.
  reflexivity.
- eapply dclosed. eassumption. rewrite H1.
  replace b with (1 * b) at 2 by ring.
  apply Qnnmult_le_compat. rewrite H. reflexivity.
  reflexivity.
- simpl. pose proof (uopen _ _ H). destruct H0 as [q' [qq' nq']].
  constructor 1 with (q / q') q'. apply Qnndiv_lt. assumption. intuition.
  unfold Qnndiv. rewrite <- (SRmul_assoc Qnnsrt).
  replace (Qnninv q' * q') with 1. replace (q * 1) with q by ring.
  reflexivity. symmetry. rewrite (SRmul_comm Qnnsrt).
  apply Qnnmult_inv_r. eapply Qnnle_lt_trans. apply (nonneg q).
  assumption.
- simpl. constructor 1 with b a; intuition.
  rewrite (SRmul_comm Qnnsrt).
  assumption.
- simpl. constructor 1 with b a; intuition.
  rewrite (SRmul_comm Qnnsrt).
  assumption.
- simpl. constructor 1 with (a * a0) b0.
  constructor 1 with a a0; intuition.
  intuition. rewrite H1, H3. ring_simplify.
  reflexivity.
- simpl. constructor 1 with a0 (b0 * b); intuition.
  constructor 1 with b0 b; intuition.
  rewrite H1, H3. ring_simplify. reflexivity.
- apply LPRplusL. simpl. econstructor; eauto.
- apply LPRplusR. simpl. econstructor; eauto.
- eapply LPRplusB. constructor 1 with q0 b; intuition. apply Qnnle_refl.
  constructor 1 with q' b; intuition.
  apply Qnnle_refl. rewrite H1, H3. ring_simplify.
  reflexivity.
- constructor 1 with a b; try (apply LPRplusL); assumption.
- constructor 1 with a b; try (apply LPRplusR); assumption.
- constructor 1 with (a0 + a) (Qnnmax b0 b); intuition.
  eapply LPRplusB; try eassumption. reflexivity.
  pattern b0, b, (Qnnmax b0 b). apply Qnnmax_induction; intros; assumption.
  rewrite H1, H3, H5.
  pattern b0, b, (Qnnmax b0 b). apply Qnnmax_induction; intros.
  rewrite H6. ring_simplify. reflexivity.
  rewrite H6. ring_simplify. reflexivity.
Qed.

Add Ring LPR_Ring : LPRsrt.

Infix "<=" := LPRle : LPR_scope.
Infix "==" := LPReq : LPR_scope.
Infix ">=" := LPRge : LPR_scope.
Infix ">"  := LPRgt : LPR_scope.
Infix "<"  := LPRlt : LPR_scope.
Infix "+"  := LPRplus : LPR_scope.
Infix "*"  := LPRmult : LPR_scope.

Notation "'0'" := (LPRQnn 0) : LPR_scope.
Notation "'1'" := (LPRQnn 1) : LPR_scope.

Delimit Scope LPR_scope with LPR.

Local Open Scope LPR.

Definition LPRle_refl (r : LPReal) : r <= r :=
  fun _ p => p.

Definition LPRle_trans {r s t : LPReal}
  (rs : r <= s) (st : s <= t) : r <= t :=
  fun q prf => (st q (rs q prf)).

Require Import RelationClasses.
Instance LPRle_preorder : PreOrder LPRle.
Proof.
constructor.
- unfold Reflexive. apply LPRle_refl.
- unfold Transitive. apply @LPRle_trans.
Qed.

Lemma LPReq_refl (x : LPReal) : x == x.
Proof. split; reflexivity. Qed.

Lemma LPReq_compat_backwards (x y : LPReal) : x = y -> x == y.
Proof. intros H; induction H; apply LPReq_refl. Qed.

Lemma LPReq_trans (x y z : LPReal)
  : x == y -> y == z -> x == z.
Proof. intros. destruct H; destruct H0; split;
  eapply LPRle_trans; eassumption.
Qed.

Theorem LPRle_antisym {x y : LPReal}
  : x <= y -> y <= x -> x = y.
Proof.
intros. apply LPReq_compat. split; assumption.
Qed.

Theorem LPRplus_le_compat {x y z t : LPReal}
  : (x <= y) -> (z <= t) -> (x + z <= y + t).
Proof. intros. unfold LPRle in *. intros.
simpl in *. destruct H1;
  [apply LPRplusL | apply LPRplusR | eapply LPRplusB ]; try intuition.
apply H. eassumption. apply H0. eassumption. assumption.
Qed.

Require Import Morphisms.
Instance LPRplus_le_compatI : Proper (LPRle ==> LPRle ==> LPRle) LPRplus.
Proof.
unfold Proper, respectful. intros.
apply LPRplus_le_compat; assumption.
Qed.

Theorem LPRmult_le_compat {x x' y y' : LPReal}
  : x <= x' -> y <= y' -> x * y <= x' * y'.
Proof.
intros. unfold LPRle in *. intros.
simpl in *. destruct H1 as [a b H1 H2 H3].
econstructor. apply H. eassumption.
apply H0. eassumption. assumption.
Qed.

Instance LPRmult_le_compatI : Proper (LPRle ==> LPRle ==> LPRle) LPRmult.
Proof.
unfold Proper, respectful. intros.
apply LPRmult_le_compat; assumption.
Qed.

Theorem LPRzero_min (r : LPReal) : 0 <= r.
Proof.
unfold LPRle. intros q Hq. simpl in *.
apply False_rect. eapply Qnnlt_zero_prop.
eassumption.
Qed.

Lemma LPRlt_not_le {x y : LPReal}
  : x < y -> ~ (y <= x).
Proof. intros. unfold LPRlt, LPRle, not in *.
intros. destruct H as [q [notxq yq]].
apply notxq. apply H0. assumption.
Qed.

Lemma LPRQnn_le {x y : Qnn} : LPRQnn x <= LPRQnn y <-> (x <= y)%Qnn.
Proof.
split; intros.
- unfold LPRle in H. simpl in *. destruct (Qnn_dec x y).
  destruct s. apply Qnnlt_le_weak. assumption.
  pose proof (H _ q). apply Qnnlt_not_le in H0.
  apply False_rect. apply H0. reflexivity.
  induction e. reflexivity.
- unfold LPRle. simpl in *. intros.
  eapply Qnnlt_le_trans. eassumption. assumption.
Qed.

Require Import Qcanon.
Local Close Scope Qc.

Lemma LPRQnn_plus {x y : Qnn}
  : LPRQnn x + LPRQnn y = LPRQnn (x + y)%Qnn.
Proof.
apply LPReq_compat. unfold LPReq.
split; unfold LPRle; intros; simpl in *.
- destruct H; simpl in *.
  + replace q with (0 + q)%Qnn by ring.
    replace (x + y)%Qnn with (y + x)%Qnn by ring.
    apply Qnnplus_le_lt_compat. apply nonneg. assumption.
  + replace q with (0 + q)%Qnn by ring.
    apply Qnnplus_le_lt_compat. apply nonneg. assumption.
  + eapply Qnnle_lt_trans. eassumption.
    eapply Qnnplus_le_lt_compat. apply Qnnlt_le_weak.
    assumption. assumption.
- destruct (Qnn_dec x 0%Qnn) as [[H0 | H0] | H0].
  + apply Qnnlt_zero_prop in H0. contradiction.
  + destruct (Qnn_dec y 0%Qnn) as [[H1 | H1] | H1].
    * apply Qnnlt_zero_prop in H1. contradiction.
    * pose proof (Qnnplus_open H H0 H1).
      destruct H2 as [x' [y' [x'x [y'y sum]]]].
      eapply LPRplusB. apply x'x. apply y'y. eassumption.
    * apply LPRplusL. simpl.
      eapply Qnnlt_le_trans. eassumption.
      subst. replace (x + 0)%Qnn with x by ring.
      apply Qnnle_refl.
  + apply LPRplusR. simpl. eapply Qnnlt_le_trans.
    eassumption. subst. replace (0 + y)%Qnn with y by ring.
    apply Qnnle_refl.
Qed.

Definition LPRsup {A : Type} (f : A -> LPReal)
  : LPReal.
Proof.
refine (
  {| lbound := fun q => exists (idx : A), f idx q |}
).
- intros. destruct H. exists x. apply dclosed with q. assumption. assumption.
- intros. destruct H. pose proof (uopen _ _ H).
  destruct H0 as [q' [qq' fq']].
  exists q'. split. assumption. exists x. assumption.
Defined.

Definition LPRinfinity : LPReal.
Proof. refine (
  {| lbound := fun q => True |}
); trivial.
intros. exists (q + 1)%Qnn. intuition.
replace q with (q + 0)%Qnn at 1 by ring.
apply Qnnplus_le_lt_compat.
apply Qnnle_refl. apply Qnnlt_alt. reflexivity.
Defined.

Theorem LPRinfinity_max (r : LPReal) : r <= LPRinfinity.
Proof.
unfold LPRle. intros. simpl. constructor.
Qed.

Lemma LPRsup_ge {A : Type} {f : A -> LPReal} {a : A}
  : f a <= LPRsup f.
Proof. unfold LPRle. simpl. intros. eexists. eassumption.
Qed.

Lemma LPRsup_le {A : Type} {f : A -> LPReal} {x : LPReal}
  : (forall (a : A), (f a <= x)) -> LPRsup f <= x.
Proof. intros. unfold LPRle in *. simpl. intros. destruct H0.
subst. apply H with x0.
assumption.
Qed.

Lemma LPRsup_ge2 {A : Type} {f : A -> LPReal} {x : LPReal}
  : (exists a, x <= f a) -> x <= LPRsup f.
Proof. intros. destruct H. rewrite H. apply LPRsup_ge.
Qed.

Lemma LPRsup_prop {A : Type} {f : A -> LPReal} {x : LPReal}
  : (forall (a : A), (f a <= x))
  -> (exists (a : A), x <= f a)
  -> LPRsup f = x.
Proof. intros. apply LPReq_compat. split. apply LPRsup_le.
assumption. eapply LPRsup_ge2. eassumption.
Qed.

Lemma LPRsup_monotonic_gen {A B : Type} (f : A -> LPReal) (g : B -> LPReal)
  : (forall (a : A), exists (b : B), f a <= g b) -> LPRsup f <= LPRsup g.
Proof.
intros mono. unfold LPRle in *.
intros. simpl in *. destruct H.
destruct (mono x).
exists x0. apply H0.  assumption.
Qed.

Lemma LPRsup_monotonic {A : Type} (f g : A -> LPReal)
  : (forall (a : A), f a <= g a) -> LPRsup f <= LPRsup g.
Proof.
intros. apply LPRsup_monotonic_gen. intros. exists a. auto.
Qed.

Lemma LPRsup_eq_pointwise {A : Type} (f g : A -> LPReal)
  : (forall (a : A), f a = g a) -> LPRsup f = LPRsup g.
Proof.
intros mono.
apply LPReq_compat. split; apply LPRsup_monotonic;
intros; rewrite mono; apply LPRle_refl.
Qed.

Lemma LPRsup_sum {A : Type} (f g : A -> LPReal)
  : LPRsup (fun x => f x + g x) <= LPRsup f + LPRsup g.
Proof. apply LPRsup_le. intros a.
apply LPRplus_le_compat; apply LPRsup_ge.
Qed.

Lemma LPRsup_iterated {A B : Type} : forall (f : A -> B -> LPReal),
   LPRsup (fun a => LPRsup (fun b => f a b))
 = LPRsup (fun b => LPRsup (fun a => f a b)).
Proof.
intros. apply LPRle_antisym; unfold LPRle; simpl; intros.
- destruct H as [a [b fab]]. exists b. exists a. assumption.
- destruct H as [b [a fab]]. exists a. exists b. assumption.
Qed.

Lemma LPRsup_sum_lattice {A : Type} (f g : A -> LPReal)
  (le : A -> A -> Prop)
  (max : A -> A -> A)
  (maxL  : forall (a b : A), le a (max a b))
  (maxR  : forall (a b : A), le b (max a b))
  (monof : forall n m, le n m -> f n <= f m)
  (monog : forall n m, le n m -> g n <= g m)
  : LPRsup (fun x => f x + g x) = LPRsup f + LPRsup g.
Proof.
apply LPReq_compat. split; [apply LPRsup_sum | ].
unfold LPRle. intros. simpl in *.
destruct H; simpl in *.
- destruct H. exists x. apply LPRplusL. assumption.
- destruct H. exists x. apply LPRplusR. assumption.
- destruct H. destruct H0. exists (max x x0). eapply LPRplusB.
  eapply monof. apply maxL. eassumption.
  eapply monog. apply maxR. eassumption. assumption.
Qed.

Lemma LPRsup_nat_ord (f g : nat -> LPReal)
  : (forall n m, (n <= m)%nat -> f n <= f m)
  -> (forall n m, (n <= m)%nat -> g n <= g m)
  -> LPRsup (fun x => f x + g x) = LPRsup f + LPRsup g.
Proof. intros. eapply LPRsup_sum_lattice; try eassumption.
apply Max.le_max_l.  apply Max.le_max_r.
Qed.

Definition LPRmax (x y : LPReal) : LPReal.
Proof. refine (
  {| lbound := fun q => x q \/ y q |}
).
- intros. destruct H; [left | right]; eapply dclosed; eassumption.
- intros. destruct H;
  pose proof (uopen _ _ H) as H';
  destruct H' as [q' [qq' pq']]; exists q'; intuition.
Defined.

Lemma LPRmax_le_and {x y z : LPReal}
  : x <= z -> y <= z -> LPRmax x y <= z.
Proof. intros.
unfold LPRle; simpl in *; intros; intuition.
Qed.

Lemma LPRmax_le_or {x y z : LPReal}
  : z <= x \/ z <= y -> z <= LPRmax x y.
Proof. intros.
unfold LPRle; simpl in *; intros; intuition.
Qed.

Lemma LPRmax_le {x y x' y' : LPReal}
  : x <= x' -> y <= y' -> LPRmax x y <= LPRmax x' y'.
Proof.
intros. unfold LPRle. intros q Hmax. simpl in *.
destruct Hmax; [left | right].
- apply H. assumption.
- apply H0. assumption.
Qed.

Lemma LPRmax_plus {x x' y y' : LPReal}
  : LPRmax (x + x') (y + y') <= LPRmax x y + LPRmax x' y'.
Proof.
apply LPRmax_le_and; apply LPRplus_le_compat; apply LPRmax_le_or;
  (left; apply LPRle_refl) || (right; apply LPRle_refl).
Qed.

Definition LPRmin (x y : LPReal) : LPReal.
Proof. refine (
  {| lbound := fun q => x q /\ y q |}
).
- intros. destruct H; split; eapply dclosed; eassumption.
- intros. destruct H.
  destruct (uopen _ _ H) as [q'x [qq'x pq'x]].
  destruct (uopen _ _ H0) as [q'y [qq'y pq'y]].
  exists (Qnnmin q'x q'y). split. eapply Qnnmin_lt_both; assumption.
  split; eapply dclosed; try eassumption. apply Qnnmin_l.
  apply Qnnmin_r.
Defined.

(* An real number which is an indicator for a logical proposition.
   It is 0 if P is false and 1 if P is true. Without a proof or
   refutation of P, you will not know which! *)
Definition LPRindicator (P : Prop) : LPReal.
Proof. refine
( {| lbound := fun q => P /\ (q < 1)%Qnn |}).
- intros. intuition. eapply Qnnle_lt_trans; eassumption.
- intros. destruct H. pose proof (Qnnbetween q 1%Qnn H0).
  destruct H1. exists x. intuition.
Defined.

Lemma LPRind_bounded (P : Prop) : LPRindicator P <= 1.
Proof.
unfold LPRle; intros; simpl in *; intuition.
Qed.

Lemma LPRind_imp (P Q : Prop) (f : P -> Q)
  : LPRindicator P <= LPRindicator Q.
Proof.
unfold LPRle; intros; simpl in *. intuition.
Qed.

Lemma LPRind_iff (P Q : Prop) (equiv : P <-> Q)
  : LPRindicator P = LPRindicator Q.
Proof.
apply LPReq_compat; split;
unfold LPRle; intros; simpl in *; intuition.
Qed.

Lemma LPRind_true (P : Prop) : P -> LPRindicator P = 1.
Proof. intros. apply LPReq_compat.
split.
- apply LPRind_bounded.
- unfold LPRle; intros; simpl in *. intuition.
Qed.

Lemma LPRind_false (P : Prop) : ~ P -> LPRindicator P = 0.
Proof. intros. apply LPReq_compat.
split.
- unfold LPRle; intros; simpl in *. intuition.
- apply LPRzero_min.
Qed.

Hint Resolve Qnnle_refl.

Lemma LPRind_scale_le {P : Prop} {x y : LPReal}
  : (P -> x <= y) -> LPRindicator P * x <= y.
Proof.
intros. unfold LPRle; simpl in *; intros.
destruct H0 as [a b pa pb ab].
destruct pa. apply H in H0. apply H0. eapply dclosed.
eassumption. eapply Qnnle_trans. eassumption.
replace b with (1 * b)%Qnn at 2 by ring.
apply Qnnmult_le_compat. apply Qnnlt_le_weak. assumption.
apply Qnnle_refl.
Qed.

Lemma LPRind_mult {U V : Prop}
  : LPRindicator (U /\ V) = LPRindicator U * LPRindicator V.
Proof.
apply LPReq_compat.
split; unfold LPRle; simpl in *; intros.
- intuition.
  assert (1 <= 1 * 1).
  ring_simplify. apply LPRle_refl.
  unfold LPRle in H0.
  specialize (H0 q H1). simpl in H0.
  destruct H0 as [a b pa pb pab].
  constructor 1 with a b; simpl; intuition.
- destruct H as [a b pa pb ab]. simpl in *. intuition.
  eapply Qnnle_lt_trans. eassumption.
  apply Qnnle_lt_trans with (a * 1)%Qnn.
  apply Qnnmult_le_compat. apply Qnnle_refl.
  apply Qnnlt_le_weak. assumption.
  replace 1%Qnn with (1 * 1)%Qnn at 2 by ring.
  apply Qnnmult_lt_compat_r. apply Qnnlt_alt. reflexivity.
  assumption.
Qed.

Lemma LPRind_max {U V : Prop}
  : LPRindicator (U \/ V) = LPRmax (LPRindicator U) (LPRindicator V).
Proof.
apply LPReq_compat.
split; unfold LPRle; simpl in *; intros; intuition.
Qed.

Lemma LPRind_exists : forall (A : Type) (f : A -> Prop),
  LPRindicator (exists a, f a) = LPRsup (fun a => LPRindicator (f a)).
Proof.
intros. apply LPRle_antisym; unfold LPRle; simpl; intros.
- destruct H as [[a fa] q1]. exists a. intuition.
- destruct H as [a [fa q1]]. split. exists a. assumption. assumption.
Qed.

Lemma LPRind_min {U V : Prop}
  : LPRindicator (U /\ V) = LPRmin (LPRindicator U) (LPRindicator V).
Proof.
apply LPReq_compat.
split; unfold LPRle; simpl in *; intros; intuition.
Qed.

Lemma LPRind_modular {U V : Prop} :
   LPRindicator U + LPRindicator V =
   LPRindicator (U /\ V) + LPRindicator (U \/ V).
Proof.
apply LPReq_compat; split; unfold LPRle; intros q H.
- destruct H.
  + apply LPRplusR. rewrite LPRind_max. left. assumption.
  + apply LPRplusR. rewrite LPRind_max. right. assumption.
  +  simpl in *. intuition. eapply LPRplusB. rewrite LPRind_min.
     simpl in *. intuition.  apply H3. apply H3. rewrite LPRind_max.
     simpl. right. split. apply H. apply H4. assumption.
- destruct H.
  + eapply LPRplusB; simpl in *; intuition. eassumption. eassumption.
    replace q with (q + 0)%Qnn at 1 by ring.
    apply Qnnplus_le_compat. apply Qnnle_refl. apply nonneg.
  + simpl in *. destruct H. destruct H.
    * apply LPRplusL. simpl. intuition.
    * apply LPRplusR. simpl. intuition.
  + simpl in *. eapply LPRplusB; simpl in *; intuition.
    eapply H3. assumption. eapply H4. assumption. assumption.
    assumption.
Qed.

Lemma LPRplus_eq_compat : forall x y x' y',
  x = x' -> y = y' -> x + y = x' + y'.
Proof. intros. subst. reflexivity. Qed.

Lemma LPRmult_eq_compat : forall x y x' y',
  x = x' -> y = y' -> x * y = x' * y'.
Proof. intros. subst. reflexivity. Qed.

Lemma LPRQnn_eq {x y : Qnn} : x = y -> LPRQnn x = LPRQnn y.
Proof. intros; subst; reflexivity. Qed.

Lemma LPRmax_scales {c x y : LPReal}
  : LPRmax (c * x) (c * y) = c * LPRmax x y.
Proof.
apply LPReq_compat. split.
- apply LPRmax_le_and; (apply LPRmult_le_compat;
  [ apply LPRle_refl
  | apply LPRmax_le_or; auto using LPRle_refl]).
- unfold LPRle; simpl; intros.
  destruct H as [a b ca xyb qab].
  destruct xyb; [left | right];
  constructor 1 with a b; auto.
Qed.

Lemma LPRsup_scales {A : Type} {f : A -> LPReal}
  {c : LPReal}
  : c * LPRsup f = LPRsup (fun x => c * f x).
Proof.
apply LPReq_compat; split.
- unfold LPRle; simpl; intros.
  destruct H as [a b ca sup qab].
  destruct sup. exists x. constructor 1 with a b; intuition.
- apply LPRsup_le. intros. apply LPRmult_le_compat.
  apply LPRle_refl. apply LPRsup_ge.
Qed.

Lemma LPRsup_constant {A : Type} (x : LPReal) :
  A -> LPRsup (fun _ : A => x) = x.
Proof.
intros. apply LPReq_compat; split; unfold LPRsup, LPRle; simpl; intros.
destruct H. assumption. exists X. assumption.
Qed.

Lemma Qnnpowsup {p : Qnn} (plt1 : (p < 1)%Qnn)
  : LPRsup (fun n => LPRQnn (1 - (p ^ n)))%Qnn = 1.
Proof.
apply LPReq_compat. split.
- replace 1 with (LPRsup (fun _ : nat => 1)).
  apply LPRsup_monotonic. intros n.
  induction n; simpl.
   + unfold LPRle. simpl. intros.
     apply Qnnminus_lt_r in H; [|apply Qnnle_refl].
     eapply Qnnle_lt_trans; [| eassumption].
     replace q with (0 + q)%Qnn at 1 by ring. apply Qnnplus_le_compat.
     apply nonneg. apply Qnnle_refl.
   + unfold LPRle. simpl. intros.
     apply LPRQnn_le in IHn. apply Qnnminus_lt_r in H.
     eapply Qnnle_lt_trans. Focus 2. apply H.
     replace q with (0 + q)%Qnn at 1 by ring.
     apply Qnnplus_le_compat. apply nonneg. apply Qnnle_refl.
     pose proof (Qnnpow_le (Qnnlt_le_weak plt1) (n := S n)) as pn1.
     apply pn1.
   + apply LPRsup_constant. exact 0%nat.
- unfold LPRle; simpl; intros.
  pose proof (Qnnlt_le_weak H) as Hle.
  pose proof (smallPowers plt1 (1 - q)%Qnn).
  destruct (Qnn_dec q 0%Qnn).
  destruct s. apply Qnnlt_zero_prop in q0. contradiction.
  assert (1 - q > 0)%Qnn.
  apply Qnnminus_lt_r. assumption.
  replace (q + 0)%Qnn with q by ring. assumption.
  apply H0 in H1. destruct H1. exists x. apply Qnnminus_lt_r.
  apply Qnnpow_le. apply Qnnlt_le_weak. assumption.
  apply Qnnminus_lt_r in H1. rewrite (SRadd_comm Qnnsrt).
  assumption. assumption. subst. exists 1%nat. simpl. apply Qnnminus_lt_r.
  replace (p * 1)%Qnn with p by ring. apply Qnnlt_le_weak.
  assumption.
  replace (p * 1 + 0)%Qnn with p by ring. assumption.
Qed.

Lemma LPRQnn_mult {x y : Qnn} : LPRQnn x * LPRQnn y = LPRQnn (x * y)%Qnn.
Proof.
apply LPRle_antisym; unfold LPRle; simpl; intros.
- destruct H as [a b pa pb pab]. simpl in *.
  eapply Qnnle_lt_trans. eassumption.
  eapply Qnnle_lt_trans. Focus 2.
  eapply Qnnmult_lt_compat_r. eapply Qnnle_lt_trans. 3:eassumption.
  apply nonneg. eassumption.
  rewrite pb. reflexivity.
- destruct (Qnnmult_open H) as [a [b pab]].
  constructor 1 with a b; intuition.
Qed.


Require Import ZArith.

Open Scope Z_scope.

Fixpoint div_bin (n m:positive) : Z*Z :=
  match n with
    | 1%positive    =>  match m with
                          | 1%positive    => (1,0)
                          | v             => (0,1)
                        end
    | xO n'         =>  let (q',r') := div_bin n' m in
                        match Z_lt_ge_dec (2*r')(Zpos m) with
                          | left _    => (2*q', 2*r')
                          | right _   => (2*q'+1, 2*r' - (Zpos m))
                        end
    | xI n'         =>  let (q',r') := div_bin n' m in
                        match Z_lt_ge_dec (2*r'+1)(Zpos m) with
                          | left _    => (2*q', 2*r' + 1)
                          | right _   => (2*q' + 1, (2*r'+1)-(Zpos m))
                        end
  end.

Lemma rem_1_1_interval : 0 <= 0 < 1.
Proof.
  auto with zarith. (* omega also works *)
Qed.

Lemma rem_1_even_interval : forall m: positive,
  0 <= 1 < Zpos (xO m).
Proof.
  intros m. split.
  auto with zarith.
(*
Nothing comes up
SearchPattern (1 < Zpos _).
*)
(*
Locate "_ < _".
  Notation            Scope
  "x < y" := Pos.lt x y          : positive_scope

  "x < y" := lt x y    : nat_scope

  "x < y" := Z.lt x y  : Z_scope (default interpretation)
  "x < y" := N.lt x y  : N_scope
*)
(*
Print Z.lt.
Z.lt = fun x y : Z => (x ?= y) = Lt
     : Z -> Z -> Prop
*)
compute. (* trick !!!! simpl fails but compute works !!! *)
reflexivity.
Qed.

Lemma rem_1_odd_interval : forall m:positive,
  0 <= 1 < Zpos(xI m).
Proof.
  intros m. split.
  auto with zarith.
  compute. reflexivity.
Qed.

Lemma rem_even_ge_interval : forall m r:Z,
  0 <= r < m -> m <= 2*r -> 0 <= 2*r - m < m.
Proof.
  intros. omega.
Qed.

Lemma rem_even_lt_interval: forall m r:Z,
  0 <= r < m -> 2*r < m -> 0 <= 2*r < m.
Proof.
  intros. omega.
Qed.

Lemma rem_odd_ge_interval: forall m r:Z,
  0 <= r < m -> m <= 2*r + 1 -> 0 <= 2*r + 1 - m < m.
Proof.
  intros. omega.
Qed.

Lemma rem_odd_lt_interval: forall m r:Z,
  0 <= r < m -> 2*r + 1 < m -> 0 <= 2*r + 1 < m.
Proof.
  intros. omega.
Qed.

Ltac div_bin_tac arg1 arg2 :=
  elim arg1;
    [intros p; lazy beta iota delta [div_bin]; fold div_bin;
      case (div_bin p arg2); unfold snd; intros q' r' Hrec;
      case (Z_lt_ge_dec (2*r' + 1)(Zpos arg2)); intros H
    | intros p; lazy beta iota delta [div_bin]; fold div_bin;
      case (div_bin p arg2); unfold snd; intros q' r' Hrec;
      case (Z_lt_ge_dec (2*r')(Zpos arg2)); intros H
    | case arg2; lazy beta iota delta [div_bin]; intros].

Hint Resolve rem_odd_ge_interval rem_even_ge_interval
rem_odd_lt_interval rem_even_lt_interval rem_1_odd_interval
rem_1_even_interval rem_1_1_interval.

Theorem div_bin_rem_lt:
  forall n m:positive, 0 <= snd (div_bin n m) < Zpos m.
Proof.
  intros n m. div_bin_tac n m; unfold snd; auto; omega.
Qed.

(* fails...
SearchRewrite (Zpos (xI _)).
*)

(*
Check Zpos_xI.
  Pos2Z.inj_xI
       : forall p : positive, Z.pos p~1 = 2 * Z.pos p + 1
*)

(*
Check Zpos_xO.
  Pos2Z.inj_xO
       : forall p : positive, Z.pos p~0 = 2 * Z.pos p
*)

Theorem div_bin_eq:
  forall n m:positive, Zpos n = (fst (div_bin n m))*(Zpos m) + snd (div_bin n m).
Proof.
  intros n m. div_bin_tac n m;
  rewrite Zpos_xI || (try rewrite Zpos_xO);
  try rewrite Hrec; unfold fst, snd; ring.
Qed.

Inductive div_data (n m:positive) : Set :=
  | div_data_def : forall q r:Z,
    Zpos n = q*(Zpos m)+r -> 0 <= r < Zpos m -> div_data n m.

Definition div_bin2 : forall n m:positive, div_data n m.
  intros n m. elim n.
  intros n' [q r H_eq H_int].
  case (Z_lt_ge_dec (2*r + 1)(Zpos m)).
  exists (2*q)(2*r + 1).
  rewrite Zpos_xI; rewrite H_eq; ring.
  auto.
  exists (2*q+1)(2*r + 1 - (Zpos m)).
  rewrite Zpos_xI; rewrite H_eq; ring.
  omega.
Abort.

Definition div_bin3 : forall n m:positive, div_data n m.
  refine
    ((fix div_bin3 (n:positive) : forall m:positive, div_data n m :=
      fun m =>
        match n return div_data n m with
          | 1%positive  =>
            match m return div_data 1 m with
              | 1%positive => div_data_def 1 1 1 0 _ _
              | xO p => div_data_def 1 (xO p) 0 1 _ _
              | xI p => div_data_def 1 (xI p) 0 1 _ _
            end
          | xO p  =>
            match div_bin3 p m with
              | div_data_def q r H_eq H_int =>
                  match Z_lt_ge_dec (Zmult 2 r)(Zpos m) with
                    | left hlt =>
                        div_data_def (xO p) m (Zmult 2 q)
                                     (Zmult 2 r) _ _
                    | right hge =>
                        div_data_def (xO p) m (Zplus (Zmult 2 q) 1)
                                     (Zminus (Zmult 2 r)(Zpos m)) _ _
                  end
            end
          | xI p =>
            match div_bin3 p m with
              | div_data_def q r H_eq H_int =>
                  match Z_lt_ge_dec (Zplus (Zmult 2 r) 1)(Zpos m) with
                    | left hlt =>
                        div_data_def (xI p) m (Zmult 2 q)
                                     (Zplus (Zmult 2 r) 1) _ _
                    | right hge =>
                        div_data_def (xI p) m (Zplus (Zmult 2 q) 1)
                        (Zminus (Zplus (Zmult 2 r) 1)(Zpos m)) _ _
                  end
              end
            end));
  clear div_bin3; try rewrite Zpos_xI; try rewrite Zpos_xO;
  try rewrite H_eq; auto with zarith; try (ring; fail).
  split;[auto with zarith | compute; auto].
  split;[auto with zarith | compute; auto].
Defined.


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

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

Unset Positivity Checking.
Unset Guard Checking.

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

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

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

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

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


Require Import Arith.
Require Import ZArith.
Require Import List.

Parameters (prime_divisor : nat -> nat)
           (prime : nat -> Prop)
           (divides : nat -> nat -> Prop).

Open Scope nat_scope.

Check (prime (prime_divisor 220)).

Check (divides (prime_divisor 220) 220).

Check (divides 3).

Parameter binary_word : nat -> Set.

Definition short : Set := binary_word 32.

Definition long : Set := binary_word 64.

Check ((nat -> nat) -> Prop).
Check ((nat -> nat) -> (nat -> nat) -> Prop).
Check (nat -> nat -> Set).

Check (not (divides 3 81)).
Check (let d := prime_divisor 220 in prime d /\ divides d 220).

Parameters (decomp : nat -> list nat) (decomp2 : nat -> nat * nat).

Check (decomp 220).
Check (decomp2 284).

Check @cons.
Check @pair.
Check (forall A B : Set, A -> B -> A*B).
Check @fst.

Check @le_n.
Check @le_S.
Check (le_n 36).

Definition le_36_37 := le_S 36 36 (le_n 36).
Check le_36_37.

Definition le_36_38 := le_S 36 37 le_36_37.
Check le_36_38.

Check (le_S _ _ (le_S _ _ (le_n 36))).

Definition twice : forall A : Set, (A -> A) -> A -> A :=
  fun A f a => f (f a).

Check (twice Z).
Check (twice Z (fun z => (z*z)%Z)).
Check (twice _ S 56).
Check (twice (nat -> nat) (fun f x => f (f x)) (mult 3)).

Eval compute in (twice (nat -> nat) (fun f x => f (f x)) (mult 3) 1).

Theorem le_i_SSi : forall i : nat, i <= S (S i).
Proof (fun i : nat => le_S _ _ (le_S _ _ (le_n i))).

Definition compose :
  forall A B C : Set, (A -> B) -> (B -> C) -> A -> C :=
    fun A B C f g x => g (f x).

Print compose.

Check (fun (A : Set) (f : Z -> A) => compose _ _ _ Z_of_nat f).

Implicit Arguments compose [A B C].
Implicit Arguments le_S [n m].

Check (le_S (le_i_SSi 1515)).

Check (compose (C := Z) S).

Check (le_S (n := 45)).

Reset compose.
Set Implicit Arguments.

Definition compose (A B C : Set) (f : A -> B) (g : B -> C) (a : A) :=
  g (f a).

Definition thrice (A : Set) (f : A -> A) := compose f (compose f f).

Unset Implicit Arguments.

Print compose.
Print thrice.

Eval cbv beta delta in (thrice (thrice (A := nat)) S O).

(* Exercise: 4.3 *)
Section A_declared.
  Variables (A : Set) (P Q : A -> Prop) (R : A -> A -> Prop).

  Theorem all_perm : (forall a b : A, R a b) -> forall a b : A, R b a.
  Proof (fun (H : forall a b : A, R a b) (a b : A) => H b a).

  Theorem all_imp_dist :
    (forall a : A, P a -> Q a) -> (forall a : A, P a) ->
      (forall a : A, Q a).
  Proof
    (fun (H : forall a : A, P a -> Q a) (H' : forall a : A, P a) (a : A) =>
      H a (H' a)).

  Theorem all_delta : (forall a b : A, R a b) -> forall a : A, R a a.
  Proof (fun (H : forall a b : A, R a b) (a : A) => H a a).

End A_declared.

Check (forall n : nat, 0 < n -> nat).

Theorem id : forall A : Set, A -> A.
Proof (fun (A : Set) (a : A) => a).

Theorem diag : forall A B : Set, (A -> A -> B) -> A -> B.
Proof (fun (A B : Set) (f : A -> A -> B) (a : A) => f a a).

Theorem permute : forall A B C : Set, (A -> B -> C) -> B -> A -> C.
Proof (fun (A B C : Set) (f : A -> B -> C) (b : B) (a : A) => f a b).

Theorem f_nat_Z : forall A : Set, (nat -> A) -> Z -> A.
Proof (fun (A : Set) (f : nat -> A) (z : Z) => f (Z.to_nat z)).


(** 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) (x : natural) : natural := plus x (mult x y).


From Coq Require Import Init.Nat Lia.
From QuickChick Require Import QuickChick.
From mathcomp Require Import ssreflect ssreflect.eqtype.
Import QcNotation. Import QcDefaultNotation.

Require Import ExtLib.Structures.Monads.
Open Scope monad_scope.
Open Scope qc_scope.
Open Scope nat_scope.

From Ltac2 Require Import Ltac2.

(* Some small examples for checker proof derivation *)

Inductive wf_list : list nat -> Prop :=
| lnil : wf_list nil
| lcons :
    forall l,
      wf_list l -> wf_list l.

Derive DecOpt for (wf_list l).

Inductive wf_list2 : list nat -> Prop :=
| lcons2 :
    forall l,
      wf_list2 l -> wf_list2 l.

Derive DecOpt for (wf_list2 l).

(* For each DecOpt instance we should be able to derive the following *)

Instance DecOptwf_listSizeMonotonic l : DecOptSizeMonotonic (wf_list l).
Proof. derive_mon (). Qed.

Instance DecOptwf_list_sound l : DecOptSoundPos (wf_list l).
Proof. derive_sound (). Qed.

Instance DecOptwf_list_complete l : DecOptCompletePos (wf_list l).
Proof. derive_complete (). Qed.

(* Counter-example for completess *)
Goal (forall l, ~ wf_list2 l).
Proof.
  intros l Hwf. induction Hwf; eauto.
Qed.

Inductive list_len : nat -> list nat -> Prop :=
| nil_len : list_len 0 nil
| cons_len :
    forall n x l,
      list_len n l ->
      wf_list l -> (* silly; just to test proofs *)
      list_len (S n) (x :: l).

Derive DecOpt for (list_len n l).

Instance DecOptlist_lenSizeMonotonic n l : DecOptSizeMonotonic (list_len n l).
Proof. derive_mon (). Qed.

Instance DecOptlist_len_sound n l : DecOptSoundPos (list_len n l).
Proof. derive_sound (). Qed.

Instance DecOptlist_len_complete n l : DecOptCompletePos (list_len n l).
Proof. derive_complete (). Qed.

Inductive tree :=
| Leaf : tree
| Node : nat -> tree -> tree -> tree.
Derive Show for tree.
Derive Arbitrary for tree.

Derive ArbitrarySizedSuchThat for (fun n => le n n').
Derive ArbitrarySizedSuchThat for (fun n' => le n n').

Inductive bst : nat -> nat -> tree -> Prop :=
| BstLeaf : forall n1 n2, bst n1 n2 Leaf
| BstNode : forall min max n t1 t2,
    le min max -> le min n -> le n max ->
    bst min n t1 -> bst n max t2 ->
    bst min max (Node n t1 t2).

Derive DecOpt for (le n m).
Derive DecOpt for (bst min max t).

(* For each DecOpt instance we should be able to derive the following *)
Instance decOptbstSizeMonotonic m n t : DecOptSizeMonotonic (bst m n t).
Proof. derive_mon (). Qed.

Instance DecOptbst_sound m n t : DecOptSoundPos (bst m n t).
Proof. derive_sound (). Qed.

Instance DecOptbst_complete m n t : DecOptCompletePos (bst m n t).
Proof. derive_complete (). Qed.

Derive ArbitrarySizedSuchThat for (fun b => bst min max b).

Conjecture expand_range : forall t,
    bst 0 30 t ->
    bst 0 40 t.
QuickChick expand_range.
Conjecture contract_range : forall t,
    bst 0 30 t ->
    bst 0 1 t.
QuickChick expand_range.
(* this shouldn't work *)

Fixpoint insert t x :=
  match t with
  | Leaf => Node x Leaf Leaf
  | Node a l r =>
    if a <= x ? then
      Node x (insert l x) r
    else
      Node x r (insert r x)
  end.

Inductive inrange : nat -> nat -> tree -> nat -> Prop :=
| InRange : forall t n max x,
    le n max ->
    bst 0 max t ->
    le x max ->
    inrange n max t x.
Derive DecOpt for (inrange n m t x).
Derive ArbitrarySizedSuchThat for (fun n => inrange n m t x).

(* Testing here doesn't work *)
(* Conjecture insert_invariant : *)
(*   forall t, *)
(*     inrange 30 30 t 30 -> *)
(*     bst 0 30 t. *)
(* QuickChick insert_invariant. *)


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

(* Following a discussion on Coq-Zulip

    https://coq.zulipchat.com/#narrow/stream/237977-Coq-users/topic/Problem.20with.20nested.20fixpoints/near/309498019

   we implement the nested short lex(icographic) order on list based rose-trees
   and show that it is a (strongly) total strict order on those trees, but
   however it is NOT well-founded as we expose a strictly decreasing sequence *)

From Coq
  Require Import Arith List Lia Wellfounded Utf8.

From KruskalTrees
  Require Import notations tactics list_utils rtree.

Import ListNotations rtree_notations.

Set Implicit Arguments.

#[local] Reserved Notation "l '<lex' m " (at level 70, no associativity, format "l  <lex  m").
#[local] Reserved Notation "l '<slex' m " (at level 70, no associativity, format "l  <slex  m").
#[local] Reserved Notation "l '<rlex' m " (at level 70, no associativity, format "l  <rlex  m").

Section measure_rect.

  Variable (X : Type) (m : X → nat) (P : X → Type).

  Hypothesis F : ∀x, (∀y, m y < m x → P y) → P x.

  Definition measure_rect x : P x.
  Proof.
    cut (Acc (fun x y => m x < m y) x); [ revert x | ].
    + refine (
        fix loop x Dx := @F x (fun y Dy => loop y _)
      ).
      apply (Acc_inv Dx), Dy.
    + apply wf_inverse_image with (f := m), lt_wf.
  Qed.

End measure_rect.

Tactic Notation "induction" "on" hyp(x) "as" ident(IH) "with" "measure" uconstr(f) :=
  pattern x; revert x; apply measure_rect with (m := fun x => f); intros x IH.

Definition order_stotal {X} (R : X → X → Prop) :=
     (∀ x y, { R x y } + { x = y } + { R y x }).

Section order.

  Context {X : Type}.

  Implicit Type (l m : list X).

  Definition list_shorter l m := ⌊l⌋ < ⌊m⌋.

  Fact list_shorter_wf : well_founded list_shorter.
  Proof. unfold list_shorter; apply wf_inverse_image, lt_wf. Qed.

  Variable (R : X → X → Prop).

  Inductive list_lex : list X -> list X -> Prop :=
    | list_lex_init x y l m : R x y → ⌊l⌋ = ⌊m⌋ → x::l <lex y::m
    | list_lex_cons x l m : l <lex m → x::l <lex x::m
  where "l <lex m" := (list_lex l m).

  Fact list_lex_length l m : l <lex m → ⌊l⌋ = ⌊m⌋.
  Proof. induction 1; simpl; f_equal; auto. Qed.

  Fact list_lex_inv l m :
        l <lex m
      → match m with
        | []   => False
        | y::m =>
          match l with
          | []   => False
          | x::l => R x y ∧ ⌊l⌋ = ⌊m⌋
                  ∨ x = y ∧ l <lex m
          end
        end.
  Proof. destruct 1; eauto. Qed.

  Section list_lex_irrefl.

    Let list_lex_irrefl_rec l m : l <lex m → l = m → ∃x, x ∈ l ∧ R x x.
    Proof.
      induction 1 as [ x y l m H1 H2 | x l m H IH ].
      + inversion 1; subst; simpl; eauto.
      + inversion 1; subst.
        destruct IH as (? & ? & ?); simpl; eauto.
    Qed.

    Fact list_lex_irrefl l : l <lex l → ∃x, x ∈ l ∧ R x x.
    Proof. intros H; apply list_lex_irrefl_rec with (1 := H); auto. Qed.

  End list_lex_irrefl.

  Lemma list_lex_trans l m k :
          (∀ x y z, x ∈ l → y ∈ m → z ∈ k → R x y → R y z → R x z)
        → l <lex m → m <lex k → l <lex k.
  Proof.
    intros H1 H2; revert H2 k H1.
    induction 1 as [ x y l m H1 H2 | x l m H IH ]; intros k HR Hk.
    + apply list_lex_inv in Hk.
      destruct k as [ | z k ]; try easy.
      destruct Hk as [ [H3 H4] | [[] H4]].
      * constructor 1; eauto; try lia.
        revert H1 H3; apply HR; simpl; auto.
      * constructor 1; auto.
        apply list_lex_length in H4; lia.
    + apply list_lex_inv in Hk.
      destruct k as [ | z k ]; try easy.
      destruct Hk as [ [H3 H4] | [[] H4]].
      * constructor 1; auto.
        apply list_lex_length in H; lia.
      * constructor 2.
        apply IH; auto.
        intros ? ? ? ? ? ?; apply HR; simpl; auto.
  Qed.

  Lemma list_lex_stotal l m :
          ⌊l⌋ = ⌊m⌋
        → (∀ x y, x ∈ l → y ∈ m → { R x y } + { x = y } + { R y x })
        → { l <lex m } + { l = m } + { m <lex l }.
  Proof.
    revert m; induction l as [ | x l IHl ]; intros [ | y m ]; try discriminate; simpl; intros E H; auto.
    apply f_equal with (f := pred) in E; simpl in E.
    destruct (H x y) as [ [ Hxy | <- ] | Hxy ]; auto.
    + do 2 left; constructor 1; auto.
    + destruct (IHl _ E) as [ [ H1 | <- ] | H1 ].
      * intros; apply H; auto.
      * do 2 left; constructor 2; auto.
      * left; right; auto.
      * right; constructor 2; auto.
    + right; constructor 1; auto.
  Qed.

  Hypothesis (Rwf : well_founded R).

  Lemma list_lex_wf : well_founded list_lex.
  Proof.
    intros m; induction on m as IHm with measure (length m).
    destruct m as [ | y m ].
    + constructor; intros l Hl; apply list_lex_inv  in Hl; easy.
    + induction y as [ y IHy' ] using (well_founded_induction Rwf) in m, IHm |- *.
      assert (Acc list_lex m) as Hm by (apply IHm; simpl; auto).
      assert (forall x l, R x y -> length l = length m -> Acc list_lex (x::l)) as IHy.
      1: { intros x l Hx Hl; apply IHy'; auto.
           intros; apply IHm.
           simpl in *; rewrite <- Hl; auto. }
      clear IHy' IHm.
      induction Hm as [ m Hm IHm ] in IHy |- *.
      constructor; intros l Hl.
      apply list_lex_inv in Hl; destruct l as [ | x l ]; try tauto.
      destruct Hl as [ (Hx & Hlm) | (-> & Hl) ].
      * apply IHy; auto.
      * apply IHm; auto.
        apply list_lex_length in Hl as ->; auto.
  Qed.

  Definition list_short_lex l m := ⌊l⌋ < ⌊m⌋ ∨ l <lex m.

  Infix "<slex" := list_short_lex.

  Lemma list_short_lex_irrefl l : l <slex l → ∃x, x ∈ l ∧ R x x.
  Proof.
    intros [ H | H ]; try lia.
    revert H; apply list_lex_irrefl.
  Qed.

  Lemma list_short_lex_trans l m k :
        (∀ x y z, x ∈ l → y ∈ m → z ∈ k → R x y → R y z → R x z)
      → l <slex m -> m <slex k -> l <slex k.
  Proof.
    intros H0 [H1|H1] [H2|H2].
    + constructor 1; lia.
    + apply list_lex_length in H2; constructor 1; lia.
    + apply list_lex_length in H1; constructor 1; lia.
    + constructor 2; eapply list_lex_trans; eauto.
  Qed.

  Lemma list_short_lex_stotal l m :
       (∀ x y, x ∈ l → y ∈ m → { R x y } + { x = y } + { R y x })
     → { list_short_lex l m } + { l = m } + { list_short_lex m l }.
  Proof.
    intros Hlm.
    destruct (lt_eq_lt_dec (length l) (length m)) as [ [| E] |].
    + do 2 left; constructor 1; auto.
    + destruct list_lex_stotal with (1 := E) as [[|[]]|]; auto.
      * do 2 left; constructor 2; auto.
      * right; constructor 2; auto.
    + right; constructor 1; auto.
  Qed.

  Lemma list_short_lex_wf : well_founded list_short_lex.
  Proof.
    intros m.
    induction on m as IH with measure (length m).
    induction m as [ m IHm ] using (well_founded_induction list_lex_wf).
    constructor; intros l [ Hl | Hl ]; auto.
    apply IHm; auto.
    apply list_lex_length in Hl as ->; eauto.
  Qed.

End order.

#[local] Hint Constructors list_lex : core.

(** This is the nested list short lex order *)

Unset Elimination Schemes.

Inductive rtree_slex : rtree → rtree → Prop :=
  | rtree_slex_intro l m : l <slex m → ⟨l⟩ᵣ <rlex ⟨m⟩ᵣ
where "r <rlex s" := (rtree_slex r s)
and "l <slex m" := (list_short_lex rtree_slex l m).

Set Elimination Schemes.

#[local] Hint Constructors rtree_slex : core.

(** A versatile non-dependent induction principle for rtree_slex
    but we do ot use it below *)

Section rtree_slex_ind.

  Variables (P : rtree → rtree → Prop)
            (HP : ∀ l m, l <slex m → list_short_lex P l m → P ⟨l⟩ᵣ ⟨m⟩ᵣ).

  Fixpoint rtree_slex_ind l m (H : l <rlex m) { struct H } : P l m.
  Proof.
    destruct H as [ l m H ]; apply HP; destruct H as [ H | H ].
    + constructor 1; trivial.
    + right; induction H; eauto.
    + constructor 1; trivial.
    + constructor 2; induction H.
      * constructor 1; trivial.
        apply rtree_slex_ind, H.
      * constructor 2; trivial.
  Qed.

End rtree_slex_ind.

(* However we use the inversion lemma below *)
Fact rtree_slex_inv r t :
        rtree_slex r t
      → match r, t with
          | ⟨l⟩ᵣ, ⟨m⟩ᵣ => l <slex m
        end.
Proof. now destruct 1. Qed.

(** rtree_slex is a strongly total strict order:
     - it is irreflexive and transitive
     - one can computationally decide r <rlex t or r = t or t <rlex r *)

Theorem rtree_slex_irrefl t : ¬ t <rlex t.
Proof. red; induction t; intros (? & ? & ?)%rtree_slex_inv%list_short_lex_irrefl; eauto. Qed.

Theorem rtree_slex_trans r s t : r <rlex s → s <rlex t → r <rlex t.
Proof.
  revert s t; induction r as [ l IHl ]; intros [m] [p] H1%rtree_slex_inv H2%rtree_slex_inv.
  constructor.
  revert H1 H2; apply list_short_lex_trans; eauto.
Qed.

Theorem rtree_slex_stotal : order_stotal rtree_slex.
Proof.
  intros r.
  induction r as [ l IH ]; intros [ m ].
  destruct (list_short_lex_stotal rtree_slex l m) as [ [|[]] | ];auto.
Qed.

(** However rtree_slex is NOT well-founded because [x,y] > [[x,y]] > [[[x,y]] ... *)

Fixpoint rtree_decr_seq n :=
  match n with
    | 0 => ⟨[⟨[]⟩ᵣ;⟨[]⟩ᵣ]⟩ᵣ
    | S n => ⟨[rtree_decr_seq n]⟩ᵣ
  end.

Fact rtree_decr_seq_spec n : rtree_decr_seq (S n) <rlex rtree_decr_seq n.
Proof.
  induction n as [ | n IHn ]; simpl.
  + simpl; constructor; constructor 1; simpl; auto.
  + simpl; constructor; constructor 2; auto.
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 (lf3 : natural) (y : natural) (lf2 : natural) : natural :=
  plus y (plus lf2 lf3).


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

Require Import Arith Omega List.

Require Import notations acc_utils list_utils finite.

Set Implicit Arguments.

Section trees.

  Variable (X : Type).

  (* we do not want the too weak Coq generated induction principles *)

  Unset Elimination Schemes.

  Inductive tree : Type := in_tree : X -> list tree -> tree.

  Set Elimination Schemes.

  Definition tree_root t := match t with in_tree x _ => x end.
  Definition tree_sons t := match t with in_tree _ l => l end.

  Fact tree_root_sons_eq t : t = in_tree (tree_root t) (tree_sons t).
  Proof. destruct t; auto. Qed.

  (* the immediate subtree relation *)

  Definition imsub_tree s t := match t with in_tree _ ll => In s ll end.

  Infix "<ist" := imsub_tree (at level 70).

  Fact imsub_tree_fix s t :  s <ist t <-> exists x ll, In s ll /\ t = in_tree x ll.
  Proof.
    split.
    destruct t as [ x ll ]; exists x, ll; auto.
    intros (x & ll & H1 & ?); subst; auto.
  Qed.

  (* The immediate subtree relation is well founded *)

  Fixpoint imsub_tree_wf t : Acc imsub_tree t.
  Proof.
    refine (
      match t with
        | in_tree x ll => Acc_intro _ _
      end); simpl; clear x t.
    induction ll as [ | x ll IH ].
    intros _ [].
    intros ? [ [] | ].
    apply imsub_tree_wf.
    apply IH; auto.
  Qed.

  (* let us define our own induction principles *)

  Section tree_rect.

    Variable P : tree -> Type.
    Hypothesis f : forall a ll, (forall x, In x ll -> P x) -> P (in_tree a ll).

    Let f' : forall t, (forall x, x <ist t -> P x) -> P t.
    Proof.
      intros []; apply f.
    Defined.

    Definition tree_rect t : P t.
    Proof.
      apply Fix with (1 := imsub_tree_wf), f'.
    Defined.

    Section tree_rect_fix.

      Variable E : forall t, P t -> P t -> Prop.

      Hypothesis f_ext : forall a ll f1 f2, (forall x Hx, E (f1 x Hx) (f2 x Hx)) -> E (f a ll f1) (f a ll f2).

      (* Coq recursive type-checking does not allow such a definition
         but it is possible to prove this identity
      *)

      Fact tree_rect_fix a ll : E (tree_rect (in_tree a ll)) (f a ll (fun t _ => tree_rect t)).
      Proof.
        unfold tree_rect, Fix.
        rewrite <- Fix_F_eq; unfold f'.
        apply f_ext; intros; apply Fix_F_ext.
        intros [] ? ?; apply f_ext.
      Qed.

    End tree_rect_fix.

    Section tree_rect_fix_eq.

      Hypothesis f_ext : forall a ll f1 f2, (forall x Hx, f1 x Hx = f2 x Hx) -> f a ll f1 = f a ll f2.

      Fact tree_rect_fix_eq a ll : tree_rect (in_tree a ll) = f a ll (fun t _ => tree_rect t).
      Proof.
        apply tree_rect_fix with (E := fun _ => @eq _); simpl; auto.
      Qed.

    End tree_rect_fix_eq.

  End tree_rect.

  Definition tree_rec (P : tree -> Set)  := tree_rect P.
  Definition tree_ind (P : tree -> Prop) := tree_rect P.

  Section tree_recursion.

    (* the particular case when the output type does not depend on the tree *)

    Variables (Y : Type) (f : X -> list tree -> list Y -> Y).

    Definition tree_recursion : tree -> Y.
    Proof.
      apply tree_rect.
      intros x ll IH.
      apply (f x ll (list_In_map _ IH)).
    Defined.

    (* In that case, extensionnality is for free *)

    Fact tree_recursion_fix x ll : tree_recursion (in_tree x ll) = f x ll (map tree_recursion ll).
    Proof.
      unfold tree_recursion at 1.
      rewrite tree_rect_fix with (E := fun _ => eq).
      f_equal; apply list_In_map_eq_map.
      clear x ll; intros x ll g h H; simpl.
      f_equal; apply list_In_map_ext, H.
    Qed.

  End tree_recursion.

  (* finite quantification over the nodes of trees *)

  Section tree_fall_exst.

    Variable P : X -> list tree -> Prop.

    Definition tree_fall (t : tree) : Prop.
    Proof.
      induction t as [ a ll IH ].
      exact (P a ll /\ forall x Hx, IH x Hx).
    Defined.

   (* this is how we would like tree_fall to be recursively defined but this would
       not be well-formed in Coq
    *)

    Fact tree_fall_fix x ll : tree_fall (in_tree x ll) <-> P x ll /\ forall t, In t ll -> tree_fall t.
    Proof.
      unfold tree_fall at 1.
      rewrite tree_rect_fix
        with (E := fun _ A B => A <-> B);
        firstorder.
    Qed.

    Section tree_fall_rect.

      Variable (Q : tree -> Type).

      Hypothesis HQ : forall x ll, tree_fall (in_tree x ll) -> (forall t, In t ll -> Q t) -> Q (in_tree x ll).

      Theorem tree_fall_rect t : tree_fall t -> Q t.
      Proof.
        induction t as [ x ll IH ]; intros H.
        apply HQ; auto.
        rewrite tree_fall_fix in H; destruct H; auto.
      Qed.

    End tree_fall_rect.

    Definition tree_fall_rec (Q : tree -> Set) := @tree_fall_rect Q.
    Definition tree_fall_ind (Q : tree -> Prop) := @tree_fall_rect Q.

    Definition tree_exst (t : tree) : Prop.
    Proof.
      induction t as [ a ll IH ].
      exact (P a ll \/ exists x Hx, IH x Hx).
    Defined.

    Let disj_eq_prop (A B B' : Prop) : (B <-> B') -> (A \/ B <-> A \/ B').
    Proof. tauto. Qed.

    Fact tree_exst_fix x ll : tree_exst (in_tree x ll) <-> P x ll \/ exists t, In t ll /\ tree_exst t.
    Proof.
      unfold tree_exst at 1.
      rewrite tree_rect_fix
        with (E := fun _ A B => A <-> B).
      apply disj_eq_prop.
      split; intros (y & ? & ?); exists y; split; auto.
      intros; apply disj_eq_prop.
      split; intros (y & Hy & ?); exists y, Hy; apply H; auto.
    Qed.

  End tree_fall_exst.

  Fact tree_fall_inc (P Q : _ -> _ -> Prop) : P inc2 Q -> tree_fall P inc1 tree_fall Q.
  Proof.
    intros H t; induction t as [ x ll IH ].
    repeat rewrite tree_fall_fix.
    intros []; split; auto.
  Qed.

  Fact tree_exst_inc (P Q : _ -> _ -> Prop) : P inc2 Q -> tree_exst P inc1 tree_exst Q.
  Proof.
    intros H t; induction t as [ x ll IH ].
    repeat rewrite tree_exst_fix.
    intros [| (t & ? & ?)]; [ left | right ]; auto; exists t; auto.
  Qed.

  Section tree_fall_exst_dec.

    Variable (P Q : X -> list tree -> Prop).

    Hypothesis PQ_incomp : forall x ll, P x ll -> Q x ll -> False.

    Fact tree_fall_exst_incomp t : tree_fall P t -> tree_exst Q t -> False.
    Proof.
      induction t as [ x ll IH ].
      rewrite tree_fall_fix, tree_exst_fix.
      intros [ H1 H2 ] [ H3 | (t & H3 & H4) ].

      apply PQ_incomp with (1 := H1); auto.
      apply IH with (1 := H3); auto.
    Qed.

    Hypothesis PQ_dec : forall x ll, { P x ll } + { Q x ll }.

    Fact tree_fall_exst_dec t : { tree_fall P t } + { tree_exst Q t }.
    Proof.
      induction t as [ x ll IH ].
      destruct (list_choose_rec (tree_exst Q) (tree_fall P) ll) as [ (t & H1 & H2) | H1 ].
      intros z Hz; specialize (IH _ Hz); tauto.

      right.
      apply tree_exst_fix.
      right; exists t; auto.

      destruct (PQ_dec x ll) as [ | H2 ].

      left; apply tree_fall_fix; auto.

      right.
      apply tree_exst_fix.
      left; auto.
    Qed.

  End tree_fall_exst_dec.

  Section tree_fall_dec.

    Variable (P : X -> list tree -> Prop).

    Hypothesis PQ_dec : forall x ll, { P x ll } + { ~ P x ll }.

    Fact tree_fall_dec t : { tree_fall P t } + { ~ tree_fall P t }.
    Proof.
      destruct (tree_fall_exst_dec _ _ PQ_dec t) as [ | C ].
      tauto.
      right; intros H.
      apply tree_fall_exst_incomp with (2 := H) (3 := C).
      intros; tauto.
    Qed.

    Fact tree_exst_dec t : { tree_exst P t } + { ~ tree_exst P t }.
    Proof.
      destruct (tree_fall_exst_dec (fun x ll => ~ P x ll) P) with (t := t) as [ C | ].
      intros x ll; specialize (PQ_dec x ll); tauto.
      right; intros H.
      apply tree_fall_exst_incomp with (2 := C) (3 := H).
      intros; tauto.
      left; auto.
    Qed.

  End tree_fall_dec.

End trees.

Section tree_map.

  Variables (X Y : Type) (f : X -> Y).

  Definition tree_map : tree X -> tree Y.
  Proof.
    induction 1 as [ x ts IH ] using tree_recursion.
    apply (in_tree (f x)), IH.
  Defined.

  Fact tree_map_fix x ts : tree_map (in_tree x ts) = in_tree (f x) (map tree_map ts).
  Proof.
    apply tree_recursion_fix.
  Qed.

End tree_map.

Section weighted_tree.

  Variable (X : Type) (w : X -> nat).

  (* We assume that there are only finitely many terms
     for a given weight *)

  Hypothesis Hf : forall n, finite_t (fun x => w x = n).

  (* We define a weight for trees which is strictly positive *)

  Definition tree_weight : tree X -> nat.
  Proof.
    induction 1 as [ c _ ll ] using tree_recursion.
    exact (1+w c+lsum ll).
  Defined.

  Fact tree_weight_fix c ll : tree_weight (in_tree c ll) = 1 + w c + lsum (map tree_weight ll).
  Proof. apply tree_recursion_fix. Qed.

  Fact tree_weight_gt_O t : 0 < tree_weight t.
  Proof. destruct t; rewrite tree_weight_fix; omega. Qed.

  (* Hence there are only finitely many trees of a given weight *)

  Fact finite_t_weighted_tree n : finite_t (fun t => tree_weight t = n).
  Proof.
    induction n as [ [ | n ] IHn ] using (well_founded_induction_type lt_wf).

    exists nil.
    intros x; split.
    intros [].
    generalize (tree_weight_gt_O x); omega.

    set (Q ln := match ln with
                   | nil  => fun _ => False
                   | n::l => fun t => w (tree_root t) = n
                                   /\ map tree_weight (tree_sons t) = l end).

    destruct finite_t_map with (Q := Q) (1 := finite_t_part n) as (ll & Hll);
      unfold Q in * |- *; clear Q.

    intros [ | x ln ].
    intros [].
    simpl; intros (H1 & H3).

    generalize (Hf x); intros Hx.
    destruct (@finite_t_Forall _ _ (fun i t => tree_weight t = i) ln) as (lt & Hlt).
    intros u Hu; apply IHn.
    apply lsum_le in Hu; omega.
    destruct Hx as (lx & Hlx).
    exists (list_prod (@in_tree _) lx lt).
    intros t.
    rewrite list_prod_spec; split.

    intros (c & ll & ? & H4 & H5); subst t; simpl.
    rewrite <- Hlx; split; auto.
    apply Hlt in H5.
    symmetry.
    clear H1 H3 Hlx lt Hlt c H4.
    induction H5; simpl; f_equal; auto.

    intros (? & ?); subst.
    destruct t as (c & l); exists c, l; split; auto.
    split.
    apply Hlx; auto.
    apply Hlt; simpl.
    clear H1 lx Hlx lt Hlt IHn.
    induction l; simpl; constructor; auto.

    exists ll.
    intros (c,l); rewrite Hll; simpl; split.
    intros ([ | x ln] & H1 & H2).
    destruct H2.
    rewrite tree_weight_fix.
    simpl in H2, H1.
    destruct H2 as (H3 & H4).
    destruct H1 as (H1 & H2).
    apply f_equal with (f := lsum) in H4.
    omega.

    rewrite tree_weight_fix.
    intros H.
    exists (w c::map tree_weight l); split.
    split.
    rewrite Forall_forall.
    intros t Ht.
    rewrite in_map_iff in Ht.
    destruct Ht as (x & ? & Hx); subst.
    apply tree_weight_gt_O.
    omega.
    simpl; split; auto.
  Qed.

End weighted_tree.


Section FirstOrder.
  Require Import Coq.Lists.List.
  Require Import Coq.Bool.Bool.
  Require Import Setoid.
  Require Import Coq.Arith.Peano_dec.

  (************************************************************************************)
  (*                           The first-order model.                                 *)
  (************************************************************************************)

Record fo_model : Type := {
                           D : Set;
                           d_Eq:  relation D; (* Equivalence of domain elements *)
                           R: nat -> (list D -> Prop); (* An ordered set of relations *)
                           F: nat -> (list D -> D); (* An ordered set of funnctions *)
                           m : nat -> nat; (* arity function for R; a list of (m n) length is given to (R n) *)
                           n : nat -> nat (* arity function for F *)
                         }.
  (************************************************************************************)
  (*                        Equiv is an equivalence relation.                         *)
 (************************************************************************************)

  (* Reflexivity of equiv *)
  Axiom equiv_refl : forall (M : fo_model) (d: D M),
                       d_Eq M d d.

  (* Symmetry of equiv *)
  Axiom equiv_symm : forall (M : fo_model) (d d' : D M),
                       d_Eq M d d' -> d_Eq M d' d.

  (* Transitivity of equiv *)
  Axiom equiv_trans : forall (M : fo_model) (d d' d'' : D M),
                        d_Eq M d d' -> d_Eq M d' d'' -> d_Eq M d d''.

  (************************************************************************************)
  (*                   Equivalence of a list of domain elements.                      *)
  (************************************************************************************)

  Definition equiv_listD : forall (M : fo_model), relation (list (D M)).
    exact (fix el M ds ds' :  Prop := match ds with
      | nil => match ds' with
                 | x :: ds'' => False (* Length differs. *)
                 | nil => True (* Base case. *)
               end
      | x :: ds'' => match ds' with
                       | y :: ds''' => (d_Eq M x y) /\ el M ds'' ds'''
                       | _ => False (* Length differs. *)
                     end
    end).
  Defined.

  (************************************************************************************)
  (*                        Indistiguishability under Equiv                           *)
  (************************************************************************************)

  (* Indistinguishability for relations *)
  Axiom ind_R : forall (M : fo_model) (ds : list (D M)) (ds' : list (D M)) (i : nat),
                  equiv_listD M ds ds' (* if two lists are equivalent *)
                  -> (R M i ds) = (R M i ds'). (* then they are either both related by R i or not *)

  (* Indisitinguishability for functions *)
  Axiom ind_F : forall (M : fo_model) (ds :list (D M)) (ds' : list (D M)) (i : nat),
                  equiv_listD M ds ds' (* if two lists are equivalent *)
                  -> d_Eq M (F M i ds) (F M i ds'). (* then they both produce the same result from a function F *)

End FirstOrder.

  Add Parametric Relation (M : fo_model) : (D M) (@d_Eq M)
    reflexivity proved by (equiv_refl M)
    symmetry proved by (equiv_symm M)
    transitivity proved by (equiv_trans M)
  as DE_rel.


Require Export Relation_Definitions.
Require Import Relation_Definitions_Implicit.
Require Import Classical.
Require Import Arith.

Local Unset Standard Proposition Elimination Names.

Record DirectedSet := {
  DS_set : Type;
  DS_ord : relation DS_set;
  DS_ord_cond : preorder DS_ord;
  DS_join_cond : forall i j:DS_set, exists k:DS_set,
    DS_ord i k /\ DS_ord j k
}.

Arguments DS_ord [d].
Arguments DS_ord_cond [d].
Arguments DS_join_cond [d].

Section for_large.

Variable I : DirectedSet.

Definition eventually (P : DS_set I -> Prop) : Prop :=
  exists i:DS_set I, forall j:DS_set I,
  DS_ord i j -> P j.

Lemma eventually_and: forall (P Q: DS_set I -> Prop),
  eventually P -> eventually Q ->
  eventually (fun i:DS_set I => P i /\ Q i).
Proof.
intros.
destruct H.
destruct H0.
destruct (DS_join_cond x x0) as [? [? ?]].
exists x1.
intros; split.
apply H.
apply preord_trans with x1; trivial.
apply DS_ord_cond.
apply H0.
apply preord_trans with x1; trivial.
apply DS_ord_cond.
Qed.

Lemma eventually_impl_base: forall (P Q: DS_set I -> Prop),
  (forall i:DS_set I, P i -> Q i) ->
  eventually P -> eventually Q.
Proof.
intros.
destruct H0.
exists x.
intros.
auto.
Qed.

Lemma eventually_impl: forall (P Q: DS_set I -> Prop),
  eventually P -> eventually (fun i:DS_set I => P i -> Q i) ->
  eventually Q.
Proof.
intros.
apply eventually_impl_base with (P := fun (i:DS_set I) =>
  P i /\ (P i -> Q i)).
tauto.
apply eventually_and; assumption.
Qed.

Definition exists_arbitrarily_large (P: DS_set I -> Prop) :=
  forall i:DS_set I, exists j:DS_set I,
  DS_ord i j /\ P j.

Lemma not_eal_eventually_not: forall (P: DS_set I -> Prop),
  ~ exists_arbitrarily_large P ->
  eventually (fun i:DS_set I => ~ P i).
Proof.
intros.
apply not_all_ex_not in H.
destruct H as [i].
exists i.
intros.
intro.
contradiction H.
exists j; split; trivial.
Qed.

Lemma not_eventually_eal_not: forall (P: DS_set I -> Prop),
  ~ eventually P ->
  exists_arbitrarily_large (fun i:DS_set I => ~ P i).
Proof.
intros.
red; intros.
apply NNPP; intro.
contradiction H.
exists i.
intros.
apply NNPP; intro.
contradiction H0.
exists j; split; trivial.
Qed.

End for_large.

Arguments eventually [I].
Arguments eventually_and [I].
Arguments eventually_impl_base [I].
Arguments eventually_impl [I].
Arguments exists_arbitrarily_large [I].
Arguments not_eal_eventually_not [I].
Arguments not_eventually_eal_not [I].

Notation "'for' 'large' i : I , p" :=
  (eventually (fun i:I => p))
  (at level 200, i ident, right associativity).

Notation "'exists' 'arbitrarily' 'large' i : I , p" :=
  (exists_arbitrarily_large (fun i:I => p))
  (at level 200, i ident, right associativity).

Section nat_DS.

Definition nat_DS : DirectedSet.
refine (Build_DirectedSet nat le _ _).
constructor; red; intros; auto with arith.
apply le_trans with y; assumption.
intros.
case (lt_eq_lt_dec i j).
exists j.
destruct s; auto with arith.
destruct e; auto with arith.
exists i; auto with arith.
Defined.

End nat_DS.


(** 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) (lf1 : natural) : natural :=
  plus y (plus Zero lf1).


Require Import Coq.Unicode.Utf8 Coq.Setoids.Setoid Coq.Lists.List.

Section pair_rel.

  Context {A B} (Ra: relation A) (Rb: relation B) `{!Equivalence Ra} `{!Equivalence Rb}.

  Definition pair_rel: relation (A * B) :=
    fun a b => Ra (fst a) (fst b) /\ Rb (snd a) (snd b).

  Global Instance: Equivalence pair_rel.
  Proof. firstorder. Qed.

End pair_rel.

Definition first {A B C} (f: A → B) (p: A * C): B * C := (f (fst p), snd p).
Definition second {A B C} (f: A → B) (p: C * A): C * B := (fst p, f (snd p)).

Lemma map_fst_map_first {A B C} (l: list (A * B)) (f: A -> C): map (@fst _ _) (map (first f) l) = map f (map (@fst _ _) l).
Proof. induction l; simpl; congruence. Qed.

Definition curry {A B C} (f: A * B → C) (a: A) (b: B): C := f (a, b).
Definition uncurry {A B C} (f: A → B → C) (p: A * B): C := f (fst p) (snd p).

Definition map_pair {X Y A B} (f: X → Y) (g: A → B) (xa: X * A): Y * B := (f (fst xa), g (snd xa)).

Lemma map_map_comp {A B C} (f: A → B) (g: B → C) (l: list A): map g (map f l) = map (Basics.compose g f) l.
Proof. apply (map_map f g). Qed.

Definition diagonal {X} (x: X): X * X := (x, x).


Require Import Arith.
Require Import FunctionalExtensionality.
Require Import Program.
Require Import Omega.

Set Implicit Arguments.

Definition Behavior (A : Type) := nat -> A.

Section shift.

  Variable A : Type.

  Implicit Types s : Behavior A.

  Definition shift s n : Behavior A :=
    fun t => s (t + n).

  Lemma unshift : forall s n i, shift s n i = s (i+n).
  Proof. unfold shift. auto. Qed.

  Lemma shift_0 : forall s, shift s 0 = s.
  Proof.
    intros s; extensionality x; replace (s x) with (s (x + 0)) by auto; apply unshift.
  Qed.

  Lemma contraction : forall s n m, shift (shift s n) m = shift s (m + n).
  Proof.
    unfold shift; intros s n m; extensionality x; rewrite plus_assoc; auto.
  Qed.

End shift.

Delimit Scope behavior_scope with behavior.

Notation "s @ n" :=
  (shift s n)
    (at level 1, no associativity) : behavior_scope.

Definition stutter_relation {A : Type} (R : Behavior A -> Behavior A -> Prop) :=
  (forall s s', R s s' -> s 0 = s' 0) /\
  (forall s s', R s s' -> exists m, R (shift s 1) (shift s' m) /\ forall k, k < m -> s' 0 = s' k) /\
  (forall s s', R s s' -> exists m, R (shift s m) (shift s' 1) /\ forall k, k < m -> s 0 = s k).

Definition stutter_equiv {A : Type} (s s' : Behavior A) : Prop :=
  exists R, R s s' /\ stutter_relation R.

Lemma stutter_equiv_stuttering_relation : forall A, stutter_relation (stutter_equiv : Behavior A -> Behavior A -> Prop).
Proof.
  intros A.
  repeat split; intros s s' H; destruct H as (R,(H,(H0,(H1,H2)))); auto.
  apply H1 in H. destruct H as (m,(H,H3)); exists m; split; auto; exists R; repeat split; auto.
  apply H2 in H. destruct H as (m,(H,H3)); exists m; split; auto; exists R; repeat split; auto.
Qed.

Lemma stutter_relation_univ : forall A (R : Behavior A -> Behavior A -> Prop),
                           stutter_relation R ->
                           forall s s',
                             R s s' ->
                             forall n, exists m, R (shift s n) (shift s' m).
Proof.
  intros A R H s s' H0 n.
  generalize dependent s. generalize dependent s'.
  induction n.
  intros s' s H0. exists 0. do 2 rewrite shift_0. auto.
  intros s' s H0. destruct H as (H,(H1,H2)).
  apply H1 in H0. destruct H0 as (m,(H0,H3)).
  apply IHn in H0. destruct H0 as (m0,H0).
  do 2 rewrite contraction in H0.
  exists (m0 + m). replace (S n) with (n + 1) by omega. auto.
Qed.

Theorem stutter_equiv_univ : forall A (s s' : Behavior A), stutter_equiv s s' ->
                                                          forall n, exists m,
                                                            stutter_equiv (shift s n) (shift s' m).
Proof.
  intros A s s' H n.
  apply stutter_relation_univ; trivial.
  apply stutter_equiv_stuttering_relation.
Qed.

Lemma id_stutter_prop : forall A, stutter_relation (fun (s s': Behavior A) => s = s').
Proof.
  intros A.
  repeat split; intros s s' H; rewrite H; auto; exists 1; split; auto;
  intros k H0; replace k with 0 by omega; auto.
Qed.

Theorem refl_stutter_equiv : forall A (s : Behavior A), stutter_equiv s s.
Proof.
  intros A s.
  exists (fun s s' => s = s'). split; trivial.
  apply id_stutter_prop.
Qed.

Lemma flip_stutter_relation : forall A (R : Behavior A -> Behavior A -> Prop),
                            stutter_relation R ->
                            stutter_relation (fun s s' => R s' s).
Proof.
  intros A R H.
  destruct H as (H,(H0,H1)).
  repeat split; auto.
  intros s s' H2. symmetry. auto.
Qed.

Theorem sym_stutter_equiv : forall A (s s' : Behavior A),
                              stutter_equiv s s'
                              -> stutter_equiv s' s.
Proof.
  intros A s s' H.
  destruct H as (R,(H,RS)).
  exists (fun s s' => R s' s).
  split; trivial.
  apply flip_stutter_relation; trivial.
Qed.

Lemma le_difference : forall n m, n <= m -> exists r, m = n + r.
Proof.
  intros n m H.
  generalize dependent n.
  induction m.
  intros n H. inversion H. exists 0; omega.
  intros n H.
  inversion H.
  exists 0; omega.
  assert (T : exists r, m = n + r). apply IHm; auto.
  destruct T as (r, T). exists (S r). omega.
Qed.

Lemma stutter_relation_univ_small : forall A R (s s' : Behavior A) n,
                                      stutter_relation R ->
                                      R s s' ->
                                      (forall k, k < n -> s 0 = s k) ->
                                      exists m, R (shift s n) (shift s' m) /\
                                                (forall k, k < m -> s' 0 = s' k).
Proof.
  intros A R s s' n H H0 H1.
  generalize dependent s. generalize dependent s'.
  induction n.
  intros s' s H0 H1. exists 0. split. do 2 rewrite shift_0. auto.
  intros k H2. exfalso. omega.
  intros s' s H0 H1.
  destruct H as (R_zero,(R_left,R_right)).
  assert (H2 : exists m, R (shift s n) (shift s' m) /\ (forall k, k < m -> s' 0 = s' k)).
  apply IHn; auto.
  destruct H2 as (m,(H2,H3)).
  assert (H4 : exists m0,
                 R (shift (shift s n) 1) (shift (shift s' m) m0)
                 /\ forall k, k < m0 -> (shift s' m) 0 = (shift s' m) k).
  apply R_left; auto.
  destruct H4 as (m0,(H4,H5)).
  unfold shift in H5. simpl in H5.
  assert (H6 : s 0 = (shift s' m) 0). transitivity ((shift s n) 0). unfold shift. simpl. apply H1.
  omega. apply R_zero; auto.
  unfold shift in H6. simpl in H6.
  exists (m0 + m). split.
  do 2 rewrite contraction in H4. simpl in H4. auto.
  intros k H.
  assert (H7 : k < m \/ m <= k). omega.
  destruct H7 as [H7|H7]. apply H3; auto.
  apply le_difference in H7.
  destruct H7 as (r,H7).
  assert (H8 : k = r + m). omega. clear H7.
  rewrite H8 in *.
  transitivity (s' m). transitivity (s 0); auto. symmetry. apply R_zero; auto.
  apply H5. omega.
Qed.

Lemma comp_stutter_prop : forall A (R1 R2 : Behavior A -> Behavior A -> Prop),
                            stutter_relation R1 ->
                            stutter_relation R2 ->
                            stutter_relation (fun s s' => exists s'', R1 s s'' /\ R2 s'' s').
Proof.
  intros A R1 R2 H H0.
  repeat split; intros s s' H1; destruct H1 as (t,(H1,H2)).
  destruct H as (H,_). destruct H0 as (H0,_). transitivity (t 0); auto.
  destruct H as (R1_zero,(R1_right,R1_left)).
  apply R1_right in H1. destruct H1 as (m,(H1,H3)).
  assert (H4 : exists m0, R2 (shift t m) (shift s' m0) /\ forall k, k < m0 -> s' 0 = s' k).
  apply stutter_relation_univ_small; auto.
  destruct H4 as (m0,(H4,H5)). exists m0. split; auto. exists (shift t m). split; auto.
  destruct H0 as (R2_zero,(R2_right,R2_left)).
  assert (H3 : exists m : nat,
              R2 (shift t m) (shift s' 1) /\
              (forall k : nat, k < m -> t 0 = t k)). apply R2_left; auto.
  destruct H3 as (m,(H3,H4)).
  set (R1_flip := fun a b => R1 b a).
  assert (H5 : exists m0, R1_flip (shift t m) (shift s m0) /\
                          (forall k, k < m0 -> s 0 = s k)).
  apply stutter_relation_univ_small; auto.
  unfold R1_flip.
  apply flip_stutter_relation. auto.
  unfold R1_flip in *. clear R1_flip.
  destruct H5 as (m0,(H5,H6)).
  exists m0. split; auto. exists (shift t m); split; auto.
Qed.

Theorem trans_stutter_equiv : forall A (s t s' : Behavior A),
                                stutter_equiv s t ->
                                stutter_equiv t s' ->
                                stutter_equiv s s'.
Proof.
  intros A s t s' H H0.
  destruct H as (R1,(H,R1_rel)).
  destruct H0 as (R2,(H0,R2_rel)).
  exists (fun a b => exists c, R1 a c /\ R2 c b).
  split. exists t. split; auto.
  apply comp_stutter_prop; auto.
Qed.

Definition prop_extension {A} (R : Behavior A -> Behavior A -> Prop) :=
  fun s s' => R s s' \/ (s 0 = s' 0 /\ R (shift s 1) (shift s' 1)).

Lemma extend_stutter_relation : forall A (R : Behavior A -> Behavior A -> Prop),
                                  stutter_relation R ->
                                  stutter_relation (prop_extension R).
Proof.
  intros A R H.
  destruct H as (H,(H0,H1)).
  repeat split; intros s s' H2; destruct H2 as [H2|(H2,H3)]; auto.
  apply H0 in H2. destruct H2 as (m,(H2,H3)). exists m. split; auto. left; auto.
  exists 1. split. left. auto. intros k H4. replace k with 0 by omega; auto.
  apply H1 in H2. destruct H2 as (m,(H2,H3)). exists m. split; auto. left; auto.
  exists 1. split. left. auto. intros k H4. replace k with 0 by omega; auto.
Qed.

Theorem extend_stutter_equiv : forall A (s s' : Behavior A), s 0 = s' 0 ->
                                            stutter_equiv (shift s 1) (shift s' 1) ->
                                            stutter_equiv s s'.
Proof.
  intros A s s' H H0.
  destruct H0 as (R,(H0,H1)).
  exists (prop_extension R). split.
  right; split; auto.
  apply extend_stutter_relation; auto.
Qed.

Definition front_relation {A} (s s' : Behavior A) := exists m n, s 0 = s' 0 /\
                                                                 (forall k, k <= m -> s 0 = s k) /\
                                                                 (forall k, k <= n -> s' 0 = s' k) /\
                                                                 shift s m = shift s' n.

Lemma front_relation_refl : forall A (s : Behavior A), front_relation s s.
Proof.
  intros A s.
  exists 0. exists 0. repeat split; auto; intros k H; replace k with 0 by omega; auto.
Qed.

Lemma front_relation_step : forall A  (s s' : Behavior A),  front_relation s s' ->
   exists m : nat,
     front_relation s @ 1%behavior s' @ m%behavior /\
     (forall k : nat, k < m -> s' 0 = s' k).
Proof.
  intros A s s' H.
  destruct H as (m,(n,(same_zero,(lt_m,(lt_n,same_tail))))).
  destruct m. exists (S n). split. rewrite shift_0 in same_tail.
  rewrite same_tail. rewrite contraction. simpl. apply front_relation_refl.
  intros k H. apply lt_n; omega.
  exists n. split. exists m. exists 0.
  assert (same_one : s 0 = s 1). apply lt_m; omega.
  repeat split.
  unfold shift. simpl. transitivity (s 0). auto.
  transitivity (s' 0); auto.
  intros k H. unfold shift. simpl. transitivity (s 0); auto.
  apply lt_m; omega.
  intros k H. replace k with 0 by omega. auto.
  do 2 rewrite contraction. simpl. replace (m + 1) with (S m) by omega. auto.
  intros k H. apply lt_n; omega.
Qed.

Lemma front_relation_sym : forall A (s s' : Behavior A), front_relation s s' ->
                                                         front_relation s' s.
Proof.
  intros A s s' H.
  destruct H as (m,(n,(same_refl,(lt_m,(lt_n,same_tail))))).
  exists n. exists m. repeat split; auto.
Qed.

Lemma front_stutter_relation : forall A, stutter_relation (front_relation : Behavior A -> Behavior A -> Prop).
Proof.
  intros A.
  repeat split; intros s s' H.
  destruct H as (m,(n,(same_zero,(lt_m,(lt_n,same_tail))))); auto.
  apply front_relation_step; auto.
  apply front_relation_sym in H. apply front_relation_step in H.
  destruct H as (m,(H,H0)).
  exists m. split; auto. apply front_relation_sym; auto.
Qed.

Lemma front_relation_shift_1 : forall A (s : Behavior A), s 0 = s 1 ->
                                                          front_relation (shift s 1) s.
Proof.
  intros A s H.
  exists 0. exists 1. repeat split; auto.
  intros k H0. replace k with 0 by omega; auto.
  intros k H0. assert (H1 : k = 0 \/ k = 1). omega. destruct H1 as [H1|H1]; rewrite H1; auto.
  rewrite contraction. auto.
Qed.

Theorem stutter_equiv_shift_1 : forall A (s : Behavior A), s 0 = s 1 ->
                                                         stutter_equiv (shift s 1) s.
Proof.
  intros A s H.
  exists front_relation. split.
  apply front_relation_shift_1; auto.
  apply front_stutter_relation; auto.
Qed.

Theorem stutter_equiv_induct_next : forall A (s s' : Behavior A) R,
                                      stutter_equiv s s' ->
                                      (forall n, R (s n) (s (S n)) \/ s n = s (S n)) ->
                                      (forall n, R (s' n) (s' (S n)) \/ s' n = s' (S n)).
Proof.
  intros A s s' R H H0 n.
  assert (H1 : exists m, stutter_equiv (shift s' n) (shift s m)).
  apply stutter_equiv_univ. apply sym_stutter_equiv; auto.
  destruct H1 as (m,H1).
  assert (H2 : stutter_relation (stutter_equiv : Behavior A -> Behavior A -> Prop)).
  apply stutter_equiv_stuttering_relation.
  destruct H2 as (same_zero,(step_left,step_right)).
  assert (H2 : (shift s' n) 0 = (shift s m) 0). apply same_zero.  auto.
  unfold shift in H2. simpl in H2.
  rewrite H2.
  apply step_left in H1.
  destruct H1 as (m0,(H1,H3)).
  destruct m0.
  assert (H4 : (shift (shift s' n) 1) 0 = (shift (shift s m) 0) 0). apply same_zero; auto.
  unfold shift in H4. simpl in H4.
  rewrite H4. right; auto.
  assert (H4 : (shift s m) 0 = (shift s m) m0). apply H3; omega.
  unfold shift in H4. simpl in H4.
  assert (H5 : (shift (shift s' n) 1) 0 = (shift (shift s m) (S m0)) 0). apply same_zero; auto.
  unfold shift in H5. simpl in H5.
  rewrite H4. rewrite H5.
  apply H0.
Qed.

Theorem stutter_equiv_same_first : forall A (s s' : Behavior A),
                                     stutter_equiv s s' ->
                                     s 0 = s' 0.
Proof.
  intros A s s' H.
  destruct H as (r,(H,(same_zero,_))).
  auto.
Qed.

Theorem stutter_equiv_induct_next'_base
     : forall (A : Type) (s s' : Behavior A) (R : A -> A -> Prop),
       stutter_equiv s s' ->
       R (s 0) (s 1) -> s 0 <> s 1 ->
       exists n : nat, R (s' n) (s' (S n)).
Proof.
  intros A s s' R H H1 H2.
  pose (H3 := stutter_equiv_stuttering_relation A).
  destruct H3 as (H3,(H4,H5)).
  assert (H6 : exists m, stutter_equiv s @ 1%behavior s' @ m%behavior /\
       (forall k : nat, k < m -> s' 0 = s' k)). apply H4; auto.
  destruct H6 as (m,(H6,H7)).
  assert (H0 : s 0 = s' 0). apply H3; auto.
  destruct m.
  apply H3 in H6. unfold shift in H6. simpl in H6.
  rewrite H0 in H2. rewrite H6 in H2. exfalso. apply H2; auto.
  exists m.
  apply H3 in H6. unfold shift in H6. simpl in H6.
  rewrite <- H6.
  specialize H7 with m. rewrite <- H7; auto.
  rewrite <- H0.
  auto.
Qed.

Theorem stutter_equiv_induct_next'
     : forall (A : Type) (s s' : Behavior A) (R : A -> A -> Prop),
       stutter_equiv s s' ->
       (exists n : nat, R (s n) (s (S n)) /\ s n <> s (S n)) ->
       exists n : nat, R (s' n) (s' (S n)).
Proof.
  intros A s s' R H H1.
  destruct H1 as (n,(H1,H2)).
  assert (H3 : exists m, stutter_equiv (shift s n) (shift s' m)). apply stutter_equiv_univ; auto.
  destruct H3 as (m,H3).
  assert (H4 : exists n0, R ((s' @ m%behavior) n0) ((s' @ m%behavior) (S n0))).
  apply stutter_equiv_induct_next'_base with (s @ n%behavior); auto.
  destruct H4 as (n0,H4).
  unfold shift in H4. simpl in H4.
  exists (n0 + m); auto.
Qed.

Theorem stutter_equiv_induct_next''
     : forall (A : Type) (s s' : Behavior A) (R : A -> A -> Prop) (B : Type) (f : A -> B),
       stutter_equiv s s' ->
       (exists n : nat, R (s n) (s (S n)) /\ f (s n) <> f (s (S n))) ->
       exists n : nat, R (s' n) (s' (S n)) /\ f (s' n) <> f (s' (S n)).
Proof.
  intros A s s' R B f H H1.
  destruct H1 as (n,(H1,H2)).
  set (M := fun x y => R x y /\ f x <> f y).
  assert (H3 : exists m, M (s' m) (s' (S m))).
  apply stutter_equiv_induct_next' with s; auto.
  exists n. unfold M. repeat split; auto. intros N. apply H2; rewrite N; auto.
  auto.
Qed.

Require Import Relations.
Require Import Setoid.
Require Import Morphisms.
Import RelationClasses.

Add Parametric Relation A : (Behavior A) (@stutter_equiv A)
    reflexivity proved by (fun s => refl_stutter_equiv s)
    symmetry proved by (fun s s' H => sym_stutter_equiv H)
    transitivity proved by (fun s t s' H0 H1 => trans_stutter_equiv H0 H1)
      as stutter_equiv_rel.


(* The language and semantics in this file is mainly copied from software foundation. Benjamin C. Pierce, Arthur Azevedo de Amorim, Chris Casinghino, Marco Gaboardi, Michael Greenberg, Catalin Hritcu, Vilhelm Sjöberg, and Brent Yorgey. http://www.cis.upenn.edu/ bcpierce/sf. *)

Require Import Coq.ZArith.ZArith.

Section Imp.

Context {Var: Type}.

Definition state := Var -> Z.

Definition update (st : state) (x : Var) (n : Z) (st': state): Prop :=
  st' x = n /\
  (forall x0, x0 <> x -> st x0 = st' x0).

Inductive aexp : Type :=
  | AVar : Var -> aexp
  | ANum : Z -> aexp
  | APlus : aexp -> aexp -> aexp
  | AMinus : aexp -> aexp -> aexp
  | AMult : aexp -> aexp -> aexp.

Inductive bexp : Type :=
  | BTrue : bexp
  | BFalse : bexp
  | BEq : aexp -> aexp -> bexp
  | BLe : aexp -> aexp -> bexp
  | BNot : bexp -> bexp
  | BAnd : bexp -> bexp -> bexp.

Fixpoint aeval (st : state) (a : aexp) : Z :=
  match a with
  | AVar x => st x
  | ANum n => n
  | APlus a1 a2 => (aeval st a1) + (aeval st a2)
  | AMinus a1 a2  => (aeval st a1) - (aeval st a2)
  | AMult a1 a2 => (aeval st a1) * (aeval st a2)
  end.

Fixpoint beval (st : state) (b : bexp) : bool :=
  match b with
  | BTrue       => true
  | BFalse      => false
  | BEq a1 a2   => Zeq_bool (aeval st a1) (aeval st a2)
  | BLe a1 a2   => Zle_bool (aeval st a1) (aeval st a2)
  | BNot b1     => negb (beval st b1)
  | BAnd b1 b2  => andb (beval st b1) (beval st b2)
  end.

Inductive cmd : Type :=
  | CSkip : cmd
  | CAss : Var -> aexp -> cmd
  | CSeq : cmd -> cmd -> cmd
  | CIf : bexp -> cmd -> cmd -> cmd
  | CWhile : bexp -> cmd -> cmd.

Notation "'SKIP'" :=
  CSkip.
Notation "x '::=' a" :=
  (CAss x a) (at level 60).
Notation "c1 ;; c2" :=
  (CSeq c1 c2) (at level 80, right associativity).
Notation "'WHILE' b 'DO' c 'END'" :=
  (CWhile b c) (at level 80, right associativity).
Notation "'IFB' c1 'THEN' c2 'ELSE' c3 'FI'" :=
  (CIf c1 c2 c3) (at level 80, right associativity).

Reserved Notation " t '/' st '==>' t' '/' st' "
                  (at level 40, st at level 39, t' at level 39).

Inductive cstep : (cmd * state) -> (cmd * state) -> Prop :=
  | CS_Ass : forall st st' i n a,
      aeval st a = n ->
      update st i n st' ->
      (i ::= a) / st ==> SKIP / st'
  | CS_SeqStep : forall st c1 c1' st' c2,
      c1 / st ==> c1' / st' ->
      (c1 ;; c2) / st ==> (c1' ;; c2) / st'
  | CS_SeqFinish : forall st c2,
      (SKIP ;; c2) / st ==> c2 / st
  | CS_IfTrue : forall st b c1 c2,
      beval st b = true ->
      IFB b THEN c1 ELSE c2 FI / st ==> c1 / st
  | CS_IfFalse : forall st b c1 c2,
      beval st b = false ->
      IFB b THEN c1 ELSE c2 FI / st ==> c2 / st
  | CS_WhileTrue : forall st b c1,
      beval st b = true ->
      (WHILE b DO c1 END) / st ==> (c1;; (WHILE b DO c1 END)) / st
  | CS_WhileFalse : forall st b c1,
      beval st b = false ->
      (WHILE b DO c1 END) / st ==> SKIP / st

  where " t '/' st '==>' t' '/' st' " := (cstep (t,st) (t',st')).


(** 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) (z : natural) : natural := plus (mult z y) z.


(** 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) (lf1 : natural) : natural := plus (Succ y) 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 (lf1 : natural) (y : natural) (lf2 : natural) : natural :=
  plus lf1 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 (y : natural) (lf1 : natural) : natural := plus (Succ lf1) y.


(** 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) (x : natural) : natural := plus y (mult x y).


(** 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) (x : natural) (y : natural) : natural :=
  mult y x.


(* %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% *)
(* Mainly borrowed from Sofware Foundations, v.4
   $Date: 2015-12-11 17:17:29 -0500 (Fri, 11 Dec 2015) $
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% *)

(* ***************************************************************** *)
(** * Identifiers as wrappers of nats *)
(* ***************************************************************** *)
(* ***************************************************************** *)

Require Import Coq.Arith.Arith.
Require Import Coq.Bool.Bool.

Require Import Coq.Structures.Orders.
Require Import Coq.Structures.OrdersAlt.
Require Import Coq.Structures.Equalities.
Require Import Coq.ZArith.ZArith.

Require Import Coq.MSets.MSets.
Require Import Coq.FSets.FMapAVL.

(* ################################################################# *)
(** ** Identifier Definitions  *)
(* ################################################################# *)

Inductive id : Type :=
  | Id : nat -> id.

Definition beq_id id1 id2 :=
  match id1,id2 with
    | Id n1, Id n2 => beq_nat n1 n2
  end.

(* ================================================================= *)
(** *** Properties of Identifiers *)
(* ================================================================= *)

Theorem beq_id_refl : forall id, true = beq_id id id.
Proof.
  intros [n]. simpl. rewrite <- beq_nat_refl.
  reflexivity.
Qed.

Theorem beq_id_true_iff : forall id1 id2 : id,
  beq_id id1 id2 = true <-> id1 = id2.
Proof.
   intros [n1] [n2].
   unfold beq_id.
   rewrite beq_nat_true_iff.
   split.
   - (* -> *) intros H. rewrite H. reflexivity.
   - (* <- *) intros H. inversion H. reflexivity.
Qed.

Theorem beq_id_false_iff : forall x y : id,
  beq_id x y = false
  <-> x <> y.
Proof.
  intros x y. rewrite <- beq_id_true_iff.
  rewrite not_true_iff_false. reflexivity.
Qed.

Theorem false_beq_id : forall x y : id,
   x <> y
   -> beq_id x y = false.
Proof.
  intros x y. rewrite beq_id_false_iff.
  intros H. apply H.
Qed.

(* ----------------------------------------------------------------- *)
(** **** Reflecting Equality of Identifiers *)
(* ----------------------------------------------------------------- *)

(** It's convenient to use the reflection idioms.
    We begin by proving a fundamental _reflection lemma_ relating
    the equality proposition on [id]s
    with the boolean function [beq_id]. *)

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

Lemma beq_idP : forall x y, reflect (x = y) (beq_id x y).
Proof.
  intros x y.
  apply iff_reflect. symmetry. apply beq_id_true_iff.
Qed.

(* ----------------------------------------------------------------- *)
(** **** Propositional Equality of Identifiers *)
(* ----------------------------------------------------------------- *)

Definition eq_id x y : Prop :=
  match x, y with
    Id n, Id m => eq_nat n m
  end.

Lemma eq_id_iff_eq_nat : forall n m,
    eq_id (Id n) (Id m) <-> eq_nat n m.
Proof.
  tauto.
Qed.

Theorem eq_id_decide : forall x y, {eq_id x y} + {~ eq_id x y}.
Proof.
  intros [n] [m]. simpl.
  apply eq_nat_decide.
Qed.

Theorem eq_id_dec : forall (x y : id), {x = y} + {x <> y}.
Proof.
  intros [x] [y]. destruct (eq_nat_dec x y) as [H|H].
  - subst. left. reflexivity.
  - right. intros contra. inversion contra as [contra'].
    apply H in contra'. assumption.
Qed.