Require Import Recdef List Omega Div2.

Import ListNotations.

Set Implicit Arguments.
Set Asymmetric Patterns.

Local  Ltac name_term n t H :=
  assert (H: exists n', n' = t);
  try (exists t; reflexivity);
  destruct H as [n H].

Section UnApp.
  Context {A: Type}.

  Fixpoint unapp (n:nat)(m:list A) : list A * list A:=
    match n with
    | 0 => ([], m)
    | S n => match m with
             | nil => ([], [])
             | x::xs => let (m1, m2) := unapp n xs in
                        (x::m1, m2)
             end
    end.

  Lemma unapp_wont_expand:
    forall n (m m1 m2: list A),
      unapp n m = (m1, m2) ->
      length m1 <= length m /\ length m2 <= length m.
  Proof.
    induction n as [| n]; intros * UA.
    - simpl in UA. injection UA; intros M1 M2.
      subst m1 m2. auto with arith.
    - destruct m.
      + simpl in UA.
        injection UA; intros M1 M2.
        subst m1 m2. auto with arith.
      + simpl in UA.
        name_term ua' (unapp n m) UA'.
        rewrite <- UA' in UA.
        destruct ua' as [m1' m2'].
        injection UA; intros M1 M2; subst m1 m2; clear UA.
        symmetry in UA'.
        apply IHn in UA'.
        simpl.
        omega.
  Qed.

  Lemma unapp_app:
    forall n (m m1 m2: list A),
      (m1, m2) = unapp n m ->
      m1 ++ m2 = m.
  Proof.
    intros n m.
    revert n.
    induction m as [| x xs]; intros * UA.
    - destruct n as [| n'];
        simpl in UA;
        injection UA; intros M1 M2; subst m1 m2; clear UA;
          simpl; auto with arith.
    - destruct n as [| n'];
        simpl in UA.
      + injection UA; intros M1 M2; subst m1 m2; clear UA.
        reflexivity.
      + name_term ua' (unapp n' xs) UA'.  rewrite <- UA' in UA.
        destruct ua' as [m1' m2'].
        injection UA; intros M1 M2; subst m1 m2; clear UA.
        simpl.
        apply IHxs in UA'.
        subst xs.
        reflexivity.
  Qed.

  Lemma unapp_reduce_m1:
    forall n (m m1 m2: list A),
      unapp n m = (m1, m2) ->
      n < length m ->
      length m1 < length m.
  Proof.
    intros n m.
    revert n.
    induction m as [| x xs];
      intros * UA NltM.
    - simpl in NltM. inversion NltM.
    - destruct n as [| n].
      + unfold unapp in UA.
        injection UA; intros M1 M2; subst m1 m2; clear UA.
        simpl. auto with arith.
      + simpl in UA.
        simpl in NltM.
        apply lt_S_n in NltM.
        name_term ua' (unapp n xs) UA'.  rewrite <- UA' in UA.
        destruct ua' as [m1' m2'].
        injection UA; intros M1 M2; subst m1 m2; clear UA.
        symmetry in UA'.
        apply IHxs in UA'; auto.
        simpl.
        omega.
  Qed.

  Lemma unapp_reduce_m2:
    forall n (m m1 m2: list A),
      unapp n m = (m1, m2)->
      n > 0 ->
      length m > 0 ->
      length m2 < length m.
  Proof.
    intros * UA Ngt0 Mgt0.
    cut (length m1 > 0).
    {
      intro H.
      symmetry in UA.
      apply unapp_app in UA.
      subst m.
      rewrite app_length in *.
      omega.
    }
    destruct n as [| n']; destruct m as [| x xs].
    - inversion Ngt0.
    - inversion Ngt0.
    - simpl in Mgt0.
      inversion Mgt0.
    - simpl in UA.
      name_term ua' (unapp n' xs) UA'.  rewrite <- UA' in UA.
      destruct ua' as [m1' m2'].
      injection UA; intros M1 M2; subst m1 m2; clear UA.
      simpl. auto with arith.
  Qed.

  Definition unapp_half(m: list A) :=
    let n := length m in
    let n2 := div2 n in
    let n1 := n - n2 in
    unapp n1 m.

  Lemma unapp_half_app:
    forall m m1 m2,
      (m1, m2) = unapp_half m ->
      m1 ++ m2 = m.
  Proof.
    induction m as [| x xs]; intros * SP.
    inversion SP; auto.
    unfold unapp_half in SP.
    apply unapp_app in SP.
    auto.
  Qed.

  Lemma div2_SS:
    forall n, div2 (S (S n)) > 0.
  Proof.
    induction n; simpl; auto with arith.
  Qed.

  Lemma unapp_half_nonnil_reduces:
    forall m m1 m2,
      unapp_half m = (m1,m2) ->
      length m > S 0 ->
      length m1 < length m /\ length m2 < length m.
  Proof.
    intros * SP MgtO.
    unfold unapp_half in SP.
    name_term k (length m) LEN.
    rewrite <- LEN in *.
    name_term n (k - div2 k) N1.
    rewrite <- N1 in SP.
    assert (DK: div2 k < k)
      by (apply lt_div2; auto with arith).
    name_term d (div2 k) D.
    rewrite <- D in *.
    destruct m as [| x1 xs].
    simpl in LEN. subst k. inversion DK.
    destruct xs as [| x2 xs].
    simpl in LEN. subst k. inversion MgtO. inversion H0.
    assert (DgtO: d > 0) by (subst k d; apply div2_SS).
    assert (NltM: n < length (x1::x2::xs))
      by (simpl in *; omega).
    subst k.
    split.
    - apply unapp_reduce_m1 with (n:=n) (m2:=m2); auto.
    - assert (n > 0) by omega.
      assert (length (x1::x2::xs) > 0) by (simpl; omega).
      apply unapp_reduce_m2 with (n:=n) (m1:=m1); auto.
  Qed.

End UnApp.

Lemma unapp_map A B (f: A -> B):
  forall n (m m1 m2: list A),
    (m1, m2) = unapp n m ->
    (map f m1, map f m2) = unapp n (map f m).
Proof.
    intros n m.
    revert n.
    induction m as [| x xs]; intros * UA.
    - destruct n as [| n'];
        simpl in UA;
        injection UA; intros M1 M2; subst m1 m2; clear UA;
          simpl; auto with arith.
    - destruct n as [| n'];
        simpl in UA.
      + injection UA; intros M1 M2; subst m1 m2; clear UA.
        reflexivity.
      + name_term ua' (unapp n' xs) UA'.  rewrite <- UA' in UA.
        destruct ua' as [m1' m2'].
        injection UA; intros M1 M2; subst m1 m2; clear UA.
        simpl.
        apply IHxs in UA'.
        rewrite <- UA'.
        reflexivity.
Qed.

Lemma unapp_half_map A B (f: A -> B):
  forall m m1 m2,
    (m1, m2) = unapp_half m ->
    (map f m1, map f m2) = unapp_half (map f m).
Proof.
  intros.
  eapply unapp_map with (f := f) in H.
  unfold unapp_half.
  rewrite map_length.
  auto.
Qed.

Section Folds.
  Variable A: Type.
  Variable f: A -> A -> A.
  Variable fComm: forall a b, f a b = f b a.
  Variable fAssoc: forall a b c, f (f a b) c = f a (f b c).
  Variable unit: A.
  Variable fUnit: forall x, f unit x = x.

  Lemma fold_right_inclusion:
    forall m1 m2 seed,
      fold_right f seed (m1 ++ m2) = fold_right f (fold_right f seed m2) m1.
  Proof.
    intro m1.
    induction m1 as [| x xs]; intros.
    - reflexivity.
    - cut (fold_right f seed (xs ++ m2)
           = fold_right f (fold_right f seed m2) xs).
      intro C; simpl.
      now rewrite C.
      apply IHxs.
  Qed.

  (* h := fold_tree *)
  (* odot := f *)

  Function fold_tree (ls: list A) {measure length ls} :=
    match ls with
    | nil => unit
    | [x] => f x unit
    | [x;y] => f x y
    | _ => let (m1, m2) := unapp_half ls in
           f (fold_tree m1) (fold_tree m2)
    end.
  Proof.
    - abstract (intros;
                unfold unapp_half in teq2;
                symmetry in teq2;
                name_term len_x_n_l0 (length (x::y::a::l1)) LEN;
                rewrite <- LEN in *;
                simpl in LEN;
                assert (L0: len_x_n_l0 > 0) by omega;
                apply lt_div2 in L0;
                assert (len_x_n_l0 - div2 len_x_n_l0 > 0) by omega;
                symmetry in teq2;
                apply unapp_reduce_m2 in teq2; auto;
                simpl in teq2;
                [rewrite <- LEN in *;
                 apply teq2|
                 simpl;
                 auto with arith]).
    - abstract (intros;
                unfold unapp_half in teq2;
                apply unapp_reduce_m1 in teq2;
                [apply teq2|
                 clear teq2;
                 name_term len_x_n_l0 (length (x::y::a::l1)) LEN;
                 rewrite <- LEN in *;
                 simpl in LEN;
                 assert (L0: len_x_n_l0 > 0) by omega;
                 apply lt_div2 in L0;
                 assert (L1: len_x_n_l0 > 1) by omega;
                 rewrite LEN at 2;
                 simpl;
                 omega]).
  Defined.

  Lemma f_comm1 a b c:
    f a (f b c) = f b (f a c).
  Proof.
    rewrite <- fAssoc.
    rewrite <- fAssoc.
    assert (sth:f a b = f b a) by apply fComm; rewrite sth; rewrite <- sth.
    auto.
  Qed.

  Lemma f_comm2 a b c:
    f a (f b c) = f (f a b) c.
  Proof.
    rewrite <- fAssoc.
    reflexivity.
  Qed.

  Lemma fold_right_f_assoc:
    forall i m1 seed,
      f i (fold_right f seed m1) = fold_right f (f i seed) m1.
  Proof.
    intros i m1.
    assert (exists k, length m1 <= k) as [k K]
        by (exists (length m1); auto).
    revert i m1 K.
    induction k as [| k]; intros * K *.
    - assert (A1: length m1 = 0) by omega.
      apply length_zero_iff_nil in A1.
      subst m1.
      reflexivity.
    - destruct m1 as [| y ys].
      + reflexivity.
      + simpl in K.
        apply le_S_n in K.
        simpl.
        rewrite <- IHk; auto.
        apply f_comm1.
  Qed.

  Lemma fold_right_slideout:
    forall m seed,
      fold_right f seed m = f (fold_right f unit m) seed.
  Proof.
    induction m as [| x xs]; intros.
    - now simpl.
    - simpl.
      rewrite IHxs.
      destruct xs.
      apply f_comm2.
      apply f_comm2.
  Qed.

  Lemma fold_right_homomorphism:
    forall m1 m2,
      fold_right f unit (m1 ++ m2) = f (fold_right f unit m1) (fold_right f unit m2).
  Proof.
    intros *.
    name_term lhs (f (fold_right f unit m1) (fold_right f unit m2)) LHS.
    rewrite <- LHS.
    rewrite fold_right_inclusion.
    rewrite fold_right_slideout.
    now subst lhs.
  Qed.

  Lemma fold_right_homomorphism_unapp:
    forall m m1 m2,
      (m1, m2) = unapp_half m ->
      fold_right f unit m = f (fold_right f unit m1) (fold_right f unit m2).
  Proof.
    intros.
    apply unapp_half_app in H.
    rewrite <- H.
    eapply fold_right_homomorphism.
  Qed.

  Theorem fold_right_fold_tree:
    forall m,
      fold_right f unit m = fold_tree m.
  Proof.
    intro m.
    assert (exists k, length m <= k)
      as [k K] by (exists (length m); auto).
    revert m K.
    induction k as [| k]; intros * K.
    - assert (A1: length m = 0) by omega.
      apply length_zero_iff_nil in A1.
      now subst m.
    - destruct m as [| x1 xs]. now simpl.
      destruct xs as [| x2 xs]. now simpl.
      rewrite fold_tree_equation.
      name_term tpl (unapp_half (x1::x2::xs)) Tpl;
        rewrite <- Tpl; destruct tpl as [m1 m2].
      simpl in K.
      assert (K': S (length xs) <= k) by (rewrite le_S_n; auto);
        clear K; rename K' into K.
      assert (length m1 <= length (x2::xs)
              /\ length m2 <= length (x2::xs))
        as [A1 A2]. {
        symmetry in Tpl.
        apply unapp_half_nonnil_reduces in Tpl; auto.
        2: simpl; omega.
        simpl in *.
        omega.
      }
      simpl in A1, A2.
      assert (A3: length m1 <= k) by omega; clear A1.
      assert (A4: length m2 <= k) by omega; clear A2.
      rewrite <- (IHk m1 A3); rewrite <- (IHk m2 A4).
      rewrite fold_right_homomorphism_unapp with (m:=(x1::x2::xs)) (m1 := m1) (m2 := m2); destruct xs; auto.
      unfold unapp_half in Tpl; simpl in *.
      inversion Tpl; clear Tpl; subst.
      simpl.
      rewrite (fComm x1 unit), (fComm x2 unit).
      rewrite ?fUnit.
      auto.
  Qed.

  Theorem fold_left_fold_right:
    forall m seed,
      fold_left f m seed = fold_right f seed m.
  Proof.
    induction m; simpl; auto; intros.
    rewrite IHm.
    rewrite fold_right_f_assoc.
    rewrite fComm.
    auto.
  Qed.

  Theorem fold_left_fold_tree:
    forall m,
      fold_left f m unit = fold_tree m.
  Proof.
    intros.
    rewrite fold_left_fold_right.
    apply fold_right_fold_tree.
  Qed.

End Folds.

Section FoldWhich.
  Variable A: Type.
  Variable decA: forall a b: A, {a = b} + {a <> b}.
  Variable which: A -> A -> bool.
  Variable whichRefl: forall a, which a a = true.
  Variable whichSym: forall x y, x = y \/ which x y = negb (which y x).
  Variable whichTrans: forall a b c, which a b = which b c -> which a c = which a b.

  Definition pick x y := if which x y then x else y.

  Local Lemma pickComm: forall a b, pick a b = pick b a.
  Proof.
    unfold pick; intros.
    specialize (whichSym a b).
    destruct whichSym; subst; auto.
    rewrite H.
    destruct (which b a); auto.
  Qed.

  Local Lemma pickAssoc: forall a b c, pick (pick a b) c = pick a (pick b c).
  Proof.
    unfold pick; intros.
    case_eq (which b c); case_eq (which a b); intros; auto.
    - erewrite whichTrans; eauto.
      rewrite H; auto.
    - rewrite H0; auto.
    - rewrite H0.
      erewrite whichTrans; eauto.
      rewrite H; auto.
  Qed.

  Variable unit: A.
  Variable whichUnit: forall x, x <> unit -> which unit x = false.

  Local Lemma pickUnit: forall x, pick unit x = x.
  Proof.
    unfold pick; intros.
    destruct (decA unit x); subst.
    destruct (which x x); auto.
    assert (sth: x <> unit) by (intro; subst; tauto).
    specialize (whichUnit sth).
    rewrite whichUnit; auto.
  Qed.

  Local Lemma pickUnit_both: forall x y, pick x y = unit -> x = unit /\ y = unit.
  Proof.
    intros.
    unfold pick in *.
    case_eq (which x y); intros sth; rewrite sth in *; subst.
    - split; auto.
      destruct (decA y unit); auto.
      specialize (whichUnit n).
      congruence.
    - split; auto.
      specialize (whichSym x unit).
      destruct whichSym; auto.
      rewrite H in sth.
      rewrite Bool.negb_false_iff in sth.
      rewrite sth in *; simpl in *.
      destruct (decA x unit); auto.
      specialize (whichUnit n).
      congruence.
  Qed.

  Lemma fold_right_unit ls:
    fold_right pick unit ls = unit -> forall x, In x ls -> x = unit.
  Proof.
    induction ls; simpl; auto; intros.
    - tauto.
    - destruct H0; subst.
      apply pickUnit_both in H.
      destruct H as [s1 s2]; subst; auto.
      apply pickUnit_both in H.
      destruct H as [s3 s4].
      eapply IHls; eauto.
  Qed.

  Theorem which1_fold_right:
    forall ls,
      forall i, i < length ls -> which (fold_right pick unit ls) (nth i ls unit) = true.
  Proof.
    induction ls; simpl; auto; intros.
    - Omega.omega.
    - unfold pick in *.
      remember (fold_right (fun x y => if which x y then x else y) unit ls) as sth.
      destruct i; simpl in *.
      + case_eq (which a sth); intros sth2.
        * subst; eapply whichRefl; eauto.
        * destruct (decA sth a); simpl in *.
          -- subst; rewrite whichRefl; auto.
          -- specialize (whichSym sth a).
             destruct whichSym; [tauto|].
             rewrite H0 in *.
             rewrite Bool.negb_true_iff.
             auto.
      + case_eq (which a sth); intros sth2.
        * specialize (IHls i ltac:(Omega.omega)).
          rewrite <- IHls in sth2.
          pose proof (@whichTrans _ _ _ sth2).
          congruence.
        * specialize (IHls i ltac:(Omega.omega)).
          auto.
  Qed.

  Theorem which1_fold_tree:
    forall ls,
      forall i, i < length ls -> which (fold_tree pick unit ls) (nth i ls unit) = true.
  Proof.
    intros.
    rewrite <- fold_right_fold_tree; auto; intros.
    - eapply which1_fold_right; eauto.
    - apply pickComm.
    - apply pickAssoc.
    - apply pickUnit.
  Qed.

  Theorem which1_fold_left:
    forall ls,
      forall i, i < length ls -> which (fold_left pick ls unit) (nth i ls unit) = true.
  Proof.
    intros.
    rewrite fold_left_fold_right; auto; intros.
    - eapply which1_fold_right; eauto.
    - apply pickComm.
    - apply pickAssoc.
  Qed.

  Theorem which2_fold_right:
    forall ls,
      fold_right pick unit ls <> unit ->
      exists n, n < length ls /\ nth n ls unit = fold_right pick unit ls.
  Proof.
    induction ls; simpl; auto; intros.
    - tauto.
    - destruct (decA (fold_right pick unit ls) unit); simpl in *.
      + rewrite e in *.
        rewrite pickComm in *.
        rewrite pickUnit in *; subst.
        exists 0; repeat split; auto; try Omega.omega; intros.
      + specialize (IHls n).
        destruct IHls as [j [jLen cond1]].
        subst.
        rewrite <- cond1 in *.
        unfold pick in *.
        case_eq (which a (nth j ls unit)); intros sth; rewrite sth in *; subst.
        * exists 0; repeat split; auto; try Omega.omega; intros.
        * exists (S j); repeat split; auto; try Omega.omega; intros.
  Qed.

  Theorem which2_fold_tree:
    forall ls,
      fold_tree pick unit ls <> unit ->
      exists n, n < length ls /\ nth n ls unit = fold_tree pick unit ls.
  Proof.
    intros.
    rewrite <- fold_right_fold_tree in *; auto; intros.
    - eapply which2_fold_right; eauto; auto.
    - apply pickComm.
    - apply pickAssoc.
    - apply pickUnit.
    - apply pickComm.
    - apply pickAssoc.
    - apply pickUnit.
  Qed.

  Theorem which2_fold_left:
    forall ls,
      fold_left pick ls unit <> unit ->
      exists n, n < length ls /\ nth n ls unit = fold_left pick ls unit.
  Proof.
    intros.
    rewrite fold_left_fold_right in *; auto; intros.
    - eapply which2_fold_right; eauto; auto.
    - apply pickComm.
    - apply pickAssoc.
    - apply pickComm.
    - apply pickAssoc.
  Qed.

   Theorem whichNonUnit_fold_right:
    forall ls val,
      val = fold_right pick unit ls ->
      val <> unit ->
      exists n, n < length ls /\ nth n ls unit = val /\ forall i, i < length ls -> i <> n -> which val (nth i ls unit) = true.
  Proof.
    induction ls; simpl; auto; intros.
    - tauto.
    - destruct (decA (fold_right pick unit ls) unit); simpl in *.
      + rewrite e in *.
        rewrite pickComm in *.
        rewrite pickUnit in *; subst.
        exists 0; repeat split; auto; try Omega.omega; intros.
        destruct i; auto.
        pose proof (fold_right_unit _ e) as sth.
        specialize (sth (nth i ls unit) (nth_In (n := i) ls unit ltac:(Omega.omega))).
        rewrite sth.
        specialize (whichSym a unit).
        destruct whichSym as [whichSym0 | whichSym0]; auto.
        rewrite whichSym0.
        rewrite Bool.negb_true_iff.
        auto.
      + specialize (IHls _ eq_refl n).
        destruct IHls as [j [jLen [cond1 cond2]]].
        subst.
        rewrite <- cond1 in *.
        unfold pick in *.
        case_eq (which a (nth j ls unit)); intros sth; rewrite sth in *; subst.
        * exists 0; repeat split; auto; try Omega.omega; intros.
          destruct i; auto.
          destruct (Nat.eq_dec i j); subst; [auto|].
          specialize (cond2 i ltac:(Omega.omega) n0).
          rewrite <- cond2 in sth.
          pose proof (whichTrans sth).
          congruence.
        * exists (S j); repeat split; auto; try Omega.omega; intros.
          destruct i; auto.
          -- specialize (whichSym (nth j ls unit) a).
             destruct whichSym as [whichSym0 | whichSym0]; auto.
             ++ rewrite whichSym0 in *.
                eapply whichRefl; eauto.
             ++ rewrite whichSym0.
                rewrite Bool.negb_true_iff; auto.
          -- eapply cond2; eauto; Omega.omega.
  Qed.

  Theorem whichNonUnit_fold_left:
    forall ls val,
      val = fold_left pick ls unit ->
      val <> unit ->
      exists n, n < length ls /\ nth n ls unit = val /\ forall i, i < length ls -> i <> n -> which val (nth i ls unit) = true.
  Proof.
    intros.
    rewrite fold_left_fold_right in H; auto; intros.
    - eapply whichNonUnit_fold_right; eauto.
    - apply pickComm.
    - apply pickAssoc.
  Qed.

  Theorem whichNonUnit_fold_tree:
    forall ls val,
      val = fold_tree pick unit ls ->
      val <> unit ->
      exists n, n < length ls /\ nth n ls unit = val /\ forall i, i < length ls -> i <> n -> which val (nth i ls unit) = true.
  Proof.
    intros.
    rewrite <- fold_right_fold_tree in H; auto; intros.
    - eapply whichNonUnit_fold_right; eauto.
    - apply pickComm.
    - apply pickAssoc.
    - apply pickUnit.
  Qed.
End FoldWhich.


From mathcomp Require Import all_ssreflect.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(* disjointness *)
Goal forall x, S x <> 0.
Proof. by []. Qed.

(* injectivity *)
Lemma inj: forall x y, S x = S y -> x = y.
Proof. move => x y. by case. Qed.

(* progress *)
Lemma progr: forall x, S x <> x.
Proof. move => x. elim: x => [//| n IH].
  by move /inj.
Qed.

(* Decidable type *)
Definition D (X: Type): Type := X + {X -> False}.

(* 15.1.2 *)
Lemma discrete: forall (x y: nat), D (x = y).
Proof.
  elim.
    - case.
        by left.
      move => n. right. by [].
    - move => n IH.
      case.
        by right.
      move => y.
      case (IH y).
        left. by rewrite e.
        right. move => H.
          apply f.
          move: H.
          by case.
Qed.

Theorem double_ind: forall (p: nat -> nat -> Type),
  (forall x, p x 0) ->
  (forall x y, p x y -> p y x -> p x (S y)) ->
  (forall x y, p x y).
Proof.
  move => p H0 H1 x y.
  move: y.
  elim.
    by apply H0.
  move => y H.
  apply H1.
    apply H.
  move: x H.
  elim => [H| n H H'].
    apply H0.
  apply H1.
Admitted.

Lemma leq0: forall x, x <= 0 -> x = 0.
Proof.
  elim => [//|n IH].
    move => contra.
    by exfalso.
Qed.

(* 15.5.2 *)
Lemma leq_unpack: forall x y, x <= y -> x < y \/ x = y.
Proof.
  move => x y.
  rewrite leq_eqVlt.
  move => /orP.
  case.
    right.
    by move: a => /eqnP.
  by left.
Qed.

(* 15.5.5 *)
Lemma existential_characrerization: forall x y, x <= y -> exists k, x + k = y.
Proof.
  move => x y.
  elim: y x => [y /leq0 -> | y' IH x H].
    by exists 0.
  move: H => /leq_unpack.
  case.
    - move => /ltnSE H.
      move : (IH x H) => [k H'].
      exists k.+1.
      by rewrite -H' addnS.
  move => ->.
  exists 0.
  by rewrite addn0.
Qed.

(* 15.6.2 *)
Lemma trans: forall x y z, x < y <= z -> x < z.
Proof.
  move => x y z /andP [Hl Hr].
  move: (existential_characrerization Hl) (existential_characrerization Hr).
  move => [k <-] [k' Hr'].
  move: Hr'.
  rewrite 2!addSn.
  rewrite addnC addnCA -addnS.
  move => <-.
  rewrite /(_ < _) addnS subSS.
  rewrite subnDA.
  rewrite subnn.
  rewrite sub0n.
  by [].
Qed.

(* 15.7.1 *)
Theorem complete_ind: forall (p: nat -> Type),
  (forall x, (forall y, y < x -> p y) -> p x) ->
  (forall x, p x).
Proof.
  move => p H x.
  have G: forall n x, x < n -> p x.
    elim.
      move => x' contra. by exfalso.
    move => n IH x' L.
    apply H => y Ly.
    apply IH.
    have G: y < x' <= n.
      apply /andP.
      split => [//|].
      move: L.
      rewrite [x' < n.+1]/(x'.+1 <= n.+1).
      by rewrite subSS.
    by apply (trans G).
  apply H.
  apply G.
Qed.


Global Set Default Goal Selector "!".

Require Import Arith.
Require Import Lia.

Record nbpair := mkpair {
  first : nat;
  second : bool;
}.

Search negb.

Theorem t2 :
  forall x b,
    mkpair (x+x-x) b = mkpair x (negb (negb b)).
Proof.
  intros.
  f_equal.
  (*- rewrite Nat.add_sub. reflexivity.*)
  (*- eauto. (* fully solves goal using "hints" or does nothing. not the same as "auto" due to
   search differences. *)*)
  - lia. (* can do anything: labs are practice where it doesn't apply. *)
  - rewrite Bool.negb_involutive. reflexivity.
Qed.

Theorem mult_plus_distr_r : forall n m p : nat,
    (n + m) * p = (n * p) + (m * p).
  induction n.
  - simpl.
    eauto.
  - intros.
    simpl.
    rewrite IHn.
    rewrite plus_assoc.
    reflexivity.
Qed.

Theorem mult_assoc : forall n m p : nat,
    n * (m * p) = (n * m) * p.
Proof.
  induction n.
  - intros.
    simpl.
    reflexivity.
  - intros.
    simpl.


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


Require Import PeanoNat.

Inductive propvar : Type :=
  pv : nat -> propvar.

Lemma propvar_dec : forall (p q : propvar), {p = q} + {p <> q}.
Proof.
  intros [p] [q]. destruct (Nat.eq_dec p q).
  subst. auto. right. intros H.
  inversion H. subst. auto.
Qed.

Inductive Modal : Type :=
    atom : propvar -> Modal
  | mneg : Modal -> Modal
  | mconj : Modal -> Modal -> Modal
  | mdisj : Modal -> Modal -> Modal
  | mimpl : Modal -> Modal -> Modal
  | box : Modal -> Modal
  | dia : Modal -> Modal.

Notation "# p" := (atom p) (at level 1) : modal_scope.
Notation "m~ ϕ" := (mneg ϕ) (at level 2) : modal_scope.
Notation "ϕ1 m∧ ϕ2" := (mconj ϕ1 ϕ2) (at level 15, right associativity) : modal_scope.
Notation "ϕ1 m∨ ϕ2" := (mdisj ϕ1 ϕ2) (at level 15, right associativity) : modal_scope.
Notation "ϕ1 m→ ϕ2" := (mimpl ϕ1 ϕ2) (at level 16, right associativity) : modal_scope.
Notation "'[.]' ϕ" := (box ϕ) (at level 2) : modal_scope.
Notation "'<.>' ϕ" := (dia ϕ) (at level 2) : modal_scope.

(* Given a conditional, return the antecedent. Don't care about other inputs. *)
Definition calc_ante_modal ϕ :=
  match ϕ with
  | mimpl ψ1 ψ2 => ψ1
  | _ => ϕ
  end.

(* Given a conditional, return the consequent. Don't care about other inputs. *)
Definition calc_cons_modal ϕ :=
  match ϕ with
  | mimpl ψ1 ψ2 => ψ2
  | _ => ϕ
  end.


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

(* ** Base p representation *)

Require Import Arith Nat Lia.

From Undecidability.Shared.Libs.DLW.Utils
  Require Import utils_tac gcd rel_iter sums.

Set Implicit Arguments.

Local Notation power := (mscal mult 1).
Local Notation "∑" := (msum plus 0).

Fact sum_0n_distr_in_out n a b f :
      ∑ n (fun i => (a i+b i) * f i)
    = ∑ n (fun i => a i * f i)
    + ∑ n (fun i => b i * f i).
Proof.
  rewrite <- msum_sum; auto.
  + apply msum_ext; intros; ring.
  + intros; ring.
Qed.

Section power_decomp.

  Variable (p : nat) (Hp : 2 <= p).

  Let power_nzero x : power x p <> 0.
  Proof. generalize (@power_ge_1 x p); lia. Qed.

  Fact power_decomp_lt n f a q :
           (forall i j, i < j < n -> f i < f j)
        -> (forall i, i < n -> f i < q)
        -> (forall i, i < n -> a i < p)
        -> ∑ n (fun i => a i * power (f i) p) < power q p.
  Proof.
    revert q; induction n as [ | n IHn ]; intros q Hf1 Hf2 Ha.
    + rewrite msum_0; apply power_ge_1; lia.
    + rewrite msum_plus1; auto.
      apply lt_le_trans with (1*power (f n) p + a n * power (f n) p).
      * apply plus_lt_le_compat; auto.
        rewrite Nat.mul_1_l.
        apply IHn.
        - intros; apply Hf1; lia.
        - intros; apply Hf1; lia.
        - intros; apply Ha; lia.
      * rewrite <- Nat.mul_add_distr_r.
        replace q with (S (q-1)).
        - rewrite power_S; apply mult_le_compat; auto.
          ++ apply Ha; auto.
          ++ apply power_mono_l; try lia.
             generalize (Hf2 n); intros; lia.
        - generalize (Hf2 0); intros; lia.
  Qed.

  Lemma power_decomp_is_digit n a f :
           (forall i j, i < j < n -> f i < f j)
        -> (forall i, i < n -> a i < p)
        ->  forall i, i < n -> is_digit (∑ n (fun i => a i * power (f i) p)) p (f i) (a i).
  Proof.
    intros Hf Ha.
    induction n as [ | n IHn ]; intros i Hi.
    + lia.
    + split; auto.
      exists (∑ (n-i) (fun j => a (S i + j) * power (f (S i+j) - f i - 1) p)),
             (∑ i (fun j => a j * power (f j) p)); split.
      - replace (S n) with (S i + (n-i)) by lia.
        rewrite msum_plus, msum_plus1; auto.
        rewrite <- plus_assoc, plus_comm; f_equal.
        rewrite Nat.mul_add_distr_r, plus_comm; f_equal.
        rewrite <- mult_assoc, mult_comm, <- sum_0n_scal_l.
        apply msum_ext.
        intros j Hj.
        rewrite (mult_comm (_ * _));
        repeat rewrite <- mult_assoc; f_equal.
        rewrite <- power_S, <- power_plus; f_equal.
        generalize (Hf i (S i+j)); intros; lia.
      - apply power_decomp_lt; auto.
        * intros; apply Hf; lia.
        * intros; apply Ha; lia.
  Qed.

  Theorem power_decomp_unique n f a b :
            (forall i j, i < j < n -> f i < f j)
         -> (forall i, i < n -> a i < p)
         -> (forall i, i < n -> b i < p)
         -> ∑ n (fun i => a i * power (f i) p)
          = ∑ n (fun i => b i * power (f i) p)
         -> forall i, i < n -> a i = b i.
  Proof.
    intros Hf Ha Hb E i Hi.
    generalize (power_decomp_is_digit _ _ Hf Ha Hi)
               (power_decomp_is_digit _ _ Hf Hb Hi).
    rewrite E; apply is_digit_fun.
  Qed.

End power_decomp.

Section power_decomp_uniq.

  Variable (p : nat) (Hp : 2 <= p).

  Theorem power_decomp_factor n f a :
           (forall i, 0 < i < S n -> f 0 < f i)
        -> ∑ (S n) (fun i => a i * power (f i) p)
         = ∑ n (fun i => a (S i) * power (f (S i) - f 0 - 1) p) * power (S (f 0)) p
         + a 0 * power (f 0) p.
  Proof.
    intros Hf.
    rewrite msum_S, plus_comm; f_equal.
    rewrite <- sum_0n_scal_r.
    apply msum_ext.
    intros i Hi.
    rewrite <- mult_assoc; f_equal.
    rewrite <- power_plus; f_equal.
    generalize (Hf (S i)); intros; lia.
  Qed.

  Let power_nzero x : power x p <> 0.
  Proof.
    generalize (@power_ge_1 x p); lia.
  Qed.

  Let lt_minus_cancel a b c : a < b < c -> b - a - 1 < c - a - 1.
  Proof. intros; lia. Qed.

  (* Another proof of the above statement *)

  Theorem power_decomp_unique' n f a b :
            (forall i j, i < j < n -> f i < f j)
         -> (forall i, i < n -> a i < p)
         -> (forall i, i < n -> b i < p)
         -> ∑ n (fun i => a i * power (f i) p)
          = ∑ n (fun i => b i * power (f i) p)
         -> forall i, i < n -> a i = b i.
  Proof.
    revert f a b.
    induction n as [ | n IHn ]; intros f a b Hf Ha Hb.
    + intros; lia.
    + assert (forall i, 0 < i < S n -> f 0 < f i)
        by (intros; apply Hf; lia).
      do 2 (rewrite power_decomp_factor; auto).
      intros E.
      apply div_rem_uniq in E; auto.
      * destruct E as (E1 & E2).
        intros [ | i ] Hi.
        - revert E2; rewrite Nat.mul_cancel_r; auto.
        - apply IHn with (4 := E1); try lia.
          ++ intros u j Hu; apply lt_minus_cancel; split; apply Hf; lia.
          ++ intros; apply Ha; lia.
          ++ intros; apply Hb; lia.
      * rewrite power_S.
        apply Nat.mul_lt_mono_pos_r.
        - apply power_ge_1; lia.
        - apply Ha; lia.
      * rewrite power_S.
        apply Nat.mul_lt_mono_pos_r.
        - apply power_ge_1; lia.
        - apply Hb; lia.
  Qed.

End power_decomp_uniq.

Fact mult_2_eq_plus x : x + x = 2 *x.
Proof. ring. Qed.

Section power_injective.

  Let power_2_inj_1 i j n : j < i -> 2* power n 2 <> power i 2 + power j 2.
  Proof.
    rewrite <- power_S; intros H4 E.
     generalize (@power_ge_1 j 2); intro C.
     destruct (lt_eq_lt_dec i (S n)) as [ [ H5 | H5 ] | H5 ].
     + apply power_mono_l with (x := 2) in H5; auto.
       rewrite power_S in H5.
       apply power_mono_l with (x := 2) in H4; auto.
       rewrite power_S in H4; lia.
     + subst i; lia.
     + apply power_mono_l with (x := 2) in H5; auto.
      rewrite power_S in H5; lia.
  Qed.

  Fact power_2_inj i j : power i 2 = power j 2 -> i = j.
  Proof.
    intros H.
    destruct (lt_eq_lt_dec i j) as [ [ C | C ] | C ]; auto;
      apply power_smono_l with (x := 2) in C; lia.
  Qed.

  Let power_plus_lt a b c : a < b < c -> power a 2 + power b 2 < power c 2.
  Proof.
    intros [ H1 H2 ].
    apply power_mono_l with (x := 2) in H2; auto.
    apply power_smono_l with (x := 2) in H1; auto.
    rewrite power_S in H2; lia.
  Qed.

  Let power_inj_2 i1 j1 i2 j2 :
             j1 < i1
          -> j2 < i2
          -> power i1 2 + power j1 2 = power i2 2 + power j2 2
          -> i1 = i2 /\ j1 = j2.
  Proof.
    intros H1 H2 H3.
    destruct (lt_eq_lt_dec i1 i2) as [ [ C | C ] | C ].
    + generalize (@power_plus_lt j1 i1 i2); intros; lia.
    + split; auto; apply power_2_inj; subst; lia.
    + generalize (@power_plus_lt j2 i2 i1); intros; lia.
  Qed.

  Theorem sum_2_power_2_injective i1 j1 i2 j2 :
              j1 <= i1
           -> j2 <= i2
           -> power i1 2 + power j1 2 = power i2 2 + power j2 2
           -> i1 = i2 /\ j1 = j2.
  Proof.
    intros H1 H2 E.
    destruct (eq_nat_dec i1 j1) as [ H3 | H3 ];
    destruct (eq_nat_dec i2 j2) as [ H4 | H4 ].
    + subst j1 j2.
      assert (i1 = i2); auto.
      do 2 rewrite mult_2_eq_plus, <- power_S in E.
      apply power_2_inj in E; lia.
    + subst j1; rewrite mult_2_eq_plus in E.
      apply power_2_inj_1 in E; lia.
    + subst j2; symmetry in E.
      rewrite mult_2_eq_plus in E.
      apply power_2_inj_1 in E; lia.
    + revert E; apply power_inj_2; lia.
  Qed.

End power_injective.


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


Require Import rt.util.tactics rt.util.notation rt.util.sorting rt.util.nat.
From mathcomp Require Import ssreflect ssrbool eqtype ssrnat seq fintype bigop path.

(* Lemmas about arithmetic with sums. *)
Section SumArithmetic.

  (* Inequality with sums is monotonic with their functions. *)
  Lemma sum_diff_monotonic :
    forall n G F,
      (forall i : nat, i < n -> G i <= F i) ->
      (\sum_(0 <= i < n) (G i)) <= (\sum_(0 <= i < n) (F i)).
  Proof.
    intros n G F ALL.
    rewrite big_nat_cond [\sum_(0 <= i < n) F i]big_nat_cond.
    apply leq_sum; intros i LT; rewrite andbT in LT.
    move: LT => /andP LT; des.
    by apply ALL, leq_trans with (n := n); ins.
  Qed.

  Lemma sum_diff :
    forall n F G,
      (forall i (LT: i < n), F i >= G i) ->
      \sum_(0 <= i < n) (F i - G i) =
        (\sum_(0 <= i < n) (F i)) - (\sum_(0 <= i < n) (G i)).
  Proof.
    intros n F G ALL.
    induction n; ins; first by rewrite 3?big_geq.
    assert (ALL': forall i, i < n -> G i <= F i).
      by ins; apply ALL, leq_trans with (n := n); ins.
    rewrite 3?big_nat_recr // IHn //; simpl.
    rewrite subh1; last by apply sum_diff_monotonic.
    rewrite subh2 //; try apply sum_diff_monotonic; ins.
    rewrite subh1; ins; apply sum_diff_monotonic; ins.
    by apply ALL; rewrite ltnS leqnn.
  Qed.

  Lemma telescoping_sum :
    forall (T: Type) (F: T->nat) r (x0: T),
    (forall i, i < (size r).-1 -> F (nth x0 r i) <= F (nth x0 r i.+1)) ->
      F (nth x0 r (size r).-1) - F (nth x0 r 0) =
        \sum_(0 <= i < (size r).-1) (F (nth x0 r (i.+1)) - F (nth x0 r i)).
  Proof.
    intros T F r x0 ALL.
    have ADD1 := big_add1.
    have RECL := big_nat_recl.
    specialize (ADD1 nat 0 addn 0 (size r) (fun x => true) (fun i => F (nth x0 r i))).
    specialize (RECL nat 0 addn (size r).-1 0 (fun i => F (nth x0 r i))).
    rewrite sum_diff; last by ins.
    rewrite addmovr; last by rewrite -[_.-1]add0n; apply prev_le_next; try rewrite add0n leqnn.
    rewrite subh1; last by apply sum_diff_monotonic.
    rewrite addnC -RECL //.
    rewrite addmovl; last by rewrite big_nat_recr // -{1}[\sum_(_ <= _ < _) _]addn0; apply leq_add.
    by rewrite addnC -big_nat_recr.
  Qed.

  Lemma leq_sum_sub_uniq :
    forall (T: eqType) (r1 r2: seq T) F,
      uniq r1 ->
      {subset r1 <= r2} ->
      \sum_(i <- r1) F i <= \sum_(i <- r2) F i.
  Proof.
    intros T r1 r2 F UNIQ SUB; generalize dependent r2.
    induction r1 as [| x r1' IH]; first by ins; rewrite big_nil.
    {
      intros r2 SUB.
      assert (IN: x \in r2).
        by apply SUB; rewrite in_cons eq_refl orTb.
      simpl in UNIQ; move: UNIQ => /andP [NOTIN UNIQ]; specialize (IH UNIQ).
      destruct (splitPr IN).
      rewrite big_cat 2!big_cons /= addnA [_ + F x]addnC -addnA leq_add2l.
      rewrite mem_cat in_cons eq_refl in IN.
      rewrite -big_cat /=.
      apply IH; red; intros x0 IN0.
      rewrite mem_cat.
      feed (SUB x0); first by rewrite in_cons IN0 orbT.
      rewrite mem_cat in_cons in SUB.
      move: SUB => /orP [SUB1 | /orP [/eqP EQx | SUB2]];
        [by rewrite SUB1 | | by rewrite SUB2 orbT].
      by rewrite -EQx IN0 in NOTIN.
    }
  Qed.

End SumArithmetic.

(* Additional lemmas about sum. *)
Section ExtraLemmas.

  Lemma extend_sum :
    forall t1 t2 t1' t2' F,
      t1' <= t1 ->
      t2 <= t2' ->
      \sum_(t1 <= t < t2) F t <= \sum_(t1' <= t < t2') F t.
  Proof.
    intros t1 t2 t1' t2' F LE1 LE2.
    destruct (t1 <= t2) eqn:LE12;
      last by apply negbT in LE12; rewrite -ltnNge in LE12; rewrite big_geq // ltnW.
    rewrite -> big_cat_nat with (m := t1') (n := t1); try (by done); simpl;
      last by apply leq_trans with (n := t2).
    rewrite -> big_cat_nat with (p := t2') (n := t2); try (by done); simpl.
    by rewrite addnC -addnA; apply leq_addr.
  Qed.

  Lemma leq_sum_nat m n (P : pred nat) (E1 E2 : nat -> nat) :
    (forall i, m <= i < n -> P i -> E1 i <= E2 i) ->
    \sum_(m <= i < n | P i) E1 i <= \sum_(m <= i < n | P i) E2 i.
  Proof.
    intros LE.
    rewrite big_nat_cond [\sum_(_ <= _ < _| P _)_]big_nat_cond.
    by apply leq_sum; move => j /andP [IN H]; apply LE.
  Qed.

  Lemma leq_sum_seq (I: eqType) (r: seq I) (P : pred I) (E1 E2 : I -> nat) :
    (forall i, i \in r -> P i -> E1 i <= E2 i) ->
    \sum_(i <- r | P i) E1 i <= \sum_(i <- r | P i) E2 i.
  Proof.
    intros LE.
    rewrite big_seq_cond [\sum_(_ <- _| P _)_]big_seq_cond.
    by apply leq_sum; move => j /andP [IN H]; apply LE.
  Qed.

  Lemma sum_nat_eq0_nat (T : eqType) (F : T -> nat) (r: seq T) :
    all (fun x => F x == 0) r = (\sum_(i <- r) F i == 0).
  Proof.
    destruct (all (fun x => F x == 0) r) eqn:ZERO.
    {
      move: ZERO => /allP ZERO; rewrite -leqn0.
      rewrite big_seq_cond (eq_bigr (fun x => 0));
        first by rewrite big_const_seq iter_addn mul0n addn0 leqnn.
      intro i; rewrite andbT; intros IN.
      specialize (ZERO i); rewrite IN in ZERO.
      by move: ZERO => /implyP ZERO; apply/eqP; apply ZERO.
    }
    {
      apply negbT in ZERO; rewrite -has_predC in ZERO.
      move: ZERO => /hasP ZERO; destruct ZERO as [x IN NEQ]; simpl in NEQ.
      rewrite (big_rem x) /=; last by done.
      symmetry; apply negbTE; rewrite neq_ltn; apply/orP; right.
      apply leq_trans with (n := F x); last by apply leq_addr.
      by rewrite lt0n.
    }
  Qed.

  Lemma leq_sum1_smaller_range m n (P Q: pred nat) a b:
    (forall i, m <= i < n /\ P i -> a <= i < b /\ Q i) ->
    \sum_(m <= i < n | P i) 1 <= \sum_(a <= i < b | Q i) 1.
  Proof.
    intros REDUCE.
    rewrite big_mkcond.
    apply leq_trans with (n := \sum_(a <= i < b | Q i) \sum_(m <= i' < n | i' == i) 1).
    {
      rewrite (exchange_big_dep (fun x => true)); [simpl | by done].
      apply leq_sum_nat; intros i LE _.
      case TRUE: (P i); last by done.
      move: (REDUCE i (conj LE TRUE)) => [LE' TRUE'].
      rewrite (big_rem i); last by rewrite mem_index_iota.
      by rewrite TRUE' eq_refl.
    }
    {
      apply leq_sum_nat; intros i LE TRUE.
      rewrite big_mkcond /=.
      destruct (m <= i < n) eqn:LE'; last first.
      {
        rewrite big_nat_cond big1; first by done.
        move => i' /andP [LE'' _]; case EQ: (_ == _); last by done.
        by move: EQ => /eqP EQ; subst; rewrite LE'' in LE'.
      }
      rewrite (bigD1_seq i) /=; [ | by rewrite mem_index_iota | by rewrite iota_uniq ].
      rewrite eq_refl big1; first by done.
      by move => i' /negbTE NEQ; rewrite NEQ.
    }
  Qed.

End ExtraLemmas.


(*
(C) Copyright 2010, COQTAIL team

Project Info: http://sourceforge.net/projects/coqtail/

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

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

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

(** Some usual integrals *)

Require Import Reals.
Require Import MyRfunctions.
Require Import Rintegral.

Open Scope R_scope.

Lemma Rint_inv a b :
  0 < a <= b -> Rint (fun x => /x) a b (ln b - ln a).
intros a b Hab.
apply Rint_derive.
  intuition.
intros x Hx.
  apply derivable_pt_lim_ln.
  apply Rlt_le_trans with a; intuition.
  intros x Hx.
  apply continuity_pt_inv.
  apply derivable_continuous, derivable_id.
  assert( 0 < x).
  apply Rlt_le_trans with a; tauto.
  auto with *.
Qed.
Hint Resolve Rint_inv : Rint.

Lemma Rint_exp a b : Rint exp a b (exp b - exp a).
Proof.
intros a b.
apply Rint_derive2.
intros; apply derivable_pt_lim_exp.
intros; apply derivable_continuous_pt, derivable_pt_exp.
Qed.
Hint Resolve Rint_exp : Rint.

Lemma Rint_pow_pos n a b :
  Rint (fun y : R => INR n * y ^ (pred n)) a b ((b ^ n - a ^ n)).
Proof.
intros n a b.
destruct n.
  replace (b ^ 0 - a ^ 0) with (0 * (b - a)) by ring.
  apply Rint_eq_compat with (fct_cte 0).
  unfold fct_cte; auto with *.
  apply Rint_constant.
apply Rint_derive2 with (f := fun x => x ^ (S n)); intros.
apply derivable_pt_lim_pow_pos; omega.
apply continuity_pt_mult.
apply continuity_pt_const; intros u v ; reflexivity.

  induction n.
  apply continuity_pt_const; intros u v ; reflexivity.
  simpl.
  apply continuity_pt_mult.

auto with Rcont.
auto with Rcont.
Qed.
Hint Resolve Rint_pow_pos : Rint.

Lemma Rint_cos a b :
  Rint cos a b (sin b - sin a).
intros a b.
apply Rint_derive2.
intros; apply derivable_pt_lim_sin.
intros; apply continuity_cos.
Qed.
Hint Resolve Rint_cos : Rint.

Lemma Rint_sin a b :
  Rint sin a b (cos a - cos b).
intros a b.
replace (cos a - cos b) with (- cos b - -cos a) by ring.
apply Rint_derive2 with (f := (-cos)%F).
intros; replace (sin x) with (--sin x) by ring;
  apply derivable_pt_lim_opp, derivable_pt_lim_cos.
intros; apply continuity_sin.
Qed.
Hint Resolve Rint_sin : Rint.

Lemma Rint_sqrt_inv a b : 0 < a -> 0 < b ->
  Rint (fun x => /(sqrt x)) a b (2 *( sqrt b - sqrt a)).
Proof.
intros a b Ha Hb.
assert(Hneq : forall x, Rmin a b <= x <= Rmax a b -> 0 < sqrt x).
  intros;
    apply sqrt_lt_R0.
    apply Rlt_le_trans with (Rmin a b).
    apply Rmin_pos; assumption.
    intuition.
apply Rint_eq_compat with (fun x => 2 * /(2 * sqrt x)).
  intros; field.
  auto with *.
apply Rint_scalar_mult_compat_l.
apply Rint_derive2.
intros; apply derivable_pt_lim_sqrt.
  apply Rlt_le_trans with (Rmin a b).
  apply Rmin_pos; assumption.
  intuition.
intros.
apply continuity_pt_inv.
  apply continuity_pt_mult.
  apply continuity_pt_constant.
  apply continuity_pt_sqrt.
  apply Rle_trans with (Rmin a b).
  apply Rmin_ge; intuition.
  intuition.
assert( 0 < 2 * sqrt x).
apply Rmult_lt_0_compat.
  auto with *.
  auto.
auto with *.
Qed.
Hint Resolve Rint_sqrt_inv : Rint.

(* cosh sinh  *)


(** * Rel: Properties of Relations *)

(* $Date: 2013-04-01 09:15:45 -0400 (Mon, 01 Apr 2013) $ *)

Require Export DmoonTactics.
Require Export SfLib.

(** A (binary) _relation_ is just a parameterized proposition. As you know
    from your undergraduate discrete math course, there are a lot of
    ways of discussing and describing relations _in general_ -- ways
    of classifying relations (are they reflexive, transitive, etc.),
    theorems that can be proved generically about classes of
    relations, constructions that build one relation from another,
    etc.  Let us pause here to review a few that will be useful in
    what follows. *)

(** A (binary) relation _on_ a set [X] is a proposition parameterized by two
    [X]s -- i.e., it is a logical assertion involving two values from
    the set [X].  *)

Definition relation (X: Type) := X->X->Prop.

(** Somewhat confusingly, the Coq standard library hijacks the generic
    term "relation" for this specific instance. To maintain
    consistency with the library, we will do the same.  So, henceforth
    the Coq identifier [relation] will always refer to a binary
    relation between some set and itself, while the English word
    "relation" can refer either to the specific Coq concept or the
    more general concept of a relation between any number of possibly
    different sets.  The context of the discussion should always make
    clear which is meant. *)

(** An example relation on [nat] is [le], the less-that-or-equal-to
    relation which we usually write like this [n1 <= n2]. *)

Print le.
(* ====>
Inductive le (n : nat) : nat -> Prop :=
    le_n : n <= n
  | le_S : forall m : nat, n <= m -> n <= S m
*)
Check le : nat -> nat -> Prop.
Check le : relation nat.

Check le_ind.

(* My addition: playing with propositions and induction. *)

Lemma one_le_three : 1 <= 3.
Proof.
  assert (H12 : 1 <= 2).
    assert (H11 : 1 <= 1).
      apply le_n.
    apply le_S in H11.
    apply H11.
  apply le_S in H12.
  apply H12.
Defined.

Eval compute in  one_le_three.

Definition evidence_one_le_three : 1 <= 3 := le_S 1 2 (le_S 1 1 (le_n 1)).

Definition evidence_two_le_five : 2 <= 5 := le_S 2 4 (le_S 2 3 (le_S 2 2 (le_n 2))).

(* ######################################################### *)
(** * Basic Properties of Relations *)

(** A relation [R] on a set [X] is a _partial function_ if, for every
    [x], there is at most one [y] such that [R x y] -- i.e., if [R x
    y1] and [R x y2] together imply [y1 = y2]. *)

Definition partial_function {X: Type} (R: relation X) :=
  forall x y1 y2 : X, R x y1 -> R x y2 -> y1 = y2.

(** For example, the [next_nat] relation defined in Logic.v is a
    partial function. *)

Print next_nat.
(* ====>
Inductive next_nat (n : nat) : nat -> Prop :=
  nn : next_nat n (S n)
*)
Check next_nat : relation nat.

Theorem next_nat_partial_function :
   partial_function next_nat.
Proof.
  unfold partial_function.
  intros x y1 y2 H1 H2.
  inversion H1. inversion H2.
  reflexivity.  Qed.

(** However, the [<=] relation on numbers is not a partial function.

    This can be shown by contradiction.  In short: Assume, for a
    contradiction, that [<=] is a partial function.  But then, since
    [0 <= 0] and [0 <= 1], it follows that [0 = 1].  This is nonsense,
    so our assumption was contradictory. *)

Theorem le_not_a_partial_function :
  ~ (partial_function le).
Proof.
  unfold not. unfold partial_function. intros Hc.
  assert (0 = 1) as Nonsense.
   Case "Proof of assertion".
   apply Hc with (x := 0).
     apply le_n.
     apply le_S. apply le_n.
  inversion Nonsense.   Qed.

(** **** Exercise: 2 stars, optional *)
(** Show that the [total_relation] defined in Logic.v is not a partial
    function. *)

Inductive total_relation (m n : nat) : Prop := R_total : total_relation m n.

Theorem total_relation_not_partial_function :
  ~ (partial_function total_relation).
Proof.
  unfold not. unfold partial_function. intros.
  assert (H' : 0 = 1).
    apply H with (x := 0); apply R_total.
  inversion H'.
Qed.

(** [] *)

(** **** Exercise: 2 stars, optional *)
(** Show that the [empty_relation] defined in Logic.v is a partial
    function. *)

Inductive empty_relation (m n : nat) : Prop := .

Theorem empty_relation_partial_function :
  partial_function empty_relation.
Proof.
  unfold partial_function. intros.
  inversion H.
Qed.

(** [] *)

(** A _reflexive_ relation on a set [X] is one for which every element
    of [X] is related to itself. *)

Definition reflexive {X: Type} (R: relation X) :=
  forall a : X, R a a.

Theorem le_reflexive :
  reflexive le.
Proof.
  unfold reflexive. intros n. apply le_n.  Qed.

(** A relation [R] is _transitive_ if [R a c] holds whenever [R a b]
    and [R b c] do. *)

Print eq.

Definition transitive {X: Type} (R: relation X) :=
  forall a b c : X, (R a b) -> (R b c) -> (R a c).

Theorem le_trans :
  transitive le.
Proof.
  intros n m o Hnm Hmo.
  induction Hmo.
  Check le_ind.
  Print le_ind.
  Case "le_n". apply Hnm.
  Case "le_S". apply le_S. apply IHHmo.  Qed.

Theorem lt_trans:
  transitive lt.
Proof.
  unfold lt. unfold transitive.
  intros n m o Hnm Hmo.
  apply le_S in Hnm.
  apply le_trans with (a := (S n)) (b := (S m)) (c := o).
  apply Hnm.
  apply Hmo. Qed.

(** **** Exercise: 2 stars, optional *)
(** We can also prove [lt_trans] more laboriously by induction,
    without using le_trans.  Do this.*)

Theorem lt_trans' :
  transitive lt.
Proof.
  (* Prove this by induction on evidence that [m] is less than [o]. *)
  unfold lt. unfold transitive.
  intros n m o Hnm Hmo.
  induction Hmo; apply le_S; assumption.
Qed.
(** [] *)

(** **** Exercise: 2 stars, optional *)
(** Prove the same thing again by induction on [o]. *)

Theorem lt_trans'' :
  transitive lt.
Proof.
  Admitted.

(** [] *)

(** The transitivity of [le], in turn, can be used to prove some facts
    that will be useful later (e.g., for the proof of antisymmetry
    below)... *)

Theorem le_Sn_le : forall n m, S n <= m -> n <= m.
Proof.
  intros n m H. apply le_trans with (S n).
    apply le_S. apply le_n.
    apply H.  Qed.

(** **** Exercise: 1 star, optional *)
Theorem le_S_n : forall n m,
  (S n <= S m) -> (n <= m).
Proof.
  induction n.
  - intros.
    inversion H.
    + apply le_n.
    + cut (0 <= 1). intro H_zero_one.
      apply (le_trans 0 1 m); assumption.
      apply le_S. apply le_n.
  - intros.
    inversion H.
    + apply le_n.
    + cut (S n <= S (S n)). intro H_Sn_SSn.
      apply (le_trans (S n) (S (S n)) m); assumption.
      apply le_S. apply le_n.
Qed.

(** [] *)

(** **** Exercise: 2 stars, optional (le_Sn_n_inf) *)
(** Provide an informal proof of the following theorem:

    Theorem: For every [n], [~(S n <= n)]

    A formal proof of this is an optional exercise below, but try
    the informal proof without doing the formal proof first.

    Proof:
    (* FILL IN HERE *)
    []
 *)

(** **** Exercise: 1 star, optional *)
Theorem le_Sn_n : forall n,
  ~ (S n <= n).
Proof.
  unfold not.
  intros.
  induction n.
  - inversion H.
  - apply IHn.
    inversion H.
    + assumption.
    + apply le_Sn_le.
      assumption.
Qed.

(** [] *)

(** Reflexivity and transitivity are the main concepts we'll need for
    later chapters, but, for a bit of additional practice working with
    relations in Coq, here are a few more common ones.

   A relation [R] is _symmetric_ if [R a b] implies [R b a]. *)

Definition symmetric {X: Type} (R: relation X) :=
  forall a b : X, (R a b) -> (R b a).

(** **** Exercise: 2 stars, optional *)
Theorem le_not_symmetric :
  ~ (symmetric le).
Proof.
  unfold not.
  unfold symmetric.
  intros.
  assert (H' : 0 <= 1). auto.
  invert_term (H 0 1 H').
Qed.
(** [] *)

(** A relation [R] is _antisymmetric_ if [R a b] and [R b a] together
    imply [a = b] -- that is, if the only "cycles" in [R] are trivial
    ones. *)

Definition antisymmetric {X: Type} (R: relation X) :=
  forall a b : X, (R a b) -> (R b a) -> a = b.

(** **** Exercise: 2 stars, optional *)
Theorem le_antisymmetric :
  antisymmetric le.
Proof.
  unfold antisymmetric.
  intros a b H.
  induction H.
  - reflexivity.
  - intros.
    exfalso.
    apply le_Sn_n with (n := m).
    apply le_trans with (a := S m) (b := a) (c := m); assumption.
Qed.
(** [] *)

(** **** Exercise: 2 stars, optional *)
Theorem le_step : forall n m p,
  n < m ->
  m <= S p ->
  n <= p.
Proof.
  intros n m p Hnm HmSp.
  unfold lt in *.
  invert_term (le_trans (S n) m (S p) Hnm HmSp).
  - apply le_n.
  - apply le_S_n.
    apply le_trans with (a := S n) (b := m) (c := S p); assumption.
Qed.

(** [] *)

(** A relation is an _equivalence_ if it's reflexive, symmetric, and
    transitive.  *)

Definition equivalence {X:Type} (R: relation X) :=
  (reflexive R) /\ (symmetric R) /\ (transitive R).

(** A relation is a _partial order_ when it's reflexive,
    _anti_-symmetric, and transitive.  In the Coq standard library
    it's called just "order" for short. *)

Definition order {X:Type} (R: relation X) :=
  (reflexive R) /\ (antisymmetric R) /\ (transitive R).

(** A preorder is almost like a partial order, but doesn't have to be
    antisymmetric. *)

Definition preorder {X:Type} (R: relation X) :=
  (reflexive R) /\ (transitive R).

Theorem le_order :
  order le.
Proof.
  unfold order. split.
    Case "refl". apply le_reflexive.
    split.
      Case "antisym". apply le_antisymmetric.
      Case "transitive.". apply le_trans.  Qed.

(* ########################################################### *)
(** * Reflexive, Transitive Closure *)

(** The _reflexive, transitive closure_ of a relation [R] is the
    smallest relation that contains [R] and that is both reflexive and
    transitive.  Formally, it is defined like this in the Relations
    module of the Coq standard library: *)

Inductive clos_refl_trans {A: Type} (R: relation A) : relation A :=
    | rt_step : forall x y, R x y -> clos_refl_trans R x y
    | rt_refl : forall x, clos_refl_trans R x x
    | rt_trans : forall x y z,
          clos_refl_trans R x y ->
          clos_refl_trans R y z ->
          clos_refl_trans R x z.

(** For example, the reflexive and transitive closure of the
    [next_nat] relation coincides with the [le] relation. *)

Theorem next_nat_closure_is_le : forall n m,
  (n <= m) <-> ((clos_refl_trans next_nat) n m).
Proof.
  intros n m. split.
    Case "->".
      intro H. induction H.
      SCase "le_n". apply rt_refl.
      SCase "le_S".
        apply rt_trans with m. apply IHle. apply rt_step. apply nn.
    Case "<-".
      intro H. induction H.
      SCase "rt_step". inversion H. apply le_S. apply le_n.
      SCase "rt_refl". apply le_n.
      SCase "rt_trans".
        apply le_trans with y.
        apply IHclos_refl_trans1.
        apply IHclos_refl_trans2. Qed.

(** The above definition of reflexive, transitive closure is
    natural -- it says, explicitly, that the reflexive and transitive
    closure of [R] is the least relation that includes [R] and that is
    closed under rules of reflexivity and transitivity.  But it turns
    out that this definition is not very convenient for doing
    proofs -- the "nondeterminism" of the [rt_trans] rule can sometimes
    lead to tricky inductions.

    Here is a more useful definition... *)

Inductive refl_step_closure {X:Type} (R: relation X) : relation X :=
  | rsc_refl  : forall (x : X), refl_step_closure R x x
  | rsc_step : forall (x y z : X),
                    R x y ->
                    refl_step_closure R y z ->
                    refl_step_closure R x z.

(** (Note that, aside from the naming of the constructors, this
    definition is the same as the [multi] step relation used in many
    other chapters.) *)

(** (The following [Tactic Notation] definitions are explained in
    Imp.v.  You can ignore them if you haven't read that chapter
    yet.) *)

Tactic Notation "rt_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "rt_step" | Case_aux c "rt_refl"
  | Case_aux c "rt_trans" ].

Tactic Notation "rsc_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "rsc_refl" | Case_aux c "rsc_step" ].

(** Our new definition of reflexive, transitive closure "bundles"
    the [rt_step] and [rt_trans] rules into the single rule step.
    The left-hand premise of this step is a single use of [R],
    leading to a much simpler induction principle.

    Before we go on, we should check that the two definitions do
    indeed define the same relation...

    First, we prove two lemmas showing that [refl_step_closure] mimics
    the behavior of the two "missing" [clos_refl_trans]
    constructors.  *)

Theorem rsc_R : forall (X:Type) (R:relation X) (x y : X),
       R x y -> refl_step_closure R x y.
Proof.
  intros X R x y H.
  apply rsc_step with y. apply H. apply rsc_refl.   Qed.

(** **** Exercise: 2 stars, optional (rsc_trans) *)
Theorem rsc_trans :
  forall (X:Type) (R: relation X) (x y z : X),
      refl_step_closure R x y  ->
      refl_step_closure R y z ->
      refl_step_closure R x z.
Proof.
  intros. generalize dependent z.
  induction H.
  - intros. assumption.
  - intros.
    apply rsc_step with y.
    + assumption.
    + apply IHrefl_step_closure.
      assumption.
Qed.

(** [] *)

(** Then we use these facts to prove that the two definitions of
    reflexive, transitive closure do indeed define the same
    relation. *)

(** **** Exercise: 3 stars, optional (rtc_rsc_coincide) *)
Theorem rtc_rsc_coincide :
         forall (X:Type) (R: relation X) (x y : X),
  clos_refl_trans R x y <-> refl_step_closure R x y.
Proof.
  split.
  - intros. induction H.
    + apply rsc_R. assumption.
    + apply rsc_refl.
    + apply rsc_trans with y; assumption.
  - intros. induction H.
    + apply rt_refl.
    + apply rt_trans with y.
      * apply rt_step. assumption.
      * assumption.
Qed.
(** [] *)


Inductive bool : Type :=
|true
|false.

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

Definition andb (b1 b2:bool) : bool :=
    match b1 with
    | true => b2
    | false => false
    end.

Definition orb (b1 b2:bool) : bool :=
match b1 with
| true => true
| false => b2
end.

Example text_orb1: (orb true false) = true.
Proof. reflexivity. Qed.
Example test_orb2: (orb false false) = false.
Proof. simpl. reflexivity. Qed.
Example test_orb3: (orb false true) = true.
Proof. simpl. reflexivity. Qed.
Example test_orb4: (orb true true) = true.
Proof. simpl. reflexivity. Qed.

Notation "x && y" := (andb x y).
Notation "x || y" := (orb x y).

Example test_orb5: false || false || true = true.
Proof. simpl. reflexivity. Qed.

Definition negb' (b: bool ): bool :=
    if b then false else true.
Definition andb' (b1 b2: bool ): bool :=
    if b1 then b2 else false.
Definition orb' (b1 b2: bool ): bool :=
    if b1 then true else b2.


Inductive bit : Type :=
  | B0
  | B1.

Inductive nybble : Type :=
  | bits (b0 b1 b2 b3 : bit).

Check (bits B1 B0 B1 B0).
(* ==> bits B1 B0 B1 B0 : nybble *)

Definition all_zero (nb : nybble) : bool :=
  match nb with
    | (bits B0 B0 B0 B0) => true
    | (bits _ _ _ _) => false
  end.

Compute (all_zero (bits B1 B0 B1 B0)).
(* ===> false : bool *)
Compute (all_zero (bits B0 B0 B0 B0)).
(* ===> true : bool *)

Example test_bits1:  (all_zero (bits B1 B0 B1 B0))  = false.
Proof. simpl. reflexivity.  Qed.

Example test_bits2:  (all_zero (bits B0 B0 B0 B0))  = true.
Proof. simpl. reflexivity.  Qed.


Require Arith.
Require Bool.
Require Compare_dec.

Inductive maxn (f:nat->nat):nat->nat->Prop :=
  maxnO: (maxn f O (f O))
 |maxnSg : forall n m:nat, (maxn f n m)->(ge m (f (S n)))->(maxn f (S n) m)
 |maxnSl : forall n m:nat, (maxn f n m) -> (le m (f (S n)))-> (maxn f (S n) (f (S n))).

Lemma nat_well_ordered : forall n m:nat, le n m \/ ge n m.
  induction n.
  - intros. left. apply le_0_n.
  - destruct m. right. apply le_0_n.
    destruct (IHn m).
    + left; apply le_n_S. assumption.
    + right; apply le_n_S. assumption. Qed.
Lemma max_val : forall (f:nat->nat) (n:nat), exists m:nat, maxn f n m.
  intros f; induction n.
  - exists (f O). apply maxnO.
  - destruct IHn as [m]; destruct (nat_well_ordered m (f (S n))).
    * exists (f (S n)). eapply maxnSl. eassumption. assumption.
    * exists m. eapply maxnSg. assumption. assumption. Qed.

Extraction Language Ocaml.
Extraction "maxv" max_val.


(* Parte 2 de la tarea: Lógica intuicionista. *)

(* Ejercicio 2a *)
Theorem double_neg_impl: forall (a b : Prop), ~~(a -> b) -> ~~a -> ~~b.
Proof.
unfold not.
intros.
apply H; intro.
apply H0; intro.
apply H1.
apply H2.
trivial.
Qed.

(* Ejercicio 2b *)
Theorem impl_double_neg: forall (a b: Prop), (~~a -> ~~b) -> ~~(a -> b).
Proof.
unfold not.
intros.
apply H0.
intro.
exfalso.
apply H.
+ intro.
  apply H2.
  trivial.
+ intro.
  apply H0.
  intro.
  trivial.
Qed.

(* Ejercicio 2 *)
Theorem impl_double_neg_iff: forall (a b: Prop), ~~(a -> b) <-> (~~a -> ~~b).
Proof.
split.
+ apply double_neg_impl.
+ apply impl_double_neg.
Qed.


Require Import demo.

(* Compute a list of pairs of factors that multiply to a number. For example,
   factor_pairs 6 includes (1,6), (2,3), (3,2), and (6,1). *)
Fixpoint build_factor_pairs n d :=
  match d with
  | 0 => nil
  | S d' => if n mod d =? 0
            then cons (d, n / d) (build_factor_pairs n d')
            else build_factor_pairs n d'
  end.

Definition factor_pairs n := build_factor_pairs n n.

(* This lemma asserts that every pair in factor_pairs indeed multiplies to the original number *)
Lemma build_factor_pairs_correct : forall n d pair,
    In pair (build_factor_pairs n d) -> (fst pair * snd pair = n).
Proof.
  intro n. intro d.
  induction d.
  - intro pair.
    simpl.
    intro contra.
    contradiction.
  - intro pair.
    destruct pair.
    simpl.
    remember (divmod n d 0 d).
    destruct p.
    simpl.
    destruct (eq_nat_dec d n3).
    + subst.
      rewrite <- minus_diag_reverse.
      simpl.
      intro H.
      destruct H.
      * inversion H.
        subst.
        pose proof (Nat.divmod_spec n n3 0 n3).
        assert (n3 <= n3) by omega.
        specialize (H0 H1).
        rewrite <- Heqp in H0.
        rewrite <- minus_diag_reverse in H0.
        rewrite <- mult_n_O in H0.
        rewrite <- plus_n_O in H0.
        rewrite <- plus_n_O in H0.
        rewrite <- plus_n_O in H0.
        destruct H0.
        symmetry.
        assumption.
      * apply IHd with (pair := (n0,n1)).
        assumption.
    + pose proof (Nat.divmod_spec n d 0 d).
      assert (d <= d) by omega.
      specialize (H H0).
      rewrite <- Heqp in H.
      destruct H.
      replace (d - n3 =? 0) with false.
      intro H2.
      apply IHd with (pair := (n0,n1)).
      assumption.
      clear H IHd Heqp H0.
      symmetry.
      rewrite Nat.eqb_neq.
      omega.
Qed.

Lemma build_factors_1 : forall n d, n >= d -> d >= 1 -> In (1, n) (build_factor_pairs n d).
Proof.
  intro n. intro d.
  induction d.
  - omega.
  - intro Hnd. intro Hd1.
    simpl.
    destruct d.
    + simpl.
      left.
      replace (fst (Nat.divmod n 0 0 0)) with n.
      reflexivity.

      pose proof (Nat.divmod_spec n 0 0 0).
      assert (0 <= 0) by omega.
      specialize (H H0).
      remember (divmod n 0 0 0).
      destruct p.
      simpl.
      omega.

    + destruct (S d - snd (divmod n (S d) 0 (S d)) =? 0).
      * simpl.
        right.
        apply IHd.
        omega.
        omega.
      * apply IHd.
        omega.
        omega.
Qed.

Lemma build_factors_first_step :
  forall n, build_factor_pairs (S n) (S n) = cons (S n, 1) (build_factor_pairs (S n) n).
Proof.
  intro n.
  unfold build_factor_pairs.
  replace (S n mod S n =? 0) with true.
  replace (S n / S n) with 1.
  reflexivity.

  symmetry.
  apply Nat.div_same.
  omega.

  symmetry.
  rewrite Nat.eqb_eq.
  apply Nat.mod_same.
  omega.
Qed.

Lemma factors_len_ge_2 : forall n, n > 1 -> In (n, 1) (factor_pairs n) /\ In (1, n) (factor_pairs n).
Proof.
  intro n.
  destruct n; [omega |].
  destruct n; [omega |].
  intro Hgt.
  unfold factor_pairs.
  split.
  - rewrite build_factors_first_step.
    unfold In.
    left.
    reflexivity.
  - apply build_factors_1.
    omega.
    omega.
Qed.

Theorem prime_or_composite : forall n, n > 1 -> prime n \/ composite n.
Proof.
  intro n.
  intro greater.
  remember (factor_pairs n).
  unfold factor_pairs in Heql.
  destruct n; [omega |].
  rewrite build_factors_first_step in Heql.
  destruct l.
  inversion Heql.
  inversion Heql.
  destruct l.
  pose proof (build_factors_1 (S n) n).
  assert (In (1, S n) (build_factor_pairs (S n) n)).
  apply H.
  omega.
  omega.
  rewrite <- H1 in H2.
  inversion H2.
  destruct p0.
  destruct (eq_nat_dec n0 1).
  - left.
    admit.
  - right.
    unfold composite.
    exists n0.
    exists n1.
    split.
    + pose proof (build_factor_pairs_correct (S n) n (n0, n1)).
      simpl in H.
      assert (n0 * n1 = S n).
      apply H.
      rewrite <- H1.
      simpl.
      left.
      reflexivity.

  set (len := length factors).

Definition


Require Import prosa.util.tactics prosa.util.notation.
From mathcomp Require Import ssreflect ssrbool eqtype ssrnat.

Section StepFunction.

  Section Defs.

    (* We say that a function f... *)
    Variable f: nat -> nat.

    (* ...is a step function iff the following holds. *)
    Definition is_step_function :=
      forall t, f (t + 1) <= f t + 1.

  End Defs.

  Section Lemmas.

    (* Let f be any step function over natural numbers. *)
    Variable f: nat -> nat.
    Hypothesis H_step_function: is_step_function f.

    (* In this section, we prove a result similar to the intermediate
       value theorem for continuous functions. *)
    Section ExistsIntermediateValue.

      (* Consider any interval [x1, x2]. *)
      Variable x1 x2: nat.
      Hypothesis H_is_interval: x1 <= x2.

      (* Let t be any value such that f x1 < y < f x2. *)
      Variable y: nat.
      Hypothesis H_between: f x1 <= y < f x2.

      (* Then, we prove that there exists an intermediate point x_mid such that
         f x_mid = y. *)
      Lemma exists_intermediate_point:
        exists x_mid, x1 <= x_mid < x2 /\ f x_mid = y.
      Proof.
        rename H_is_interval into INT, H_step_function into STEP, H_between into BETWEEN.
        move: x2 INT BETWEEN; clear x2.
        suff DELTA:
          forall delta,
            f x1 <= y < f (x1 + delta) ->
            exists x_mid, x1 <= x_mid < x1 + delta /\ f x_mid = y.
        { move => x2 LE /andP [GEy LTy].
          exploit (DELTA (x2 - x1));
            first by apply/andP; split; last by rewrite addnBA // addKn.
            by rewrite addnBA // addKn.
        }
        induction delta.
        { rewrite addn0; move => /andP [GE0 LT0].
            by apply (leq_ltn_trans GE0) in LT0; rewrite ltnn in LT0.
        }
        { move => /andP [GT LT].
          specialize (STEP (x1 + delta)); rewrite leq_eqVlt in STEP.
          have LE: y <= f (x1 + delta).
          { move: STEP => /orP [/eqP EQ | STEP];
              first by rewrite !addn1 in EQ; rewrite addnS EQ ltnS in LT.
            rewrite [X in _ < X]addn1 ltnS in STEP.
            apply: (leq_trans _ STEP).
              by rewrite addn1 -addnS ltnW.
          } clear STEP LT.
          rewrite leq_eqVlt in LE.
          move: LE => /orP [/eqP EQy | LT].
          { exists (x1 + delta); split; last by rewrite EQy.
              by apply/andP; split; [by apply leq_addr | by rewrite addnS].
          }
          { feed (IHdelta); first by apply/andP; split.
            move: IHdelta => [x_mid [/andP [GE0 LT0] EQ0]].
            exists x_mid; split; last by done.
            apply/andP; split; first by done.
              by apply: (leq_trans LT0); rewrite addnS.
          }
        }
      Qed.

    End ExistsIntermediateValue.

  End Lemmas.

  (* In this section, we prove an analogue of the intermediate
     value theorem, but for predicates of natural numbers. *)
  Section ExistsIntermediateValuePredicates.

    (* Let P be any predicate on natural numbers. *)
    Variable P : nat -> bool.

    (* Consider a time interval [t1,t2] such that ... *)
    Variables t1 t2 : nat.
    Hypothesis H_t1_le_t2 : t1 <= t2.

    (* ... P doesn't hold for t1 ... *)
    Hypothesis H_not_P_at_t1 : ~~ P t1.

    (* ... but holds for t2. *)
    Hypothesis H_P_at_t2 : P t2.

    (* Then we prove that within time interval [t1,t2] there exists time
       instant t such that t is the first time instant when P holds. *)
    Lemma exists_first_intermediate_point:
      exists t, (t1 < t <= t2) /\ (forall x, t1 <= x < t -> ~~ P x) /\ P t.
    Proof.
      have EX: exists x, P x && (t1 < x <= t2).
      { exists t2.
        apply/andP; split; first by done.
        apply/andP; split; last by done.
        move: H_t1_le_t2; rewrite leq_eqVlt; move => /orP [/eqP EQ | NEQ1]; last by done.
          by exfalso; subst t2; move: H_not_P_at_t1 => /negP NPt1.
      }
      have MIN := ex_minnP EX.
      move: MIN => [x /andP [Px /andP [LT1 LT2]] MIN]; clear EX.
      exists x; repeat split; [ apply/andP; split | | ]; try done.
      move => y /andP [NEQ1 NEQ2]; apply/negPn; intros Py.
      feed (MIN y).
      { apply/andP; split; first by done.
        apply/andP; split.
        - move: NEQ1. rewrite leq_eqVlt; move => /orP [/eqP EQ | NEQ1]; last by done.
            by exfalso; subst y; move: H_not_P_at_t1 => /negP NPt1.
        - by apply ltnW, leq_trans with x.
      }
        by move: NEQ2; rewrite ltnNge; move => /negP NEQ2.
    Qed.

  End ExistsIntermediateValuePredicates.

End StepFunction.


Require Import RelationClasses.

From sflib Require Import sflib.
From PromisingLib Require Import Basic.
From PromisingLib Require Import Axioms.

Set Implicit Arguments.

Section FOLDN.

  Fixpoint fold_n {T} (f: T -> T) (n: nat) (t: T) : T :=
    match n with
    | O => t
    | S m => f (fold_n f m t)
    end.

  Lemma fold_n_2 {T} :
    forall f (t: T), f (f t) = fold_n f 2 t.
  Proof. ss. Qed.

  Lemma fold_n_one_out {T} :
    forall f (t: T) n, f (fold_n f n t) = fold_n f (1 + n) t.
  Proof.
    i. depgen t. induction n; i; ss; clarify.
  Qed.

  Lemma fold_n_one_in {T} :
    forall f (t: T) n, (fold_n f n (f t)) = fold_n f (1 + n) t.
  Proof.
    i. depgen t. induction n; i; ss; clarify. rewrite IHn. ss.
  Qed.

  Lemma fold_n_add {T} :
    forall f (t: T) n1 n2, fold_n f (n2 + n1) t = fold_n f n2 (fold_n f n1 t).
  Proof.
    i. depgen t. depgen n1. induction n2; i; ss; clarify.
    rewrite fold_n_one_out at 1.
    rewrite fold_n_one_out. rewrite <- ! fold_n_one_in.
    rewrite fold_n_one_out. rewrite <- fold_n_one_in.
    eauto.
  Qed.

  Lemma fold_n_fix {T} :
    forall f (t: T) n, (f t) = t -> fold_n f n t = t.
  Proof.
    i. depgen t. depgen n. induction n; i; ss; clarify.
    rewrite IHn; auto.
  Qed.

  Lemma fold_n_prop
        (T: Type) x
        (f: T -> T)
        (P: T -> T -> Prop)
        (REFL: forall x, P x x)
        (TRANS: forall a b c, P a b -> P b c -> P a c)
        (IND: forall x y: T, P x y -> P (f x) (f y))
        (BASE: forall x, P (f (f x)) (f x))
    :
      forall n, P (fold_n f (S n) x) (f x).
  Proof.
    induction n; ss.
    eapply TRANS. 2: eauto. eapply BASE.
  Qed.

  Lemma fold_n_mon
        (T: Type) (x y: T)
        (f: T -> T)
        (P: T -> T -> Prop)
        (IND: forall x y: T, P x y -> P (f x) (f y))
        (BASE: P x y)
    :
      forall n, P (fold_n f n x) (fold_n f n y).
  Proof.
    induction n; ss; clarify; eauto.
  Qed.

  Lemma fold_n_curry
        (T1: Type) (T2: Type)
        (d: T1 -> T2)
        (p: T1)
        f n
    :
      fold_n (fun d p => f (d p)) n d p = fold_n f n (d p).
  Proof.
    induction n; ss; clarify.
    rewrite IHn. ss.
  Qed.

  Lemma fold_n_curry2
        (T1: Type) (T2: Type)
        (d: T1 -> T2)
        (p: T1)
        f n
    :
      fold_n (fun d p => f p (d p)) n d p = fold_n (f p) n (d p).
  Proof.
    rewrite <- fold_n_curry. induction n; ss; clarify.
    rewrite IHn. ss.
  Qed.

End FOLDN.

Section FIX.

  Definition is_fix_point {T} {eq} {EQ: Equivalence eq} (f: T -> T) (t: T) :=
    eq (f t) t.

  Definition is_fix {T} {eq} {EQ: Equivalence eq} (f fp: T -> T) :=
    forall t, is_fix_point f (fp t).

  Lemma is_fix_alt {T}:
    forall (f fp: T -> T) (FIX: is_fix f fp), (forall (t: T), (f (fp t)) = (fp t)).
  Proof.
    i. unfold is_fix in FIX. unfold is_fix_point in FIX. auto.
  Qed.

  Lemma is_fix_alt_eq {T} {eq} {EQ: Equivalence eq}:
    forall (f fp: T -> T) (FIX: is_fix f fp), (forall (t: T), eq (f (fp t)) (fp t)).
  Proof.
    i. unfold is_fix in FIX. unfold is_fix_point in FIX. auto.
  Qed.

  Definition n_fix {T} {eq} {EQ: Equivalence eq} (f: T -> T) n :=
    is_fix f (fold_n f n).

  Lemma n_fix_fix {T}:
    forall (f: T -> T) n (NFIX: n_fix f n),
      (forall t, f (fold_n f n t) = fold_n f n t).
  Proof.
    i. unfold n_fix in NFIX. eapply is_fix_alt in NFIX. eapply NFIX.
  Qed.

  Lemma n_fix_fix_eq {T} {eq} {EQ: Equivalence eq}:
    forall (f: T -> T) n (NFIX: n_fix f n),
      (forall t, eq (f (fold_n f n t)) (fold_n f n t)).
  Proof.
    i. unfold n_fix in NFIX. eapply is_fix_alt_eq in NFIX. eapply NFIX.
  Qed.

  Lemma n_fix_m_fix {T}:
    forall (f: T -> T) n (NFIX: n_fix f n),
      (forall m t, (fold_n f m (fold_n f n t)) = fold_n f n t).
  Proof.
    i. depgen f. depgen n. depgen t. induction m; i; ss; clarify.
    erewrite IHm; auto. apply n_fix_fix; auto.
  Qed.

  Lemma n_fix_m_fix_eq {T} {eq} {EQ: Equivalence eq}:
    forall (f: T -> T) n (NFIX: n_fix f n),
      (forall m t, eq (fold_n f m (fold_n f n t)) (fold_n f n t)).
  Proof.
    i. depgen f. depgen n. depgen t. induction m; i; ss; clarify.
    { reflexivity. }
    etransitivity.
    2: eapply IHm; eauto.
    rewrite <- fold_n_add. rewrite PeanoNat.Nat.add_comm. rewrite fold_n_add.
    eapply n_fix_fix_eq; eauto.
  Qed.

End FIX.

Section GFIX.

  Variable K: Type.
  Variable P: Type.

  Definition GD := P -> K.

  Definition local_update := K -> K.
  Definition pointwise_update := P -> local_update.
  Definition global_update := GD -> GD.

  Definition mk_global (fs: pointwise_update) : global_update :=
    fun (d: GD) => (fun p => (fs p) (d p)).

  Lemma mk_global_fold_n_comm
        (fs: pointwise_update)
        n
    :
      mk_global (fun p => (fold_n (fs p) n)) = (fold_n (mk_global fs) n).
  Proof.
    depgen fs. induction n; i.
    { ss. }
    ss. unfold mk_global in *. ss.
    extensionality d. extensionality p. f_equal.
    specialize IHn with fs.
    assert (A: (fun (d : GD) (p : P) => fold_n (fs p) n (d p)) d p = fold_n (fs p) n (d p)).
    { ss. }
    rewrite IHn in A. rewrite <- A. ss.
  Qed.

  Lemma g_n_fix:
    forall (fs: pointwise_update) n (NFIX: forall p, @n_fix K eq eq_equivalence (fs p) n),
      @n_fix GD eq eq_equivalence (mk_global fs) n.
  Proof.
    i. unfold n_fix in *. unfold is_fix in *. i. unfold is_fix_point in *. ii.
    unfold mk_global. extensionality p. setoid_rewrite fold_n_curry2. rewrite ! NFIX. ss.
  Qed.

End GFIX.


Require Import String.

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

Fixpoint plus n m :=
  match n with
  | O => m
  | S n' => S (plus n' m)
  end.

Theorem plus_O_right : forall n, plus n O = n.
Proof.
  intros. induction n.
  + simpl. reflexivity.
  + simpl. rewrite -> IHn. reflexivity.
Qed.

Inductive binaryTree :=
| Leaf : bool -> binaryTree
| Node : binaryTree -> binaryTree -> binaryTree
.

Fixpoint insertRight b t :=
  match t with
  | Leaf b2 => Node (Leaf b2) (Leaf b)
  | Node t1 t2 => Node t1 (insertRight b t2)
  end.

Fixpoint tSize t :=
  match t with
  | Leaf _ => 1
  | Node t1 t2 => tSize t1 + tSize t2
  end.

Theorem insertRight_length : forall b t, tSize (insertRight b t) = 1 + tSize t.
Proof.
  intros. induction t.
  + simpl. reflexivity.
  + simpl. rewrite -> IHt2. simpl. rewrite plus_n_Sm. reflexivity.
Qed.

Inductive expr :=
| Var : string -> expr
| App : expr -> expr -> expr
.

Fixpoint renameAllVars s e :=
  match e with
  | Var _ => Var s
  | App e1 e2 => App (renameAllVars s e1) (renameAllVars s e2)
  end.

Fixpoint nbVars e :=
  match e with
  | Var _ => 1
  | App e1 e2 => nbVars e1 + nbVars e2
  end.

Theorem renameAllVars_nbVars : forall e, nbVars e = nbVars (renameAllVars "foo" e).
Proof.
  intros. induction e.


Print nat.
(*
Inductive nat : Set :=
| O : nat
| S : nat -> nat.
*)

Inductive Tree (A : Type) : Type :=
| Leaf : A -> Tree A
| Node : Tree A -> Tree A -> Tree A.

Arguments Leaf {A} _.
Arguments Node {A} _ _.

Fixpoint label
  {A : Type} (t : Tree A) (n : nat) : nat * Tree (A * nat) :=
match t with
| Leaf x => (n, Leaf (x, n))
| Node l r =>
    let (n', l') := label l n in
    let (n'', r') := label r (S n') in
      (n'', Node  l' r')
end.

Definition lbl {A : Type} (t : Tree A) : Tree (A * nat) :=
  snd (label t 0).

Compute lbl (Node (Node (Leaf true) (Leaf true)) (Leaf false)).
(* = Node (Node (Leaf (true, 0)) (Leaf (true, 1))) (Leaf (false, 2))
   : Tree (bool * nat) *)

Fixpoint size {A : Type} (t : Tree A) : nat :=
match t with
| Leaf _ => 1
| Node l r => size l + size r
end.

Require Import Arith.

Theorem label_size :
  forall (A : Type) (t : Tree A) (n n' : nat) (t' : Tree (A * nat)),
    label t n = (n', t') -> S n' = n + size t.
Proof.
  induction t as [| l IHl r IHr]; intros.
    rewrite <- plus_comm. cbn. inversion H. reflexivity.
    cbn. intros.
      case_eq (label l n); intros m1 t1 H1.
      case_eq (label r (S m1)); intros m2 t2 H2.
      cbn in H. rewrite H1, H2 in H. inversion H; subst.
      rewrite (IHr _ _ _ H2), (IHl _ _ _ H1), plus_assoc. reflexivity.
Qed.


Require Import Coq.Lists.List.
Require Import Coq.Structures.OrdersFacts.
Require Import Omega.

Inductive qs_tree : list nat -> Type :=
| qs_tree_base : qs_tree nil
| qs_tree_step : forall ( x: nat) (xs: list nat),
  qs_tree (filter (fun y => leb y  x) (xs)) ->
  qs_tree (filter (fun y => negb (leb y x)) (xs)) ->
    qs_tree (cons x xs).

(*new definition of quicksort using invariant*)

Lemma qs_acc_inv_1_0'' : forall (l:list nat)(x: nat)(xs : list nat),
qs_tree l -> l = cons x xs -> qs_tree (filter (fun y => leb y  x) xs).
intros l x xs H.
inversion H.
congruence.
intro H3.
inversion H3.
rewrite H5 in H0.
rewrite H6 in H0.
exact H0.
Defined.

Lemma qs_acc_inv_1_1'' : forall (l:list nat)(x: nat)(xs : list nat),
qs_tree l -> l = cons x xs -> qs_tree (filter (fun y => negb (leb y x)) xs).
intros l x xs H.
inversion H.
congruence.
intro H3.
inversion H3.
rewrite H5 in H1.
rewrite H6 in H1.
exact H1.
Defined.

Fixpoint qss (xl : list nat) (conc : qs_tree xl) {struct conc}:=
match xl as _y0 return (xl = _y0) -> list nat with
   | nil       => fun  _h0 => nil
   | cons x xs => fun _h0 =>
      (qss (filter (fun y => leb y  x) xs)(qs_acc_inv_1_0'' _ _ _ conc _h0))
      ++ (cons x (qss (filter (fun y => negb (leb y x)) xs)(qs_acc_inv_1_1'' _ _ _ conc _h0)))
  end (refl_equal xl).


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

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

Unset Positivity Checking.
Unset Guard Checking.

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

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

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

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

Definition synth (y : natural) (lf2 : natural) (x : natural) : natural :=
  mult (Succ x) 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) (x : natural) (lf1 : natural) : natural :=
  mult (Succ 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 (x : natural) (y : natural) (lf1 : natural) : natural :=
  mult (Succ y) x.


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


(*|
##########################
How proof functions prove?
##########################

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

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

It'd help my understanding the 'programs/proofs' parallelism if
somebody was kind enough to explain me how the proof function is used
in the following simple case:
|*)

Theorem ex1 : forall n : nat, 7*5 < n -> 6*6 <= n.
Proof.
  intros. assumption.
Qed.

(*| The proof function: |*)

Print ex1. (* .unfold .messages *)

(*|
Is the proof function executed in the proof process? How its return
value is used? Is it correct to say that the return value of ``ex1``
is an instance of the type ``forall n : nat, 7 * 5 < n -> 6 * 6 <=
n``?
|*)

(*|
Answer
******

    Is it correct to say that the return value of ``ex1`` is an
    instance of the type ``forall n : nat, 7 * 5 < n -> 6 * 6 <= n``?

Not quite. It would be more correct to say that the return type of
``ex1`` is ``6 * 6 <= n``, where ``n`` is the first argument passed to
``ex1``, or that ``ex1`` has type ``forall n, 7 * 5 < n -> 6 * 6 <=
n``.

    Is the proof function executed in the proof process?

Not necessarily. Execution here means "simplification" or
"normalization". The term built by the proof is usually not
simplified. For example:
|*)

Theorem foo : True.
Proof.
  assert (H : True -> True).
  { intros H'. exact H'. }
  apply H. exact I. (* I is a proof of True *)
Qed.

Print foo. (* .unfold *)

(*|
Simplifying this proof means replacing ``H`` by ``fun H' : True =>
H'`` and reducing the application, which yields ``I``. You can see
this by asking Coq to compute this term:
|*)

Compute let H : True -> True := fun H' : True => H' in H I. (* .unfold *)

(*|
*However*:

    How its return value is used?

Every proof that you enter in Coq goes a type-checking step to ensure
it is correct. One of the things the type checker does is to simplify
terms when comparing their types. In Coq, two terms that compute to
the same normal form are considered equal. The term given in the
result, ``H``, was given type ``7 * 5 < n``. But ``a < b`` is defined
as ``S a <= b``; thus we can also view ``H`` as having type ``S (7 *
5) <= n``. Coq now needs to ensure that ``H`` has type ``6 * 6 <= n``,
which it does, because the two lower bounds compute to 36. Thus, there
is computation happening when you enter a proof in Coq, but the
computation is performed by the type-checker, not the proof term (even
though the proof term does have computational behavior).
|*)


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

(* A "real" algorithm with nested recursion, unification

   µ v : is a variable (term)
   φ c : is a constant (term)
   m⋄n : is a compound term

   occ-check x (µ _)   = false
   occ-check x (φ _)   = false
   occ-check x (M  N)  = (µ x =? m)
                      or (µ x =? n)
                      or occ-check x m
                      or occ-check x n

   unify (µ v) m       = if occ-check v m
                         then None
                         else Some [(v,m)]

   unify (φ c) (µ v)   = Some [(v,φ c)]

   unify (φ c) (φ d)   = if c =? d
                         then Some []
                         else None

   unify (φ c) (_⋄_)   = None

   unify (_⋄_) (φ c)   = None

   unify (m⋄n) (µ v)   = if occ-check v (m⋄n)
                         then None
                         else Some [(v,m⋄n)]

   unify (m⋄n) (m'⋄n') = match unify m m' with
                           | None   ⇒ None
                           | Some σ ⇒ match unify (σ n) (σ n') with
                                   | None   ⇒ None
                                   | Some υ ⇒ Some (σ o υ)

  From http://www21.in.tum.de/~krauss/function/function.pdf

  orig algo from Z. Manna, R. Waldinger,

  "Deductive synthesis of the unification algorithm"

  https://www.sri.com/sites/default/files/uploads/publications/pdf/689.pdf

  We synthesize something close to ...

  Inductive d_unif : trm -> trm -> Prop :=
    | d_unif_1 : forall c m n,          d_unif (φ c) (m⋄n)
    | d_unif_2 : forall c m n,          d_unif (m⋄n) (φ c)
    | d_unif_3 : forall c x,            d_unif (φ c) (µ x)
    | d_unif_4 : forall m n x,          d_unif (m⋄n) (µ x)
    | d_unif_5 : forall x t,            d_unif (µ x) t
    | d_unif_6 : forall c d,            d_unif (φ c) (φ d)
    | d_unif_7 : forall m n m' n' D1,   unif m m' D1 = None
                                     -> d_unif (m⋄n) (m'⋄n')
    | d_unif_8 : forall m n m' n' D1 σ, unif m m' D1 = Some σ
                                     -> d_unif (subst σ n) (subst σ n')
                                     -> d_unif (m°n) (m'⋄n')
  with Fixpoint unif m n (D : d_unif m n) :=
  match D with
    | d_unif_1 c m n => None
    | d_unif_2 c m n => None
    | d_unif_3 c x   => Some ((x,φ c)::∅)
    | d_unif_4 m n x => if occ_check x (m ⋄ n) then None else Some ((x,m⋄n)::∅)
    | d_unif_5 x m   => if occ_check x m       then None else Some ((x,m)::∅)
    | d_unif_6 c d   => if c =? d then Some ∅ else None
    | d_unif_7 _ _ _ _ _ _ => None
    | d_unif_8 m n m' n' D1 σ H1 D2 => match unif (subst σ n) (subst σ n') D2 with
                                         | None    => None
                                         | Some υ => Some (σ o υ)
                                       end
  end.

*)

Require Import List Bool Utf8. (* → λ ∀ ∃ ↔ ∧ ∨ ≤ ¬ *)

Set Implicit Arguments.

(** Small list goodies *)

Infix "∈" := In (at level 70, no associativity).
Notation "x ∉ l" := (¬ x ∈ l) (at level 70, no associativity).
Infix "⊆" := incl (at level 70, no associativity).

Tactic Notation "destruct" "∈" "at" hyp(H) :=
  repeat match type of H with
    | In _ (_ ++ _)  => apply in_app_or in H; destruct H as [ H | H ]
    | In _ (_ :: _)  => destruct H as [ H | H ]
  end.

Parameter (𝓥  : Type) (eqV : 𝓥  → 𝓥  → bool) (eqV_spec : ∀ x y, eqV x y = true ↔ x = y).
Parameter (𝓒  : Type) (eqC : 𝓒  → 𝓒  → bool) (eqC_spec : ∀ x y, eqC x y = true ↔ x = y).

(** A type of constants and a type of variables, both discrete *)

Lemma eq_bool_dec {X} (eqb : X → X → bool) :
         (∀ x y, eqb x y = true ↔ x = y)
      -> (∀ x y : X, { x=y } + { x≠y }).
Proof.
  intros H x y; generalize (H x y).
  refine (match eqb x y with true => _ | false => _ end); intros [ H1 H2 ].
  + left; auto.
  + right; intros ->; now specialize (H2 eq_refl).
Qed.

Fact eqV_dec (x y : 𝓥 ) : { x=y } + { x≠y }.
Proof. apply eq_bool_dec with (1 := eqV_spec). Qed.

Fact eqC_dec : forall x y : 𝓒 , { x=y } + { x≠y }.
Proof. apply eq_bool_dec with (1 := eqC_spec). Qed.

(** The type of terms, ie binary trees built from C or V as leaves *)

Inductive trm : Type :=
  | Var : 𝓥  → trm
  | Cst : 𝓒  → trm
  | App : trm → trm → trm.

(** Compact notations *)

Notation Λ := trm.
Notation µ := Var.
Notation φ := Cst.
Notation "a ⋄ b" := (App a b) (at level 61, left associativity, format "a ⋄ b").

(** The inversion lemma (injectivity) for _⋄_ = _⋄_ and a tactic for it *)

(* → λ ∀ ∃ ↔ ∧ ∨ ≤ ¬ ≠ *)

Fact term_eq_app_inv m n m' n' : m⋄n = m'⋄n' → m = m' ∧ n = n'.
Proof. now inversion 1. Qed.

Tactic Notation "trm" "eq" "inv" hyp(H) "as" ident(E1) ident(E2) :=
  apply term_eq_app_inv in H; destruct H as [ E1 E2 ].

(** Various equality deciders *)

Hint Resolve eqC_dec eqV_dec : core.

Definition trm_eq_dec (u v : Λ) : { u=v } + { u≠v }.
Proof. decide equality. Qed.

(* Implemented with tight control of computational behavior because
   it is extracted *)

Definition eq_Var_b x m : bool :=
  match m with
    | µ y => if eqV_dec x y then true else false
    | _   => false
  end.

Fact eq_Var_b_spec x m : eq_Var_b x m = true ↔ µ x = m.
Proof.
  destruct m as [ y | | ]; simpl; try (split; discriminate).
  destruct (eqV_dec x y); subst; split; try tauto; try discriminate.
  now inversion 1.
Qed.

(* We use the Boolean decider for better extraction *)

Definition eq_Var_dec (x : 𝓥 ) (t : Λ) : { µ x=t } + { µ x≠t }.
Proof.
  generalize (eq_Var_b_spec x t).
  destruct (eq_Var_b x t); intros [ H1 H2 ]; try tauto.
  right; intros <-.
  now specialize (H2 eq_refl).
Qed.

(** Term size and variable list *)

Reserved Notation "⟦ x ⟧" (at level 1, format "⟦ x ⟧").

Fixpoint trm_size t :=
  match t with
    | m⋄n => 1+⟦m⟧+⟦n⟧
    | _   => 0
  end
where "⟦ t ⟧" := (trm_size t).

Reserved Notation "⟪ x ⟫" (at level 1, format "⟪ x ⟫").

Fixpoint trm_vars t :=
  match t with
    | µ x => x::nil
    | φ _ => nil
    | m⋄n => ⟪m⟫ ++ ⟪n⟫
  end
where "⟪ t ⟫" := (trm_vars t).

(** Occur check, see below for charact. vs var list *)

(* → λ ∀ ∃ ↔ ∧ ∨ ≤ ¬ ≠ *)

Reserved Notation "x ≺ t" (at level 70, no associativity).

Fixpoint occ_check (x : 𝓥 ) (t : Λ) :=
  match t with
    | m⋄n => µ x=m ∨ µ x=n ∨ x ≺ m ∨ x ≺ n
    | _   => False
  end
where "x ≺ t" := (occ_check x t).

Notation "x ⊀ t" := (~ x ≺ t) (at level 70).

(* x occur checks in m is m is not µx and x belongs to the variables of m *)

Fact trm_vars_occ_check x m : x ≺ m ↔ m≠µ x ∧ x ∈ ⟪m⟫.
Proof.
  induction m as [ y | c | m Hm n Hn ].
  + simpl.
    split; try tauto.
    intros (H1 & [ H2 | [] ]); subst; tauto.
  + simpl; tauto.
  + simpl; rewrite Hm, Hn.
    split.
    * intros [|[|[|]]]; split; try discriminate;
        subst; rewrite in_app_iff; simpl; tauto.
    * intros (_ & H).
      destruct ∈ at H.
      - destruct (trm_eq_dec m (µ x)); subst; tauto.
      - destruct (trm_eq_dec n (µ x)); subst; tauto.
Qed.

Fact trm_vars_nocc_check x m : x ⊀ m ↔ m=µ x ∨ x ∉ ⟪m⟫.
Proof.
  rewrite trm_vars_occ_check.
  destruct (trm_eq_dec m (Var x)); tauto.
Qed.

(* Careful Boolean implementation for better extraction *)

Reserved Notation "x '≺?' t" (at level 1, no associativity).

Fixpoint occ_check_b (x : 𝓥 ) (t : Λ) :=
  match t with
    | µ _ => false
    | φ _ => false
    | m⋄n => eq_Var_b x m || eq_Var_b x n || x ≺? m || x ≺? n
  end
where "x ≺? t" := (occ_check_b x t).

Fact occ_check_b_spec x t : x ≺? t = true ↔ x ≺ t.
Proof.
  induction t as [ y | c | m IHm n IHn ]; simpl; try easy.
  rewrite !orb_true_iff, !eq_Var_b_spec, IHm, IHn; tauto.
Qed.

(* We implement occ_check decision using the Boolean function
   for better extraction, because this one is used in the
   code of unif below *)

Definition occ_check_dec x t : { x ≺ t } + { x ⊀ t }.
Proof.
  generalize (occ_check_b_spec x t).
  refine (match x ≺? t with
    | true => _
    | false => _
  end); intros [ H1 H2 ]; try tauto.
  right; intro H; apply H2 in H; discriminate.
Qed.

(** // Substitutions of variables and then inside terms *)

Notation Σ := (list (𝓥 *Λ)).  (* the type of substitutions *)
Notation "∅" := (@nil _).     (* Notation for the empty/identity substitution *)

Reserved Notation "σ ↑ x" (at level 61, format "σ ↑ x").

(* We avoid unicode in extracted terms because
   it does not mix well with OCaml. So here
   the letter s is used instead of σ *)

Fixpoint subst_var s (x : 𝓥 ) : option Λ :=
  match s with
    | ∅      => None
    | (y,t)::s => if eqV_dec x y then Some t else s↑x
  end
where "σ ↑ x" := (subst_var σ x).

(* → λ ∀ ∃ ↔ ∧ ∨ ≤ ¬ ≠ *)

Fact subst_var_spec σ x : { m | σ↑x = Some m ∧ (x,m) ∈ σ }
                        + { σ↑x = None ∧ ∀m, (x,m) ∉ σ }.
Proof.
  induction σ as [ | (y,m) σ IHσ ].
  + right; simpl; tauto.
  + simpl.
    destruct (eqV_dec x y) as [ H | H ].
    * left; exists m; subst; tauto.
    * destruct IHσ as [ (n & H1 & H2) | (H1 & H2) ].
      - left; exists n; tauto.
      - right; split; auto.
        intros n [ H3 | H3 ].
        ++ destruct H; inversion H3; auto.
        ++ revert H3; apply H2.
Qed.

Reserved Notation "t ⦃ s ⦄" (at level 1, left associativity, format "t ⦃ s ⦄").

Fixpoint subst s t :=
  match t with
    | µ x =>
    match s↑x with
      | Some v => v
      | None   => µ x
    end
    | φ x      => φ x
    | m⋄n      => m⦃s⦄⋄n⦃s⦄
  end
where "t ⦃ σ ⦄" := (subst σ t).

(** The composition of substitutions *)

  Definition subst_comp s r := map (fun c => (fst c, (snd c)⦃r⦄)) s ++ r.

Notation "x 'o' y" := (subst_comp x y) (at level 60, format "x  o  y").

Fact subst_nil t : t⦃∅⦄  = t.
Proof. induction t; simpl; f_equal; auto. Qed.

Fact subst_comp_spec σ υ t : t⦃σ o υ⦄ = t⦃σ⦄⦃υ⦄.
Proof.
  induction t as [ x | c | m IHm n IHn ]; simpl; auto.
  + induction σ as [ | (y,t) s IHs ]; simpl.
    * unfold subst_comp; simpl; auto.
    * destruct (eqV_dec x y) as [ H | H ]; auto.
  + f_equal; auto.
Qed.

(** The graph of unif, ie a ⋉ b ⟼ r encodes
    the ternary relation r = unif a b *)

(* → λ ∀ ∃ ↔ ∧ ∨ ≤ ¬ ≠ *)

Reserved Notation "a ⋉ b ⟼u r" (at level 70).

Inductive 𝔾unif : Λ → Λ → option Σ → Prop :=
    | in_gu_0 c m n :             φ c ⋉ m⋄n   ⟼u None
    | in_gu_1 c m n :             m⋄n ⋉ φ c   ⟼u None
    | in_gu_2 c x :               φ c ⋉ µ x   ⟼u Some ((x,φ c)::∅)
    | in_gu_3 m n x :             x ≺ m⋄n
                               →  m⋄n ⋉ µ x   ⟼u None
    | in_gu_4 m n x :             x ⊀ m⋄n
                               →  m⋄n ⋉ µ x   ⟼u Some ((x,m⋄n)::∅)
    | in_gu_5 x m :               x ≺ m
                               →  µ x ⋉ m     ⟼u None
    | in_gu_6 x m :               x ⊀ m
                               →  µ x ⋉ m     ⟼u Some ((x,m)::∅)
    | in_gu_7 c d :               c = d
                               →  φ c ⋉ φ d   ⟼u Some ∅
    | in_gu_8 c d :               c ≠ d
                               →  φ c ⋉ φ d   ⟼u None
    | in_gu_9 m m' n n' :         m   ⋉ m'    ⟼u None
                               →  m⋄n ⋉ m'⋄n' ⟼u None
    | in_gu_a m m' n n' σ :       m   ⋉ m'    ⟼u Some σ
                               → n⦃σ⦄ ⋉ n'⦃σ⦄ ⟼u None
                               →  m⋄n ⋉ m'⋄n' ⟼u None
    | in_gu_b m m' n n' σ υ :     m   ⋉ m'    ⟼u Some σ
                               → n⦃σ⦄ ⋉ n'⦃σ⦄ ⟼u Some υ
                               →  m⋄n ⋉ m'⋄n' ⟼u Some (σ o υ)
where "a ⋉ b ⟼u r" := (𝔾unif a b r).

(** The graph is functional *)

Fact 𝔾unif_fun m n o1 o2 : m ⋉ n ⟼u o1  →  m ⋉ n ⟼u o2  →  o1 = o2.
Proof.
  intros H; revert H o2.
  induction 1 as [ c m n
                 | c m n
                 | c x
                 | m n x H1
                 | m n x H1
                 | x m H1
                 | x m H1
                 | c d H1
                 | c d H1
                 | m m' n n' H1 IH1
                 | m m' n n' σ H1 IH1 H2 IH2
                 | m m' n n' σ υ H1 IH1 H2 IH2
                 ]; intros r2; inversion 1; subst; auto; try discriminate; try tauto.
  + apply IH1 in H6; discriminate.
  + apply IH1 in H7; inversion H7; subst.
    apply IH2 in H8; discriminate.
  + apply IH1 in H7; discriminate.
  + apply IH1 in H7; inversion H7; subst.
    apply IH2 in H8; discriminate.
  + apply IH1 in H7; inversion H7; subst.
    apply IH2 in H8; inversion H8; subst.
    trivial.
Qed.