Require Import Braun.common.log Braun.common.le_util.
Require Import Arith Coq.Arith.Mult Arith.Even Arith.Div2 Omega.

(* big_oh and big_omega definitions based on _Introduction to           *)
(* Algorithms_, 3rd Edition by Thomas H. Cormen, Charles E. Leiserson,  *)
(* Ronald L. Rivest, Clifford Stein                                     *)
(*                                                                      *)
(* but more restrictive in the big_oh case, since we allow only         *)
(* natural number constants. In the big_omega case we effectively       *)
(* allow rational number 'c's, but do it by asking for an explicit      *)
(* numerator and denominator and then multiplying through by the        *)
(* denominator to avoid needing to use rational numbers.                *)

Definition big_oh f g :=
  exists n0 c,
    forall n,
      n0 <= n ->
      f(n) <= c * g(n).

Definition big_O2 f g :=
  exists l c,
    forall n m,
      l <= n -> l <= m ->
      f n m <= c * g n m.

Definition big_omega f g :=
  exists n0 c_num c_den,
    c_num > 0 /\
    forall n,
      n >= n0 ->
      c_num * g(n) <= c_den * f(n).

Definition big_theta f g :=
  big_oh f g /\ big_omega f g.

Lemma big_oh_rev :
  forall f g,
    big_oh g f ->
    big_omega f g.
Proof.
  intros f g [n0 [m BIGOH_IMP]].
  exists n0.
  exists 1.
  exists m.
  split. auto.
  intros n LT.
  remember (BIGOH_IMP n LT) as LT2; clear HeqLT2.
  clear LT BIGOH_IMP n0.
  rewrite mult_1_l.
  auto.
Qed.

Lemma big_oh_trans :
  forall f g h,
    big_oh f g ->
    big_oh g h ->
    big_oh f h.
Proof.
  intros f g h [FGn [FGm FGP]] [GHn [GHm GHP]].
  exists (FGn+GHn).
  exists (FGm*GHm).
  intros n LE.
  apply (le_trans (f n)
                  (FGm * g n)
                  (FGm * GHm * h n)).
  apply FGP.
  omega.
  rewrite <- mult_assoc.
  apply le_mult_right.
  apply GHP.
  omega.
Qed.

Lemma big_O2_trans :
  forall f g h,
    big_O2 f g ->
    big_O2 g h ->
    big_O2 f h.
Proof.
  intros f g h [FGn [FGm FGP]] [GHn [GHm GHP]].
  exists (FGn+GHn).
  exists (FGm*GHm).
  intros n m LEn LEm.
  apply (le_trans (f n m)
                  (FGm * g n m)
                  (FGm * GHm * h n m)).
  apply FGP.
  omega.
  omega.
  rewrite <- mult_assoc.
  apply le_mult_right.
  apply GHP.
  omega.
  omega.
Qed.

Lemma big_oh_k_1: forall k, 1 <= k -> big_oh (fun n => 1) (fun n => k).
Proof.
  intros k LE.
  unfold big_oh.
  exists 0.
  exists 1.
  intros n.
  omega.
Qed.

Lemma big_omega_k_1: forall k, 1 <= k -> big_omega (fun n => 1) (fun n => k).
Proof.
  intros k LE.
  unfold big_omega.
  exists 0.
  exists 1.
  exists k.
  split. auto.
  intros n.
  omega.
Qed.

Lemma big_theta_k_1: forall k, 1 <= k -> big_theta (fun n => 1) (fun n => k).
Proof.
  intros k LE. split.
  apply big_oh_k_1. auto.
  apply big_omega_k_1. auto.
Qed.

Lemma big_oh_fl_log_plus_1 : big_oh (fun n => (fl_log n + 1)) fl_log.
Proof.
  exists 1.
  exists 2.
  intros n LE.
  destruct n; intuition.
  destruct n; intuition.
  rewrite <- fl_log_div2.
  omega.
Qed.

Lemma big_oh_nlogn_plus_n__nlogn :
  big_oh (fun n : nat => n * fl_log n + n) (fun n : nat => n * fl_log n).
Proof.
  exists 2.
  exists 2.
  intros n L.
  destruct n; intuition.
  destruct n; intuition.
  clear L.
  replace 2 with (1+1); try omega.
  rewrite mult_plus_distr_r.
  unfold mult; fold mult.
  rewrite plus_0_r.

  assert (1 <= fl_log (S (S n))).
  induction n.
  rewrite fl_log_div2'.
  omega.
  apply (le_trans 1 (fl_log (S (S n))) (fl_log (S (S (S n))))); auto.
  apply fl_log_monotone_Sn.

  apply le_plus_right.
  apply (le_trans (S (S n))
                  (1 + 1 + n * fl_log (S (S n)))
                  (fl_log (S (S n)) + (fl_log (S (S n)) + n * fl_log (S (S n))))); try omega.
  apply (le_trans (S (S n))
                  (1 + 1 + n * 1)
                  (1 + 1 + n * fl_log (S (S n)))); try omega.
  rewrite mult_comm.
  apply le_plus_right.
  rewrite mult_comm at 1.
  apply le_mult_right.
  assumption.
Qed.

Lemma big_oh_k___nlogn :
 forall k, big_oh (fun _ => k) (fun n => n * cl_log n).
Proof.
  intros k.
  exists k.
  exists 1.
  intros n LT.
  rewrite mult_1_l.
  apply (le_trans k n); auto.
  clear k LT.
  destruct n.
  omega.
  replace (S n) with (S n * 1) at 1;[|omega].
  apply mult_le_compat; auto.
  induction n.
  unfold_sub cl_log (cl_log 1).
  omega.
  apply (le_trans 1 (cl_log (S n))); auto.
  apply cl_log_monotone.
  omega.
Qed.

Lemma big_oh_mult :
  forall f g h,
    big_oh f g ->
    big_oh (fun x => (h x) * (f x)) (fun x => (h x) * (g x)).
Proof.
  intros f g n [n0 [m FG]].
  exists n0.
  exists m.
  intros n1 LT.
  apply FG in LT.
  rewrite mult_assoc.
  replace (m * n n1) with (n n1 * m); try (apply mult_comm).
  rewrite <- mult_assoc.
  apply le_mult_right.
  assumption.
Qed.
Hint Resolve big_oh_mult.

Lemma big_O2_mult :
  forall f g h,
    big_O2 f g ->
    big_O2 (fun n m => (h n m) * (f n m)) (fun n m => (h n m) * (g n m)).
Proof.
  intros f g h [k [l FG]].
  exists k.
  exists l.
  intros n1 m1 LTN LTM.
  apply FG with (n:=n1)(m:=m1) in LTN; auto.
  rewrite mult_assoc.
  replace (l* h n1 m1) with (h n1 m1 * l); try (apply mult_comm).
  rewrite <- mult_assoc.
  apply le_mult_right.
  auto.
Qed.

Lemma big_oh_plus :
  forall f g h,
    big_oh f h -> big_oh g h -> big_oh (fun n => f n + g n) h.
Proof.
  intros f g h FG GH.
  destruct FG as [FGn [FGm FG]].
  destruct GH as [GHn [GHm GH]].
  exists (FGn + GHn).
  exists (FGm + GHm).
  intros n LT.
  apply (le_trans (f n + g n)
                  ((FGm * h n) + g n)
                  ((FGm + GHm) * h n)).
  apply le_plus_left.
  apply FG; omega.
  rewrite mult_plus_distr_r.
  apply le_plus_right.
  apply GH; omega.
Qed.
Hint Resolve big_oh_plus.

Lemma big_oh_plus_rev :
  forall f g h,
    big_oh h f -> big_oh h g -> big_oh h (fun n => f n + g n).
Proof.
  intros f g h HF HG.
  destruct HF as [HFn [HFm HF]].
  destruct HG as [HGn [HGm HG]].
  exists (HFn + HGn).
  exists ((S HFm) * (S HGm)).
  intros n LT.
  repeat (rewrite mult_plus_distr_l).
  assert (h n <= HFm * f n) as LTONE;[apply HF;omega|clear HF].
  assert (h n <= HGm * g n) as LTTWO;[apply HG;omega|clear HG].
  clear LT.
  apply (le_trans (h n) (HFm * f n)); auto.
  replace (S HFm) with (HFm + 1);[|omega].
  rewrite mult_plus_distr_r.
  rewrite mult_plus_distr_r.
  apply le_plus_trans.
  apply le_plus_trans.
  clear LTONE LTTWO.
  induction HGm.
  rewrite mult_1_r.
  auto.
  apply (le_trans (HFm * f n) (HFm * S HGm * f n)).
  auto.
  apply mult_le_compat; auto.
  apply mult_le_compat; auto.
Qed.

Lemma big_oh_k_linear : forall k, big_oh (fun n => k) (fun n => n).
Proof.
  intros k.
  exists k.
  exists 1.
  intros; omega.
Qed.
Hint Resolve big_oh_k_linear.

Lemma big_oh_n_nlogn:
  big_oh (fun n : nat => n) (fun n : nat => n * cl_log n).
Proof.
  exists 0.
  exists 1.
  intros n _.
  replace (1 * (n * cl_log n)) with (n * cl_log n); [|omega].
  induction n;[omega|].
  apply le_n_S in IHn.
  replace (S n) with (n+1) at 2; [|omega].
  rewrite mult_plus_distr_r.
  apply (le_trans (S n) (S (n * cl_log n))); [omega|].
  clear IHn.
  replace (S (n * cl_log n)) with ((n * cl_log n)+1);[|omega].
  apply plus_le_compat.
  apply mult_le_compat;[omega|].
  apply cl_log_monotone; omega.
  rewrite cl_log_div2'.
  omega.
Qed.

Lemma big_oh_add_k_linear : forall k, big_oh (fun n => n + k) (fun n => n).
Proof.
  intros k.
  exists 1.
  exists (S k).
  intros.
  destruct n; intuition.
  replace (S k) with (k + 1); [|omega].
  rewrite mult_plus_distr_r.
  replace (k * S n) with (k * (n + 1)).
  rewrite mult_plus_distr_l.
  replace (k*1) with k;[|omega].
  replace (1*S n) with (S n);[|omega].
  apply (le_trans (S n + k)
                  (0 + k + S n)
                  (k*n + k + S n)).
  omega.
  apply le_plus_left.
  apply le_plus_left.
  apply le_0_n.
  replace (n + 1) with (S n); [|omega].
  omega.
Qed.
Hint Resolve big_oh_add_k_linear.

Lemma big_oh_mult_k_right_linear : forall k, big_oh (fun n => n*k) (fun n => n).
Proof.
  intros.
  exists 0.
  exists k.
  intros.
  rewrite mult_comm.
  omega.
Qed.
Hint Resolve big_oh_mult_k_right_linear.

Lemma big_oh_mult_k_left_linear : forall k, big_oh (fun n => k*n) (fun n => n).
Proof.
  intros.
  exists 1.
  exists k.
  intros; omega.
Qed.
Hint Resolve big_oh_mult_k_left_linear.

Lemma big_oh_add_k:
  forall f g k,
    (forall n, 0 < g n) ->
    big_oh f g ->
    big_oh (fun n => f n + k) g.
Proof.
  intros f g k Gpos FG.
  destruct FG as [N [M FG]].
  eexists. exists (M + k).
  intros n LE.
  apply FG in LE.
  rewrite mult_plus_distr_r.
  apply le_add. auto.
  assert (0 < g n) as Gpos'. auto.
  destruct (g n) as [|gn].
  omega.
  rewrite mult_comm. simpl.
  replace k with (k + 0); try omega.
  apply le_add. omega.
  apply le_0_n.
Qed.

Lemma big_oh_add_k_both:
  forall f g k,
    big_oh f g ->
    big_oh (fun n => f n + k) (fun n => g n + k).
Proof.
  intros f g k FG.
  destruct FG as [N [M FG]].
  exists N. exists (S M).
  intros n LE.
  apply FG in LE.
  rewrite mult_plus_distr_l.
  apply le_add. simpl. omega.
  clear FG LE f g N n.
  simpl.
  replace k with (k + 0); try omega.
  apply le_add. omega.
  apply le_0_n.
Qed.

Lemma big_theta_mult_plus:
  forall x y,
    big_theta (fun n : nat => (S x) * n + y) (fun n : nat => n).
Proof.
  unfold big_theta. split.
  unfold big_oh.
  exists y. exists (S (S x)).
  intros n LE.
  simpl. omega.

  apply big_oh_rev.
  exists 0. exists 1.
  intros n LE. simpl.
  replace n with (n + 0); try omega.
  replace (n + 0 + x * (n + 0) + y + 0) with
    (n + (0 + x * (n + 0) + y + 0)); try omega.
  apply le_add. auto.
  apply le_0_n.
Qed.

Lemma big_oh_eq:
  forall f g,
    (forall n, f n = g n) ->
    big_oh f g.
Proof.
  intros f g EQ.
  exists 0. exists 1.
  intros n LE. rewrite EQ. omega.
Qed.

Lemma big_theta_eq:
  forall f g,
    (forall n, f n = g n) ->
    big_theta f g.
Proof.
  intros f g EQ.
  split. apply big_oh_eq. auto.
  apply big_oh_rev. apply big_oh_eq. auto.
Qed.

Lemma big_omega_rev :
  forall f g,
    big_omega g f ->
    big_oh f g.
Proof.
  intros f g [n0 [m1 [m2 [GT BIGOM_IMP]]]].
  exists n0.
  exists m2.
  intros n LT.
  remember (BIGOM_IMP n LT) as LT2; clear HeqLT2.
  clear LT BIGOM_IMP n0.
  eapply le_trans; [| apply LT2 ].
  destruct m1 as [|m1]. omega.
  rewrite mult_succ_l.
  apply le_plus_r.
Qed.

Lemma big_theta_trans :
  forall f g h,
    big_theta f g ->
    big_theta g h ->
    big_theta f h.
