Declare Scope mynat_scope.
Local Open Scope mynat_scope.
Set Printing Projections.

Inductive mynat : Set :=
  | zero : mynat
  | succ : mynat -> mynat.

Notation "0" := zero.
Notation "x `" := (succ x) (at level 5, left associativity, format "x `").

Fixpoint repeat {A : Type} (n : mynat) (f : A -> A) (x : A) : A :=
  match n with
  | 0 => x
  | n2` => f (repeat n2 f x)
  end.

Definition plus (a b : mynat) : mynat :=
  repeat b succ a.
Infix "+" := plus.

Definition fin (a : mynat) : Set :=
  repeat a (fun (x : Set) => x + unit)%type Empty_set.

Definition inv {A B : Type} (g : B -> A) (f : A -> B) : Prop :=
  forall x, g (f x) = x.

Record bij (A B : Type) : Type := make_bij {
  fw_map : A -> B;
  bw_map : B -> A;
  left_inv : inv bw_map fw_map;
  right_inv : inv fw_map bw_map;
}.
Arguments fw_map {A B}.
Arguments bw_map {A B}.
Arguments left_inv {A B}.
Arguments right_inv {A B}.

Definition size (A : Type) (a : mynat) : Prop :=
  inhabited (bij A (fin a)).

Definition bij_id (A : Type) : bij A A.
  exists
    (fun x => x)
    (fun y => y);
  intro x; trivial.
Defined.

Definition bij_rev {A B : Type} (f : bij A B) : bij B A.
  exists
    (f.(bw_map))
    (f.(fw_map)).
  - exact f.(right_inv).
  - exact f.(left_inv).
Defined.

Definition bij_comp {A B C : Type} (f : bij A B) (g : bij B C) : bij A C.
  exists
    (fun x => g.(fw_map) (f.(fw_map) x))
    (fun z => f.(bw_map) (g.(bw_map) z)).
  - intro x. repeat rewrite left_inv. trivial.
  - intro z. repeat rewrite right_inv. trivial.
Defined.

Theorem size_fin : forall a, size (fin a) a.
  intro a. split. exact (bij_id (fin a)).
Defined.

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

Theorem injective_left_inv : forall {A B} (g : B -> A) (f : A -> B), inv g f -> injective f.
  intros A B f g H x y H2.
  rewrite <- (H x), <- (H y), H2.
  trivial.
Qed.

Definition drop_right {A B : Type} (x : A + B) (P : forall y, x <> inr y) : A :=
  match x with
  | inl y => fun H => y
  | inr y => fun H => False_rect A (P y H)
  end eq_refl.

Theorem drop_right_spec :
  forall {A B} (x : A + B) (P : forall y, x <> inr y), inl (drop_right x P) = x.
Proof.
  intros A B x P.
  unfold drop_right.
  destruct x as [y|y].
  - trivial.
  - pose (P y) as H.
    contradict H.
    trivial.
Qed.

Definition untangle_unit {A B : Type} (f : A + unit -> B + unit) (x : A) : B + unit :=
  match f (inl x) with
  | inl y => inl y
  | inr tt => f (inr tt)
  end.

Theorem untangle_unit_spec :
  forall {A B} (f : A + unit -> B + unit),
    injective f -> forall x y, untangle_unit f x <> inr y.
Proof.
  intros A B f H x [].
  unfold untangle_unit.
  destruct (f (inl x)) as [z|[]] eqn:E.
  - discriminate.
  - rewrite <- E.
    intro H2.
    apply H in H2.
    discriminate.
Qed.

Definition drop_unit {A B : Type} (f : A + unit -> B + unit) (P : injective f) (x : A) : B :=
  drop_right (untangle_unit f x) (untangle_unit_spec f P x).

Theorem inl_injective : forall {A} B (x y : A), (inl x : A + B) = inl y -> x = y.
  intros A B x y H.
  inversion H.
  trivial.
Qed.

Theorem drop_unit_inv :
  forall {A B} (f : A + unit -> B + unit) (g : B + unit -> A + unit) (PL : inv g f) (PR : inv f g),
    inv (drop_unit g (injective_left_inv f g PR)) (drop_unit f (injective_left_inv g f PL)).
Proof.
  intros A B f g PL PR x.
  set (HF := injective_left_inv g f PL).
  set (HG := injective_left_inv f g PR).
  apply (inl_injective unit).
  unfold drop_unit at 1, untangle_unit.
  simpl.
  rewrite drop_right_spec.
  destruct (g (inl (drop_unit f HF x))) as [z|[]] eqn:E;
    unfold drop_unit, untangle_unit in E;
    rewrite drop_right_spec in E;
    destruct (f (inl x)) as [y|[]] eqn:E2.
  - rewrite <- E, <- E2.
    apply PL.
  - rewrite PL in E.
    discriminate.
  - rewrite <- E2, PL in E.
    discriminate.
  - rewrite <- E2.
    apply PL.
Qed.

Definition bij_drop_unit {A B : Type} (f : bij (A + unit) (B + unit)) : bij A B.
  exists
    (drop_unit f.(fw_map) (injective_left_inv f.(bw_map) f.(fw_map) f.(left_inv)))
    (drop_unit f.(bw_map) (injective_left_inv f.(fw_map) f.(bw_map) f.(right_inv)));
  apply drop_unit_inv.
Defined.

Theorem bij_fin_empty : forall n, bij (fin n) Empty_set -> n = 0.
  intros [|n] b.
  - trivial.
  - destruct b as [f g H1 H2].
    destruct (f (inr tt)).
Qed.

Theorem bij_fin_fin : forall m n, bij (fin m) (fin n) -> m = n.
  induction m as [|m IH]; intros n b.
  - apply bij_rev, bij_fin_empty in b.
    symmetry.
    trivial.
  - destruct n as [|n].
    + apply bij_fin_empty, b.
    + apply f_equal, IH, bij_drop_unit, b.
Qed.

Theorem size_fin_eq : forall m n, size (fin m) n -> m = n.
  intros m n [b].
  apply bij_fin_fin, b.
Qed.

Theorem size_unique : forall A m n, size A m -> size A n -> m = n.
  intros A m n [bm] [bn].
  apply bij_fin_fin.
  exact (bij_comp (bij_rev bm) bn).
Qed.

Theorem bij_size_eq : forall A B m n, bij A B -> size A m -> size B n -> m = n.
  intros A B m n b [bm] [bn].
  apply bij_fin_fin.
  exact (bij_comp (bij_rev bm) (bij_comp b bn)).
Qed.

Definition bij_sum_empty_r (A : Type) : bij (A + Empty_set) A.
  exists
    (sum_rect (fun _ => A) (fun x => x) (Empty_set_rect (fun _ => A)))
    inl;
  intro x; tauto.
Defined.

Definition bij_sum_empty_l (A : Type) : bij (Empty_set + A) A.
  exists
    (sum_rect (fun _ => A) (Empty_set_rect (fun _ => A)) (fun x => x))
    inr;
  intro x; tauto.
Defined.

Definition bij_sum {A B C D : Type} (f : bij A B) (g : bij C D) : bij (A + C) (B + D).
  exists
    (sum_rect _ (fun a => inl (f.(fw_map) a)) (fun c => inr (g.(fw_map) c)))
    (sum_rect _ (fun b => inl (f.(bw_map) b)) (fun d => inr (g.(bw_map) d))).
  - intros [a|c]; simpl; rewrite left_inv; trivial.
  - intros [b|d]; simpl; rewrite right_inv; trivial.
Defined.

Definition bij_sum_assoc (A B C : Type) : (bij (A + (B + C)) ((A + B) + C))%type.
  exists
    (sum_rect _ (fun a => inl (inl a)) (sum_rect _ (fun b => inl (inr b)) (fun c => inr c)))
    (sum_rect _ (sum_rect _ (fun a => inl a) (fun b => inr (inl b))) (fun c => inr (inr c)));
  intro x; tauto.
Defined.

Definition bij_sum_comm (A B : Type) : (bij (A + B) (B + A))%type.
  exists
    (sum_rect _ (fun a => inr a) (fun b => inl b))
    (sum_rect _ (fun b => inr b) (fun a => inl a));
  intro x; tauto.
Defined.

Fixpoint bij_plus (a b : mynat) : bij (fin a + fin b)%type (fin (a + b)) :=
  match b with
  | 0 => bij_sum_empty_r (fin a)
  | c` => 
      bij_comp
        (bij_sum_assoc (fin a) (fin c) unit)
        (bij_sum (bij_plus a c) (bij_id unit))
  end.

