Require Export Tactics.

Check (3 = 3).
Check forall n m : nat, n + m = m + n.

Check forall n : nat, n = 2.
Check 3 = 5.

Definition plus_fact : Prop := 2 + 2 = 4.
Check plus_fact.

Theorem plus_fact_is_true :
  plus_fact.
Proof. reflexivity. Qed.

Definition is_three (n : nat) : Prop :=
  n = 3.
Check is_three.

Definition injective {A B} (f : A -> B) :=
  forall x y : A, f x = f y -> x = y.

Lemma succ_injective: injective S.
Proof.
  intros n m H. inversion H. reflexivity.
Qed.

Check @eq.

Example and_example : 3 + 4 = 7 /\ 2 * 2 = 4.
Proof.
  split.
  - reflexivity.
  - reflexivity.
Qed.

Lemma and_intro: forall A B: Prop,
    A -> B -> (A /\ B).
Proof.
  intros.
  split.
  - apply H.
  - apply H0.
Qed.

Example and_example' : 3 + 4 = 7 /\ 2 * 2 = 4.
Proof.
  apply and_intro.
  - reflexivity.
  - reflexivity.
Qed.

Example and_exercise :
  forall n m : nat, n + m = 0 -> n = 0 /\ m = 0.
Proof.
  intros.
  split.
  - destruct n as [| n'].
    + reflexivity.
    + inversion H.
  - destruct m as [| m'].
    + reflexivity.
    + rewrite -> plus_comm in H.
      inversion H.
Qed.

Lemma and_example2 :
  forall n m : nat, n = 0 /\ m = 0 -> n + m = 0.
Proof.
  intros.
  destruct H as [Hn Hm].
  rewrite -> Hn.
  rewrite -> Hm.
  reflexivity.
Qed.

Lemma proj1: forall P Q: Prop,
    P /\ Q -> P.
Proof.
  intros.
  destruct H as [L R].
  apply L.
Qed.

Lemma and_example3 :
  forall n m : nat, n + m = 0 -> n * m = 0.
Proof.
  intros.
  assert (J: n = 0 /\ m = 0).
  { apply and_exercise. apply H. }
  destruct J as [L R].
  rewrite -> L.
  rewrite -> R.
  reflexivity.
Qed.

Lemma proj2 : forall P Q : Prop,
  P /\ Q -> Q.
Proof.
  intros.
  destruct H as [L R].
  apply R.
Qed.

Theorem and_commut : forall P Q : Prop,
  P /\ Q -> Q /\ P.
Proof.
  intros.
  destruct H as [L R].
  split.
  - apply R.
  - apply L.
Qed.

Theorem and_assoc : forall P Q R : Prop,
  P /\ (Q /\ R) -> (P /\ Q) /\ R.
Proof.
  intros.
  destruct H as [Hl [Hm Hr]].
  split.
  - split.
    + apply Hl.
    + apply Hm.
  - apply Hr.
Qed.

Check and.

Lemma or_example :
  forall n m : nat, n = 0 \/ m = 0 -> n * m = 0.
Proof.
  intros.
  destruct H as [Hl | Hr].
  - rewrite -> Hl.
    reflexivity.
  - rewrite -> Hr.
    rewrite -> mult_O_r.
    reflexivity.
Qed.

Lemma or_intro : forall A B : Prop, A -> A \/ B.
Proof.
  intros.
  left.
  apply H.
Qed.

Lemma zero_or_succ :
  forall n : nat, n = 0 \/ n = S (pred n).
Proof.
  intros.
  destruct n as [| n'].
  - left. reflexivity.
  - right. reflexivity.
Qed.

Lemma mult_eq_0 :
  forall n m, n * m = 0 -> n = 0 \/ m = 0.
Proof.
  intros.
  destruct n as [| n'].
  - left. reflexivity.
  - destruct m as [| m'].
    + right. reflexivity.
    + inversion H.
Qed.

Theorem or_commut : forall P Q : Prop,
  P \/ Q -> Q \/ P.
Proof.
  intros.
  destruct H as [Hl | Hr].
  - right. apply Hl.
  - left. apply Hr.
Qed.

Module MyNot.

Definition not (P:Prop) := P -> False.

Notation "~ x" := (not x) : type_scope.

Check not.

End MyNot.

Theorem ex_falso_quodlibet : forall (P:Prop),
  False -> P.
Proof.
  intros.
  destruct H.
Qed.

Fact not_implies_our_not : forall (P:Prop),
  ~P -> (forall (Q:Prop), P -> Q).
Proof.
  intros.
  destruct H.
  apply H0.
Qed.

Theorem zero_not_one : ~(0 = 1).
Proof.
  intros H. inversion H.
Qed.

Check (0 <> 1).

Theorem zero_not_one': 0 <> 1.
Proof.
  intros H. inversion H.
Qed.

Theorem not_False :
  ~ False.
Proof.
  unfold not.
  intros.
  destruct H.
Qed.

Theorem contradiction_implies_anything : forall P Q : Prop,
  (P /\ ~P) -> Q.
Proof.
  intros.
  unfold not in H.
  destruct H as [Hr Hl].
  destruct Hl.
  apply Hr.
Qed.

Theorem double_neg : forall P : Prop,
  P -> ~~P.
Proof.
  intros.
  unfold not.
  intros.
  apply H0.
  apply H.
Qed.

Theorem contrapositive : forall P Q : Prop,
  (P -> Q) -> (~Q -> ~P).
Proof.
  intros.
  unfold not.
  unfold not in H0.
  intros.
  apply H0 in H.
  apply H.
  apply H1.
Qed.

Theorem not_both_true_and_false : forall P : Prop,
  ~ (P /\ ~P).
Proof.
  intros.
  unfold not.
  intros.
  destruct H as [Hl Hr].
  apply Hr in Hl.
  apply Hl.
Qed.

Theorem not_true_is_false : forall b : bool,
  b <> true -> b = false.
Proof.
  intros.
  destruct b.
  - unfold not in H.
    exfalso.
    apply H.
    reflexivity.
  - reflexivity.
Qed.

Lemma True_is_true : True.
Proof. apply I. Qed.

Module MyIff.

Definition iff (P Q : Prop) := (P -> Q) /\ (Q -> P).

Notation "P <-> Q" := (iff P Q)
                      (at level 95, no associativity)
                      : type_scope.

End MyIff.

Theorem iff_sym : forall P Q : Prop,
  (P <-> Q) -> (Q <-> P).
Proof.
  intros.
  destruct H as [Hl Hr].
  split.
  - apply Hr.
  - apply Hl.
Qed.

Lemma not_true_iff_false : forall b,
  b <> true <-> b = false.
Proof.
  intros.
  split.
  - apply not_true_is_false.
  - intros.
    rewrite -> H.
    unfold not.
    intros.
    inversion H0.
Qed.

Theorem iff_refl : forall P : Prop,
  P <-> P.
Proof.
  intros.
  split.
  - intros. apply H.
  - intros. apply H.
Qed.

Theorem iff_trans : forall P Q R : Prop,
  (P <-> Q) -> (Q <-> R) -> (P <-> R).
Proof.
  intros.
  destruct H as [Hpq Hqp].
  destruct H0 as [Hqr Hrq].
  split.
  - intros.
    apply Hqr.
    apply Hpq.
    apply H.
  - intros.
    apply Hqp.
    apply Hrq.
    apply H.
Qed.

Theorem or_distributes_over_and : forall P Q R : Prop,
  P \/ (Q /\ R) <-> (P \/ Q) /\ (P \/ R).
Proof.
  intros.
  split.
  - intros.
    split.
    + destruct H.
      * left. apply H.
      * destruct H.
        right.
        apply H.
    + destruct H.
      * left. apply H.
      * destruct H.
        right.
        apply H0.
  - intros.
    destruct H.
    destruct H.
    + left. apply H.
    + destruct H0.
      * left.
        apply H0.
      * right.
        split.
          apply H.
          apply H0.
Qed.

Require Import Coq.Setoids.Setoid.

Lemma mult_0 : forall n m, n * m = 0 <-> n = 0 \/ m = 0.
Proof.
  intros.
  split.
  - apply mult_eq_0.
  - apply or_example.
Qed.

Lemma or_assoc :
  forall P Q R : Prop, P \/ (Q \/ R) <-> (P \/ Q) \/ R.
Proof.
  intros.
  split.
  - intros.
    destruct H.
    + left. left. apply H.
    + destruct H.
      * left. right. apply H.
      * right. apply H.
  - intros.
    destruct H.
    + destruct H.
      * left. apply H.
      * right. left. apply H.
    + right. right. apply H.
Qed.

Lemma mult_0_3 :
  forall n m p, n * m * p = 0 <-> n = 0 \/ m = 0 \/ p = 0.
Proof.
  intros.
  rewrite -> mult_0.
  rewrite -> mult_0.
  rewrite -> or_assoc.
  reflexivity.
Qed.

Lemma apply_iff_example :
  forall n m : nat, n * m = 0 -> n = 0 \/ m = 0.
Proof.
  intros.
  apply mult_0.
  apply H.
Qed.

Lemma four_is_even : exists n : nat, 4 = n + n.
Proof.
  exists 2. reflexivity.
Qed.

Theorem exists_example_2 : forall n,
  (exists m, n = 4 + m) ->
  (exists o, n = 2 + o).
Proof.
  intros.
  destruct H as [m Hm].
  exists (2 + m).
  apply Hm.
Qed.

Theorem dist_not_exists : forall (X:Type) (P : X -> Prop),
  (forall x, P x) -> ~ (exists x, ~ P x).
Proof.
  intros.
  unfold not.
  intros.
  destruct H0.
  apply H0.
  apply H.
Qed.

Theorem dist_exists_or : forall (X:Type) (P Q : X -> Prop),
  (exists x, P x \/ Q x) <-> (exists x, P x) \/ (exists x, Q x).
Proof.
  intros.
  split.
  - intros.
    destruct H as [x Hx].
    destruct Hx.
    + left. exists x. apply H.
    + right. exists x. apply H.
  - intros.
    destruct H.
    + destruct H as [x Hx].
      exists x.
      left.
      apply Hx.
    + destruct H as [x Hx].
      exists x.
      right.
      apply Hx.
Qed.

Fixpoint In {A : Type} (x : A) (l : list A) : Prop :=
  match l with
  | [] => False
  | h :: t => x = h \/ In x t
  end.

Example In_example_1 : In 4 [1; 2; 3; 4; 5].
Proof.
  simpl.
  right. right. right. left.
  reflexivity.
Qed.

Example In_example_2 :
  forall n, In n [2; 4] ->
  exists n', n = 2 * n'.
Proof.
  simpl.
  intros.
  destruct H as [H' | [H' | []]].
  - exists 1.
    rewrite -> H'.
    reflexivity.
  - exists 2.
    rewrite -> H'.
    reflexivity.
Qed.

Lemma In_map :
  forall (A B : Type) (f : A -> B) (l : list A) (x : A),
    In x l ->
    In (f x) (map f l).
Proof.
  intros.
  generalize dependent H.
  induction l as [| h t IH].
  - intros.
    simpl in H.
    destruct H.
  - intros.
    simpl in H.
    destruct H as [Hl | Hr].
    + rewrite -> Hl.
      simpl.
      left.
      reflexivity.
    + simpl.
      right.
      apply IH.
      apply Hr.
Qed.

Lemma In_map_iff :
  forall (A B : Type) (f : A -> B) (l : list A) (y : B),
    In y (map f l) <->
    exists x, f x = y /\ In x l.
Proof.
  intros.
  split.
  - induction l as [| h t IH].
    + intros. simpl in H. destruct H.
    + intros.
      simpl.
      destruct H.
      * exists h.
        split.
          rewrite -> H. reflexivity.
          left. reflexivity.
      * apply IH in H.
        destruct H.
          exists x.
          destruct H.
          split.
            apply H.
            right. apply H0.
  - induction l as [| h t IH].
    + intros.
      simpl.
      destruct H.
      destruct H.
      destruct H0.
    + simpl.
      intros.
      destruct H.
      destruct H.
      destruct H0.
      * rewrite -> H0 in H.
        left.
        rewrite -> H.
        reflexivity.
      * simpl.
        right.
        apply IH.
        exists x.
        split.
          apply H.
          apply H0.
Qed.

Lemma in_app_iff : forall A l l' (a:A),
  In a (l++l') <-> In a l \/ In a l'.
Proof.
  intros.
  split.
  - induction l as [| h t IH].
    + simpl. intros. right. apply H.
    + simpl. intros.
      apply or_assoc.
      destruct H.
      * left. apply H.
      * right. apply IH. apply H.
  - induction l as [| h t IH].
    + simpl. intros. destruct H.
        destruct H.
        apply H.
    + simpl. intros. destruct H. destruct H.
        left. apply H.
        right. apply IH. left. apply H.
        right. apply IH. right. apply H.
Qed.

Fixpoint All {T : Type} (P : T -> Prop) (l : list T) : Prop :=
  match l with
  | [] => True
  | h :: t => P h /\ All P t
  end.

Lemma All_In :
  forall T (P : T -> Prop) (l : list T),
    (forall x, In x l -> P x) <->
    All P l.
Proof.
  intros.
  split.
  - induction l as [| h t IH].
    + simpl. intros. reflexivity.
    + simpl. intros.
      split.
      * apply H. left. reflexivity.
      * apply IH. intros.
        apply H. right. apply H0.
  - induction l as [| h t IH].
    + simpl. intros. destruct H0.
    + simpl. intros.
      destruct H.
      destruct H0.
      * rewrite -> H0. apply H.
      * apply IH.
          apply H1.
          apply H0.
Qed.

Definition combine_odd_even (Podd Peven : nat -> Prop) : nat -> Prop :=
  fun (x:nat) => if oddb x then Podd x
                           else Peven x.

Theorem combine_odd_even_intro :
  forall (Podd Peven : nat -> Prop) (n : nat),
    (oddb n = true ->  Podd n) ->
    (oddb n = false -> Peven n) ->
    combine_odd_even Podd Peven n.
Proof.
  intros.
  unfold combine_odd_even.
  destruct (oddb n).
  - apply H. reflexivity.
  - apply H0. reflexivity.
Qed.

Theorem combine_odd_even_elim_odd :
  forall (Podd Peven : nat -> Prop) (n : nat),
    combine_odd_even Podd Peven n ->
    oddb n = true ->
    Podd n.
Proof.
  intros.
  unfold combine_odd_even in H.
  rewrite -> H0 in H.
  apply H.
Qed.

Theorem combine_odd_even_elim_even :
  forall (Podd Peven : nat -> Prop) (n : nat),
    combine_odd_even Podd Peven n ->
    oddb n = false ->
    Peven n.
Proof.
  intros.
  unfold combine_odd_even in H.
  rewrite -> H0 in H.
  apply H.
Qed.

Check plus_comm.

Lemma plus_comm3 :
  forall n m p, n + (m + p) = (p + m) + n.
Proof.
  intros.
  rewrite -> plus_comm.
  rewrite -> (plus_comm m).
  reflexivity.
Qed.

Example lemma_application_ex :
  forall {n : nat} {ns : list nat},
    In n (map (fun m => m * 0) ns) ->
    n = 0.
Proof.
  intros.
  rewrite (In_map_iff _ _ _ _ _) in H.
  destruct H.
  apply proj1 in H.
  rewrite -> mult_O_r in H.
  rewrite -> H.
  reflexivity.
Qed.

Example function_equality_ex1 : plus 3 = plus (pred 4).
Proof. reflexivity. Qed.

Axiom functional_extensionality : forall {X Y: Type} {f g: X -> Y},
    (forall (x: X), f x = g x) -> f = g.

Example function_equality_ex2 :
  (fun x => plus x 1) = (fun x => plus 1 x).
Proof.
  apply functional_extensionality.
  intros.
  apply plus_comm.
Qed.

Print Assumptions function_equality_ex2.

Fixpoint rev_append {X} (l1 l2: list X) : list X :=
  match l1 with
  | [] => l2
  | h :: t => rev_append t (h :: l2)
  end.

Definition tr_rev {X} (l : list X) : list X :=
  rev_append l [].

Lemma rev_append_correct :
  forall (X: Type) (l1 l2: list X),
  rev_append l1 l2 = rev l1 ++ l2.
Proof.
  intros.
  generalize dependent l2.
  induction l1 as [| h1 t1 IH1].
  - intros.
    reflexivity.
  - intros.
    simpl.
    rewrite -> IH1.
    rewrite <- app_assoc.
    simpl.
    reflexivity.
Qed.

Lemma tr_rev_correct : forall X, @tr_rev X = @rev X.
Proof.
  intros.
  apply functional_extensionality.
  intros.
  unfold tr_rev.
  rewrite -> rev_append_correct.
  apply app_nil_r.
Qed.

Theorem evenb_double : forall k, evenb (double k) = true.
Proof.
  intros.
  induction k as [| k' IH].
  - reflexivity.
  - simpl. apply IH.
Qed.

Theorem evenb_double_conv : forall n,
  exists k, n = if evenb n then double k
                else S (double k).
Proof.
  intros.
  induction n as [| n' IH].
  - exists 0. reflexivity.
  - rewrite -> evenb_S.
    destruct (evenb n').
    + simpl.
      destruct IH.
      exists x. rewrite -> H. reflexivity.
    + simpl.
      destruct IH.
      exists (S x). rewrite -> H.
      reflexivity.
Qed.

Theorem even_bool_prop : forall n,
  evenb n = true <-> exists k, n = double k.
Proof.
  intros.
  split.
  - intros.
    destruct (evenb_double_conv n).
    rewrite -> H in H0.
    exists x.
    apply H0.
  - intros.
    destruct H.
    rewrite -> H.
    apply evenb_double.
Qed.

Theorem beq_nat_true_iff : forall n1 n2 : nat,
  beq_nat n1 n2 = true <-> n1 = n2.
Proof.
  intros.
  split.
  - intros.
    apply beq_nat_true in H.
    apply H.
  - intros.
    rewrite -> H.
    rewrite <- beq_nat_refl.
    reflexivity.
Qed.

Lemma andb_true_l: forall (a: bool),
  true && a = a.
Proof.
  intros.
  destruct a.
  - reflexivity.
  - reflexivity.
Qed.

Lemma andb_true_iff : forall b1 b2:bool,
  b1 && b2 = true <-> b1 = true /\ b2 = true.
Proof.
  intros.
  split.
  - intros.
    split.
    + destruct b2.
      * rewrite -> andb_true_r in H.
        apply H.
      * destruct b1.
          reflexivity.
          destruct H. reflexivity.
    + destruct b1.
      * rewrite -> andb_true_l in H.
        apply H.
      * inversion H.
   - intros.
     destruct H.
     rewrite -> H.
     rewrite -> H0.
     reflexivity.
Qed.

Lemma orb_true_iff : forall b1 b2,
  b1 || b2 = true <-> b1 = true \/ b2 = true.
Proof.
  intros.
  split.
  - intros.
    destruct b1.
    + left. reflexivity.
    + destruct b2.
      * right. reflexivity.
      * simpl in H. inversion H.
  - intros.
    destruct H.
    + rewrite -> H. reflexivity.
    + rewrite -> H.
      destruct b1.
      * reflexivity.
      * reflexivity.
Qed.

Theorem beq_nat_false_iff : forall x y : nat,
  beq_nat x y = false <-> x <> y.
Proof.
  intros.
  split.
  - unfold not.
    intros.
    rewrite -> H0 in H.
    rewrite <- beq_nat_refl in H.
    inversion H.
  - unfold not.
    intros.
    destruct (beq_nat x y) eqn:beqnatxy.
    + exfalso. apply H. apply beq_nat_true_iff in beqnatxy.
      apply beqnatxy.
    + reflexivity.
Qed.

Fixpoint beq_list {A : Type} (beq : A -> A -> bool)
                  (l1 l2 : list A) : bool :=
  match l1 with
  | [] => match l2 with
          | [] => true
          | _  => false
          end
  | h1 :: t1 => match l2 with
                | [] => false
                | h2 :: t2 => (beq h1 h2) && (beq_list beq t1 t2)
                end
  end.

Lemma beq_list_true_iff :
  forall A (beq : A -> A -> bool),
    (forall a1 a2, beq a1 a2 = true <-> a1 = a2) ->
    forall l1 l2, beq_list beq l1 l2 = true <-> l1 = l2.
Proof.
  intros.
  split.
  - intros.
    generalize dependent l2.
    induction l1 as [| h1 t1 IH1].
    + intros.
      destruct l2 as [| h2 t2].
      * reflexivity.
      * inversion H0.
    + intros.
      destruct l2 as [| h2 t2].
      * inversion H0.
      * simpl in H0.
        apply andb_true_iff in H0.
        destruct H0.
        apply H in H0.
        apply IH1 in H1.
        rewrite -> H0.
        rewrite -> H1.
        reflexivity.
  - intros.
    generalize dependent l2.
    induction l1 as [| h t IH].
    + intros.
      rewrite <- H0.
      reflexivity.
    + intros.
      rewrite <- H0.
      simpl.
      apply andb_true_iff.
      split.
      * apply H.
        reflexivity.
      * apply IH.
        reflexivity.
Qed.

Lemma forallb_test_elements:
  forall X test (h: X) (t: list X),
    forallb test (h :: t) = true ->
    ((test h = true) /\ (forallb test t = true)).
Proof.
  intros.
  inversion H.
  apply andb_true_iff in H1.
  destruct H1.
  rewrite -> H0.
  rewrite -> H1.
  split.
  - reflexivity.
  - reflexivity.
Qed.

Theorem forallb_true_iff : forall X test (l : list X),
   forallb test l = true <-> All (fun x => test x = true) l.
Proof.
  intros.
  split.
  - induction l as [| h t IH].
    + reflexivity.
    + intros.
      simpl.
      apply forallb_test_elements in H.
      destruct H.
      split.
      * apply H.
      * apply IH.
        apply H0.
  - induction l as [| h t IH].
    + reflexivity.
    + intros.
      simpl.
      destruct H.
      rewrite -> H.
      rewrite -> andb_true_l.
      apply IH.
      apply H0.
Qed.

Definition excluded_middle := forall P : Prop,
  P \/ ~ P.

Theorem restricted_excluded_middle : forall P b,
  (P <-> b = true) -> P \/ ~ P.
Proof.
  intros.
  destruct b.
  - left. apply H. reflexivity.
  - right.
    rewrite -> H.
    unfold not.
    intros.
    inversion H0.
Qed.

Theorem restricted_excluded_middle_eq : forall(n m : nat),
  n = m \/ n <> m.
Proof.
  intros.
  apply (restricted_excluded_middle (n = m) (beq_nat n m)).
  symmetry.
  apply beq_nat_true_iff.
Qed.

Theorem excluded_middle_irrefutable: forall (P:Prop),
  ~ ~ (P \/ ~ P).
Proof.
  unfold not.
  intros.
  apply H.
  right.
  intros.
  apply H.
  left.
  apply H0.
Qed.

Theorem not_exists_dist :
  excluded_middle ->
  forall (X:Type) (P : X -> Prop),
    ~ (exists x, ~ P x) -> (forall x, P x).
Proof.
  unfold excluded_middle.
  intros.
  assert (P x \/ ~ P x).
  - apply H.
  - destruct H1.
    + apply H1.
    + exfalso.
      apply H0.
      exists x.
      apply H1.
Qed.

Definition peirce := forall P Q: Prop,
  ((P->Q)->P)->P.

Definition double_negation_elimination := forall P:Prop,
  ~~P -> P.

Definition de_morgan_not_and_not := forall P Q:Prop,
  ~(~P /\ ~Q) -> P\/Q.

Definition implies_to_or := forall P Q:Prop,
  (P->Q) -> (~P\/Q).


Require Import List Arith BinNat.
Import ListNotations.

Inductive digit : Set :=
| Digit : forall n, n < 10 -> digit.

Definition denoteDigit (d : digit) : nat :=
  match d with Digit n _ => n end.

Fixpoint denoteDigitList_helper (dl : list digit) (acc : nat) :=
  match dl with
  | [] => acc
  | a :: dl => denoteDigitList_helper dl ((acc * 10) + (denoteDigit a))
  end.

(* using explicit recursion over fold_left because I can't figure out how re-"fold" the induction for induction proofs *)
Definition denoteDigitList dl := denoteDigitList_helper dl 0.

Definition D0 : digit.
  refine (Digit 0 _).
  auto with arith.
Defined.

Definition D1 : digit.
  refine (Digit 1 _).
  auto with arith.
Defined.

Definition D2 : digit.
  refine (Digit 2 _).
  auto with arith.
Defined.

Definition D3 : digit.
  refine (Digit 3 _).
  auto with arith.
Defined.

Definition D4 : digit.
  refine (Digit 4 _).
  auto with arith.
Defined.

Definition D5 : digit.
  refine (Digit 5 _).
  auto with arith.
Defined.

Definition D6 : digit.
  refine (Digit 6 _).
  auto with arith.
Defined.

Definition D7 : digit.
  refine (Digit 7 _).
  auto with arith.
Defined.

Definition D8 : digit.
  refine (Digit 8 _).
  auto with arith.
Defined.

Definition D9 : digit.
  refine (Digit 9 _).
  auto with arith.
Defined.

Compute (denoteDigitList [D3 ; D4 ; D7]).

Definition toDigit (n : nat | n < 10) : digit.
  inversion n.
  intros.
  exact (Digit x H).
Defined.

Lemma all_nat_gte_zero : forall m, m >= 0.
  intros.
  induction m.
  auto.
  auto with arith.
Qed.

Lemma denoteDigit_is_lt_10 : forall (d : digit), denoteDigit d < 10.
Proof.
  intro d; unfold denoteDigit; elim d.
  intros; assumption.
Qed.

Lemma denoteDigit_is_le_9 : forall (d : digit), denoteDigit d <= 9.
Proof.
  intro d.
  assert (denoteDigit d < 10). apply denoteDigit_is_lt_10.
  apply lt_n_Sm_le; assumption.
Qed.

Require Import Omega.

Inductive remainder := R0 | R1.

Definition denotePair p :=
  match p with
  | (R0, d) => (denoteDigit d)
  | (R1, d) => 10 + (denoteDigit d)
  end.

Definition addDigit (d1 : digit) (d2 : digit) : (remainder * digit).
  pose (m := denoteDigit d1).
  pose (n := denoteDigit d2).
  destruct (lt_dec (m + n) 10) as [ TotalLt10 | TotalGt10 ].
  exact (R0, Digit (m + n) TotalLt10).

  assert (m <= 9). apply denoteDigit_is_le_9.
  assert (n <= 9). apply denoteDigit_is_le_9.
  assert (m + n <= 18) as SumMinus20.
  replace 18 with (9 + 9).
  apply plus_le_compat; [ assumption | assumption].
  auto with arith.
  cut (forall a b c, b <= a -> a <= b + c -> a - b <= c).
  intros Cut.
  replace 18 with (9 + 9) in SumMinus20.
  apply Cut in SumMinus20.
  Search (_ <= _ -> _ < _).
  apply le_lt_n_Sm in SumMinus20.
  assert (m + n - 10 < 10) as mPlusNLe10. omega.
  exact (R1, Digit (m + n - 10) mPlusNLe10).
  apply not_lt in TotalGt10; unfold ge in TotalGt10; omega.
  ring.
  intros; omega.
Defined.

Compute (denotePair (addDigit D3 D4)).
Compute (denotePair (addDigit D8 D6)).

Theorem addDigit_works_as_expected :
  forall d1 d2 : digit,
          (denoteDigit d1) + (denoteDigit d2) = (denotePair (addDigit d1 d2)).
Proof.
  intros.
  unfold denotePair, denoteDigit, addDigit.
  destruct (lt_dec (denoteDigit d1 + denoteDigit d2) 10) as [d1_plus_d2_lt_10 | d1_plus_d2_gte_10].
  - auto with arith.
  - apply not_lt in d1_plus_d2_gte_10.
    fold (denoteDigit d1); fold (denoteDigit d2).
    auto with arith.
Qed.

Theorem addDigit_assoc_r : forall (d1 d2 d3 : digit),
    (denoteDigit d1) + (denotePair (addDigit d2 d3)) = (denotePair (addDigit d1 d2)) + denoteDigit d3.
Proof.
  intros.
  rewrite <- addDigit_works_as_expected.
  rewrite <- addDigit_works_as_expected.
  rewrite Nat.add_assoc.
  reflexivity.
Qed.

Definition addDigitsWithRemainder (d1 d2 : digit) (r : remainder) : (remainder * digit).
  destruct (addDigit d1 d2) as (r', subtotal).
  case r.
  exact (r', subtotal).
  remember (denoteDigit subtotal) as n.
  destruct (lt_dec (denoteDigit subtotal) 9) as [ SubtotalLt9 | SubtotalEq9 ].
  apply lt_n_S in SubtotalLt9.
  rewrite <- Heqn in SubtotalLt9.
  exact (r', Digit (S n) SubtotalLt9).
  (* this is the situation where d1 + d2 = 9 with one as r, so final answer is 10.
     this means r' = zero by necessity. will need to show this in the theorem *)
  exact (R1, D0).
Defined.

(*Compute (addDigitsWithRemainder D3 D8 R0).*)
Compute (addDigitsWithRemainder D3 D8 R1).
Compute (addDigitsWithRemainder D2 D8 R1).
Compute (addDigitsWithRemainder D1 D8 R1).

Definition denoteRemainder r :=
  match r with
  | R0 => 0
  | R1 => 1
  end.

Lemma denotePair_S : forall r d H, denotePair (r, Digit (S (denoteDigit d)) H) = denotePair (r, d) + 1.
Proof.
  intros r d H.
  unfold denotePair, denoteDigit; destruct d; rewrite Nat.add_1_r.
  destruct r; reflexivity.
Qed.

Lemma addDigit_bounded : forall d1 d2, denotePair (addDigit d1 d2) <= 18.
  intros d1 d2.
  rewrite <- addDigit_works_as_expected.
  remember (denoteDigit_is_le_9 d1).
  remember (denoteDigit_is_le_9 d2).
  omega.
Qed.

Lemma addDigit_R0 : forall d d1 d2, addDigit d1 d2 = (R0, d) -> denoteDigit d1 + denoteDigit d2 = denoteDigit d.
  intros d d1 d2 def_of_d.
  remember (denotePair (addDigit d1 d2)) as n.
  rewrite <- addDigit_works_as_expected in Heqn.
  unfold addDigit in def_of_d.
  destruct (lt_dec (denoteDigit d1 + denoteDigit d2) 10).
  inversion def_of_d.
  unfold denoteDigit.
  auto with arith.
  inversion def_of_d.
Qed.

Theorem addDigitsWithRemainder_works: forall d1 d2 r, denotePair (addDigitsWithRemainder d1 d2 r) = denoteDigit d1 + denoteDigit d2 + denoteRemainder r.
Proof.
  intros d1 d2 r.
  unfold addDigitsWithRemainder.
  remember (addDigit d1 d2) as p.
  destruct p as (r', subtotal).
  destruct r.
  rewrite Heqp, <- addDigit_works_as_expected.
  unfold denoteRemainder; auto with arith.
  destruct (lt_dec (denoteDigit subtotal) 9).
  rewrite denotePair_S.
  rewrite Heqp, <- addDigit_works_as_expected.
  unfold denoteRemainder; auto with arith.
  (* must argue that subtotal = 9.  this is because ~(subtotal < 9), so obviously subtotal = 9 *)
  assert (denoteDigit subtotal = 9) as SubtotalEq9.
  remember (denoteDigit_is_lt_10 subtotal); omega.
  induction r'.
  symmetry in Heqp. apply addDigit_R0 in Heqp.
  rewrite Heqp, SubtotalEq9. compute; auto with arith.
  (* must argue that R1 is impossible because since subtotal = 9, so d1 + d2 can't be 19 *)
  remember (addDigit_bounded d1 d2) as l.
  destruct Heql.
  rewrite <- Heqp in l.
  unfold denotePair in l.
  rewrite SubtotalEq9 in l.
  omega.
Qed.

Lemma plus_reg_r : forall (a b c : nat), a + b = c + b <-> a = c.
Proof.
  intros.
  induction b.
  rewrite Nat.add_0_r, Nat.add_0_r; reflexivity.
  rewrite <- plus_n_Sm, <- plus_n_Sm.
  split.
  intros HSab_eq_Scb.
  apply eq_add_S, IHb in HSab_eq_Scb; assumption.
  intros.
  apply eq_S, IHb; assumption.
Qed.

Fixpoint denoteDigitList_backwards (dl : list digit) : nat :=
  match dl with
  | [] => 0
  | x :: dl => (denoteDigit x) + (10 * denoteDigitList_backwards dl)
  end.

Fixpoint addDigitList_helper (dl1 dl2 : list digit) (rem : digit) :=
  match (dl1, dl2) with
  | ([], []) => [rem]
  | ([], _) => addDigitList_helper_remainder dl2 rem
  | (_, []) => addDigitList_helper_remainder dl1 rem
  | (d1 :: tl1, d2 :: tl2) =>
    let (rem', total) := addDigitsWithRemainder d1 d2 rem in
    total :: (addDigitList_helper tl1 tl2 rem')
  end.

Lemma list_cons_app : forall (A : Type) (a : A) (l : (list A)), a :: l = [a] ++ l.
Proof.
  intros; simpl; reflexivity.
Qed.

Lemma denoteDigitList_backwards_single : forall d, denoteDigitList_backwards [d] = denoteDigit d.
Proof.
  intros.
  unfold denoteDigitList_backwards.
  rewrite <- mult_n_O, <- plus_n_O; reflexivity.
Qed.

Lemma denoteDigitList_backwards_empty : denoteDigitList_backwards [] = 0.
Proof.
  intros.
  unfold denoteDigitList_backwards; reflexivity.
Qed.

Lemma addDigitList_helper_works :
  forall dl1 dl2 rem,
    denoteDigitList_backwards (addDigitList_helper dl1 dl2 rem) = denoteDigit rem + denoteDigitList_backwards dl1 + denoteDigitList_backwards dl2.
Proof.
  induction dl1.
  induction dl2.
  intros.
  unfold addDigitList_helper.
  rewrite denoteDigitList_backwards_single.
  rewrite denoteDigitList_backwards_empty.
  ring.

  intros.
  unfold addDigitList_helper.
  rewrite addDigitList_helper_remainder_works.
  rewrite denoteDigitList_backwards_empty.
  ring.

  intros.
  destruct dl2.
  unfold addDigitList_helper at 1.
  rewrite addDigitList_helper_remainder_works.
  rewrite denoteDigitList_backwards_empty.
  ring.

  unfold addDigitList_helper.
  remember (addThreeDigits a d rem) as p.
  destruct p as (rem', total).
  fold addDigitList_helper.
  unfold denoteDigitList_backwards at 1.
  fold denoteDigitList_backwards.
  rewrite IHdl1.
  unfold denoteDigitList_backwards at 3.
  unfold denoteDigitList_backwards at 3.
  fold denoteDigitList_backwards.
  fold denoteDigitList_backwards.
  (* playing with the terms so they end up with the right terms on LHS/RHS
     annoying, feels like this should be easier *)
  replace (denoteDigit total +
           10 * (denoteDigit rem' +
                 denoteDigitList_backwards dl1 +
                 denoteDigitList_backwards dl2))
    with (denoteDigit total +
          10 * denoteDigit rem' +
          10 * denoteDigitList_backwards dl1 +
          10 * denoteDigitList_backwards dl2).
  replace (denoteDigit rem +
           (denoteDigit a + 10 * denoteDigitList_backwards dl1) +
           (denoteDigit d + 10 * denoteDigitList_backwards dl2))
    with (denoteDigit rem +
          denoteDigit a +
          denoteDigit d +
          10 * denoteDigitList_backwards dl1 +
          10 * denoteDigitList_backwards dl2).
  rewrite plus_reg_r, plus_reg_r.
  rewrite plus_comm.
  fold (denotePair (rem', total)).
  rewrite Heqp, addThreeDigits_works; ring.
  ring.
  ring.
Qed.

Definition addDigitList (dl1 : list digit) (dl2 : list digit) :=
  rev (addDigitList_helper (rev dl1) (rev dl2) D0).

Lemma length_always_gte_0 : forall (A : Type) (l : list A), length l >= 0.
Proof.
  intros.
  induction l.
  unfold length.
  auto.
  rewrite list_cons_app.
  rewrite app_length.
  unfold length at 1.
  auto.
Qed.

Lemma denoteDigitList_backwards_app : forall dl1 dl2,
    denoteDigitList_backwards (dl1 ++ dl2) = 10 ^ (length dl1) * denoteDigitList_backwards dl2 + denoteDigitList_backwards dl1.
Proof.
  induction dl1.
  intros.
  rewrite app_nil_l.
  symmetry.
  unfold length.
  rewrite Nat.pow_0_r.
  unfold denoteDigitList_backwards at 2.
  ring.

  intros.
  rewrite <- app_comm_cons.
  unfold denoteDigitList_backwards at 1.
  fold denoteDigitList_backwards.
  rewrite IHdl1, Nat.mul_add_distr_l, Nat.mul_assoc, <- Nat.pow_succ_r.
  (* need to drop the denoteDigitList_backwards dl2 term from both sides *)
  replace (10 ^ S (length dl1)) with (10 ^ (length (a :: dl1))).
  rewrite plus_comm, <- plus_assoc, Nat.add_cancel_l.
  symmetry.
  unfold denoteDigitList_backwards.
  fold denoteDigitList_backwards.
  ring.
  auto with arith.
  apply length_always_gte_0.
Qed.

Lemma denoteDigitList_backwards_rev_cons : forall dl a, denoteDigitList_backwards (rev (a :: dl)) = 10 ^ (length dl) * (denoteDigit a) + denoteDigitList_backwards (rev dl).
Proof.
  induction dl.
  intro a0; simpl; ring.
  intro a0.
  rewrite list_cons_app, rev_app_distr.
  unfold rev at 2.
  rewrite app_nil_l, denoteDigitList_backwards_app, IHdl, rev_length, Nat.add_cancel_r.
  unfold denoteDigitList_backwards.
  ring.
Qed.

Lemma denoteDigitList_helper_cons : forall dl a acc, denoteDigitList_helper (a :: dl) acc = denoteDigitList_helper dl (10 * acc + denoteDigit a).
Proof.
  intros.
  unfold denoteDigitList_helper at 1.
  fold denoteDigitList_helper.
  rewrite mult_comm.
  reflexivity.
Qed.

Lemma denoteDigitList_helper_split : forall dl m n, denoteDigitList_helper dl (m + n) = denoteDigitList_helper dl m + n * 10 ^ (length dl).
Proof.
  induction dl.
  intros; unfold denoteDigitList_helper; simpl; ring.
  intros m n.
  rewrite denoteDigitList_helper_cons, Nat.mul_add_distr_l.
  rewrite <- plus_assoc, IHdl, Nat.mul_add_distr_r.
  replace (n * 10 ^ length (a :: dl)) with (10 * n * 10 ^ length dl).
  rewrite plus_comm.
  symmetry.
  rewrite plus_comm, <- plus_assoc, Nat.add_cancel_l, denoteDigitList_helper_cons.
  symmetry.
  rewrite IHdl.
  ring.
  (* previous form was more convenient to show correctness, now we rewrite
     again *)
  replace (10 * n * 10 ^ length dl)
    with ((10 * 10 ^ length dl) * n) ; [auto | ring].
  rewrite <- Nat.pow_succ_r ; [auto | apply length_always_gte_0].
  replace (length (a :: dl)) with (S (length dl)); [ring | auto].
Qed.

Lemma denoteDigitList_helper_cons_unwrap : forall dl a acc, denoteDigitList_helper (a :: dl) acc = 10 ^ length dl * denoteDigit a + denoteDigitList_helper dl (acc * 10).
Proof.
  induction dl.
  intros a acc.
  rewrite denoteDigitList_helper_cons.
  unfold denoteDigitList_helper.
  symmetry.
  unfold length; rewrite Nat.pow_0_r; ring.

  intros a0 acc.
  (* don't want to unfold both a0 :: a so we use a temp variable *)
  remember (a :: dl) as dl'.
  rewrite denoteDigitList_helper_cons, Heqdl', denoteDigitList_helper_split, plus_comm.
  replace (10 * acc) with (acc * 10); [rewrite Nat.add_cancel_r ; ring | ring].
Qed.

Lemma denoteDigitList_unwrap : forall dl a, denoteDigitList (a :: dl) = 10 ^ length dl * denoteDigit a + denoteDigitList dl.
Proof.
  induction dl.
  intros.
  unfold denoteDigitList, denoteDigitList_helper; simpl; ring.

  intros.
  unfold denoteDigitList.
  rewrite denoteDigitList_helper_cons_unwrap, Nat.add_cancel_l.
  simpl; reflexivity.
Qed.

Lemma denoteDigitList_backwards_rev : forall dl, denoteDigitList_backwards (rev dl) = denoteDigitList dl.
Proof.
  induction dl.
  intros; compute; reflexivity.

  rewrite denoteDigitList_backwards_rev_cons.
  rewrite IHdl.
  symmetry.
  rewrite denoteDigitList_unwrap; reflexivity.
Qed.

Lemma denoteDigitList_app : forall dl1 dl2, denoteDigitList (dl1 ++ dl2) = 10 ^ (length dl2) * denoteDigitList dl1 + denoteDigitList dl2.
Proof.
  induction dl1.
  intros.
  rewrite app_nil_l.
  symmetry.
  unfold denoteDigitList at 1.
  unfold denoteDigitList_helper.
  ring.

  intros.
  rewrite <- app_comm_cons.
  unfold denoteDigitList.
  rewrite denoteDigitList_helper_cons_unwrap.
  symmetry.
  rewrite denoteDigitList_helper_cons_unwrap.
  simpl.
  fold (denoteDigitList dl1).
  fold (denoteDigitList dl2).
  fold (denoteDigitList (dl1 ++ dl2)).
  rewrite Nat.mul_add_distr_l.
  rewrite Nat.mul_assoc.

  replace (10 ^ length dl2 * 10 ^ length dl1) with (10 ^ length (dl1 ++ dl2)).
  rewrite <- Nat.add_assoc.
  rewrite Nat.add_cancel_l.
  symmetry.
  rewrite IHdl1.
  reflexivity.

  (* proof of replacement *)
  rewrite <- Nat.pow_add_r, plus_comm.
  rewrite app_length.
  reflexivity.
Qed.

Lemma denoteDigitList_rev : forall dl, denoteDigitList (rev dl) = denoteDigitList_backwards dl.
Proof.
  induction dl.
  compute.
  reflexivity.

  rewrite list_cons_app, rev_app_distr.
  unfold rev at 2.
  rewrite app_nil_l, denoteDigitList_app.
  unfold length, denoteDigitList at 2, denoteDigitList_helper.
  rewrite Nat.mul_0_l, Nat.pow_1_r, Nat.add_0_l.
  rewrite denoteDigitList_backwards_app.
  unfold length.
  rewrite Nat.pow_1_r.
  rewrite <- IHdl.
  rewrite Nat.add_cancel_l.
  unfold denoteDigitList_backwards.
  ring.
Qed.

Theorem addDigitList_works :
  forall dl1 dl2, denoteDigitList dl1 + denoteDigitList dl2 = denoteDigitList (addDigitList dl1 dl2).
Proof.
  intros.
  unfold addDigitList.
  symmetry.
  rewrite denoteDigitList_rev, addDigitList_helper_works, denoteDigitList_backwards_rev, denoteDigitList_backwards_rev, Nat.add_cancel_r.
  unfold denoteDigit.
  simpl.
  reflexivity.
Qed.

Lemma mod_is_lt : forall (m n : nat), n > 0 -> (m mod n) < n.
  intros.
  apply (Nat.mod_bound_pos m n (all_nat_gte_zero m)).
  exact H.
Qed.

Lemma TenGt0 : 10 > 0.
Proof.
  auto with arith.
Qed.

(* https://stackoverflow.com/questions/33302526/well-founded-recursion-in-coq *)
Require Coq.Program.Tactics.
Require Coq.Program.Wf.

Fixpoint convertToDigitList_helper (n i : nat) : (list digit) :=
  match i with
  | 0 => []
  | (S p) =>
    let a := n mod 10 in
    let m := n / 10 in
    let d := Digit a (mod_is_lt n 10 TenGt0) in
    if eq_nat_dec m 0 then
      [d]
    else
      (convertToDigitList_helper m p) ++ [d]
  end.

Definition convertToDigitList (n : nat) : (list digit) :=
  convertToDigitList_helper n n.

Compute (convertToDigitList 123).

Lemma div_zero_implies_small : (forall a b, b <> 0 -> a / b = 0 -> a < b).
Proof.
  intros a b b_neq_0 a_div_b_eq_0.
  apply (Nat.div_str_pos_iff a b) in b_neq_0.
  omega.
Qed.

Lemma div_nonzero_implies_not_small : (forall a b, b <> 0 -> a / b <> 0 -> b <= a).
  intros a b b_neq_0.
  apply (Nat.div_str_pos_iff a b) in b_neq_0.
  intros a_b_neq_0.
  omega.
Qed.

Lemma denoteDigitList_trivial : forall d : digit, denoteDigitList [d] = denoteDigit d.
Proof.
  intro d.
  unfold denoteDigitList.
  unfold denoteDigitList_helper.
  ring.
Qed.

Require Import Arith Wf.

Lemma convertToDigitList_helper_works :
  forall m i, m <= i -> denoteDigitList (convertToDigitList_helper m i) = m.
Proof.
  induction m as [ m IHn ] using (well_founded_induction lt_wf).
  intros i m_bounded.
  unfold convertToDigitList_helper.
  destruct i.
  compute; omega.

  fold convertToDigitList_helper.
  destruct (Nat.eq_dec (m / 10) 0) as [m_div_10_eq_0 | m_div_10_neq_0].
  apply div_zero_implies_small in m_div_10_eq_0 ; [auto | auto].
  apply Nat.mod_small in m_div_10_eq_0; auto.
  cut (m / 10 < m).
  intros m_lt_10_lt_m.
  Search (denoteDigitList (_ ++ _)).
  rewrite denoteDigitList_app.
  rewrite IHn.
  unfold length.
  rewrite denoteDigitList_trivial.
  unfold denoteDigit.
  rewrite Nat.pow_1_r.
  symmetry.
  apply Nat.div_mod; [auto].
  omega.
  omega.
  apply Nat.div_lt; [auto|auto with arith].
  apply div_nonzero_implies_not_small; [auto | auto].
  rewrite Nat.div_1_r.
  unfold not.
  intros Hm_0.
  rewrite Hm_0 in m_div_10_neq_0.
  auto.
Qed.

Theorem convertToDigitList_works : forall n : nat, denoteDigitList (convertToDigitList n) = n.
Proof.
  intros n.
  unfold convertToDigitList.
  apply convertToDigitList_helper_works ; auto.
Qed.

Compute (convertToDigitList 123).

Theorem grade_school_addition_correct: forall m n, denoteDigitList (addDigitList (convertToDigitList m) (convertToDigitList n)) = m + n.
Proof.
  intros m n.
  rewrite <- addDigitList_works.
  repeat rewrite convertToDigitList_works.
  reflexivity.
Qed.

Recursive Extraction addDigitList convertToDigitList.

  (* Multiplication *)

(* 123 * 456 = (100 + 20 + 3) * (400 + 50 + 6) *)
(* 100 * 400 + 100 * 50 + 100 * 6 + 20 * 400 + 20 * 50 + 20 * 6 + 3 * 400 + 3 * 50 + 3 * 6 *)

Fixpoint multiplyDigit (d1 : digit) (d2 : digit) : (digit * digit).
  pose (m := denoteDigit d1).
  pose (n := denoteDigit d2).
  destruct (lt_dec (m * n) 10) as [ TotalLt10 | TotalGt10 ].
  exact (D0, Digit (m * n) TotalLt10).

  (* Must prove that multiplying two digits gives a remainder / modulus both < 10 *)
  assert (m * n <= 81) as MultBounded.
  Search (_ <= _ -> _ < _).
  assert (m <= 9). apply denoteDigit_is_le_9.
  assert (n <= 9). apply denoteDigit_is_le_9.
  apply (mult_le_compat _ _ _ _ H H0).

  pose (a := (m * n) / 10).
  pose (b := (m * n) mod 10).

  assert (b < 10) as ModLt10. apply mod_is_lt. auto with arith.
  assert (a < 10) as RemainderLt10.
  Search (_ <= _ -> _ / _ <= _).
  apply (Nat.div_le_mono (m * n) 81 10) in MultBounded.
  assert (81 / 10 = 8). auto with arith.
  rewrite H in MultBounded.
  apply le_lt_n_Sm in MultBounded.
  apply Nat.lt_lt_succ_r in MultBounded.
  exact MultBounded.
  auto with arith.
  exact (Digit a RemainderLt10, Digit b ModLt10).
Defined.

Fixpoint multiplyDigitList_backwards_helper (dl : list digit) (d : digit) : list digit :=
  match dl with
  | [] => []
  | d' :: dl =>
    let (rem, d0) := (multiplyDigit d d') in
    let dl' := (multiplyDigitList_backwards_helper dl d) in
    d0 :: (addDigitList_helper dl' [rem] D0)
  end.


Require Import Bool Arith.

Inductive bintree :=
| Leaf : nat -> bintree
| Node : nat -> bintree -> bintree -> bintree.

Inductive is_post_order : bintree -> nat -> nat -> Prop :=
| po_leaf k : is_post_order (Leaf k) k (S k)
| po_node t1 t2 k l m :
    is_post_order t1 k l -> is_post_order t2 l m ->
    is_post_order (Node m t1 t2) k (S m).

Coercion Leaf : nat >-> bintree.
Notation "[ x ; y ,  z ] " :=  (Node x y z).

Definition task :=
  forall i j k l m n : nat,
    is_post_order [i; [j; k, l], m] 0 n <->
    k = 0 /\ l = 1 /\ j = 2 /\ m = 3 /\ i = 4 /\ n = 5.


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

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

Unset Positivity Checking.
Unset Guard Checking.

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

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

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

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

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


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

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

Unset Positivity Checking.
Unset Guard Checking.

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

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

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

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

Definition synth (lf1 : natural) (y : natural) (x : natural) : natural :=
  mult x lf1.


Require Export Lists.

Inductive boollist : Type :=
  | bool_nil : boollist
  | bool_cons : bool -> boollist -> boollist.

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

Check nil.

Check cons.

Check (cons nat 2 (cons nat 1 (nil nat))).

Fixpoint repeat (X : Type) (x : X) (count : nat) : list X :=
  match count with
  | 0 => nil X
  | S count' => cons X x (repeat X x count')
  end.

Example test_repeat1 :
  repeat nat 4 2 = cons nat 4 (cons nat 4 (nil nat)).
Proof. reflexivity. Qed.

Example test_repeat2 :
  repeat bool false 1 = cons bool false (nil bool).
Proof. reflexivity. Qed.

Module MumbleGrumble.

Inductive mumble : Type :=
  | a : mumble
  | b : mumble -> nat -> mumble
  | c : mumble.

Inductive grumble (X:Type) : Type :=
  | d : mumble -> grumble X
  | e : X -> grumble X.

(* d (b a 5)
   d mumble (b a 5)
   d bool (b a 5) *)

End MumbleGrumble.

Fixpoint repeat' X x count : list X :=
  match count with
  | 0 => nil X
  | S count' => cons X x (repeat' X x count')
  end.

Check repeat'.

Check repeat.

Fixpoint repeat'' X x count : list X :=
  match count with
  | 0 => nil _
  | S count' => cons _ x (repeat'' _ x count')
  end.

Definition list123 :=
  cons nat 1 (cons nat 2 (cons nat 3 (nil nat))).

Definition list123' :=
  cons _ 1 (cons _ 2 (cons _ 3 (nil _))).

Arguments nil {X}.
Arguments cons {X} _ _.
Arguments repeat {X} x count.

Definition list123'' := cons 1 (cons 2 (cons 3 nil)).

Fixpoint repeat''' {X : Type} (x : X) (count : nat) : list X :=
  match count with
  | 0 => nil
  | S count' => cons x (repeat''' x count')
  end.

Inductive list' {X:Type} : Type :=
  | nil' : list'
  | cons' : X -> list' -> list'.

Fixpoint app {X : Type} (l1 l2 : list X) : (list X) :=
  match l1 with
  | nil => l2
  | cons h t => cons h (app t l2)
  end.

Fixpoint rev {X : Type} (l:list X) : list X :=
  match l with
  | nil => nil
  | cons h t => app (rev t) (cons h nil)
  end.

Fixpoint length {X : Type} (l : list X) : nat :=
  match l with
  | nil => 0
  | cons _ l' => S (length l')
  end.

Example test_rev1 :
  rev (cons 1 (cons 2 nil)) = (cons 2 (cons 1 nil)).
Proof. reflexivity. Qed.

Example test_rev2:
  rev (cons true nil) = cons true nil.
Proof. reflexivity. Qed.

Example test_length: length (cons 1 (cons 2 (cons 3 nil))) = 3.
Proof. reflexivity. Qed.

Fail Definition mynil := nil.

Definition mynil : list nat := nil.

Check @nil.

Definition mynil' := @nil nat.

Notation "x :: y" := (cons x y)
                     (at level 60, right associativity).
Notation "[ ]" := nil.
Notation "[ x ; .. ; y ]" := (cons x .. (cons y []) ..).
Notation "x ++ y" := (app x y)
                     (at level 60, right associativity).

Definition list123''' := [1; 2; 3].

Theorem app_nil_r : forall(X:Type), forall l:list X,
  l ++ [] = l.
Proof.
  intros X l. induction l as [|l' n IHl'].
  - simpl. reflexivity.
  - simpl. rewrite -> IHl'.
    reflexivity.
Qed.

Theorem app_assoc : forall A (l m n:list A),
  l ++ m ++ n = (l ++ m) ++ n.
Proof.
  intros A l m n. induction l as [|l' a IHl'].
  - simpl. reflexivity.
  - simpl. rewrite -> IHl'.
    reflexivity.
Qed.

Lemma app_length : forall(X:Type) (l1 l2 : list X),
  length (l1 ++ l2) = length l1 + length l2.
Proof.
  intros X l1 l2. induction l1 as [|l1' n IHl1'].
  - simpl. reflexivity.
  - simpl. rewrite -> IHl1'.
    reflexivity.
Qed.

Theorem rev_app_distr: forall X (l1 l2 : list X),
  rev (l1 ++ l2) = rev l2 ++ rev l1.
Proof.
  intros X l1 l2. induction l1 as [|l1' n IHl1'].
  - simpl. rewrite -> app_nil_r. reflexivity.
  - simpl. rewrite -> IHl1'.
    rewrite -> app_assoc. reflexivity.
Qed.

Theorem rev_involutive : forall X : Type, forall l : list X,
  rev (rev l) = l.
Proof.
  intros X l. induction l as [|l n IHl'].
  - simpl. reflexivity.
  - simpl. rewrite -> rev_app_distr.
    rewrite -> IHl'. simpl. reflexivity.
Qed.

Inductive prod (X Y : Type) : Type :=
| pair : X -> Y -> prod X Y.

Arguments pair {X} {Y} _ _.

Notation "( x , y )" := (pair x y).

Notation "X * Y" := (prod X Y) : type_scope.

Definition fst {X Y : Type} (p : X * Y) : X :=
  match p with
  | (x, y) => x
end.

Definition snd {X Y : Type} (p: X * Y) : Y :=
  match p with
  | (x, y) => y
  end.

Fixpoint combine {X Y : Type} (lx : list X) (ly : list Y)
           : list (X*Y) :=
  match lx, ly with
  | [], _ => []
  | _, [] => []
  | x :: tx, y :: ty => (x, y) :: (combine tx ty)
  end.

Fixpoint split {X Y : Type} (l : list (X * Y))
               : (list X) * (list Y) :=
  match l with
  | [] => ([],[])
  | ([x;y],[tx;ty]) :: m => ([x :: tx], [y :: ty]) ++ (split m)
  end.


(* This file another solution Ex 8.9 used by Coq.Arith.Even in Coq'Art. *)

Open Scope nat_scope.
(* In Coq'Art's solution, following even definition is used. *)
(* But, in this solution, this definition is not used. *)
(* Inductive even : nat -> Prop := *)
(* | O_even : even 0 *)
(* | SS_even : forall n:nat, even n -> even (S (S n)). *)

(* Hint Resolve O_even SS_even. *)

Require Import Coq.Arith.Even.

Hint Resolve even_O even_S.
Hint Resolve odd_S even_S.

Fixpoint mult2 (n:nat) : nat :=
  match n with
    | O => 0
    | S p => S (S (mult2 p))
  end.

Theorem even_mult2 :
  forall n:nat, even (mult2 n).
Proof.
  induction n.
  simpl.
  auto.
  simpl.
  auto.
Qed.

Theorem sum_even :
  forall n p:nat, even n -> even p -> even (n+p).
Proof.
  intros n p H0 H1.
  apply even_even_plus.
  trivial.
  auto.
Qed.

Hint Resolve sum_even.

Theorem square_even :
  forall n:nat, even n -> even (n*n).
Proof.
  intros.
  apply even_mult_l.
  trivial.
Qed.


Section Minimal_propositional_logic.
 Variables P Q R T : Prop.

 Theorem imp_trans : (P->Q)->(Q->R)->P->R.
 Proof.
  intros H H' p.
  apply H'.
  apply H.
  assumption.
 Qed.

 Theorem imp_trans' : (P->Q)->(Q->R)->P->R.
 Proof.
  intros H H' p; apply H'; apply H; assumption.
 Qed.

 Theorem imp_trans'' : (P->Q)->(Q->R)->P->R.
 Proof.
  auto.
 Qed.

 Theorem delta : (P->P->Q)->P->Q.
 Proof (fun (H:P->P->Q)(p:P) => H p p).

 Lemma apply_example : (Q->R->T)->(P->Q)->P->R->T.
 Proof.
  intros H H0 p.
  apply H.
  exact (H0 p).
 Qed.

 Theorem imp_dist : (P->Q->R)->(P->Q)->(P->R).
 Proof.
  intros H H' p.
  apply H.
  - assumption.
  - apply H'; assumption.
 Qed.

 Theorem K : P->Q->P.
 Proof.
  intros p q;  assumption.
 Qed.

 Section proof_of_triple_impl.
  Hypothesis H : ((P->Q)->Q)-> Q.
  Hypothesis p : P.

  Remark  R1 : (P->Q)->Q.
  Proof fun H0:P->Q => H0 p.

  Theorem triple_impl : Q.
  Proof H R1.

 End proof_of_triple_impl.

 Theorem triple_impl_one_liner : (((P->Q)->Q)->Q)->P->Q.
 Proof.
  intros H p; apply H; intro H0; apply H0; assumption.
 Qed.

 Lemma imp_dist' : (P->Q->R)->(P->Q)->(P->R).
 Proof.
  intros H H' p.
  apply H;[assumption | apply H'; assumption].
 Qed.

 Section section_assert_example.
  Hypotheses (H : P->Q)
             (H0 : Q->R)
             (H1 : (P->R)->T->Q)
             (H2 : (P->R)->T).

  Lemma cut_example : Q.
  Proof.
    cut (P -> R).
    intro H3.
    apply H1; [ assumption | apply H2; assumption].
    intro Hp; apply H0; apply H; assumption.
  Qed.

  (* 3.5 *)
  Lemma cut_exercise : Q.
  Proof.
    apply H1; [intro Hp; apply H0; apply H; assumption |
               apply H2; intro Hp; apply H0; apply H; assumption].
  Qed.

  Print cut_example.
  Print cut_exercise.

 End section_assert_example.

 Lemma triple_impl2 : (((P->Q)->Q)->Q)->P->Q.
 Proof.
  auto.
 Qed.

End Minimal_propositional_logic.

Print imp_dist.

Section using_imp_dist.
 Variables (P1 P2 P3 : Prop).

 Check imp_dist P1 P2 P3.

 Check imp_dist (P1->P2) (P2->P3) (P3->P1).

End using_imp_dist.


(*
 * Coq code for "Using XCAP to Certify Realistic System Code: Machine Context Management"
 *
 * Math lemma library
 *
 * (for Coq version 8.0pl2)
 *)

Require Import Div2.
Require Import EqNat.
Require Import Lt.
Require Import Le.
Require Import ZArith.

Fixpoint bgt_nat (n m : nat) {struct n} : bool :=
  match n, m with
  | O, O => false
  | O, S _ => false
  | S _, O => true
  | S n1, S m1 => bgt_nat n1 m1
  end.

Fixpoint blt_nat (n m : nat) {struct n} : bool :=
  match n, m with
  | O, O => false
  | O, S _ => true
  | S _, O => false
  | S n1, S m1 => blt_nat n1 m1
  end.

Fixpoint ble_nat (n m : nat) {struct n} : bool :=
  match n, m with
  | O, O => true
  | O, S _ => true
  | S _, O => false
  | S n1, S m1 => ble_nat n1 m1
  end.

Lemma ble_le_true : forall a b : nat, a <= b -> ble_nat a b = true.
intro.
induction  a as [| a Hreca].
 intros.
   simpl in |- *.
   destruct b as [| n].
  auto.
  auto.
 intros.
   destruct H.
  simpl in |- *.
    apply Hreca.
    auto.
  simpl in |- *.
    apply Hreca.
    auto.
    apply le_Sn_le.
    auto.
Qed.

Lemma ble_gt_false : forall a b : nat, a > b -> ble_nat a b = false.
unfold gt in |- *.
simple induction a.
 intros.
   inversion H.
 intros.
   destruct b as [| n0].
  auto.
  simpl in |- *.
    apply H.
    auto.
    apply lt_S_n.
    auto.
Qed.

Lemma blt_S_false : forall a : nat, blt_nat (S a) a = false.
Proof.
simple induction a.
unfold blt_nat in |- *.
auto.
intros.
unfold blt_nat in |- *.
auto.
Qed.

Lemma blt_S_eq :
 forall (a b : nat) (t : bool), blt_nat a b = t -> blt_nat (S a) (S b) = t.
Proof.
intros.
unfold blt_nat in |- *.
fold blt_nat in |- *.
auto.
Qed.

Lemma blt_lt_true : forall a b : nat, a < b -> blt_nat a b = true.
Proof.
simple induction a.
intros.
inversion H.
unfold blt_nat in |- *.
auto.
unfold blt_nat in |- *.
auto.
intros.
inversion H0.
apply blt_S_eq.
apply H.
apply lt_n_Sn.
apply blt_S_eq.
apply H.
rewrite <- H2 in H0.
apply lt_S_n.
auto.
Qed.

Lemma blt_Sm_false :
 forall a b : nat, blt_nat a b = false -> blt_nat (S a) b = false.
Proof.
simple induction a.
simple induction b.
intros.
unfold blt_nat in |- *.
auto.
intros.
unfold blt_nat in H0.
absurd (true = false).
discriminate.
auto.
simple induction b.
intros.
unfold blt_nat in |- *.
auto.
intros.
intros.
unfold blt_nat in H1.
fold blt_nat in H1.
cut (blt_nat (S n) n0 = false).
intros.
apply blt_S_eq.
auto.
apply (H n0).
auto.
Qed.

Lemma blt_false : forall a b : nat, a < b -> blt_nat b a = false.
Proof.
intros.
induction  H as [| m H HrecH].
apply blt_S_false.
apply blt_Sm_false.
auto.
Qed.

Lemma blt_eq_false : forall a : nat, blt_nat a a = false.
Proof.
simple induction a.
unfold blt_nat in |- *.
auto.
intros.
unfold blt_nat in |- *.
auto.
Qed.

Lemma beq_eq_true : forall a b : nat, a = b -> true = beq_nat a b.
simple induction a.
 simple induction b.
  auto.
  intros.
    inversion H0.
 simple induction b.
  intros.
    inversion H0.
  intros.
    simpl in |- *.
    auto.
Qed.

Lemma beq_neq_false : forall a b : nat, a <> b -> false = beq_nat a b.
Proof.
simple induction a.
simple induction b.
intros.
absurd (0 <> 0).
auto.
auto.
intros.
unfold beq_nat in |- *.
auto.
intros.
unfold beq_nat in |- *.
auto.
induction  b as [| b Hrecb].
auto.
unfold beq_nat in |- *.
fold beq_nat in |- *.
unfold beq_nat in |- *.
auto.
Qed.

Lemma eq_neq_Sl : forall a b : nat, a = b -> S a <> b.
Proof.
simple induction a.
simple induction b.
intros.
auto.
intros.
absurd (0 = S n).
discriminate.
auto.
simple induction b.
intros.
absurd (S n = 0).
discriminate.
auto.
intros.
apply not_eq_S.
auto.
Qed.

Theorem eqorneq_nat : forall a a' : nat, a = a' \/ a <> a'.
Proof.
intros.
compare a a'.
auto.
auto.
Qed.

Theorem le_or_gt : forall m n : nat, n <= m \/ n > m.
Proof.
double induction m n.
left.
auto.
intros.
right.
red in |- *.
red in |- *.
apply le_n_S.
apply le_O_n.
intros.
left.
apply le_O_n.
intros.
cut (n <= n1 \/ n > n1).
intros.
inversion_clear H1.
left.
apply le_n_S.
auto.
right.
unfold gt in |- *.
unfold gt in H2.
apply lt_n_S.
auto.
apply H0.
Qed.

Lemma lt_neq : forall m n : nat, n < m -> n <> m.
Proof.
simple induction m.
intros.
inversion H.
intros.
induction  n0 as [| n0 Hrecn0].
auto.
cut (n0 < n).
intros.
cut (n0 <> n).
intros.
auto.
apply H.
auto.
apply lt_S_n.
auto.
Qed.

Lemma lt_S_neq : forall n x : nat, n < S x -> x <> n -> n < x.
Proof.
double induction n x.
intros.
absurd (0 <> 0).
auto.
auto.
intros.
apply lt_O_Sn.
intros.
unfold lt in H0.
cut (S n0 <= 0).
intros.
absurd (S n0 <= 0).
apply le_Sn_O.
auto.
apply le_S_n.
auto.
intros.
apply lt_n_S.
cut (n1 = n0 \/ n1 <> n0).
intros.
inversion_clear H3.
absurd (S n1 <> S n1).
auto.
rewrite <- H4 in H2.
auto.
cut (n1 < S n0).
intros.
apply (H0 n0 H3).
auto.
apply lt_S_n.
auto.
apply eqorneq_nat.
Qed.

Lemma lt_S_eq_or_lt : forall n x : nat, n < S x -> x = n \/ n < x.
Proof.
intros.
cut (x = n \/ x <> n).
intros.
inversion_clear H0.
left;
auto.
right;
apply lt_S_neq.
auto.
auto.
apply eqorneq_nat.
Qed.

Lemma plus_n_O_n : forall n : nat, n + 0 = n.
Proof.
simple induction n.
unfold plus in |- *.
auto.
intros.
unfold plus in |- *.
fold plus in |- *.
rewrite H.
auto.
Qed.

Lemma plus_S_neq : forall n m : nat, n <> n + S m.
Proof.
simple induction n.
intros.
unfold plus in |- *.
auto.
intros.
unfold plus in |- *.
fold plus in |- *.
auto.
Qed.

Lemma Psucc_eq : forall a b, Psucc a = Psucc b -> a = b.
induction a; induction b; simpl; auto; intros; try (inversion H; fail).
inversion H; rewrite IHa with b; auto.
induction a; inversion H.
inversion H; auto.
induction b; inversion H.
Qed.

Lemma Z_eq_nat_eq : forall a b, Z_of_nat a = Z_of_nat b -> a = b.
induction a; induction b; auto; intros.
inversion H. inversion H.
rewrite (IHa b); auto.
simpl in H. inversion H.
clear IHa IHb.
generalize a b H1. clear a b H H1.
induction a; induction b; simpl; auto; intros.
generalize (P_of_succ_nat b) H1; clear H1 IHb; induction p; simpl; intro; inversion H1.
generalize (P_of_succ_nat a) H1; clear H1 IHa; induction p; simpl; intro; inversion H1.
rewrite (Psucc_eq _ _ H1); auto.
Qed.

Lemma Zeq_bool_true_eq : forall a b, true = Zeq_bool a b -> a = b.
intros a b; unfold Zeq_bool; generalize (Zcompare_Eq_eq a b); destruct (a?=b)%Z;
auto; intros; inversion H0.
Qed.

Lemma Zeq_bool_neq_false : forall a b, a <> b -> false = Zeq_bool a b.
intros a b; unfold Zeq_bool; generalize (Zcompare_Eq_eq a b); destruct (a?=b)%Z;
auto.
Qed.

Lemma Zeq_bool_eq_true : forall a b, a = b -> true = Zeq_bool a b.
intros. rewrite H. clear a H. destruct b; auto; induction p; auto.
Qed.


Require Export D.

(** **** Problem  : 4 stars (plus_swap) *)
(** Use [assert] to help prove this theorem if necessary.
    You shouldn't need to use induction. *)

Theorem plus_swap : forall n m p : nat,
  n + (m + p) = m + (n + p).
Proof.
  Lemma plus_assoc : forall a b c:nat, a + (b + c) = (a + b) + c.
  Proof.
    intros. induction a. reflexivity. simpl. rewrite -> IHa. reflexivity. Qed.
    intros. rewrite -> plus_assoc. symmetry. rewrite -> plus_assoc.  assert (H : m + n = n + m).
    induction n. simpl. induction m. reflexivity. simpl. rewrite -> IHm. reflexivity. simpl. rewrite <- IHn.
    Lemma plus_mSn_Smn : forall n m : nat, m + S n = S (m + n).
      intros. induction m. reflexivity. simpl. rewrite -> IHm. reflexivity.
    Qed.
    apply plus_mSn_Smn.
    rewrite -> H. reflexivity.

    Qed.


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

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

Unset Positivity Checking.
Unset Guard Checking.

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

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

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

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

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


Require Import NormTypes.NormalizedTypes.
Require Import NormTypes.irreleventQuantifiers.
Require Import NPeano Omega.

Module Mod3_byHand.
  Definition mod3 (n:nat) := (Nat.modulo n 3).

  (* Notation "'class' nf a" := (isig_intro _ (nf a) (iex_intro _ a eq_refl)) (at level 100). *)
  Check (class mod3 3).
  Check (class mod3 0).

  Notation "'[[' x ']N/3N]'" := (class mod3 x) (at level 200).
  Notation "'N/3N'" := (Norm mod3) (at level 200).
  Check [[3]N/3N].
  Check [[0]N/3N].

  Lemma eq_3_0: [[3]N/3N] = [[0]N/3N].
  Proof.
    reflexivity.
  Qed.

  Lemma eq_3_x: forall x , [[x]N/3N] = [[3+x]N/3N].
  Proof.
    intros x.
    apply eqS_eq.
    simpl.
    unfold class.
    unfold eqS, liftR.
    simpl.
    replace (S (S (S x))) with (x+1*3);try omega.
    unfold mod3.
    rewrite (Nat.mod_add x 1 3);auto.
  Qed.

  Lemma eq_3_mult_x: forall x , [[0]N/3N] = [[3*x]N/3N].
  Proof.
    intros x.
    apply eqS_eq.
    simpl.
    unfold class.
    unfold eqS, liftR.
    simpl.
    replace (x + (x + (x + 0))) with (0+x*3);try omega.
    unfold mod3.

    rewrite (Nat.mod_add 0 x 3);auto.
  Qed.

  Definition add1:= @lift _ _ mod3 _ (fun x:nat => [[ x +1 ]N/3N]).
  Eval compute in (add1 ([[3]N/3N])).

  Notation "[[ x ]]" := (isig_intro _ x _) (only printing, at level 200).
  Eval compute in (add1 ([[3]N/3N])).
  Eval compute in (add1 ([[4]N/3N])).

  Definition add:=
    @lift _ _ mod3 _ (fun n:nat =>
                            @lift _ _ mod3 _ (fun x:nat => [[ x + n ]N/3N])).

  Eval compute in (add ([[2]N/3N]) ([[2]N/3N])).

  (* Definition toint (x:N/3N):nat := extract _ x. *)
  (* Definition fromint (x:nat):N/3N := class _ x. *)

End Mod3_byHand.

Module Mod3_usingLibMod.

  Definition mod3 (n:nat) := (Nat.modulo n 3).
  Definition NMod3 := Norm mod3.

  Check (class mod3 3).
  Check (class mod3 0).

  Notation "'[[' x ']Z/3Z]'" := (class mod3 x) (at level 200).
  Notation "A == B" := (@eqS _ _ mod3 A B) (at level 200).
  Check [[3]Z/3Z].
  Check [[0]Z/3Z].

  Lemma eq_3_0: [[3]Z/3Z] = [[0]Z/3Z].
  Proof.
    reflexivity.
  Qed.

  Lemma eq_3_x: forall x , [[x]Z/3Z] = [[3+x]Z/3Z].
  Proof.
    intros x.
    apply eqS_eq.
    simpl.
    unfold class.
    unfold eqS, liftR.
    simpl.
    replace (S (S (S x))) with (x+1*3);try omega.
    unfold mod3.
    rewrite (Nat.mod_add x 1 3);auto.
  Qed.

End Mod3_usingLibMod.

(* Example: Z/3Z. *)
Require Import ZArith.

Module Mod3Z.

  Open Scope Z_scope.

  Definition mod3Z (z:Z) := (Z.modulo z 3%Z).
  Definition NMod3Z := Norm mod3Z.

  Check (class mod3Z 3).
  Check (class mod3Z 0).

  Notation "'[[' x ']Z/3Z]'" := (class mod3Z x) (at level 200).
  Check [[3]Z/3Z].
  Check [[0]Z/3Z].

  Lemma eq_3_0Z: [[3]Z/3Z] = [[0]Z/3Z].
  Proof.
    reflexivity.
  Qed.

  Lemma eq_3_x: forall x , [[x]Z/3Z] = [[3+x]Z/3Z].
  Proof.
    intros x.
    apply eqS_eq.
    lazy beta delta -[Z.add Z.modulo] iota.
    replace (3+x) with (x+1*3);try omega.
    rewrite (Z.mod_add x 1 3);auto.
    omega.
  Qed.
End Mod3Z.


Theorem t1 (P Q R : Prop) : (P -> Q) -> (Q -> R) -> (P -> R).
Proof.
  intros H1 H2 H. apply H2, H1, H.
Qed.

Print t1.
(* t1 = fun (P Q R : Prop)
   (H1 : P -> Q) (H2 : Q -> R) (H : P) => H2 (H1 H)
   : forall P Q R : Prop, (P -> Q) -> (Q -> R) -> P -> R *)

Theorem t2 (P Q R : Prop) : (P -> Q) -> (Q -> R) -> (P -> R).
Proof.
  exact (fun f g p => g (f p)).
Qed.

Print t2.
(* t2 = fun (P Q R : Prop)
   (f : P -> Q) (g : Q -> R) (p : P) => g (f p)
   : forall P Q R : Prop, (P -> Q) -> (Q -> R) -> P -> R *)

Definition ex_middle := forall P : Prop, P \/ ~P.
Definition pierce_law := forall P Q : Prop, ((P -> Q) -> P) -> P.
Definition pierce_law' := forall P : Prop, ((P -> False) -> P) -> P.

Theorem ex_middle_impl_pierce_law : ex_middle -> pierce_law'.
Proof.
  unfold ex_middle, pierce_law'. intros E P H.
  pose (E P) as Hp. destruct Hp as [Hp | Hnp]; try assumption.
  apply H. intro Hp. contradiction.
Qed.

Theorem pierce : pierce_law <-> pierce_law'.
Proof.
  unfold pierce_law, pierce_law'.
  split; intro L.
  - intro P. apply (L P False).
  - intros P Q H. apply L. intro Hnp.
    apply H. intro Hp.
    contradiction. (* apply Hnp in Hp. destruct Hp. *)
Qed.

Print pierce.
(* pierce = conj
   (fun (L : forall P Q : Prop, ((P -> Q) -> P) -> P) (P : Prop) => L P False)
   (fun (L : forall P : Prop, ((P -> False) -> P) -> P)
     (P Q : Prop) (H : (P -> Q) -> P) =>
       L P (fun Hnp : P -> False => H (fun Hp : P => False_ind Q (Hnp Hp))))
     : pierce_law <-> pierce_law' *)

Theorem pierce' : pierce_law' -> pierce_law.
Proof.
  unfold pierce_law, pierce_law'. intro L.
  intros P Q H. apply L. intro Hnp.
  apply H. intro Hp.
  apply Hnp in Hp. destruct Hp.
Qed.

Print pierce'.
(* pierce' =
   fun (L : forall P : Prop, ((P -> False) -> P) -> P)
     (P Q : Prop) (H : (P -> Q) -> P) =>
       L P (fun Hnp : P -> False =>
         H (fun Hp : P => let Hp0 : False := Hnp Hp
           in match Hp0 return Q with end))
   : pierce_law' -> pierce_law *)

Section Minimal_propositional_logic.
  Variables P Q R T : Prop.

  Theorem imp_trans : (P -> Q) -> (Q -> R) -> (P -> R).
  Proof using. intros H H' p. apply H', H, p. Qed.

  Print imp_trans.
  (* imp_trans = [fun (f g p) => g (f p)]
     fun (H : P -> Q) (H' : Q -> R) (p : P) => H' (H p)
     : forall P Q R : Prop, (P -> Q) -> (Q -> R) -> P -> R *)

  Theorem imp_trans' : (P -> Q) -> (Q -> R) -> (P -> R).
  Proof using. auto. Qed.

  Check Q. (* Q : Prop *)
  Check (P -> Q) -> (Q -> R) -> (P -> R).
  (*    (P -> Q) -> (Q -> R) -> P -> R : Prop *)

  Section example_of_assumption.
    Hypothesis H : P -> Q -> R.
    Lemma L1 : P -> Q -> R.
    Proof using H. assumption. Qed.
  End example_of_assumption.

  Theorem delta : (P -> P -> Q) -> P -> Q.
  Proof using. exact (fun f p => f p p). Qed.

  Theorem apply_example: (Q -> R -> T) -> (P -> Q) -> P -> R -> T.
  Proof using.
    intros H H0 p. apply H, H0, p.
  Qed.

  Theorem imp_dist : (P -> Q -> R) -> (P -> Q) -> P -> R.
  Proof using.
    intros H H' p. apply H.
    - exact p.
    - exact (H' p).
  Qed.

  Print imp_dist.
  (* imp_dist = [fun f g x => f x (g x)]
     fun (H : P -> Q -> R) (H' : P -> Q) (p : P) => H p (H' p)
     : (P -> Q -> R) -> (P -> Q) -> P -> R *)

  Theorem K : P -> Q -> P.
  Proof using. intros p q. assumption. Qed.

  Print K. (* K = [fun p q => p]
                  fun (p : P) (_ : Q) => p
                : P -> Q -> P *)

  Definition f : (nat -> bool) -> (nat -> bool) -> nat -> bool.
    intros f1 f2. assumption.
  Defined.

  Print f.
  (* f = [fun f1 f2 => f2]
       fun _ f2 : nat -> bool => f2
     : (nat -> bool) -> (nat -> bool) -> nat -> bool *)

  Eval compute in (f (fun n => true) (fun n => false) 45).
  (* = false : bool *)

  Opaque f.

  Eval compute in (f (fun n => true) (fun n => false) 45).
  (* = f (fun _ : nat => true) (fun _ : nat => false) 45 : bool *)

  Section proof_of_triple_impl.
    Hypothesis H : ((P -> Q) -> Q) -> Q.
    Hypothesis p : P.

    Lemma Rem: (P -> Q) -> Q.
    Proof using p.
      exact (fun H0 : P -> Q => H0 p).
    Qed.

    Theorem triple_impl : Q.
    Proof using H p. exact (H Rem). Qed.
  End proof_of_triple_impl.

  Print triple_impl.
  (* triple_impl = [fun H p => H (Rem p)]
     fun (H : ((P -> Q) -> Q) -> Q) (p : P) => H (Rem p)
     : (((P -> Q) -> Q) -> Q) -> P -> Q *)

  Print Rem.
  (* Rem = fun (p : P) (H0 : P -> Q) => H0 p
         : P -> (P -> Q) -> Q *)

  Theorem then_example : P -> Q -> (P -> Q -> R) -> R.
  Proof using.
    intros p q H.
    apply H; assumption.
  Qed.

  Theorem triple_impl_one_shot : (((P -> Q) -> Q) -> Q) -> P -> Q.
  Proof using.
    intros H p; apply H; intro H0; apply H0; assumption.
  Qed.

  Theorem compose_example : (P -> Q -> R) -> (P -> Q) -> P -> R.
  Proof using.
    intros H H' p.
    apply H; [exact p | exact (H' p)].
  Qed.

  Theorem compose_example' : (P -> Q -> R) -> (P -> Q) -> P -> R.
  Proof using.
    intros H H' p.
    apply H; try apply H'; assumption.
  Qed.

  Theorem orelse_example
    : (P -> Q) -> R -> ((P -> Q) -> R -> (T -> Q) -> T) -> T.
  Proof.
    intros H r H0. apply H0; (assumption || intro H1).
  Abort.

  Lemma L3 : (P -> Q) -> (P -> R) -> (P -> Q -> R -> T) -> P -> T.
  Proof using.
    intros H H0 H1 p.
    apply H1; [idtac | apply H | apply H0]; assumption.
  Qed.

  Theorem then_fail_example : (P -> Q) -> (P -> Q).
  Proof using.
    intro X; apply X; fail.
  Qed.

  Theorem then_fail_example2 : ((P -> P) -> (Q -> Q) -> R) -> R.
  Proof using.
    (* intro X; apply X; fail. *)
  Abort.

  Theorem try_example : (P -> Q -> R -> T) -> (P -> Q) -> (P -> R -> T).
  Proof using.
    intros H H' p r.
    apply H; try assumption. apply H', p.
  Qed.

  Theorem imp_dist' : (P -> Q -> R) -> (P -> Q) -> P -> R.
  Proof using.
    intros. apply H.
    - exact H1.
    - exact (H0 H1).
  Qed.

  Section section_for_cut_example.
    Hypotheses (H : P -> Q)
               (H0 : Q -> R)
               (H1 : (P -> R) -> T -> Q)
               (H2 : (P -> R) -> T).

    Theorem cut_example : Q.
    Proof using H H0 H1 H2.
      cut (P -> R).
      - intro H3. apply H1; [idtac | apply H2]; assumption.
      - intro Hp. apply H0, H, Hp.
    Qed.

    Print cut_example.
    (* cut_example =
       let H3 : P -> R := fun Hp : P => H0 (H Hp)
       in (fun H4 : P -> R => H1 H4 (H2 H4)) H3
       : Q *)

    Theorem cut_example' : Q.
    Proof using H H0 H1 H2.
      assert (P -> R) as H3.
      { intro Hp. apply H0, H, Hp. }
      apply H1; [idtac | apply H2]; assumption.
    Qed.

    Print cut_example'.
    (* cut_example' =
       let H3 : P -> R := fun Hp : P => H0 (H Hp)
       in H1 H3 (H2 H3)
       : Q *)

    Theorem cut_example0 : Q.
    Proof using H H0 H1 H2.
      apply H1.
      - intro Hp. apply H0, H, Hp.
      - apply H2.
        intro Hp. apply H0, H, Hp.
    Qed.

    Print cut_example0.
    (* cut_example0 =
       H1 (fun Hp : P => H0 (H Hp)) (H2 (fun Hp : P => H0 (H Hp)))
       : Q *)
  End section_for_cut_example.

  Theorem triple_impl' : (((P -> Q) -> Q) -> Q) -> P -> Q.
  Proof using. auto. Qed.

  Theorem auto1 : (P -> Q) -> P -> Q.
  Proof using. auto 0. auto 1. Qed.

  Print auto1.
  (* auto1 = fun H : P -> Q => H
           : (P -> Q) -> P -> Q *)

  Theorem auto2 : ((Q -> P) -> Q) -> P -> Q.
  Proof using. auto 1. auto 2. Qed.

  Print auto2.
  (* auto2 = fun (H : (Q -> P) -> Q) (H0 : P) => H (fun _ : Q => H0)
           : ((Q -> P) -> Q) -> P -> Q *)

  Theorem auto_t2 : P -> (P -> Q) -> Q.
  Proof using. auto 1. auto 2. Qed.

  Theorem auto3 : (((P -> Q) -> Q) -> Q) -> P -> Q.
  Proof using. auto 2. auto 3. Qed.

  Print auto3.
  (* auto3 = [fun H H0 => H (fun H1 => H1 H0)]
     fun (H : ((P -> Q) -> Q) -> Q) (H0 : P) => H (fun H1 : P -> Q => H1 H0)
     : (((P -> Q) -> Q) -> Q) -> P -> Q *)

  Theorem auto3' : ((((Q -> P) -> Q) -> Q) -> Q) -> P -> Q.
  Proof using. auto 2. auto 3. Qed.

  Print auto3'.
  (* auto3' = [fun H H0 => H (fun H1 => H1 (fun _ => H0))]
     fun (H : (((Q -> P) -> Q) -> Q) -> Q) (H0 : P)
         => H (fun H1 : (Q -> P) -> Q => H1 (fun _ : Q => H0))
     : ((((Q -> P) -> Q) -> Q) -> Q) -> P -> Q *)

  Theorem auto_t3 : P -> (P -> Q) -> (Q -> R) -> R.
  Proof using. auto 2. auto 3. Qed.

  Theorem auto4 : (((((P -> Q) -> Q) -> Q) -> Q) -> Q) -> P -> Q.
  Proof using. auto 3. auto 4. Qed.

  Theorem auto4' : ((((((Q -> P) -> Q) -> Q) -> Q) -> Q) -> Q) -> P -> Q.
  Proof using. auto 3. auto 4. Qed.

  Theorem auto_t4 : P -> (P -> Q) -> (Q -> R) -> (R -> T) -> T.
  Proof using. auto 3. auto 4. Qed.

  Theorem auto5 : (((((((P -> Q) -> Q) -> Q) -> Q) -> Q) -> Q) -> Q)
                  -> P -> Q.
  Proof using. auto 4. auto 5. Qed.

  Variables S U : Prop.

  Theorem auto_t5 : P -> (P -> Q) -> (Q -> R) -> (R -> T) -> (T -> S) -> S.
  Proof using. auto 4. auto 5. Qed.

  Theorem auto6 : (((((((((P -> Q) -> Q) -> Q) -> Q) -> Q)
                      -> Q) -> Q) -> Q) -> Q)
                  -> P -> Q.
  Proof using. auto 5. auto 6. Qed.

  Theorem auto_t6 : P -> (P -> Q) -> (Q -> R) -> (R -> T) -> (T -> S)
                    -> (S -> U) -> U.
  Proof using. auto 5. auto 6. Qed.
End Minimal_propositional_logic.

Print imp_dist.
(* imp_dist =
   fun (P Q R : Prop) (H : P -> Q -> R) (H' : P -> Q) (p : P) => H p (H' p)
   : forall P Q R : Prop, (P -> Q -> R) -> (P -> Q) -> P -> R *)

Section using_imp_dist.
  Variables (P1 P2 P3 : Prop).
  Check (imp_dist P1 P2 P3).
  (* imp_dist P1 P2 P3
     : (P1 -> P2 -> P3) -> (P1 -> P2) -> P1 -> P3 *)

  Check (imp_dist (P1 -> P2) (P2 -> P3) (P3 -> P1)).
  (* imp_dist (P1 -> P2) (P2 -> P3) (P3 -> P1)
     : ((P1 -> P2) -> (P2 -> P3) -> P3 -> P1) ->
       ((P1 -> P2) -> P2 -> P3) -> (P1 -> P2) -> P3 -> P1 *)
End using_imp_dist.


Unset Elimination Schemes.
Definition dec (X: Type) : Type := X + (X -> False).
Definition eqdec X := forall x y: X, dec (x = y).
Definition iffT (X Y: Type) : Type := (X -> Y) * (Y -> X).
Notation "X <=> Y" := (iffT X Y) (at level 95, no associativity).
Notation sig := sigT.
Notation Sig := existT.
Notation pi1 := projT1.
Notation pi2 := projT2.
Notation "'Sigma' x .. y , p" :=
  (sigT (fun x => .. (sigT (fun y => p)) ..))
    (at level 200, x binder, right associativity,
     format "'[' 'Sigma'  '/  ' x  ..  y ,  '/  ' p ']'")
    : type_scope.

(*** Numbers from first Principles *)

Module Demo.
  Inductive nat: Type := O | S (n: nat).

  Implicit Types (n x y: nat).

  Definition nat_elim (p: nat -> Type)
    : p O -> (forall n, p n -> p (S n)) -> forall n, p n
    := fun a f => fix F n := match n with O => a | S n' => f n' (F n') end.

  Fact S_O n:
      S n <> O.
  Proof.
    intros H.
    change (if S n then True else False).
    rewrite H. exact I.
  Qed.

  Fact S_injective n n' :
      S n = S n' -> n = n'.
  Proof.
    intros H.
    change (match S n with O => True | S n => n = n' end).
    rewrite H. auto.
  Qed.

  Goal forall n,
      S n <> n.
  Proof.
    refine (nat_elim _ _ _).
    - apply S_O.
    - intros n IH H. eapply IH, S_injective, H.
  Qed.
End Demo.

(* From now on we use the predefined numbers from the library *)

Implicit Types x y z n k : nat.

Fact nat_eqdec : eqdec nat.
Proof.
  hnf.
  induction x as [|x IH]; destruct y.
  - left. reflexivity.
  - right. intros [=].
  - right. intros [=].
  - destruct (IH y) as [H|H].
    + left. f_equal. exact H.
    + right. intros [= H1]. apply H, H1.
Defined.

Lemma add_assoc x y z :
  x + y + z = x + (y +z).
Proof.
  induction x as [|x IH]; cbn; congruence.
Qed.

Lemma addO x :
  x + 0 = x.
Proof.
  induction x as [|x IH]; cbn; congruence.
Qed.

Lemma addS x y :
  x + S y = S (x + y).
Proof.
  induction x as [|x IH]; cbn. reflexivity.
  rewrite IH. reflexivity.
Qed.

Lemma add_comm x y :
  x + y = y + x.
Proof.
  induction x as [|x IH]; cbn.
  - rewrite addO. reflexivity.
  - rewrite addS, IH. reflexivity.
Qed.

Lemma add_injective x y y' :
  x + y = x + y' -> y = y'.
Proof.
  induction x as [|x IH]; cbn.
  - auto.
  - intros [= H]. apply IH, H.
Qed.

Lemma add_injectiveO x y :
  x + y = x -> y = 0.
Proof.
  induction x as [|x IH]; cbn.
  - auto.
  - intros [= H]. auto.
Qed.

(*** Subtraction *)

Locate "-".
Arguments Nat.sub : simpl nomatch.

Fact sub_add_left x y :
  (x + y) - x = y.
Proof.
  induction x as [|x IH]; cbn.
  - destruct y; reflexivity.
  - exact IH.
Qed.

Fact sub_add_right x y :
  x - (x + y) = 0.
Proof.
  induction x as [|x IH]; cbn.
  - reflexivity.
  - exact IH.
Qed.

Fact sub_O_right x :
  x - 0 = x.
Proof.
  destruct x; reflexivity.
Qed.

Fact sub_xx x :
  x - x = 0.
Proof.
  induction x as [|x IH].
  - reflexivity.
  - exact IH.
Qed.

(*** Order *)

Notation "x <= y" := (x - y = 0) : nat_scope.
Notation "x < y" := (S x - y = 0) : nat_scope.
Notation "x >= y" := (y - x = 0) (only parsing) : nat_scope.
Notation "x > y" := (S y - x = 0) (only parsing) : nat_scope.
(* Negations ~(x < y) don't print correctly *)

(** Case analysis *)

Definition le_dec x y : dec ( x <= y).
Proof.
  apply nat_eqdec.
Defined.

Fact le_lt_dec x y :
  (x <= y) + (y < x).
Proof.
  induction x as [|x IH] in y |-*.
  - left. reflexivity.
  - destruct y.
    + right. reflexivity.
    + apply (IH y).
Defined.

Fact le_tricho x y :
  (x < y) + (x = y) + (y < x).
Proof.
  induction x as [|x IH] in y |-*; destruct y.
  - auto.
  - left. left. reflexivity.
  - right. reflexivity.
  - destruct (IH y) as [[H|H]|H].
    + left. left. exact H.
    + left. right. f_equal. exact H.
    + right. exact H.
Defined.

Fact le_lt_eq_dec x y :
  x <= y -> (x < y) + (x = y).
Proof.
  induction x as [|x IH] in y |-*; destruct y.
  - auto.
  - auto.
  - intros [=].
  - intros H. specialize (IH y H) as [IH|IH].
    + left. exact IH.
    + right. f_equal. exact IH.
Defined.

Fact le_contra x y :
  (y < x -> False) -> x <= y.
Proof.
  destruct (le_lt_dec x y) as [H|H].
  - intros _. exact H.
  - intros H1. exfalso.  apply H1, H.
Qed.

(** Existential characterization *)

Fact le_eq_sub x y :
  x <= y -> x + (y - x) = y.
Proof.
  induction x as [|x IH] in y |-*; cbn.
  - intros _. apply sub_O_right.
  - destruct y; cbn.
    + intros [=].
    + intros H%IH. f_equal. apply H.
Qed.

Fact le_ex x y :
  x <= y <-> exists k, x + k = y.
Proof.
  split.
  - intros H. exists (y - x). apply le_eq_sub, H.
  - intros [k <-]. apply sub_add_right.
Qed.

(** Order properties *)

Fact le_add x y :
  x <= x + y.
Proof.
  apply sub_add_right.
Qed.

Fact le_S x :
  x <= S x.
Proof.
  replace (S x) with (x + 1).
  - apply le_add.
  - rewrite addS, addO. reflexivity.
Qed.

Fact le_add_O x y :
  x + y <= x -> y = 0.
Proof.
  rewrite sub_add_left. easy.
Qed.

Fact le_eq_O x :
  x <= 0 -> x = 0.
Proof.
  destruct x. auto. intros [=].
Qed.

Fact le_refl x :
  x <= x.
Proof.
  apply sub_xx.
Qed.

Fact le_trans x y z:
  x <= y -> y <= z -> x <= z.
Proof.
  intros [a <-]%le_ex [b <-]%le_ex.
  rewrite add_assoc. rewrite sub_add_right. reflexivity.
Qed.

Fact le_anti x y :
  x <= y -> y <= x -> x = y.
Proof.
  intros [a <-]%le_ex.
  rewrite sub_add_left.
  intros ->. symmetry. apply addO.
Qed.

Fact le_trans_lt_le x y z :
  x < y -> y <= z -> x < z.
Proof.
  intros [a <-]%le_ex [b <-]%le_ex.
  cbn. rewrite add_assoc. apply le_add.
Qed.

Fact le_strict_O x :
  (x < 0) -> False.
Proof.
  cbv. intros [=].
Qed.

Fact le_strict_add x y :
  (x + y < x) -> False.
Proof.
  rewrite <-addS. rewrite sub_add_left. intros [=].
Qed.

Fact le_strict x :
  (x < x) -> False.
Proof.
  pattern x at 1. rewrite <-(addO x). apply le_strict_add.
Qed.

Fact le_add_right x y z :
  x <= y -> x <= y + z.
Proof.
  intros [a <-]%le_ex. rewrite add_assoc. apply le_add.
Qed.

Fact le_add_S x y :
  x <= y -> x <= S y.
Proof.
  replace (S y) with (y + 1).
  - apply le_add_right.
  - rewrite addS, addO. reflexivity.
Qed.

Fact lt_le x y :
  x < y -> x <= y.
Proof.
  destruct y.
  - intros [=].
  - cbn. apply le_add_S.
Qed.

Fact lt_eq_le x y :
   (x < y) \/ (x = y) -> x <= y.
Proof.
  intros [H|<-].
  + apply lt_le, H.
  + apply le_refl.
Qed.

Fact le_contra_eq x y :
  (x < y -> False) -> (y < x -> False) -> x = y.
Proof.
  intros H1%le_contra H2%le_contra.
  eapply le_anti; eassumption.
Qed.

Lemma bounded_forall_dec (p: nat -> Prop) k:
  (forall x, dec (p x)) -> dec (forall x, x < k -> p x).
Proof.
  intros H.
  induction k as [|k IH].
  - left. intros x [=].
  - destruct (H k) as [H1|H1].
    + destruct IH as [IH|IH]; cbn.
      * left. intros x H2.
        apply le_lt_eq_dec in H2 as [H2| ->]; auto.
      * right. contradict IH. intros x H2. apply IH, lt_le, H2.
    + right. contradict H1. apply H1, le_refl.
Qed.

Fact le_sub x y :
  x - y <= x.
Proof.
  induction x as [|x IH] in y |-*.
  - reflexivity.
  - destruct y; cbn.
    + apply sub_xx.
    + eapply le_trans.
      * apply IH.
      * apply le_S.
Qed.

(*** Complete Induction  *)

Definition nat_compl_ind (p: nat -> Type) :
  (forall x, (forall y, y < x -> p y) -> p x) -> forall x, p x.
Proof.
  intros H x. apply H.
  induction x as [|x IH]; intros y H1.
  - exfalso. cbn in H1. discriminate H1.
  - apply H. intros z H2. apply IH.
    eapply le_trans_lt_le. exact H2. exact H1.
Defined.

(*** Euclidean Division *)

Definition delta x y a b := x = a * S y + b /\ b <= y.

Fact delta1 y :
  delta 0 y 0 0.
Proof.
  unfold delta. cbn. easy.
Qed.

Fact delta2 x y a b :
  delta x y a b -> b = y -> delta (S x) y (S a) 0.
Proof.
  unfold delta. intros [-> H] ->. cbn. split.
  - f_equal. rewrite addO. apply add_comm.
  - reflexivity.
Qed.

Fact delta3 x y a b :
  delta x y a b -> b <> y -> delta (S x) y a (S b).
Proof.
  unfold delta. intros [-> H] H1. cbn. split.
  - symmetry. apply addS.
  - apply le_lt_eq_dec in H as [H| ->].
    + exact H.
    + easy.
Qed.

Fact delta_total :
  forall x y, Sigma a b, delta x y a b.
Proof.
  intros x y.
  induction x as [|x (a&b&IH)].
  - exists 0, 0. apply delta1.
  - destruct (nat_eqdec b y) as [->|H].
    + exists (S a), 0. eapply delta2. exact IH. reflexivity.
    + exists a, (S b). apply delta3; assumption.
Defined.

Definition D x y := pi1 (delta_total x y).
Definition M x y := pi1 (pi2 (delta_total x y)).

Compute D 103 3.
Compute M 103 3.

Fact delta_DM x y :
  delta x y (D x y) (M x y).
Proof.
  exact (pi2 (pi2 (delta_total x y))).
Qed.

Fixpoint Delta x y : nat * nat :=
  match x with
  | 0 => (0,0)
  | S x' => let (a,b) := Delta x' y in
           if nat_eqdec b y then (S a, 0) else (a, S b)
  end.

Fact Delta_correct x y :
  delta x y (fst (Delta x y)) (snd (Delta x y)).
Proof.
  induction x as [|x IH].
  - apply delta1.
  - unfold delta. cbn.
    destruct (Delta x y) as [a b]. cbn in IH.
    destruct nat_eqdec as [->|H]; cbn [fst snd].
    + eapply delta2. exact IH. reflexivity.
    + eapply delta3. exact IH.  exact H.
Qed.

Fact delta_unique x y a b a' b' :
  delta x y a b  -> delta x y a' b' -> a = a' /\ b = b'.
Proof.
  intros [-> H1] [H3 H2].
  revert a a' H3.
  induction a as [|a IH]; destruct a'; cbn.
  - easy.
  - intros ->. exfalso. clear H2. revert H1.
    rewrite add_assoc. apply le_strict_add.
  - intros <-. exfalso. clear H1 IH. revert H2.
    rewrite add_assoc. apply le_strict_add.
  - intros [= H3]. rewrite !add_assoc in H3.
    apply add_injective, IH in H3 as [<- <-].
    easy.
Qed.

Fact delta4 x y:
  x <= y -> delta x y 0 x.
Proof.
  unfold delta. cbn. easy.
Qed.

Fact delta5 x y a b:
  delta (x - S y) y a b -> x > y -> delta x y (S a) b.
Proof.
  unfold delta. cbn [Nat.mul]. rewrite add_assoc. intros [<- H1] H2.
  split. 2:exact H1.
  symmetry. apply (le_eq_sub (S y) x), H2.
Qed.

Goal forall x y,
    (D x y = if le_lt_dec x y then 0 else S (D (x - S y) y)) /\
    (M x y = if le_lt_dec x y then x else M (x - S y) y).
Proof.
  intros x y.
  apply (delta_unique x y).
  - apply delta_DM.
  - destruct (le_lt_dec x y) as [H|H].
    + apply delta4, H.
    + apply delta5.
      * apply delta_DM.
      * exact H.
Qed.

(*** Lia Demo *)

(* The automation tactic lia provides an abstract treatment
   of numbers that frees  us from knowing the basic definitions
   and the basic lemmas. We shall use it from now on. *)

(* Note that our definition of order via subtraction is still active.
   All examples with lia will also work with Coq's definition of order *)

From Coq Require Import Lia.

Goal forall x y, x <= y -> y <= x -> x = y.
Proof.
  lia.
Qed.

Goal forall x y, ~ x < y -> ~ y < x -> x = y.
Proof.
  lia.
Qed.

Goal forall x y, x <= y -> x + (y - x) = y.
Proof.
  lia.
Qed.

Goal forall x y, x + y <= x -> y = 0.
Proof.
  lia.
Qed.

  Goal forall x y, x < y \/ x = y \/ y < x.
Proof.
  lia.
Qed.

Locate "<=".

(* lia cannot do sums *)
Goal forall x y, (x <= y) + (y < x).
Proof.
  intros x y.
  Fail lia.
  destruct (x-y) as [|z] eqn:E.
  - left. lia.
  - right. lia.
Qed.

Goal forall x y, x <= y <-> exists z, x + z = y.
Proof.
  split.
  - intros H. exists (y-x). lia.
  - intros [z H]. lia.
Qed.