Proof.
  intros f g h [Ofg Tfg] [Ogh Tgh].
  split. eapply big_oh_trans. apply Ofg. auto.
  apply big_oh_rev. eapply big_oh_trans.
  apply big_omega_rev. apply Tgh.
  apply big_omega_rev. apply Tfg.
Qed.

(* because TT'FACT is hard to establish, this seems useless *)
Lemma recurrence_that_sums :
  forall k k' f f' T T',
    (forall n, T 0 n = k) ->
    (forall n, T' 0 n = k') ->
    (forall fuel n, T (S fuel) n = f n + T fuel (n+1) + 1) ->
    (forall fuel n, T' (S fuel) n = f' n + T' fuel (n+1) + 1) ->
    k <= k' ->
    big_oh f f' ->
    (forall fuel n k,  T fuel n <= (S k) * T' fuel n ->
                       T fuel (n+1) <= (S k) * (T' fuel (n+1))) ->
    exists n,
      forall n',
        n <= n' ->
        big_oh (fun fuel => T fuel n') (fun fuel => T' fuel n').
Proof.
  intros k k' f f' T T' T0 T'0 TR TR' LTkk' [fn0 [fc FF']] TT'FACT.
  destruct fc.
  exists fn0. intros n' NN'. exists 0. exists 1.
  intros fuel _.
  rewrite mult_1_l.
  induction fuel.
  rewrite T0.
  rewrite T'0.
  omega.

  rewrite TR.
  rewrite TR'.
  repeat (apply plus_le_compat); auto.

  assert (f n' <= 0);[|omega].
  replace 0 with (0 * f' n');[|omega].
  apply FF'.
  omega.

  replace (T' fuel (n' + 1)) with (1*(T' fuel (n' + 1)));[|omega].
  apply TT'FACT;omega.

  exists fn0.
  intros n' NN'. exists 0. exists (1+fc).
  intros fuel _.
  induction fuel.
  rewrite T0.
  rewrite T'0.
  rewrite mult_plus_distr_r.
  apply le_plus_trans.
  omega.

  rewrite TR.
  rewrite TR'.
  repeat (rewrite mult_plus_distr_l).
  repeat (apply plus_le_compat); auto.
  omega.
Qed.

Lemma recurrence_that_sums' :
  forall k k' f f' T T',
    (forall n, T 0 n = k) ->
    (forall n, T' 0 n = k') ->
    (forall fuel n, T (S fuel) n = f n + T fuel n) ->
    (forall fuel n, T' (S fuel) n = f' n + T' fuel n) ->
    k <= k' ->
    big_oh f f' ->
    exists n,
      forall n',
        n <= n' ->
        big_oh (fun fuel => T fuel n') (fun fuel => T' fuel n').
Proof.
  intros k k' f f' T T' T0 T'0 TR TR' LTkk' [fn0 [fc FF']].
  destruct fc.
  exists fn0. intros n' NN'. exists 0. exists 1.
  intros fuel _.
  rewrite mult_1_l.
  induction fuel.
  rewrite T0.
  rewrite T'0.
  omega.

  rewrite TR.
  rewrite TR'.
  apply plus_le_compat; auto.
  assert (f n' <= 0);[|omega].
  replace 0 with (0 * f' n');[|omega].
  apply FF'.
  omega.

  exists fn0.
  intros n' NN'. exists 0. exists (1+fc).
  intros fuel _.
  induction fuel.
  rewrite T0.
  rewrite T'0.
  rewrite mult_plus_distr_r.
  apply le_plus_trans.
  omega.

  rewrite TR.
  rewrite TR'.
  rewrite mult_plus_distr_l.
  apply plus_le_compat; auto.
Qed.

Theorem cl_log_O_fl_log : big_oh cl_log fl_log.
Proof.
  exists 2.
  exists 2.
  intros.
  destruct n.
  intuition.
  rewrite <- fl_log_cl_log_relationship.
  replace (S (fl_log n)) with (fl_log n + 1);[|omega].
  replace (2*(fl_log (S n))) with (fl_log (S n) + fl_log (S n));[|omega].
  apply plus_le_compat.
  apply fl_log_monotone.
  auto.
  replace 1 with (fl_log 1).
  apply fl_log_monotone.
  omega.
  compute.
  auto.
Qed.


Require Import Arith List String.

(* Simple functional language *)
Inductive term :=
  | Var: string -> term
  | Nat : nat -> term
  | Plus : term -> term -> term
  | IfZero: term -> term -> term -> term
.

Definition Env := list (string * nat).

Axiom string_eq : string -> string -> bool.
Hypothesis string_eq_spec: forall s t, string_eq s t = true <-> s = t.

Fixpoint mem {T: Type} (env: list (string * T)) (key: string) : option T :=
    match env with
    | nil => None
    | (id, val) :: tl =>
        if string_eq key id then Some val else mem tl key
    end.

Fixpoint eval (env: Env) t : option nat :=
 match t with
 | Var x => mem env x
 | Nat n => Some n
 | Plus a b =>
     match (eval env a, eval env b) with
     | (Some u, Some v) => Some (u + v)
     | _ => None
     end
 | IfZero test then_branch else_branch =>
     match eval env test with
     | Some 0 => eval env then_branch
     | Some _ => eval env else_branch
     | None => None
     end
end.

Inductive ok : Env -> term -> Prop :=
 | okVar: forall env x, mem env x <> None -> ok env (Var x)
 | okNat: forall env n, ok env (Nat n)
 | okPlus: forall env a b, ok env a ->
         ok env b ->
         ok env (Plus a b)
 | okIfZero: forall env test then_branch else_branch,
         ok env test ->
         ok env then_branch ->
         ok env else_branch ->
         ok env (IfZero test then_branch else_branch)
.

Hint Constructors ok.

Lemma wf: forall env t, ok env t ->
    exists v, eval env t = Some v.
Proof.
induction 1 as [ env x hmem | env n | env a b ha [va hia] hb [vb hib] |
        env t l r ht [vt hit] hl [vl hil] hr [vr hir]]; simpl in *.
- now destruct (mem env x) as [ v | ]; [exists v | elim hmem].
- now exists n.
- rewrite hia, hib.
  now exists (va + vb).
- rewrite hit.
  now destruct vt; [rewrite hil; exists vl | rewrite hir; exists vr].
Qed.


Require Iso.
Require Fin.

Set Asymmetric Patterns.

(** A type family which is isomorphic to Fin.t, but defined in
    terms of simpler types by recursion, and is a little bit
    easier to work with. *)
Fixpoint Fin (n : nat) : Set := match n with
  | 0 => Empty_set
  | S n' => (unit + Fin n')%type
  end.

(** Fin and Fin.t are isomorphic for every size. *)
Theorem finIso (n : nat) : Iso.T (Fin.t n) (Fin n).
Proof.
induction n.
- eapply Iso.Build_T.
  intros a. inversion a.
  intros b. inversion b.
-
refine (
{| Iso.to := fun x => (match x in Fin.t n'
  return (S n = n') -> Fin (S n) with
   | Fin.F1 _ => fun _ => inl tt
   | Fin.FS n' x' => fun pf => inr (Iso.to IHn (eq_rect n' Fin.t x' _ (eq_sym (eq_add_S _ _ pf))))
   end) eq_refl
 ; Iso.from := fun x => match x with
   | inl tt => Fin.F1
   | inr x' => Fin.FS (Iso.from IHn x')
   end
|}).
intros a.
Require Import Program.
dependent destruction a; simpl.
reflexivity. rewrite Iso.from_to. reflexivity.
intros b. destruct b. destruct u. reflexivity.
  simpl. rewrite Iso.to_from. reflexivity.
Grab Existential Variables.
intros bot. contradiction.
intros f0. inversion f0.
Defined.

Lemma botNull (A : Type) : Iso.T A (A + Empty_set).
Proof.
refine (
{| Iso.to   := inl
 ; Iso.from := fun x => match x with
    | inl x' => x'
    | inr bot => Empty_set_rect (fun _ => A) bot
   end
|}).
reflexivity.
intros b. destruct b. reflexivity. contradiction.
Qed.

Fixpoint split (m : nat)
  : forall (n : nat), Fin.t (m + n) -> (Fin.t m + Fin.t n).
refine (
  match m return (forall (n : nat), Fin.t (m + n) -> (Fin.t m + Fin.t n)) with
  | 0 => fun _ => inr
  | S m' => fun n x => (match x as x0 in Fin.t k
    return forall (pf : k = (S m' + n)), (Fin.t (S m') + Fin.t n) with
    | Fin.F1 _ => fun pf => inl Fin.F1
    | Fin.FS n' x' => fun pf => _
    end) eq_refl
  end).
simpl in pf.
apply eq_add_S in pf.
rewrite pf in x'.
refine (match split m' n x' with
  | inl a => inl (Fin.FS a)
  | inr b => inr b
  end).
Defined.

Lemma splitL : forall {m n : nat} {x : Fin.t m},
  split m n (Fin.L n x) = inl x.
Proof.
intros m. induction m; intros n x.
- inversion x.
- dependent destruction x; simpl.
  + reflexivity.
  + rewrite (IHm n x). reflexivity.
Qed.

Lemma splitR : forall {m n : nat} {x : Fin.t n},
  split m n (Fin.R m x) = inr x.
Proof.
intros m. induction m; intros n x; simpl.
- reflexivity.
- rewrite (IHm n x). reflexivity.
Qed.

Lemma splitInj : forall {m n : nat} {x y : Fin.t (m + n)},
  split m n x = split m n y -> x = y.
Proof.
intros m; induction m; intros n x y Heq.
- inversion Heq. reflexivity.
- dependent destruction x; dependent destruction y.
  + reflexivity.
  + simpl in Heq. destruct (split m n y); inversion Heq.
  + simpl in Heq. destruct (split m n x); inversion Heq.
  + apply f_equal. simpl in Heq. apply IHm.
    destruct (split m n x) eqn:sx;
    destruct (split m n y) eqn:sy.
    apply f_equal.
    assert (forall (A B : Type) (x y : A), @inl A B x = @inl A B y -> x = y).
    intros A B x0 y0 Heqn. inversion Heqn. reflexivity.
    apply H in Heq. apply Fin.FS_inj in Heq. assumption.
    inversion Heq. inversion Heq. apply f_equal. injection Heq. trivial.
Qed.

Fixpoint splitMult (m : nat)
  : forall (n : nat), Fin.t (m * n) -> (Fin.t m * Fin.t n)
  := match m return (forall (n : nat), Fin.t (m * n) -> (Fin.t m * Fin.t n)) with
  | 0 => fun _ => Fin.case0 _
  | S m' => fun n x => match split n (m' * n) x with
    | inl a => (Fin.F1, a)
    | inr b => match splitMult m' n b with
      | (x, y) => (Fin.FS x, y)
      end
    end
  end.

Lemma finPlus : forall {m n : nat},
  Iso.T (Fin.t m + Fin.t n) (Fin.t (m + n)).
Proof.
intros m n.
refine (
{| Iso.to := fun x => match x with
   | inl a => Fin.L n a
   | inr b => Fin.R m b
   end
 ; Iso.from := split m n
|}).
intros. destruct a; simpl. induction m; simpl.
- inversion t.
Require Import Program.
- dependent destruction t; simpl.
  + reflexivity.
  + rewrite IHm. reflexivity.
- induction m; simpl. reflexivity. rewrite IHm. reflexivity.
- induction m; intros; simpl.
  + reflexivity.
  + dependent destruction b; simpl. reflexivity.
     pose proof (IHm b).
     destruct (split m n b) eqn:seqn;
     simpl; rewrite H; reflexivity.
Qed.

Lemma finMult : forall {m n : nat},
  Iso.T (Fin.t m * Fin.t n) (Fin.t (m * n)).
Proof.
intros m n.
refine (
{| Iso.to := fun x => match x with (a, b) => Fin.depair a b end
 ; Iso.from := splitMult m n
|}).
intros p. destruct p.
induction m; simpl.
- inversion t.
- dependent destruction t; simpl.
  + rewrite splitL. reflexivity.
  + rewrite splitR. rewrite (IHm t). reflexivity.

- induction m; intros b; simpl.
  + inversion b.
  + destruct (split n (m * n) b) eqn:seqn.
    * simpl. rewrite <- splitL in seqn.
      apply splitInj in seqn. symmetry. assumption.
    * pose proof (IHm t). assert (b = Fin.R n t).
      apply (@splitInj n (m * n)).
      rewrite seqn. symmetry. apply splitR.
      rewrite H0. simpl.
      destruct (splitMult m n t) eqn:smeqn.
      simpl. rewrite <- H. reflexivity.
Defined.

Fixpoint pow (b e : nat) : nat := match e with
  | 0 => 1
  | S e' => b * pow b e'
  end.

Theorem finPow : forall {e b : nat},
  Iso.T (Fin.t (pow b e)) (Fin.t e -> Fin.t b).
Proof.
intros e. induction e; intros n; simpl.
- eapply Iso.Trans. apply finIso. simpl. eapply Iso.Trans.
  eapply Iso.Sym. apply botNull. eapply Iso.Trans. Focus 2.
  eapply Iso.FuncCong. eapply Iso.Sym. apply finIso. apply Iso.Refl.
  simpl. apply Iso.Sym. apply Iso.FFunc.
- eapply Iso.Trans. eapply Iso.Sym. apply finMult.
  eapply Iso.Trans. Focus 2. eapply Iso.FuncCong.
  eapply Iso.Sym. apply finIso. apply Iso.Refl.
  simpl. eapply Iso.Trans. Focus 2. eapply Iso.Sym. eapply Iso.PlusFunc.
  apply Iso.TFunc. eapply Iso.Trans. eapply Iso.FuncCong.
  eapply Iso.Sym. apply finIso. apply Iso.Refl. eapply Iso.Sym.
  apply IHe. apply Iso.Refl.
Qed.

(** A universe of codes for finite types. *)
Inductive U : Set :=
  | U0    : U
  | U1    : U
  | UPlus : U -> U -> U
  | UTimes : U -> U -> U
  | UFunc : U -> U -> U
  | UFint : nat -> U
  | UFin : nat -> U.

(** The types which the codes of U represent. *)
Fixpoint ty (t : U) : Set := match t with
  | U0 => Empty_set
  | U1 => unit
  | UPlus a b => (ty a + ty b)%type
  | UTimes a b => (ty a * ty b)%type
  | UFunc a b => ty a -> ty b
  | UFint n => Fin.t n
  | UFin n => Fin n
  end.

(** For every code for a finite type, we give its cardinality as
    a natural number. *)
Fixpoint card (t : U) : nat := match t with
  | U0 => 0
  | U1 => 1
  | UPlus a b => card a + card b
  | UTimes a b => card a * card b
  | UFunc a b => pow (card b) (card a)
  | UFint n => n
  | UFin n => n
  end.

(** Each type in the finite universe is isomorphic to the Fin.t
    family whose size is determined by the cardinality function above. *)
Theorem finChar (t : U) : Iso.T (ty t) (Fin.t (card t)).
Proof.
induction t; simpl.
- apply Iso.Sym. apply (finIso 0).
- apply Iso.Sym. apply (@Iso.Trans _ (Fin 1)). apply (finIso 1).
  apply Iso.Sym. apply botNull.
- eapply Iso.Trans. eapply Iso.PlusCong. eassumption.
  eassumption.
  apply finPlus.
- eapply Iso.Trans. eapply Iso.TimesCong; try eassumption.
  apply finMult.
- eapply Iso.Trans. eapply Iso.FuncCong; try eassumption.
  apply Iso.Sym. apply finPow.
- apply Iso.Refl.
- apply Iso.Sym. apply finIso.
Qed.

(** A type for evidence that a type is finite: a type is finite if
    any of the following hold:
    a) it is unit
    b) it is Empty_set
    c) it is a sum of finite types
    d) it is isomorphic to a finite type

    This is not minimal. We could have replaced b) and c) with the condition
    e) it is the sum of unit with a finite type
       (this is the analog of Successor)
    But this definition is simple so I like it.
*)

Inductive T : Type -> Type :=
  | F0 : T Empty_set
  | FS : forall {A}, T A -> T (unit + A)
  | FIso : forall {A B}, T A -> Iso.T A B -> T B
.

Definition fin (n : nat) : T (Fin.t n).
Proof. eapply FIso. Focus 2. eapply Iso.Sym. eapply finIso.
induction n; simpl.
- apply F0.
- apply FS. assumption.
Qed.

Definition finU (A : U) : T (ty A).
Proof.
eapply FIso. Focus 2. eapply Iso.Sym. apply finChar.
apply fin.
Qed.

Definition iso {A : Type} : T A -> sigT (fun n => Iso.T A (Fin.t n)).
Proof.
intros. induction X.
-  exists 0. apply (finChar U0).
- destruct IHX. exists (S x). apply Iso.Sym. eapply Iso.Trans.
  apply finIso. simpl. apply Iso.PlusCong. apply Iso.Refl.
  eapply Iso.Trans. eapply Iso.Sym. apply finIso. apply Iso.Sym.
  assumption.
- destruct IHX. exists x. eapply Iso.Trans. eapply Iso.Sym. eassumption.
  assumption.
Qed.

Definition true : T unit := finU U1.

Definition plus {A B : Type} (fa : T A) (fb : T B) : T (A + B).
Proof.
destruct (iso fa), (iso fb).
eapply (@FIso (Fin.t (x + x0))). apply (finU (UFint (x + x0))).
eapply Iso.Trans. eapply Iso.Sym. apply finPlus.
eapply Iso.PlusCong; eapply Iso.Sym; eassumption.
Qed.

Lemma finiteSig {A : Type} (fa : T A)
  : forall {B : A -> Type},
  (forall (x : A), T (B x))
  -> sigT (fun S => (T S * Iso.T (sigT B) S)%type).
Proof.
induction fa; intros b fb.
- exists Empty_set. split. constructor. apply Iso.FSig.
- pose proof (IHfa (fun x => b (inr x)) (fun x => fb (inr x))).
  destruct X. destruct p.
  exists (b (inl tt) + x)%type. constructor. apply plus. apply fb.
  assumption.
  apply Iso.PlusSig. apply (@Iso.TSig (fun x => b (inl x))).
  assumption.
- pose (Iso.Sym t).
  pose proof (IHfa (fun x => b (Iso.from t0 x))
                   (fun x => fb (Iso.from t0 x))).
  destruct X. destruct p.
  exists x. split. assumption.
  eapply Iso.Trans. Focus 2. apply t2.
  admit.
  (* Here we need Iso.sigmaProp, which we have yet to prove,
     so we cannot finish the proof here. *)
  (*apply Iso.sigmaProp.*)
Admitted.

(** Sigma types are closed under finiteness. *)
Theorem sig {A : Type} {B : A -> Type}
  : T A
  -> (forall (x : A), T (B x))
  -> T (sigT B).
Proof.
intros fA fB.
pose proof (finiteSig fA fB).
destruct X. destruct p.
eapply FIso. apply t.
apply Iso.Sym. assumption.
Defined.

(** Product types are closed under finiteness. *)
Theorem times {A B : Type} : T A -> T B -> T (A * B).
Proof.
intros fa fb.
eapply FIso. Focus 2. eapply Iso.Sym. eapply Iso.sigTimes.
apply sig. assumption. apply (fun _ => fb).
Defined.

Lemma finiteMapped {A : Type} (fa : T A)
  : forall {B : Type}, T B -> sigT (fun S => (T S * Iso.T (A -> B) S)%type).
Proof.
induction fa.
- intros. exists unit. apply (true, Iso.FFunc).
- intros B fb.
  destruct (IHfa B fb).
  exists (B * x)%type.
  destruct p.
  apply (times fb t , Iso.PlusFunc Iso.TFunc t0).
- intros B1 fb.
  destruct (IHfa B1 fb).
  destruct p.
  exists x.
  split.
  assumption.
  eapply Iso.Trans.
  eapply Iso.Sym.
  apply (Iso.FuncCong t (Iso.Refl B1)).
  assumption.
Defined.

(** Functions are closed under finiteness. *)
Theorem func {A B : Type} : T A -> T B -> T (A -> B).
Proof.
intros FA FB.
pose proof (finiteMapped FA FB).
destruct X.
destruct p.
eapply FIso.
eassumption.
apply Iso.Sym.
assumption.
Defined.

(** Any finite type has decidable equality. *)
Theorem eq_dec {A : Type} : T A -> forall a b : A, {a = b} + {a <> b}.
Proof.
intros finite.
induction finite; intros; try (decide equality).
- destruct a0, u; auto.
- eapply Iso.eq_dec; eassumption.
Qed.


(* -*- coding: utf-8 -*- *)
(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

Require Import BinPos PeanoNat.

(** Properties of the injection from binary positive numbers
    to Peano natural numbers *)

(** Original development by Pierre Crégut, CNET, Lannion, France *)

Local Open Scope positive_scope.
Local Open Scope nat_scope.

Module Pos2Nat.
 Import Pos.

(** [Pos.to_nat] is a morphism for successor, addition, multiplication *)

Lemma inj_succ p : to_nat (succ p) = S (to_nat p).
Proof.
 unfold to_nat. rewrite iter_op_succ. trivial.
 apply Nat.add_assoc.
Qed.

Theorem inj_add p q : to_nat (p + q) = to_nat p + to_nat q.
Proof.
 revert q. induction p using peano_ind; intros q.
 now rewrite add_1_l, inj_succ.
 now rewrite add_succ_l, !inj_succ, IHp.
Qed.

Theorem inj_mul p q : to_nat (p * q) = to_nat p * to_nat q.
Proof.
 revert q. induction p using peano_ind; simpl; intros; trivial.
 now rewrite mul_succ_l, inj_add, IHp, inj_succ.
Qed.

(** Mapping of xH, xO and xI through [Pos.to_nat] *)

Lemma inj_1 : to_nat 1 = 1.
Proof.
 reflexivity.
Qed.

Lemma inj_xO p : to_nat (xO p) = 2 * to_nat p.
Proof.
 exact (inj_mul 2 p).
Qed.

Lemma inj_xI p : to_nat (xI p) = S (2 * to_nat p).
Proof.
 now rewrite xI_succ_xO, inj_succ, inj_xO.
Qed.

(** [Pos.to_nat] maps to the strictly positive subset of [nat] *)

Lemma is_succ : forall p, exists n, to_nat p = S n.
Proof.
 induction p using peano_ind.
 now exists 0.
 destruct IHp as (n,Hn). exists (S n). now rewrite inj_succ, Hn.
Qed.

(** [Pos.to_nat] is strictly positive *)

Lemma is_pos p : 0 < to_nat p.
Proof.
 destruct (is_succ p) as (n,->). auto with arith.
Qed.

(** [Pos.to_nat] is a bijection between [positive] and
    non-zero [nat], with [Pos.of_nat] as reciprocal.
    See [Nat2Pos.id] below for the dual equation. *)

Theorem id p : of_nat (to_nat p) = p.
Proof.
 induction p using peano_ind. trivial.
 rewrite inj_succ. rewrite <- IHp at 2.
 now destruct (is_succ p) as (n,->).
Qed.

(** [Pos.to_nat] is hence injective *)

Lemma inj p q : to_nat p = to_nat q -> p = q.
Proof.
 intros H. now rewrite <- (id p), <- (id q), H.
Qed.

Lemma inj_iff p q : to_nat p = to_nat q <-> p = q.
Proof.
 split. apply inj. intros; now subst.
Qed.

(** [Pos.to_nat] is a morphism for comparison *)

Lemma inj_compare p q : (p ?= q)%positive = (to_nat p ?= to_nat q).
Proof.
 revert q. induction p as [ |p IH] using peano_ind; intros q.
 - destruct (succ_pred_or q) as [Hq|Hq]; [now subst|].
   rewrite <- Hq, lt_1_succ, inj_succ, inj_1, Nat.compare_succ.
   symmetry. apply Nat.compare_lt_iff, is_pos.
 - destruct (succ_pred_or q) as [Hq|Hq]; [subst|].
   rewrite compare_antisym, lt_1_succ, inj_succ. simpl.
   symmetry. apply Nat.compare_gt_iff, is_pos.
   now rewrite <- Hq, 2 inj_succ, compare_succ_succ, IH.
Qed.

(** [Pos.to_nat] is a morphism for [lt], [le], etc *)

Lemma inj_lt p q : (p < q)%positive <-> to_nat p < to_nat q.
Proof.
 unfold lt. now rewrite inj_compare, Nat.compare_lt_iff.
Qed.

Lemma inj_le p q : (p <= q)%positive <-> to_nat p <= to_nat q.
Proof.
 unfold le. now rewrite inj_compare, Nat.compare_le_iff.
Qed.

Lemma inj_gt p q : (p > q)%positive <-> to_nat p > to_nat q.
Proof.
 unfold gt. now rewrite inj_compare, Nat.compare_gt_iff.
Qed.

Lemma inj_ge p q : (p >= q)%positive <-> to_nat p >= to_nat q.
Proof.
 unfold ge. now rewrite inj_compare, Nat.compare_ge_iff.
Qed.

(** [Pos.to_nat] is a morphism for subtraction *)

Theorem inj_sub p q : (q < p)%positive ->
 to_nat (p - q) = to_nat p - to_nat q.
Proof.
 intro H. apply Nat.add_cancel_r with (to_nat q).
 rewrite Nat.sub_add.
 now rewrite <- inj_add, sub_add.
 now apply Nat.lt_le_incl, inj_lt.
Qed.

Theorem inj_sub_max p q :
 to_nat (p - q) = Nat.max 1 (to_nat p - to_nat q).
Proof.
 destruct (ltb_spec q p).
 - (* q < p *)
   rewrite <- inj_sub by trivial.
   now destruct (is_succ (p - q)) as (m,->).
 - (* p <= q *)
   rewrite sub_le by trivial.
   apply inj_le, Nat.sub_0_le in H. now rewrite H.
Qed.

Theorem inj_pred p : (1 < p)%positive ->
 to_nat (pred p) = Nat.pred (to_nat p).
Proof.
 intros. now rewrite <- Pos.sub_1_r, inj_sub, Nat.sub_1_r.
Qed.

Theorem inj_pred_max p :
 to_nat (pred p) = Nat.max 1 (Peano.pred (to_nat p)).
Proof.
 rewrite <- Pos.sub_1_r, <- Nat.sub_1_r. apply inj_sub_max.
Qed.

(** [Pos.to_nat] and other operations *)

Lemma inj_min p q :
 to_nat (min p q) = Nat.min (to_nat p) (to_nat q).
Proof.
 unfold min. rewrite inj_compare.
 case Nat.compare_spec; intros H; symmetry.
 - apply Nat.min_l. now rewrite H.
 - now apply Nat.min_l, Nat.lt_le_incl.
 - now apply Nat.min_r, Nat.lt_le_incl.
Qed.

Lemma inj_max p q :
 to_nat (max p q) = Nat.max (to_nat p) (to_nat q).
Proof.
 unfold max. rewrite inj_compare.
 case Nat.compare_spec; intros H; symmetry.
 - apply Nat.max_r. now rewrite H.
 - now apply Nat.max_r, Nat.lt_le_incl.
 - now apply Nat.max_l, Nat.lt_le_incl.
Qed.

Theorem inj_iter :
  forall p {A} (f:A->A) (x:A),
    Pos.iter f x p = nat_rect _ x (fun _ => f) (to_nat p).
Proof.
 induction p using peano_ind.
 - trivial.
 - intros. rewrite inj_succ, iter_succ.
  simpl. f_equal. apply IHp.
Qed.

End Pos2Nat.

Module Nat2Pos.

(** [Pos.of_nat] is a bijection between non-zero [nat] and
    [positive], with [Pos.to_nat] as reciprocal.
    See [Pos2Nat.id] above for the dual equation. *)

Theorem id (n:nat) : n<>0 -> Pos.to_nat (Pos.of_nat n) = n.
Proof.
 induction n as [|n H]; trivial. now destruct 1.
 intros _. simpl Pos.of_nat. destruct n. trivial.
 rewrite Pos2Nat.inj_succ. f_equal. now apply H.
Qed.

Theorem id_max (n:nat) : Pos.to_nat (Pos.of_nat n) = max 1 n.
Proof.
 destruct n. trivial. now rewrite id.
Qed.

(** [Pos.of_nat] is hence injective for non-zero numbers *)

Lemma inj (n m : nat) : n<>0 -> m<>0 -> Pos.of_nat n = Pos.of_nat m -> n = m.
Proof.
 intros Hn Hm H. now rewrite <- (id n), <- (id m), H.
Qed.

Lemma inj_iff (n m : nat) : n<>0 -> m<>0 ->
 (Pos.of_nat n = Pos.of_nat m <-> n = m).
Proof.
 split. now apply inj. intros; now subst.
Qed.

(** Usual operations are morphisms with respect to [Pos.of_nat]
    for non-zero numbers. *)

Lemma inj_succ (n:nat) : n<>0 -> Pos.of_nat (S n) = Pos.succ (Pos.of_nat n).
Proof.
intro H. apply Pos2Nat.inj. now rewrite Pos2Nat.inj_succ, !id.
Qed.

Lemma inj_pred (n:nat) : Pos.of_nat (pred n) = Pos.pred (Pos.of_nat n).
Proof.
 destruct n as [|[|n]]; trivial. simpl. now rewrite Pos.pred_succ.
Qed.

Lemma inj_add (n m : nat) : n<>0 -> m<>0 ->
 Pos.of_nat (n+m) = (Pos.of_nat n + Pos.of_nat m)%positive.
Proof.
intros Hn Hm. apply Pos2Nat.inj.
rewrite Pos2Nat.inj_add, !id; trivial.
intros H. destruct n. now destruct Hn. now simpl in H.
Qed.

Lemma inj_mul (n m : nat) : n<>0 -> m<>0 ->
 Pos.of_nat (n*m) = (Pos.of_nat n * Pos.of_nat m)%positive.
Proof.
intros Hn Hm. apply Pos2Nat.inj.
rewrite Pos2Nat.inj_mul, !id; trivial.
intros H. apply Nat.mul_eq_0 in H. destruct H. now elim Hn. now elim Hm.
Qed.

Lemma inj_compare (n m : nat) : n<>0 -> m<>0 ->
 (n ?= m) = (Pos.of_nat n ?= Pos.of_nat m)%positive.
Proof.
intros Hn Hm. rewrite Pos2Nat.inj_compare, !id; trivial.
Qed.

Lemma inj_sub (n m : nat) : m<>0 ->
 Pos.of_nat (n-m) = (Pos.of_nat n - Pos.of_nat m)%positive.
Proof.
 intros Hm.
 apply Pos2Nat.inj.
 rewrite Pos2Nat.inj_sub_max.
 rewrite (id m) by trivial. rewrite !id_max.
 destruct n, m; trivial.
Qed.

Lemma inj_min (n m : nat) :
 Pos.of_nat (min n m) = Pos.min (Pos.of_nat n) (Pos.of_nat m).
Proof.
 destruct n as [|n]. simpl. symmetry. apply Pos.min_l, Pos.le_1_l.
 destruct m as [|m]. simpl. symmetry. apply Pos.min_r, Pos.le_1_l.
 unfold Pos.min. rewrite <- inj_compare by easy.
 case Nat.compare_spec; intros H; f_equal;
  apply Nat.min_l || apply Nat.min_r.
 rewrite H; auto. now apply Nat.lt_le_incl. now apply Nat.lt_le_incl.
Qed.

Lemma inj_max (n m : nat) :
 Pos.of_nat (max n m) = Pos.max (Pos.of_nat n) (Pos.of_nat m).
Proof.
 destruct n as [|n]. simpl. symmetry. apply Pos.max_r, Pos.le_1_l.
 destruct m as [|m]. simpl. symmetry. apply Pos.max_l, Pos.le_1_l.
 unfold Pos.max. rewrite <- inj_compare by easy.
 case Nat.compare_spec; intros H; f_equal;
  apply Nat.max_l || apply Nat.max_r.
 rewrite H; auto. now apply Nat.lt_le_incl. now apply Nat.lt_le_incl.
Qed.

End Nat2Pos.

(**********************************************************************)
(** Properties of the shifted injection from Peano natural numbers
    to binary positive numbers *)

Module Pos2SuccNat.

(** Composition of [Pos.to_nat] and [Pos.of_succ_nat] is successor
    on [positive] *)

Theorem id_succ p : Pos.of_succ_nat (Pos.to_nat p) = Pos.succ p.
Proof.
rewrite Pos.of_nat_succ, <- Pos2Nat.inj_succ. apply Pos2Nat.id.
Qed.

(** Composition of [Pos.to_nat], [Pos.of_succ_nat] and [Pos.pred]
    is identity on [positive] *)

Theorem pred_id p : Pos.pred (Pos.of_succ_nat (Pos.to_nat p)) = p.
Proof.
now rewrite id_succ, Pos.pred_succ.
Qed.

End Pos2SuccNat.

Module SuccNat2Pos.

(** Composition of [Pos.of_succ_nat] and [Pos.to_nat] is successor on [nat] *)

Theorem id_succ (n:nat) : Pos.to_nat (Pos.of_succ_nat n) = S n.
Proof.
rewrite Pos.of_nat_succ. now apply Nat2Pos.id.
Qed.

Theorem pred_id (n:nat) : pred (Pos.to_nat (Pos.of_succ_nat n)) = n.
Proof.
now rewrite id_succ.
Qed.

(** [Pos.of_succ_nat] is hence injective *)

Lemma inj (n m : nat) : Pos.of_succ_nat n = Pos.of_succ_nat m -> n = m.
Proof.
 intro H. apply (f_equal Pos.to_nat) in H. rewrite !id_succ in H.
 now injection H.
Qed.

Lemma inj_iff (n m : nat) : Pos.of_succ_nat n = Pos.of_succ_nat m <-> n = m.
Proof.
 split. apply inj. intros; now subst.
Qed.

(** Another formulation *)

Theorem inv n p : Pos.to_nat p = S n -> Pos.of_succ_nat n = p.
Proof.
 intros H. apply Pos2Nat.inj. now rewrite id_succ.
Qed.

(** Successor and comparison are morphisms with respect to
    [Pos.of_succ_nat] *)

Lemma inj_succ n : Pos.of_succ_nat (S n) = Pos.succ (Pos.of_succ_nat n).
Proof.
apply Pos2Nat.inj. now rewrite Pos2Nat.inj_succ, !id_succ.
Qed.

Lemma inj_compare n m :
 (n ?= m) = (Pos.of_succ_nat n ?= Pos.of_succ_nat m)%positive.
Proof.
rewrite Pos2Nat.inj_compare, !id_succ; trivial.
Qed.

(** Other operations, for instance [Pos.add] and [plus] aren't
    directly related this way (we would need to compensate for
    the successor hidden in [Pos.of_succ_nat] *)

End SuccNat2Pos.

(** For compatibility, old names and old-style lemmas *)

Notation Psucc_S := Pos2Nat.inj_succ (only parsing).
Notation Pplus_plus := Pos2Nat.inj_add (only parsing).
Notation Pmult_mult := Pos2Nat.inj_mul (only parsing).
Notation Pcompare_nat_compare := Pos2Nat.inj_compare (only parsing).
Notation nat_of_P_xH := Pos2Nat.inj_1 (only parsing).
Notation nat_of_P_xO := Pos2Nat.inj_xO (only parsing).
Notation nat_of_P_xI := Pos2Nat.inj_xI (only parsing).
Notation nat_of_P_is_S := Pos2Nat.is_succ (only parsing).
Notation nat_of_P_pos := Pos2Nat.is_pos (only parsing).
Notation nat_of_P_inj_iff := Pos2Nat.inj_iff (only parsing).
Notation nat_of_P_inj := Pos2Nat.inj (only parsing).
Notation Plt_lt := Pos2Nat.inj_lt (only parsing).
Notation Pgt_gt := Pos2Nat.inj_gt (only parsing).
Notation Ple_le := Pos2Nat.inj_le (only parsing).
Notation Pge_ge := Pos2Nat.inj_ge (only parsing).
Notation Pminus_minus := Pos2Nat.inj_sub (only parsing).
Notation iter_nat_of_P := @Pos2Nat.inj_iter (only parsing).

Notation nat_of_P_of_succ_nat := SuccNat2Pos.id_succ (only parsing).
Notation P_of_succ_nat_of_P := Pos2SuccNat.id_succ (only parsing).

Notation nat_of_P_succ_morphism := Pos2Nat.inj_succ (only parsing).
Notation nat_of_P_plus_morphism := Pos2Nat.inj_add (only parsing).
Notation nat_of_P_mult_morphism := Pos2Nat.inj_mul (only parsing).
Notation nat_of_P_compare_morphism := Pos2Nat.inj_compare (only parsing).
Notation lt_O_nat_of_P := Pos2Nat.is_pos (only parsing).
Notation ZL4 := Pos2Nat.is_succ (only parsing).
Notation nat_of_P_o_P_of_succ_nat_eq_succ := SuccNat2Pos.id_succ (only parsing).
Notation P_of_succ_nat_o_nat_of_P_eq_succ := Pos2SuccNat.id_succ (only parsing).
Notation pred_o_P_of_succ_nat_o_nat_of_P_eq_id := Pos2SuccNat.pred_id (only parsing).

Lemma nat_of_P_minus_morphism p q :
 Pos.compare_cont Eq p q = Gt ->
  Pos.to_nat (p - q) = Pos.to_nat p - Pos.to_nat q.
Proof (fun H => Pos2Nat.inj_sub p q (Pos.gt_lt _ _ H)).

Lemma nat_of_P_lt_Lt_compare_morphism p q :
 Pos.compare_cont Eq p q = Lt -> Pos.to_nat p < Pos.to_nat q.
Proof (proj1 (Pos2Nat.inj_lt p q)).

Lemma nat_of_P_gt_Gt_compare_morphism p q :
 Pos.compare_cont Eq p q = Gt -> Pos.to_nat p > Pos.to_nat q.
Proof (proj1 (Pos2Nat.inj_gt p q)).

Lemma nat_of_P_lt_Lt_compare_complement_morphism p q :
 Pos.to_nat p < Pos.to_nat q -> Pos.compare_cont Eq p q = Lt.
Proof (proj2 (Pos2Nat.inj_lt p q)).

Definition nat_of_P_gt_Gt_compare_complement_morphism p q :
 Pos.to_nat p > Pos.to_nat q -> Pos.compare_cont Eq p q = Gt.
Proof (proj2 (Pos2Nat.inj_gt p q)).

(** Old intermediate results about [Pmult_nat] *)

Section ObsoletePmultNat.

Lemma Pmult_nat_mult : forall p n,
 Pmult_nat p n = Pos.to_nat p * n.
Proof.
 induction p; intros n; unfold Pos.to_nat; simpl.
 f_equal. rewrite 2 IHp. rewrite <- Nat.mul_assoc.
  f_equal. simpl. now rewrite Nat.add_0_r.
 rewrite 2 IHp. rewrite <- Nat.mul_assoc.
  f_equal. simpl. now rewrite Nat.add_0_r.
 simpl. now rewrite Nat.add_0_r.
Qed.

Lemma Pmult_nat_succ_morphism :
 forall p n, Pmult_nat (Pos.succ p) n = n + Pmult_nat p n.
Proof.
 intros. now rewrite !Pmult_nat_mult, Pos2Nat.inj_succ.
Qed.

Theorem Pmult_nat_l_plus_morphism :
 forall p q n, Pmult_nat (p + q) n = Pmult_nat p n + Pmult_nat q n.
Proof.
 intros. rewrite !Pmult_nat_mult, Pos2Nat.inj_add. apply Nat.mul_add_distr_r.
Qed.

Theorem Pmult_nat_plus_carry_morphism :
 forall p q n, Pmult_nat (Pos.add_carry p q) n = n + Pmult_nat (p + q) n.
Proof.
 intros. now rewrite Pos.add_carry_spec, Pmult_nat_succ_morphism.
Qed.

Lemma Pmult_nat_r_plus_morphism :
 forall p n, Pmult_nat p (n + n) = Pmult_nat p n + Pmult_nat p n.
Proof.
 intros. rewrite !Pmult_nat_mult. apply Nat.mul_add_distr_l.
Qed.

Lemma ZL6 : forall p, Pmult_nat p 2 = Pos.to_nat p + Pos.to_nat p.
Proof.
 intros. rewrite Pmult_nat_mult, Nat.mul_comm. simpl. now rewrite Nat.add_0_r.
Qed.

Lemma le_Pmult_nat : forall p n, n <= Pmult_nat p n.
Proof.
 intros. rewrite Pmult_nat_mult.
 apply Nat.le_trans with (1*n). now rewrite Nat.mul_1_l.
 apply Nat.mul_le_mono_r. apply Pos2Nat.is_pos.
Qed.

End ObsoletePmultNat.


(** This module defines the full signature of language algebra we
consider here, and its finite complete axiomatization. We also define
here some normalisation functions, and list some of their properties. *)

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Require Import tools language.

Delimit Scope lat_scope with lat.
Open Scope lat_scope.

Section s.
  (** * Main definitions *)
  Variable X : Set.
  Variable dec_X : decidable_set X.

  (** [𝐄'' X] is the type of expressions with variables ranging over the
  type [X]. They are built out of the constant [0], the
  concatenation (also called sequential product) [⋅], the intersection
  [∩], the union [+], and the non-zero iteration, denoted by [⁺]. *)
  Inductive 𝐄'' : Set :=
  | 𝐄''_zero : 𝐄''
  | 𝐄''_var : X -> 𝐄''
  | 𝐄''_seq : 𝐄'' -> 𝐄'' -> 𝐄''
  | 𝐄''_inter : 𝐄'' -> 𝐄'' -> 𝐄''
  | 𝐄''_plus : 𝐄'' -> 𝐄'' -> 𝐄''
  | 𝐄''_iter : 𝐄'' -> 𝐄''.

  Notation "x ⋅ y" := (𝐄''_seq x y) (at level 40) : lat_scope.
  Notation "x + y" := (𝐄''_plus x y) (left associativity, at level 50) : lat_scope.
  Notation "x ∩ y" := (𝐄''_inter x y) (at level 45) : lat_scope.
  Notation "x ⁺" := (𝐄''_iter x) (at level 25) : lat_scope.
  Notation " 0 " := 𝐄''_zero : lat_scope.

  (** The size of an expression is the number of nodes in its syntax
  tree. *)
  Global Instance size_𝐄'' : Size 𝐄'' :=
    fix 𝐄''_size (e: 𝐄'') : nat :=
      match e with
      | 0 | 𝐄''_var _ => 1%nat
      | e + f | e ∩ f | e ⋅ f => S (𝐄''_size e + 𝐄''_size f)
      | e ⁺ => S (𝐄''_size e)
      end.
  (* begin hide *)
  Lemma 𝐄''_size_zero : |0| = 1%nat. trivial. Qed.
  Lemma 𝐄''_size_var a : |𝐄''_var a| = 1%nat. trivial. Qed.
  Lemma 𝐄''_size_seq e f : |e⋅f| = S(|e|+|f|). trivial. Qed.
  Lemma 𝐄''_size_inter e f : |e∩f| = S(|e|+|f|). trivial. Qed.
  Lemma 𝐄''_size_plus e f : |e+f| = S(|e|+|f|). trivial. Qed.
  Lemma 𝐄''_size_iter e : |e⁺| = S(|e|). trivial. Qed.
  Hint Rewrite 𝐄''_size_zero 𝐄''_size_var 𝐄''_size_seq
       𝐄''_size_inter 𝐄''_size_plus 𝐄''_size_iter
    : simpl_typeclasses.
  Fixpoint eqb e f :=
    match (e,f) with
    | (0,0) => true
    | (𝐄''_var a,𝐄''_var b) => eqX a b
    | (e⁺,f⁺) => eqb e f
    | (e1 + e2,f1 + f2)
    | (e1 ⋅ e2,f1 ⋅ f2)
    | (e1 ∩ e2,f1 ∩ f2) => eqb e1 f1 && eqb e2 f2
    | _ => false
    end.
  Lemma eqb_reflect e f : reflect (e = f) (eqb e f).
  Proof.
    apply iff_reflect;symmetry;split;
      [intro h;apply Is_true_eq_left in h;revert f h
      |intros <-;apply Is_true_eq_true];induction e;
        try destruct f;simpl;autorewrite with quotebool;firstorder.
    - apply Is_true_eq_true,eqX_correct in h as ->;auto.
    - erewrite IHe1;[|eauto]; erewrite IHe2;[|eauto];auto.
    - erewrite IHe1;[|eauto]; erewrite IHe2;[|eauto];auto.
    - erewrite IHe1;[|eauto]; erewrite IHe2;[|eauto];auto.
    - erewrite IHe;[|eauto];auto.
    - apply Is_true_eq_left,eqX_correct;auto.
  Qed.
  (* end hide *)

  (** If the set of variables [X] is decidable, then so is the set of
  expressions. _Note that we are here considering syntactic equality,
  as no semantic or axiomatic equivalence relation has been defined
  for expressions_. *)
  Global Instance 𝐄''_decidable_set : decidable_set 𝐄''.
  Proof. exact (Build_decidable_set eqb_reflect). Qed.

  (** The following are the axioms of the algebra of languages over
  this signature.*)
  Inductive ax : 𝐄'' -> 𝐄'' -> Prop :=
  (* first line *)
  | ax_inter_assoc e f g : ax (e∩(f ∩ g)) ((e∩f)∩g)
  | ax_inter_comm e f : ax (e∩f) (f∩e)
  | ax_inter_idem e : ax (e ∩ e) e
  (* second line *)
  | ax_plus_inter e f g: ax (e ∩ (f + g)) ((e∩f) + (e∩g))
  | ax_plus_inter_id e f : ax (e ∩ (e + f)) e
  | ax_inter_plus_id e f : ax (e + (e ∩ f)) e
  (* third line *)
  | ax_plus_ass e f g : ax (e+(f+g)) ((e+f)+g)
  | ax_plus_com e f : ax (e+f) (f+e)
  | ax_plus_idem e : ax (e+e) e
  (* fourth line *)
  | ax_seq_assoc e f g : ax (e⋅(f ⋅ g)) ((e⋅f)⋅g)
  | ax_seq_plus e f g: ax (e⋅(f + g)) (e⋅f + e⋅g)
  | ax_plus_seq e f g: ax ((e + f)⋅g) (e⋅g + f⋅g)
  | ax_plus_0 e : ax (e+0) e
  | ax_seq_0 e : ax (e⋅0) 0
  | ax_0_seq e : ax (0⋅e) 0
  (* fifth line *)
  | ax_iter_left e : ax (e⁺) (e + e⋅e⁺)
  | ax_iter_right e : ax (e⁺) (e + e⁺ ⋅e).

  Inductive ax_impl : 𝐄'' -> 𝐄'' -> 𝐄'' -> 𝐄'' -> Prop:=
  | ax_right_ind e f : ax_impl (e⋅f + f) f (e⁺⋅f + f) f
  | ax_left_ind e f : ax_impl (f ⋅ e + f) f (f ⋅e⁺ + f) f.

  (** We use these axioms to generate an axiomatic equivalence
  relation and an axiomatic order relations. *)
  Inductive 𝐄''_eq : Equiv 𝐄'' :=
  | eq_refl e : e ≡ e
  | eq_trans f e g : e ≡ f -> f ≡ g -> e ≡ g
  | eq_sym e f : e ≡ f -> f ≡ e
  | eq_plus e f g h : e ≡ g -> f ≡ h -> (e + f) ≡ (g + h)
  | eq_seq e f g h : e ≡ g -> f ≡ h -> (e ⋅ f) ≡ (g ⋅ h)
  | eq_inter e f g h : e ≡ g -> f ≡ h -> (e ∩ f) ≡ (g ∩ h)
  | eq_iter e f : e ≡ f -> (e⁺) ≡ (f⁺)
  | eq_ax e f : ax e f -> e ≡ f
  | eq_ax_impl e f g h : ax_impl e f g h -> e ≡ f -> g ≡ h.
  Global Instance 𝐄''_Equiv : Equiv 𝐄'' := 𝐄''_eq.

  Global Instance 𝐄''_Smaller : Smaller 𝐄'' := (fun e f => e + f ≡ f).

  Hint Constructors 𝐄''_eq ax ax_impl.

  Global Instance ax_equiv : subrelation ax equiv.
  Proof. intros e f E;apply eq_ax,E. Qed.

End s.

(* begin hide *)
Arguments 𝐄''_zero {X}.
Arguments eqb {X} {dec_X} e%lat f%lat.
Hint Constructors 𝐄''_eq ax ax_impl.
Hint Rewrite @𝐄''_size_zero @𝐄''_size_var @𝐄''_size_seq
     @𝐄''_size_inter @𝐄''_size_plus @𝐄''_size_iter
  : simpl_typeclasses.
(* end hide *)

Infix " ⋅ " := 𝐄''_seq (at level 40) : lat_scope.
Infix " + " := 𝐄''_plus (left associativity, at level 50) : lat_scope.
Infix " ∩ " := 𝐄''_inter (at level 45) : lat_scope.
Notation "x ⁺" := (𝐄''_iter x) (at level 25) : lat_scope.
Notation " 0 " := 𝐄''_zero : lat_scope.

Section language.
  (** * Language interpretation *)
  Context { X : Set }.

  (** We interpret expressions as languages in the obvious way: *)
  Global Instance to_lang_𝐄'' {Σ}: semantics 𝐄'' language X Σ :=
    fix to_lang_𝐄'' σ e:=
      match e with
      | 0 => 0%lang
      | 𝐄''_var a => (σ a)
      | e + f => ((to_lang_𝐄'' σ e) + (to_lang_𝐄'' σ f))%lang
      | e ⋅ f => ((to_lang_𝐄'' σ e) ⋅ (to_lang_𝐄'' σ f))%lang
      | e ∩ f => ((to_lang_𝐄'' σ e) ∩ (to_lang_𝐄'' σ f))%lang
      | e⁺ => (to_lang_𝐄'' σ e)⁺%lang
      end.

  (* begin hide *)
  Global Instance semSmaller_𝐄'' : SemSmaller (𝐄'' X) :=
    (@semantic_containment _ _ _ _ _).
  Global Instance semEquiv_𝐄'' : SemEquiv (𝐄'' X) :=
    (@semantic_equality _ _ _ _ _).
  Hint Unfold semSmaller_𝐄'' semEquiv_𝐄'' : semantics.

  Section rsimpl.
    Context { Σ : Set }{σ : 𝕬[X→Σ] }.
    Lemma 𝐄''_union e f : (⟦ e+f ⟧σ) = ((⟦e⟧σ) + ⟦f⟧σ)%lang.
    Proof. unfold interprete;simpl;auto. Qed.
    Lemma 𝐄''_prod e f :  (⟦ e⋅f ⟧σ) = ((⟦e⟧σ) ⋅ ⟦f⟧σ)%lang.
    Proof. unfold interprete;simpl;auto. Qed.
    Lemma 𝐄''_intersection e f : (⟦ e∩f ⟧σ) = ((⟦e⟧σ) ∩ ⟦f⟧σ)%lang.
    Proof. unfold interprete;simpl;auto. Qed.
    Lemma 𝐄''_iter_l e :  (⟦ e⁺⟧σ) = (⟦e⟧σ)⁺%lang.
    Proof. unfold interprete;simpl;auto. Qed.
    Lemma 𝐄''_variable a : (⟦𝐄''_var a⟧ σ) = σ a.
    Proof. unfold interprete;simpl;auto. Qed.
    Lemma 𝐄''_empty : (⟦0⟧σ) = 0%lang.
    Proof. unfold interprete;simpl;auto. Qed.
  End rsimpl.
  Hint Rewrite @𝐄''_empty @𝐄''_variable @𝐄''_intersection
       @𝐄''_prod @𝐄''_union @𝐄''_iter_l
    : simpl_typeclasses.
  (* end hide *)
  Theorem klm_completeness : forall e f : 𝐄'' X, e ≡ f <-> e ≃ f.
  Admitted.

  Corollary klm_completeness_inf : forall e f : 𝐄'' X, e ≤ f <-> e ≲ f.
  Proof.
    intros e f;unfold smaller,𝐄''_Smaller;rewrite klm_completeness.
    split.
    - intros E A ? u Ie;apply E;now left.
    - intros E A ? u;split;rsimpl.
      + intros [I|I];auto.
        apply E,I.
      + intros I;now right.
  Qed.
End language.
Hint Rewrite @𝐄''_empty @𝐄''_variable @𝐄''_intersection
     @𝐄''_prod @𝐄''_union @𝐄''_iter_l
  : simpl_typeclasses.

Close Scope lat_scope.

(*  LocalWords:  subunits
 *)


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

Require Import Bool NZAxioms NZMulOrder.

(** Parity functions *)

Module Type NZParity (Import A : NZAxiomsSig').
 Parameter Inline even odd : t -> bool.
 Definition Even n := exists m, n == 2*m.
 Definition Odd n := exists m, n == 2*m+1.
 Axiom even_spec : forall n, even n = true <-> Even n.
 Axiom odd_spec : forall n, odd n = true <-> Odd n.
End NZParity.

Module Type NZParityProp
 (Import A : NZOrdAxiomsSig')
 (Import B : NZParity A)
 (Import C : NZMulOrderProp A).

(** Morphisms *)

Instance Even_wd : Proper (eq==>iff) Even.
Proof. unfold Even. solve_proper. Qed.

Instance Odd_wd : Proper (eq==>iff) Odd.
Proof. unfold Odd. solve_proper. Qed.

Instance even_wd : Proper (eq==>Logic.eq) even.
Proof.
 intros x x' EQ. rewrite eq_iff_eq_true, 2 even_spec. now f_equiv.
Qed.

Instance odd_wd : Proper (eq==>Logic.eq) odd.
Proof.
 intros x x' EQ. rewrite eq_iff_eq_true, 2 odd_spec. now f_equiv.
Qed.

(** Evenness and oddity are dual notions *)

Lemma Even_or_Odd : forall x, Even x \/ Odd x.
Proof.
 nzinduct x.
 left. exists 0. now nzsimpl.
 intros x.
 split; intros [(y,H)|(y,H)].
 right. exists y. rewrite H. now nzsimpl.
 left. exists (S y). rewrite H. now nzsimpl'.
 right.
 assert (LT : exists z, z<y).
  destruct (lt_ge_cases 0 y) as [LT|GT]; [now exists 0 | exists x].
  rewrite <- le_succ_l, H. nzsimpl'.
  rewrite <- (add_0_r y) at 3. now apply add_le_mono_l.
 destruct LT as (z,LT).
 destruct (lt_exists_pred z y LT) as (y' & Hy' & _).
 exists y'. rewrite <- succ_inj_wd, H, Hy'. now nzsimpl'.
 left. exists y. rewrite <- succ_inj_wd. rewrite H. now nzsimpl.
Qed.

Lemma double_below : forall n m, n<=m -> 2*n < 2*m+1.
Proof.
 intros. nzsimpl'. apply lt_succ_r. now apply add_le_mono.
Qed.

Lemma double_above : forall n m, n<m -> 2*n+1 < 2*m.
Proof.
 intros. nzsimpl'.
 rewrite <- le_succ_l, <- add_succ_l, <- add_succ_r.
 apply add_le_mono; now apply le_succ_l.
Qed.

Lemma Even_Odd_False : forall x, Even x -> Odd x -> False.
Proof.
intros x (y,E) (z,O). rewrite O in E; clear O.
destruct (le_gt_cases y z) as [LE|GT].
generalize (double_below _ _ LE); order.
generalize (double_above _ _ GT); order.
Qed.

Lemma orb_even_odd : forall n, orb (even n) (odd n) = true.
Proof.
 intros.
 destruct (Even_or_Odd n) as [H|H].
 rewrite <- even_spec in H. now rewrite H.
 rewrite <- odd_spec in H. now rewrite H, orb_true_r.
Qed.

Lemma negb_odd : forall n, negb (odd n) = even n.
Proof.
 intros.
 generalize (Even_or_Odd n) (Even_Odd_False n).
 rewrite <- even_spec, <- odd_spec.
 destruct (odd n), (even n) ; simpl; intuition.
Qed.

Lemma negb_even : forall n, negb (even n) = odd n.
Proof.
 intros. rewrite <- negb_odd. apply negb_involutive.
Qed.

(** Constants *)

Lemma even_0 : even 0 = true.
Proof.
 rewrite even_spec. exists 0. now nzsimpl.
Qed.

Lemma odd_0 : odd 0 = false.
Proof.
 now rewrite <- negb_even, even_0.
Qed.

Lemma odd_1 : odd 1 = true.
Proof.
 rewrite odd_spec. exists 0. now nzsimpl'.
Qed.

Lemma even_1 : even 1 = false.
Proof.
 now rewrite <- negb_odd, odd_1.
Qed.

Lemma even_2 : even 2 = true.
Proof.
 rewrite even_spec. exists 1. now nzsimpl'.
Qed.

Lemma odd_2 : odd 2 = false.
Proof.
 now rewrite <- negb_even, even_2.
Qed.

(** Parity and successor *)

Lemma Odd_succ : forall n, Odd (S n) <-> Even n.
Proof.
 split; intros (m,H).
 exists m. apply succ_inj. now rewrite add_1_r in H.
 exists m. rewrite add_1_r. now f_equiv.
Qed.

Lemma odd_succ : forall n, odd (S n) = even n.
Proof.
 intros. apply eq_iff_eq_true. rewrite even_spec, odd_spec.
 apply Odd_succ.
Qed.

Lemma even_succ : forall n, even (S n) = odd n.
Proof.
 intros. now rewrite <- negb_odd, odd_succ, negb_even.
Qed.

Lemma Even_succ : forall n, Even (S n) <-> Odd n.
Proof.
 intros. now rewrite <- even_spec, even_succ, odd_spec.
Qed.

(** Parity and successor of successor *)

Lemma Even_succ_succ : forall n, Even (S (S n)) <-> Even n.
Proof.
 intros. now rewrite Even_succ, Odd_succ.
Qed.

Lemma Odd_succ_succ : forall n, Odd (S (S n)) <-> Odd n.
Proof.
 intros. now rewrite Odd_succ, Even_succ.
Qed.

Lemma even_succ_succ : forall n, even (S (S n)) = even n.
Proof.
 intros. now rewrite even_succ, odd_succ.
Qed.

Lemma odd_succ_succ : forall n, odd (S (S n)) = odd n.
Proof.
 intros. now rewrite odd_succ, even_succ.
Qed.

(** Parity and addition *)

Lemma even_add : forall n m, even (n+m) = Bool.eqb (even n) (even m).
Proof.
 intros.
 case_eq (even n); case_eq (even m);
  rewrite <- ?negb_true_iff, ?negb_even, ?odd_spec, ?even_spec;
  intros (m',Hm) (n',Hn).
 exists (n'+m'). now rewrite mul_add_distr_l, Hn, Hm.
 exists (n'+m'). now rewrite mul_add_distr_l, Hn, Hm, add_assoc.
 exists (n'+m'). now rewrite mul_add_distr_l, Hn, Hm, add_shuffle0.
 exists (n'+m'+1). rewrite Hm,Hn. nzsimpl'. now rewrite add_shuffle1.
Qed.

Lemma odd_add : forall n m, odd (n+m) = xorb (odd n) (odd m).
Proof.
 intros. rewrite <- !negb_even. rewrite even_add.
 now destruct (even n), (even m).
Qed.

(** Parity and multiplication *)

Lemma even_mul : forall n m, even (mul n m) = even n || even m.
Proof.
 intros.
 case_eq (even n); simpl; rewrite ?even_spec.
 intros (n',Hn). exists (n'*m). now rewrite Hn, mul_assoc.
 case_eq (even m); simpl; rewrite ?even_spec.
 intros (m',Hm). exists (n*m'). now rewrite Hm, !mul_assoc, (mul_comm 2).
 (* odd / odd *)
 rewrite <- !negb_true_iff, !negb_even, !odd_spec.
 intros (m',Hm) (n',Hn). exists (n'*2*m' +n'+m').
 rewrite Hn,Hm, !mul_add_distr_l, !mul_add_distr_r, !mul_1_l, !mul_1_r.
 now rewrite add_shuffle1, add_assoc, !mul_assoc.
Qed.

Lemma odd_mul : forall n m, odd (mul n m) = odd n && odd m.
Proof.
 intros. rewrite <- !negb_even. rewrite even_mul.
 now destruct (even n), (even m).
Qed.

(** A particular case : adding by an even number *)

Lemma even_add_even : forall n m, Even m -> even (n+m) = even n.
Proof.
 intros n m Hm. apply even_spec in Hm.
 rewrite even_add, Hm. now destruct (even n).
Qed.

Lemma odd_add_even : forall n m, Even m -> odd (n+m) = odd n.
Proof.
 intros n m Hm. apply even_spec in Hm.
 rewrite odd_add, <- (negb_even m), Hm. now destruct (odd n).
Qed.

Lemma even_add_mul_even : forall n m p, Even m -> even (n+m*p) = even n.
Proof.
 intros n m p Hm. apply even_spec in Hm.
 apply even_add_even. apply even_spec. now rewrite even_mul, Hm.
Qed.

Lemma odd_add_mul_even : forall n m p, Even m -> odd (n+m*p) = odd n.
Proof.
 intros n m p Hm. apply even_spec in Hm.
 apply odd_add_even. apply even_spec. now rewrite even_mul, Hm.
Qed.

Lemma even_add_mul_2 : forall n m, even (n+2*m) = even n.
Proof.
 intros. apply even_add_mul_even. apply even_spec, even_2.
Qed.

Lemma odd_add_mul_2 : forall n m, odd (n+2*m) = odd n.
Proof.
 intros. apply odd_add_mul_even. apply even_spec, even_2.
Qed.

End NZParityProp.


Require Import Wf_nat PeanoNat Psatz. (* lt_wf =? lia *)

Check lt_wf.

Definition dec : forall (b:bool), {b = true} + {b = false} :=
    fun (b:bool) =>
        match b as b' return {b' = true} + {b' = false} with
        | true  => left  (eq_refl true)
        | false => right (eq_refl false)
        end.

Definition fac : nat -> nat.
Proof.
refine (Fix lt_wf (fun _ => nat)
    (fun (n:nat) =>
        fun (fac : forall (y:nat), y < n -> nat) =>
            if dec (n =? 0)
                then 1
                else n * (fac (n - 1) _)
)).
clear fac.
destruct n as [|n].
    - inversion e.
    - lia.
Defined.

Compute fac 8.

(* works but no idea why                                                        *)
Lemma fac_S (n:nat) : fac (S n) = (S n) * fac n.
Proof.
    unfold fac at 1; rewrite Fix_eq; fold fac.
    now replace (S n - 1) with n by lia.
    now intros x f g H; case dec; intros; rewrite ?H.
Qed.


(*
inversion について。
*)

Require Export SfLib_J.

(*
Logic_J.vより。

Inversion 再び

これまでにも inversion が等値性にからむ仮定や帰納的に定義された命題に対して 使われるところを見てきま
した。今度もやることは変わりませんが、もう少し近くまで 寄って inversion の振る舞いを観察してみましょ
う。

一般的に inversion タクティックは、
- 帰納的に定義された型 P の命題 H をとる。
- その型 P の定義にある各コンストラクタ C が、
  - H が C から成っていると仮定するような新しいサブゴールを作る。
  - C の引数（前提）を、追加の仮定としてサブゴールのコンテキストに加える。
  - C の結論（戻り値の型）を現在のゴールとmatchして、 C を適用できるような一連の等式算出する。
  - そしてこれらの等式をサブゴールのコンテキストに加えてから、
  - もしこの等式が充足可能でない場合（S n = O というような式を含むなど）は、 即座にサブゴールを解決する。

例 : or で構築された仮定を反転（ invert ）すると、or に二つのコンストラクタが あるため二つのサブゴー
ルが生成されます。コンストラクタ (P ∨ Q) の結果 （戻り値の型）は P や Q の形からくる制約を付けません。
そのため追加の等式が サブゴールのコンテキストに加えられることはありません。

例 : and で構築された仮定を反転（ invert ）すると、and にはコンストラクタが 一つしかないため、サブゴー
ルも一つしか生成されません。やはり、コンストラクタ (P ∧ Q) の結果（戻り値の型）は P や Q の形からく
る制約を付けず、追加の等式が サブゴールのコンテキストに加えられることはありません。このコンストラクタ
は引数を二つ とりますが、それらはサブゴールのコンテキストに現れます。

例 : eq で構築された仮定を反転（ invert ）すると、これにもやはりコンストラクタが 一つしかないため、サ
ブゴールも一つしか生成されません。しかしこの場合 コンストラクタ refl_equal の形は我々にもう少し情報を
与えてくれます。 それは、eq の二つの引数は同じでなければならないという点です。 inversion タクティック
はこの事実をコンテキストに加えてくれます。

*)

(*
証明事例集: 自前で inversion を行う より
http://homepage2.nifty.com/magicant/programmingmemo/coq/maninv.html

ただし、ここでは同じ例題をinversionを使って証明する。
*)

(* 単純な例: even *)

Inductive even : nat -> Prop :=
  | even_O : even O
  | even_SS : forall n, even n -> even (S (S n)).

Goal ~ even 1.
Proof.
  intro H.
  inversion H.
Qed.
(*
even 1 には even_O と even_SS のどちらも当てはまらないため、inversion を使うと直ちに証明が完了する。
*)
(*
では、組み込みの inversion タクティクを使わない場合はどうするか。以下のように単純に case H をしただけ
では、even の引数が 1 であることが場合分けの後に忘れられてしまうので、False を導くための条件が揃わな
い。実際、case H した後の一つ目のサブゴールは case H をする前と全く変わっていない。（略）
*)

(* 追記： ~even 5のとき。*)

Goal ~ even 7.
Proof.
  intro H.
  inversion H.
  (* H1 : even 5 *)
  inversion H1.
  (* H3 : even 3 *)
  inversion H3.
  (* H5 : even 1 *)
  inversion H5.
Qed.

(* 途中で、いらない前提を消すと、見通しがよくなる。*)
Goal ~ even 7.
Proof.
  intro H.
  inversion H. subst. clear H.
  (* H1 : even 5 *)
  inversion H1. subst. clear H1.
  (* H0 : even 3 *)
  inversion H0. subst. clear H0.
  (* H1 : even 1 *)
  inversion H1.
Qed.

(* 次は証明できるに違いないが、前提のほうは even 0 から進まない。
また、前提Hを反転ることについては、GoalはTrueでもFalseでも関係ない、ことに注意するべきだ。
 *)
Goal even 2 -> True.
Proof.
  intro H.
  inversion H. subst. clear H.
  exact I.
Qed.

(* その上、とどめのinversion H1さえ、GoalがTrueでもFalseでも有効である。 *)
Goal even 3 -> True.
Proof.
  intro H.
  inversion H. subst. clear H.
  inversion H1.                             (* exact Iでもよいが。 *)
Qed.

(* さすがに、これは証明できない。*)
Goal even 2 -> False.
Proof.
  intro H.
  inversion H. subst. clear H.
  inversion H1.
Admitted.                                   (* OK *)

(* 今度は、S (S n) が偶数ならば n も偶数であることを示そう。*)
Goal forall n, even (S (S n)) -> even n.
Proof.
  intros n H.
  inversion H.
  apply H1.
Qed.

(* 複数の引数を取る述語: succ *)

(*
場合分けをする述語が複数の引数を取る場合は、それに合わせて複数の等式をゴールに追加する必要がある。こ
こでは、二つの自然数の後者関係を表す述語 succ を定義し、任意の自然数は自分自身の後者ではないことを示
そう。
*)

Inductive succ : nat -> nat -> Prop :=
  succ_intro : forall n, succ n (S n).
(* succ は二つの引数を取るので、それらに対応する二つの等式をゴールに追加してから case する。 *)

Goal forall n, ~ succ n n.
Proof.
  intros n H.
  induction n.
  inversion H.
  apply IHn.
  inversion H.
  apply H.
Qed.

(* 固定パラメータのある述語: le *)

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

le は二つの引数を受け取るように見えるが、実際には最初の引数は固定されたパラメータである。すなわち正確
には、任意の自然数 n に対して le n が一つの引数を受け取ると考える必要がある。そのため、inversion では
最初の引数 n に関する条件は得られず、最後の引数に関する条件だけが得られる。最後の引数に関する条件を場
合分けの後まで覚えておくために、最後の引数に関する等式をゴールに追加してから場合分けを行う。

なぜ最初の引数に関する等式を追加してはいけないのかというと、もしそうすると pattern 後の case で正しく
値が置き換えられないからである。
*)

(* 以下の例は、n <= 0 から n = 0 を導く証明である。 *)

Goal forall n, n <= 0 -> n = 0.
Proof.
  intros n H.
  induction n.
  reflexivity.
  inversion H.
Qed.

(*
タクティクリファレンス: 帰納法と場合分け より
http://homepage2.nifty.com/magicant/programmingmemo/coq/t-induct.html
*)

(*
inversion タクティク

inversion タクティクは、case タクティクや destruct タクティクのように代数的データ型に対する場合分けを
行うが、コンストラクタの引数に関する条件を保存する。

特定の値に関する条件を表す述語が代数的データ型として定義してあり、そのような述語が実際に前提として得
られている場合に、その述語から具体的な値に関する条件を取り出すのに使う。
*)

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

Goal forall n : nat, n <= 0 -> n = 0.
Proof.
  intros n H.
  inversion H as [ H' | ].
  reflexivity.
Qed.
(*
上の例では、前提 H : n <= 0 から条件 n = 0 を取り出すために inversion を用いている。述語 le には二つ
のコンストラクタがあるが、le_S から作ることのできる条件の型 n <= S m は前提 H の型 n <= 0 に適合しな
いため、この場合は自動的に除外される。le_n の型 n <= n と H の型 n <= 0 とを照らし合わせた結果として
条件 n = 0 が前提に追加され、この等式を利用して自動的にゴールの n が 0 に書き換えられる。
*)

(*
inversion ident
前提 ident に対して inversion を適用し、得られる条件を前提に追加する。指定した前提が存在しない場合は、
先に intros until ident を試みる。
as によって前提名を指定しないで inversion を使うと、処理系によって自動的に前提名が生成される。生成さ
れる前提名は常に同じとは限らないので、前提名に依存した証明を書く場合は以下の as を用いる構文を使うこ
と。

inversion num
intros until num を行い、最後に追加された前提に対して inversion を適用する。

inversion … as intropattern
追加される前提の名前を指定して inversion する。名前の指定のしかたは destruct … as … と似ているが、
inversion が取り出した条件 (等式) の名前も追加で指定する必要がある。条件の名前の指定は injection …
as … に準ずる。名前が足りない場合は処理系が自動的に名前を選ぶので注意。
*)

Inductive list_in {A : Type} : A -> list A -> Prop :=
| in_hd : forall a l, list_in a (a :: l)
| in_tl : forall a b l, list_in a l -> list_in a (b :: l).

Goal forall l, list_in 0 (1 :: l) -> list_in 0 l.
Proof.
  inversion 1 as [ | a b l' H' H1 [H2 H3] ].
  exact H'.
Qed.
(*
上の例では、述語 list_in の二つのコンストラクタのうち in_hd の場合については条件が合わずに自動的に除
外されるので名前を指定していない。in_tl の場合の名前の指定は、まず a, b, l', H' の四つがそれぞれ
in_tl の四つの引数に対応しており (ここまでは destruct と同じ)、その後の H1 と [H2 H3] はそれぞれ
list_in の二つの引数 (A 型と list A 型) に対応して得られる二つの条件 a = 0 と b :: l' = 1 :: l に対応
している。後者は自動的に適用される injection により b = 1 と l' = l とに分解されるため、それに合わせ
て H2 と H3 の二つの名前を指定している。
*)

(*
inversion … in ident1 … identn
ゴールだけでなく前提 ident1 … identn においても、得られた条件に基づいた書き換えを行う。

inversion … as … in …
inversion タクティクの最も一般的な形。

inversion_clear ident
inversion_clear ident as …
inversion_clear ident in …
inversion_clear ident as … in …
inversion した後に、ident および不要な条件等を自動的に前提から消去する。

inversion ident1 using ident2
inversion ident1 using ident2 in …
Derive Inversion コマンドで作成した補題 ident2 を使用して inversion ident1 を行う。
*)

Derive Inversion le_0_inv with (forall n, n <= 0) Sort Prop.

Check le_0_inv.
(*
le_0_inv
     : forall (n : nat) (P : nat -> Prop),
       (n <= 0 -> n = 0 -> P 0) -> n <= 0 -> P n
*)

Goal forall n, n <= 0 -> n = 0.
Proof.
  intros n H.
  inversion H using le_0_inv.
  reflexivity.
Qed.
(*
この例で inversion H using le_0_inv がしていることは、pattern n; apply le_0_inv, H に等しい。
*)

(*
Derive Inversion コマンドの亜種として、Derive Inversion_clear, Derive Dependent Inversion, Derive
Dependent Inversion_clear コマンドがある。

dependent inversion ident
dependent inversion ident as …
dependent inversion ident with …
dependent inversion ident as … with …
dependent inversion_clear ident
dependent inversion_clear ident as …
dependent inversion_clear ident with …
dependent inversion_clear ident as … with …
ident 自体がゴールの型に含まれる場合に使う。通常の inversion/inversion_clear の処理をする他に、ゴール
の型に含まれる ident を実際に場合分けされた値に置換する。

simple inversion ident
simple inversion num
より単純な inversion を行う。すなわち、場合分けの際に条件が噛み合わない場合を除外したり、得られた条件
を元にゴールを書き換えたりしない。追加される前提名は処理系が自動的に選ぶので、前提名に依存した証明を
書く際には使わないこと。*)

(* END *)


(********************************************************************)
(*                                                                  *)
(*  The Why3 Verification Platform   /   The Why3 Development Team  *)
(*  Copyright 2010-2018   --   Inria - CNRS - Paris-Sud University  *)
(*                                                                  *)
(*  This software is distributed under the terms of the GNU Lesser  *)
(*  General Public License version 2.1, with the special exception  *)
(*  on linking described in file LICENSE.                           *)
(*                                                                  *)
(********************************************************************)

(* This file is generated by Why3's Coq-realize driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.

(* Why3 comment *)
(* infix_ls is replaced with (x < x1)%Z by the coq driver *)

(* Why3 goal *)
Lemma infix_lseq_def :
  forall (x:Z) (y:Z), (x <= y)%Z <-> ((x < y)%Z \/ (x = y)).
exact Zle_lt_or_eq_iff.
Qed.

(* Why3 comment *)
(* infix_pl is replaced with (x + x1)%Z by the coq driver *)

(* Why3 comment *)
(* prefix_mn is replaced with (-x)%Z by the coq driver *)

(* Why3 comment *)
(* infix_as is replaced with (x * x1)%Z by the coq driver *)

(* Why3 goal *)
Lemma Assoc :
forall (x:Z) (y:Z) (z:Z), (((x + y)%Z + z)%Z = (x + (y + z)%Z)%Z).
Proof.
intros x y z.
apply sym_eq.
apply Zplus_assoc.
Qed.

(* Why3 goal *)
Lemma Unit_def_l :
forall (x:Z), ((0%Z + x)%Z = x).
Proof.
exact Zplus_0_l.
Qed.

(* Why3 goal *)
Lemma Unit_def_r :
forall (x:Z), ((x + 0%Z)%Z = x).
Proof.
exact Zplus_0_r.
Qed.

(* Why3 goal *)
Lemma Inv_def_l :
forall (x:Z), (((-x)%Z + x)%Z = 0%Z).
Proof.
exact Zplus_opp_l.
Qed.

(* Why3 goal *)
Lemma Inv_def_r :
forall (x:Z), ((x + (-x)%Z)%Z = 0%Z).
Proof.
exact Zplus_opp_r.
Qed.

(* Why3 goal *)
Lemma Comm :
forall (x:Z) (y:Z), ((x + y)%Z = (y + x)%Z).
Proof.
exact Zplus_comm.
Qed.

(* Why3 goal *)
Lemma Assoc1 :
forall (x:Z) (y:Z) (z:Z), (((x * y)%Z * z)%Z = (x * (y * z)%Z)%Z).
Proof.
intros x y z.
apply sym_eq.
apply Zmult_assoc.
Qed.

(* Why3 goal *)
Lemma Mul_distr_l :
forall (x:Z) (y:Z) (z:Z), ((x * (y + z)%Z)%Z = ((x * y)%Z + (x * z)%Z)%Z).
Proof.
intros x y z.
apply Zmult_plus_distr_r.
Qed.

(* Why3 goal *)
Lemma Mul_distr_r :
forall (x:Z) (y:Z) (z:Z), (((y + z)%Z * x)%Z = ((y * x)%Z + (z * x)%Z)%Z).
Proof.
intros x y z.
apply Zmult_plus_distr_l.
Qed.

(* Why3 goal *)
Lemma infix_mn_def : forall (x:Z) (y:Z), ((x - y)%Z = (x + (-y)%Z)%Z).
reflexivity.
Qed.

(* Why3 goal *)
Lemma Comm1 :
forall (x:Z) (y:Z), ((x * y)%Z = (y * x)%Z).
Proof.
exact Zmult_comm.
Qed.

(* Why3 goal *)
Lemma Unitary :
forall (x:Z), ((1%Z * x)%Z = x).
Proof.
exact Zmult_1_l.
Qed.

(* Why3 goal *)
Lemma NonTrivialRing :
~ (0%Z = 1%Z).
Proof.
discriminate.
Qed.

(* Why3 goal *)
Lemma Refl :
forall (x:Z), (x <= x)%Z.
Proof.
intros x.
apply Zle_refl.
Qed.

(* Why3 goal *)
Lemma Trans :
forall (x:Z) (y:Z) (z:Z), (x <= y)%Z -> ((y <= z)%Z -> (x <= z)%Z).
Proof.
exact Zle_trans.
Qed.

(* Why3 goal *)
Lemma Antisymm :
forall (x:Z) (y:Z), (x <= y)%Z -> ((y <= x)%Z -> (x = y)).
Proof.
exact Zle_antisym.
Qed.

(* Why3 goal *)
Lemma Total :
forall (x:Z) (y:Z), (x <= y)%Z \/ (y <= x)%Z.
Proof.
intros x y.
destruct (Zle_or_lt x y) as [H|H].
left.
assumption.
right.
now apply Zlt_le_weak.
Qed.

(* Why3 goal *)
Lemma ZeroLessOne :
(0%Z <= 1%Z)%Z.
Proof.
apply Zle_lt_or_eq_iff.
now left.
Qed.

(* Why3 goal *)
Lemma CompatOrderAdd :
forall (x:Z) (y:Z) (z:Z), (x <= y)%Z -> ((x + z)%Z <= (y + z)%Z)%Z.
Proof.
exact Zplus_le_compat_r.
Qed.

(* Why3 goal *)
Lemma CompatOrderMult :
forall (x:Z) (y:Z) (z:Z),
 (x <= y)%Z -> ((0%Z <= z)%Z -> ((x * z)%Z <= (y * z)%Z)%Z).
Proof.
exact Zmult_le_compat_r.
Qed.


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

Require Import List Arith Omega.

Set Implicit Arguments.

Section sublist_defs.

  Variable X : Type.

  Reserved Notation "x '<sl' y" (at level 70).

  Inductive sublist : list X -> list X -> Prop :=
    | in_sl_0 : forall ll, nil <sl ll
    | in_sl_1 : forall a ll mm, ll <sl mm -> a::ll <sl a::mm
    | in_sl_2 : forall a ll mm, ll <sl mm -> ll <sl a::mm
  where "x <sl y" := (sublist x y).

  Hint Constructors sublist.

  Fact sl_refl ll : ll <sl ll.              Proof. induction ll; auto. Qed.

  Hint Resolve sl_refl.

  Fact sl_cons a ll : ll <sl a::ll.         Proof. auto. Qed.
  Fact sl_app_left ll mm : mm <sl ll++mm.   Proof. induction ll; simpl; auto. Qed.
  Fact sl_app_right ll mm : ll <sl ll++mm.  Proof. induction ll; simpl; auto. Qed.

  Hint Resolve sl_cons sl_app_left sl_app_right.

  Fact sl_nil_inv l : l <sl nil <-> l = nil.
  Proof.
    split.
    + inversion 1; auto.
    + intros; subst; auto.
  Qed.

  Fact sl_cons_inv x y l m : x::l <sl y::m <-> (x = y /\ l <sl m) \/ x::l <sl m.
  Proof.
    split.
    + inversion 1; subst; auto.
    + intros [[]|]; subst; auto.
  Qed.

End sublist_defs.

Infix "<sl" := (@sublist _) (at level 70).

Hint Constructors sublist.
Hint Resolve sl_refl sl_cons sl_app_left sl_app_right.

Tactic Notation "sl" "nil" "inv" hyp(H) :=
  repeat match type of H with
    | _::_  <sl nil   => rewrite sl_nil_inv in H; discriminate
    | _     <sl nil   => rewrite sl_nil_inv in H; subst
  end; auto.

Tactic Notation "sl" "cons" "inv" hyp(H) "left" :=
  match type of H with
    | ?a::_ <sl ?b::_ => rewrite sl_cons_inv in H; destruct H as [ (?&H) | H ]; [ subst a | ]
  end; auto.

Tactic Notation "sl" "cons" "inv" hyp(H) "right" :=
  match type of H with
    | ?a::_ <sl ?b::_ => rewrite sl_cons_inv in H; destruct H as [ (?&H) | H ]; [ subst b | ]
  end; auto.

Tactic Notation "sl" "inv" hyp(H) :=
  repeat match type of H with
    | _ <sl nil       => sl nil inv H
    | ?a::_ <sl ?b::_ => sl cons inv H left
    | ?l    <sl _::_  => destruct l as [ | ? l ]; auto; sl cons inv H left
    | ?a::_ <sl ?l    => destruct l as [ | ? l ]; auto; sl cons inv H right
  end; auto.

Section sublist_props.

  Variable (X : Type).

  Implicit Type (l ll : list X).

  Fact sl_trans l1 l2 l3 : l1 <sl l2 -> l2 <sl l3 -> l1 <sl l3.
  Proof.
    intros H1 H2; revert H2 l1 H1.
    induction 1; intros ? H1; auto; sl inv H1.
  Qed.

  Fact sl_app l1 m1 l2 m2 : l1 <sl l2 -> m1 <sl m2 -> l1++m1 <sl l2++m2.
  Proof.
    intros H1 H2.
    apply sl_trans with (l2 := l1++m2); auto.
    + clear H1; induction l1; simpl; auto.
    + clear H2; induction H1; simpl; auto.
  Qed.

  Fact sublist_nil_inv x l : x::l <sl nil <-> False.
  Proof. split; inversion 1; auto. Qed.

  Fact sublist_inv_cons l a : l <sl a::nil <-> l = nil \/ l = a::nil.
  Proof.
    split.
    + intros H; sl inv H.
    + intros [|]; subst; auto.
  Qed.

  Fact sublist_app_inv_lft l1 r1 mm : l1++r1 <sl mm -> exists l2 r2, mm = l2++r2 /\ l1 <sl l2 /\ r1 <sl r2.
  Proof.
    revert l1 r1; induction mm as [ | x mm IH ]; simpl; intros l1 r1 H.
    + sl inv H; destruct l1; destruct r1; try discriminate; exists nil, nil; auto.
    + destruct l1 as [ | y l1 ].
      * exists nil, (x::mm); auto.
      * simpl in H; sl inv H.
        - destruct (IH _ _ H) as (l2 & r2 & H1 & H2 & H3).
          exists (x::l2), r2; subst; auto.
        - destruct (IH (_::_) _ H) as (l2 & r2 & H1 & H2 & H3).
          exists (x::l2), r2; subst; auto.
  Qed.

  Fact sublist_app_inv_rt ll l2 r2 : ll <sl l2++r2 -> exists l1 r1, ll = l1++r1 /\ l1 <sl l2 /\ r1 <sl r2.
  Proof.
    revert ll; induction l2 as [ | x l2 IH ]; intros ll H.
    + exists nil, ll; auto.
    + destruct ll as [ | y ll ].
      * exists nil, nil; auto.
      * simpl in H; sl inv H; destruct (IH _ H) as (l1 & r1 & H1 & H2 & H3).
        - exists (x::l1), r1; subst; auto.
        - exists l1, r1; subst; auto.
  Qed.

  Fact sublist_cons_inv_rt ll x mm : ll <sl x::mm -> ll <sl mm \/ exists l', ll = x::l' /\ l' <sl mm.
  Proof. destruct ll; auto; intros H; sl inv H; right; firstorder. Qed.

  Fact sl_length ll mm : ll <sl mm -> length ll <= length mm.
  Proof. induction 1; simpl; auto; omega. Qed.

  Fact sl_In ll mm x : ll <sl mm -> In x ll -> In x mm.
  Proof. induction 1; simpl; tauto. Qed.

  Fact In_sl x ll : In x ll <-> x::nil <sl ll.
  Proof.
    split.
    + intros H; apply in_split in H.
      destruct H as (? & ? & ?); subst.
      apply sl_trans with (2 := sl_app_left _ _); auto.
    + intros H; apply (sl_In _ H); left; auto.
  Qed.

  Fact sl_erase l m r mm : l++m++r <sl mm -> l++r <sl mm.
  Proof. intros H; apply sl_trans with (2 := H), sl_app; auto. Qed.

  Fact sl_snoc l m x : l <sl m -> l <sl (m++x::nil).
  Proof. intros H; apply sl_trans with (1 := H); auto. Qed.

  Hint Resolve sl_app sl_snoc.

  Fact sl_rev l m : l <sl m -> rev l <sl rev m.
  Proof. induction 1; simpl; auto. Qed.

  Fact sublist_cons_inv x ll mm : x::ll <sl mm <-> exists l r, mm = l++x::r /\ ll <sl r.
  Proof.
    split.
    * change (x::ll) with ((x::nil)++ll); intros H.
      apply sublist_app_inv_lft in H.
      destruct H as (pp & r & H1 & H2 & H3).
      rewrite <- In_sl in H2.
      apply in_split in H2.
      destruct H2 as (l & m & H2); subst.
      exists l, (m++r); rewrite app_ass; simpl; split; auto.
      apply sl_trans with (1 := H3); auto.
    * intros (? & ? & ? & ?); subst.
      apply sl_trans with (2 := sl_app_left _ _); auto.
  Qed.

  Fact sublist_snoc_inv ll mm x : ll <sl mm++x::nil -> ll <sl mm \/ exists l', l' <sl mm /\ ll = l'++x::nil.
  Proof.
    intros H.
    apply sublist_app_inv_rt in H.
    destruct H as ( l1 & r1 & H1 & H2 & H3 ).
    inversion H3; subst.
    left; rewrite <- app_nil_end; auto.
    apply sublist_inv_cons in H3.
    destruct H3 as [ H3 | H3 ]; try discriminate H3.
    injection H3; clear H3; intros; subst.
    right; exists l1; auto.
    left; rewrite (app_nil_end mm); auto.
  Qed.

  Fact sl_cons_erase a l m : a::l <sl m -> l <sl m.
  Proof. apply sl_erase with (l := nil) (m := a::nil). Qed.

  Fact sublist_eq ll mm : ll <sl mm -> length mm <= length ll -> ll = mm.
  Proof.
    induction 1 as [ mm | a ll mm H IH | a ll mm H IH ].
    destruct mm; simpl; try omega; auto.
    simpl; intros H1; apply le_S_n in H1; f_equal; auto.
    simpl; intros H1; apply sl_length in H; omega.
  Qed.

End sublist_props.

Hint Resolve sl_app sl_snoc.

Fact sublist_map X Y (f : X -> Y) l m : l <sl m -> map f l <sl map f m.
Proof. induction 1; simpl; auto. Qed.


Require Import Logic.Nat.Fresh.
Require Import Logic.Fol.Syntax.

Definition Formula : Type := P nat.

Definition Not (p:Formula)          :Formula := Imp p Bot.
Definition Or  (p q:Formula)        :Formula := Imp (Not p) q.
Definition And (p q:Formula)        :Formula := Not (Or (Not p) (Not q)).
Definition Exi  (n:nat) (p:Formula) :Formula := Not (All n (Not p)).
Definition Iff (p q:Formula)        :Formula := And (Imp p q) (Imp q p).

Definition Sub (n m:nat) : Formula :=
    let x := fresh n m in
        All x (Imp (Elem x n) (Elem x m)).

Definition Equ (n m:nat) : Formula :=
    let x := fresh n m in And
        (All x (Iff (Elem x n) (Elem x m)))
        (All x (Iff (Elem n x) (Elem m x))).

Definition Empty (n:nat) : Formula :=
    let x := fresh n n in
        All x (Not (Elem x n)).

(* Predicate expressing the 'minimality' of a set n in a set m                  *)
Definition Min (n m:nat) : Formula :=
    let x := fresh n m in And
        (Elem n m)
        (Not (Exi x (And (Elem x m) (Elem x n)))).


From Coq Require Import ArithRing.
From Coq Require Import Compare_dec.
From Coq Require Import Wf_nat.
From Coq Require Import Arith.
From Coq Require Import Lia.

Lemma add_zero_r : forall n, n + 0 = n.
Proof.
  intros n.
  induction n.
  reflexivity.
  simpl.
  rewrite IHn.
  reflexivity.
Qed.

Lemma x_times_2_is_even : forall x : nat,
  Nat.even (2*x) = true.
Proof.
  simpl.
  induction x.
  - simpl.
    reflexivity.
  - rewrite add_zero_r.
    rewrite add_zero_r in IHx.
    replace (S x + S x) with (S (S (x + x))).
    + simpl.
      apply IHx.
    + simpl.
      rewrite (Nat.add_comm x (S x)).
      simpl.
      reflexivity.
Qed.

Lemma even_exists : forall x : nat,
  Nat.even x = true -> exists k, 2*k = x.
Proof.
  intros.
  apply Nat.even_spec in H.
  unfold Nat.Even in H.
  destruct H.
  exists x0.
  symmetry.
  apply H.
Qed.

Lemma next_even_is_odd : forall x : nat,
  Nat.even x = negb (Nat.even (S x)).
Proof.
  intros.
  induction x.
  - simpl.
    reflexivity.
  - simpl.
    rewrite -> IHx.
    rewrite -> Bool.negb_involutive.
    reflexivity.
Qed.

Lemma cancel_negb : forall a b: bool,
  negb a = negb b -> a = b.
Proof.
  intros.
  destruct a.
  - destruct b.
    + reflexivity.
    + simpl in H.
      symmetry.
      apply H.
  - destruct b.
    + simpl in H.
      symmetry.
      apply H.
    + reflexivity.
Qed.

Lemma even_is_xor: forall x y : nat,
  Nat.even (x+y) = negb (xorb (Nat.even x) (Nat.even y)).
Proof.
  intros.
  induction x.
  - simpl.
    case (Nat.even y); reflexivity.
  - rewrite next_even_is_odd in IHx.
    rewrite (next_even_is_odd x) in IHx.
    apply cancel_negb in IHx.
    rewrite Nat.add_succ_l.
    rewrite -> IHx.
    clear IHx.
    rewrite Bool.negb_xorb_l.
    reflexivity.
Qed.

Lemma square_even_is_even : forall x : nat,
  Nat.even (x*x) = Nat.even x.
Proof.
  intros.
  induction x.
  - simpl.
    reflexivity.
  - replace (S x * S x) with ((1 + x) * (1 + x)).
    2: {
      simpl.
      reflexivity.
    }
    rewrite Nat.mul_add_distr_r.
    rewrite Nat.mul_add_distr_l.
    repeat rewrite Nat.mul_1_l.
    rewrite Nat.mul_add_distr_l.
    repeat rewrite Nat.mul_1_r.
    rewrite Nat.add_assoc.
    repeat rewrite <- Nat.add_assoc.
    repeat rewrite even_is_xor.
    repeat rewrite <- IHx.
    replace (Nat.even 1) with false.
    2 : { trivial. }
    rewrite -> Bool.xorb_false_l.
    rewrite -> Bool.xorb_nilpotent.
    rewrite -> Bool.negb_involutive.
    replace (negb false) with (true).
    2 : { trivial. }
    rewrite -> Bool.xorb_true_r.
    rewrite -> IHx.
    clear IHx.
    induction x.
    + simpl.
      reflexivity.
    + rewrite <- IHx.
      rewrite -> Bool.negb_involutive.
      simpl.
      reflexivity.
Qed.

Lemma cancel_2: forall x y : nat,
  2 * x = 2 * y -> x = y.
Proof.
  intros.
  lia.
Qed.

Theorem sqrt2_infinite_descent: forall p q,
  (q <> 0 /\ p*p = 2*q*q) -> exists pp qq : nat,
 (qq <> 0 /\ pp * pp = 2 * qq * qq) /\ qq < q.
Proof.
  intros p q [qnz eq].
  assert (eq' := eq).

  assert (Nat.even (p*p) = true).
  {
    rewrite -> eq.
    rewrite <- Nat.mul_assoc.
    apply x_times_2_is_even.
  }

  assert (Nat.even p = true).
  {
    rewrite square_even_is_even in H.
    apply H.
  }

  apply even_exists in H0.
  destruct H0 as [p' Hp'].
  rewrite <- Hp' in eq.
  repeat rewrite <- Nat.mul_assoc in eq.
  apply cancel_2 in eq.
  rewrite Nat.mul_comm in eq.
  clear H.

  assert (Nat.even (q*q) = true).
  {
    rewrite <- eq.
    rewrite <- Nat.mul_assoc.
    apply x_times_2_is_even.
  }

  assert (Nat.even q = true).
  {
    rewrite square_even_is_even in H.
    apply H.
  }

  apply even_exists in H0.
  destruct H0 as [q' Hq'].
  rewrite <- Hq' in eq.
  repeat rewrite <- Nat.mul_assoc in eq.
  apply cancel_2 in eq.
  symmetry in eq.
  rewrite Nat.mul_comm in eq.
  clear H.
  symmetry in eq.

  assert (q > q').
  lia.

  exists p'.
  exists q'.
  split.
  split.
  rewrite <- Hq' in qnz.
  lia.
  apply eq.
  apply H.
Qed.

Definition lt_nat (p q : nat*nat) := snd p < snd q.

Theorem lt_wf: well_founded lt_nat.
Proof.
  apply (well_founded_lt_compat (nat*nat) snd).
  intros.
  unfold lt_nat in H.
  apply H.

Qed.

Theorem infinite_descent: forall f : nat -> nat -> Prop,
  (forall p q : nat, ((f p q) -> exists p' q' : nat, (f p' q') /\ q' < q)) ->
  forall r s : nat, ~(f r s).
Proof.
  intros f H.
  intros r s.
  pose (rs := (r,s)).
  replace r with (fst rs); try reflexivity.
  replace s with (snd rs); try reflexivity.
  apply (well_founded_ind lt_wf (fun x => ~(f (fst x) (snd x)))).
  intros.
  specialize (H (fst x) (snd x)).
  unfold not.
  intros HA.
  apply H in HA.
  destruct HA as [A HA].
  destruct HA as [B HA].
  specialize (H0 (A,B)).
  unfold lt_nat in H0.
  destruct HA.
  simpl in H0.
  apply H0 in H2.
  apply H2.
  apply H1.
Qed.

Theorem sqrt2_is_irrational: forall p q: nat,
  q <> 0 -> p*p <> 2*q*q.
Proof.
  intros p q qnz.
  unfold not.
  intros eq.
  specialize (infinite_descent (fun (p q : nat) => q <> 0 /\ p * p = 2 * q * q)).
  intros id.
  simpl in id.
  generalize sqrt2_infinite_descent.
  intros.
  simpl in H.
  assert (forall r s : nat, ~(s <> 0 /\ r * r = (s + (s + 0)) * s)).
  {
    apply id.
    apply H.
  }

  specialize (H0 p q).
  unfold not in H0.
  destruct H0.
  split.
  apply qnz.
  apply eq.

Qed.

  Set Printing All


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