Theorem size_plus : forall A B a b, size A a -> size B b -> size (A + B)%type (a + b).
  intros A B a b [fa] [fb]. split.
  exact (bij_comp (bij_sum fa fb) (bij_plus a b)).
Qed.

Theorem plus_zero_r : forall n, n + 0 = n.
  intro n.
  apply (bij_size_eq (fin n + fin 0) (fin n)).
  - apply bij_sum_empty_r.
  - apply size_plus; apply size_fin.
  - apply size_fin.
Qed.

Theorem plus_zero_l : forall n, 0 + n = n.
  intro n.
  apply (bij_size_eq (fin 0 + fin n) (fin n)).
  - apply bij_sum_empty_l.
  - apply size_plus; apply size_fin.
  - apply size_fin.
Qed.

Theorem plus_assoc : forall a b c, a + (b + c) = (a + b) + c.
  intros a b c.
  apply (bij_size_eq (fin a + (fin b + fin c)) ((fin a + fin b) + fin c)).
  - apply bij_sum_assoc.
  - repeat apply size_plus; apply size_fin.
  - repeat apply size_plus; apply size_fin.
Qed.

Theorem plus_comm : forall a b, a + b = b + a.
  intros a b.
  apply (bij_size_eq (fin a + fin b) (fin b + fin a)).
  - apply bij_sum_comm.
  - apply size_plus; apply size_fin.
  - apply size_plus; apply size_fin.
Qed.

Definition times (a b : mynat) : mynat :=
  repeat a (fun n => n + b) 0.
Infix "*" := times.

Definition bij_fin_unit : bij (fin 0`) unit :=
  bij_sum_empty_l unit.

Definition bij_prod {A B C D : Type} (f : bij A B) (g : bij C D) : bij (A * C) (B * D).
  exists
    (fun x => (f.(fw_map) (fst x), g.(fw_map) (snd x)))
    (fun y => (f.(bw_map) (fst y), g.(bw_map) (snd y))).
  - intros [a c]. simpl. repeat rewrite left_inv. trivial.
  - intros [b d]. simpl. repeat rewrite right_inv. trivial.
Defined.

Definition bij_prod_empty_l (A : Type) : bij (Empty_set * A) Empty_set.
  exists
    fst
    (Empty_set_rect (fun _ => Empty_set * A))%type;
  intro x; tauto.
Defined.

Definition bij_prod_unit_l (A : Type) : bij (unit * A) A.
  exists
    snd
    (fun a => (tt, a)).
  - intros [[] x]; trivial.
  - intro x; trivial.
Defined.

Definition bij_prod_sum_dist_l (A B C : Type) : bij ((A + B) * C) (A * C + B * C).
  exists
    (fun x => sum_rect (fun _ => A * C + B * C)%type (fun a => inl (a, snd x)) (fun b => inr (b, snd x)) (fst x))
    (sum_rect _ (fun ac => (inl (fst ac), snd ac)) (fun bc => (inr (fst bc), snd bc)));
  intro x; tauto.
Defined.

Definition bij_prod_assoc (A B C : Type) : (bij (A * (B * C)) ((A * B) * C))%type.
  exists
    (fun x => ((fst x, fst (snd x)), snd (snd x)))
    (fun x => (fst (fst x), (snd (fst x), snd x)));
  intro x; tauto.
Defined.

Definition bij_prod_comm (A B : Type) : (bij (A * B) (B * A))%type.
  exists
    (fun x => (snd x, fst x))
    (fun x => (snd x, fst x));
  intro x; tauto.
Defined.

Fixpoint bij_times (a b : mynat) : bij (fin a * fin b)%type (fin (a * b)) :=
  match a with
  | 0 => bij_prod_empty_l (fin b)
  | a` =>
      bij_comp
        (bij_prod_sum_dist_l (fin a) unit (fin b))
        (bij_comp
          (bij_sum
            (bij_times a b)
            (bij_prod_unit_l (fin b))
          )
          (bij_plus (a * b) b)
        )
  end.

Theorem size_times : forall A B a b, size A a -> size B b -> size (A * B)%type (a * b).
  intros A B a b [fa] [fb]. split.
  exact (bij_comp (bij_prod fa fb) (bij_times a b)).
Qed.

Theorem times_zero_l : forall n, 0 * n = 0.
  intro n.
  apply (bij_size_eq (fin 0 * fin n) (fin 0)).
  - apply bij_prod_empty_l.
  - apply size_times; apply size_fin.
  - apply size_fin.
Qed.

Theorem times_one_l : forall n, 0` * n = n.
  intro n.
  apply (bij_size_eq (fin 0` * fin n) (fin n)).
  - apply (@bij_comp _ (unit * fin n)%type).
    + apply bij_prod.
      * apply bij_fin_unit.
      * apply bij_id.
    + apply bij_prod_unit_l.
  - apply size_times; apply size_fin.
  - apply size_fin.
Qed.

Theorem times_plus_dist_l : forall a b c, (a + b) * c = a * c + b * c.
  intros a b c.
  apply (bij_size_eq ((fin a + fin b) * fin c) (fin a * fin c + fin b * fin c)).
  - apply bij_prod_sum_dist_l.
  - apply size_times; try apply size_plus; apply size_fin.
  - apply size_plus; apply size_times; apply size_fin.
Qed.

Theorem times_assoc : forall a b c, a * (b * c) = (a * b) * c.
  intros a b c.
  apply (bij_size_eq (fin a * (fin b * fin c)) ((fin a * fin b) * fin c)).
  - apply bij_prod_assoc.
  - repeat apply size_times; apply size_fin.
  - repeat apply size_times; apply size_fin.
Qed.

Theorem times_comm : forall a b, a * b = b * a.
  intros a b.
  apply (bij_size_eq (fin a * fin b) (fin b * fin a)).
  - apply bij_prod_comm.
  - apply size_times; apply size_fin.
  - apply size_times; apply size_fin.
Qed.