import data.pfun

import category_theory.colimits
import .category
import .homeomorphism
import for_mathlib

/-

The quotient of a space by a subspace. Abstractly, this is given as
the pushout in the diagram

    A → *
  i ↓   ↓ j
    X → X/A
      q

We write X/A here, though the quotient space also depends on i and we
will not assume that i is an embedding or even injective. The space
X/A is equipped with a base point, the image of the map j.

Note that when A is empty, X/A is X with a disjoint base point
added. When A is nonempty, q : X → X/A is a quotient map.

* q restricts to a bijection of sets q' : X-A → X/A - *. We denote the
  latter set by X/A₋.

* The subset {*} of X/A is closed (open) if and only if A is closed
  (open) in X.

* In either of the above cases, q' is a homeomorphism.

-/

open category_theory set

universe u

namespace homotopy_theory.topological_spaces
local notation `Top` := Top.{u}

namespace construction
section
parameters {A X : Top} (i : A ⟶ X)
include i

-- We construct X/A as the quotient of X₊ by the equivalence relation
-- which identifies the added base point with everything in the image
-- of i : A → X.

inductive Xplus : Type u
| pt : Xplus
| k : X → Xplus
open Xplus
local attribute [elab_with_expected_type] Xplus.rec_on

local notation `X₊` := Xplus

instance Xplus.topological_space : topological_space X₊ :=
X.str.coinduced k

@[continuity] lemma continuous_k : continuous k :=
continuous_id

@[continuity] lemma continuous_rec_on {β : Type*} [topological_space β]
  (y : β) {g : X → β} (hg : continuous g) :
  continuous (show X₊ → β, from λ p, p.rec_on y g) :=
hg

def Aplus : set X₊ := insert pt (range (k ∘ i))
local notation `A₊` := Aplus

-- Two elements of X₊ are related either if they are equal, or if both
-- are either the base point or in the image of i : A → X.
def Xplus_rel (p₁ p₂ : X₊) : Prop := p₁ = p₂ ∨ p₁ ∈ A₊ ∧ p₂ ∈ A₊

lemma Xplus_rel.refl : reflexive Xplus_rel := assume p, or.inl rfl
lemma Xplus_rel.symm : symmetric Xplus_rel
| p₁ p₂ (or.inl e) := or.inl e.symm
| p₁ p₂ (or.inr a) := or.inr a.swap
lemma Xplus_rel.trans : transitive Xplus_rel :=
assume p₁ p₂ p₃ h₁ h₂,
  by unfold Xplus_rel; cases h₁; cases h₂; solve_by_elim { discharger := `[cc] }

instance Xplus.setoid : setoid Xplus :=
⟨Xplus_rel, Xplus_rel.refl, Xplus_rel.symm, Xplus_rel.trans⟩

@[simp] lemma Aplus_related (p₁ p₂ : X₊) (h₁ : p₁ ∈ A₊) (h₂ : p₂ ∈ A₊) : p₁ ≈ p₂ :=
or.inr ⟨h₁, h₂⟩

@[simp] lemma Aplus_pt : pt ∈ A₊ := by unfold Aplus; simp
@[simp] lemma Aplus_image (a : A) : k (i a) ∈ A₊ := by unfold Aplus; simp; tauto

def XmodA : Top := Top.mk_ob (quotient Xplus.setoid)
local notation `X/A` := XmodA

local notation `t` := Top.point_induced A

def q : X ⟶ X/A := Top.mk_hom (quotient.mk ∘ k) (by continuity!)
def j : * ⟶ X/A := Top.mk_hom (λ _, quotient.mk pt) (by continuity!)

lemma qi : q ∘ i = j ∘ t :=
by ext; funext a; apply quotient.sound; simp

section pushout
local notation f ` ∘ `:80 g:80 := g ≫ f

lemma commutes : q ∘ i = j ∘ t := Top.hom_eq2.mpr qi

section induced
parameters (Z : Top) (h₀ : X ⟶ Z) (h₁ : * ⟶ Z) (e : h₀ ∘ i = h₁ ∘ t)
include e

def induced' : X₊ → Z :=
λ p, p.rec_on (h₁ punit.star) h₀

lemma induced'_ok (p p' : X₊) (h : p ≈ p') : induced' p = induced' p' :=
have ∀ q, q ∈ A₊ → induced' q = h₁ punit.star, from assume q hq, begin
  cases q, { refl },
  { simp [Aplus] at hq, cases hq with a h,
    subst q, exact Top.hom_congr e a }
end,
begin
  cases h, { subst h },
  { cases h with h h', rw [this p h, this p' h'] }
end

def induced : X/A ⟶ Z :=
Top.mk_hom (λ p, quotient.lift induced' induced'_ok p) (by continuity!)

lemma induced_commutes₀ : induced ∘ q = h₀ :=
by ext; refl

lemma induced_commutes₁ : induced ∘ j = h₁ :=
by ext s; cases s; refl

end induced

lemma uniqueness (Z : Top) (k k' : X/A ⟶ Z)
  (e₀ : k ∘ q = k' ∘ q) (e₁ : k ∘ j = k' ∘ j) : k = k' :=
begin
  ext x,
  -- There is a bug when using the `induction` tactic with
  -- `quotient.ind`. Fortunately we can just as well use `quot.ind`.
  induction x using quot.ind,
  cases x,
  exact @@Top.hom_congr e₁ punit.star,
  exact @@Top.hom_congr e₀ _
end

def po : Is_pushout i t q j :=
Is_pushout.mk' commutes induced induced_commutes₀ induced_commutes₁ uniqueness

end pushout

local notation `*` := quotient.mk pt

lemma A_is_preimage_of_base_point : range i = q ⁻¹' {*} :=
have ∀ x, (∃ a, i a = x) ↔ q x = *, from assume x,
  show (∃ a, i a = x) ↔ quotient.mk (k x) = quotient.mk (pt),
  by rw quotient.eq; simp [(≈), setoid.r, Xplus_rel, Aplus],
by ext x; convert this x; simp

lemma A_closed_iff : is_closed (range i) ↔ is_closed ({*} : set X/A) :=
by rw A_is_preimage_of_base_point; refl

lemma A_open_iff : is_open (range i) ↔ is_open ({*} : set X/A) :=
by rw A_is_preimage_of_base_point; refl

def XminusA : set X := (range i)ᶜ
local notation `X-A` := XminusA

def XmodAminus : set X/A := {*}ᶜ
local notation `X/A₋` := XmodAminus

def q' : X-A → X/A₋ :=
assume x, ⟨q x.val, have x.val ∈ (range i)ᶜ := x.property,
  by rw A_is_preimage_of_base_point at this; simpa [XmodAminus]⟩

section q'_inv

lemma mem_XmodAminus_iff {p} : ⟦p⟧ ∈ XmodAminus ↔ p ∉ A₊ :=
by simp [XmodAminus, Aplus, (≈), setoid.r, Xplus_rel]; rw ←or_assoc; simp

-- This construction is very fragile for some reason
private def q'_inv0 : X₊ → roption (X-A) :=
λ p, p.rec_on roption.none (λ x, ⟨x ∉ range i, λ h, ⟨x, h⟩⟩)

private def q'_inv1 (p₀ : X/A) (hp₀ : p₀ ∈ X/A₋) : X-A :=
have ∀ (p : X₊), p ∈ A₊ → q'_inv0 p = roption.none, begin
  intros p hp, cases p, { refl },
  { simp [Aplus] at hp, cases hp, subst p,
    rw roption.eq_none_iff', dsimp [q'_inv0],
    apply not_not_intro, apply mem_range_self }
end,
have ok : ∀ (a b : X₊), a ≈ b → q'_inv0 a = q'_inv0 b, begin
  intros p p' h, cases h, { subst h },
  { cases h with h h', rw [this p h, this p' h'] }
end,
have ∀ (p : X₊), ⟦p⟧ ∈ X/A₋ → (q'_inv0 p).dom, from assume p h,
  have z : _ := mem_XmodAminus_iff.mp h,
  by cases p; dsimp [Aplus] at z; dsimp [q'_inv0]; simpa using z,
(quotient.lift q'_inv0 ok p₀).get
  (quotient.ind (assume p' h, this p' h) p₀ hp₀)

def q'_inv : X/A₋ → X-A :=
assume p, q'_inv1 p.val p.property

lemma q'_inv_q' (x) : q'_inv (q' x) = x :=
subtype.eq rfl

private lemma q'_q'_inv1 (p₀ hp₀) : q' (q'_inv ⟨p₀, hp₀⟩) = ⟨p₀, hp₀⟩ :=
have foo :  ∀ p hp, (q' (q'_inv ⟨⟦p⟧, hp⟩)).val = ⟦p⟧, from assume p hp,
  show q ((q'_inv0 p).get _) = ⟦p⟧, from
  begin
    cases p,
    { rw mem_XmodAminus_iff at hp, simpa using hp },
    refl
  end,
subtype.eq $ (quotient.ind foo p₀) hp₀

lemma q'_q'_inv (p) : q' (q'_inv p) = p := by cases p; apply q'_q'_inv1

end q'_inv

-- We have constructed an inverse (on the level of sets) for q', the
-- restriction of q to X-A.
def q'_equiv : X-A ≃ X/A₋ :=
{ to_fun := q',
  inv_fun := q'_inv,
  left_inv := q'_inv_q',
  right_inv := q'_q'_inv }

lemma q'_val (x : X-A) : (q'_equiv x).val = q x := rfl

-- Now we want to show that q' is a homeomorphism.

lemma continuous_q' : continuous q' := by continuity!

-- For continuity of q'_inv we need a hypothesis: A is open or closed.

-- Suppose A is closed. Then
-- U ⊆ X-A open → U ⊆ X open → q'(U) ⊆ X/A open → q'(U) ⊆ X/A₋ open.
-- So q' is an open map, hence q'_inv is continuous.
-- If A is open instead, replace "open" by "closed" throughout.

@[simp] lemma ugly_lemma (u : set X-A) :
  q ⁻¹' (subtype.val '' (q' '' u)) = subtype.val '' u :=
have subtype.val ∘ q' = q ∘ subtype.val := rfl,
begin
  rw [←image_comp, this, image_comp],
  apply subset.antisymm,
  { intros x h, rcases h with ⟨x', ⟨x'', h₁, h₂⟩, h₃⟩, refine ⟨x'', h₁, _⟩, subst x',
    have x''_x : Xplus_rel _ (k x''.val) (k x) := quotient.exact h₃, cases x''_x,
    { exact construction.Xplus.k.inj x''_x },
    { -- This case is impossible: x'' ∈ X-A but k x''.val ∈ A₊
      cases x''_x.left with h h, { simpa using h },
      { cases h with a h, have : i a = x''.val, by simpa using h,
        have bad := x''.property, rw ←this at bad, dsimp [XminusA] at bad,
        exact absurd (mem_range_self _) bad } } },
  apply subset_preimage_image
end

lemma q'_open_of_A_closed (ha : is_closed (range i)) {u : set X-A} (hu : is_open u) :
  is_open (q' '' u) :=
suffices is_open (subtype.val '' (q' '' u)), from
  let j : X/A₋ → X/A := subtype.val in
  have is_open (j ⁻¹' (j '' (q' '' u))) :=
    continuous_subtype_val _ this,
  by rwa preimage_image_eq _ subtype.val_injective at this,
show is_open (q ⁻¹' (subtype.val '' (q' '' u))), from
suffices is_open (subtype.val '' u), by rwa ugly_lemma,
embedding_open embedding_subtype_coe (by rwa subtype.range_val) hu

lemma q'_closed_of_A_open (ha : is_open (range i)) {u : set X-A} (hu : is_closed u) :
  is_closed (q' '' u) :=
suffices is_closed (subtype.val '' (q' '' u)), from
  let j : X/A₋ → X/A := subtype.val in
  have is_closed (j ⁻¹' (j '' (q' '' u))) :=
    continuous_iff_is_closed.mp continuous_subtype_val _ this,
  by rwa preimage_image_eq _ subtype.val_injective at this,
show is_closed (q ⁻¹' (subtype.val '' (q' '' u))), from
suffices is_closed (subtype.val '' u), by rwa ugly_lemma,
have is_closed X-A := is_closed_compl_iff.mpr ha,
embedding_is_closed embedding_subtype_coe (by rwa subtype.range_val) hu

lemma continuous_q'_inv_of_A_closed (ha : is_closed (range i)) : continuous q'_inv :=
assume u hu,
  show is_open (q'_equiv.symm ⁻¹' u), from
  have _ := q'_open_of_A_closed ha hu,
  by rwa ←equiv.image_eq_preimage

lemma continuous_q'_inv_of_A_open (ha : is_open (range i)) : continuous q'_inv :=
continuous_iff_is_closed.mpr $ assume u hu,
  show is_closed (q'_equiv.symm ⁻¹' u), from
  have _ := q'_closed_of_A_open ha hu,
  by rwa ←equiv.image_eq_preimage

end
end construction

-- Interface to this module.
open construction

variables {A X : Top} (i : A ⟶ X)
-- The quotient space X/A (see preamble for more details).
def quotient_space : Top := XmodA i

-- The "quotient map" X → X/A. (Not an actual quotient map when A is
-- empty.)
def quotient_space.map : X ⟶ quotient_space i := q i

-- The base point of X/A.
def quotient_space.pt : quotient_space i := quotient.mk Xplus.pt

@[reducible] def quotient_space.singleton_pt : set (quotient_space i) :=
{quotient_space.pt i}

theorem quotient_space_pt_is_closed_iff :
  is_closed (quotient_space.singleton_pt i) ↔ is_closed (range i) :=
(A_closed_iff i).symm

theorem quotient_space_pt_is_open_iff :
  is_open (quotient_space.singleton_pt i) ↔ is_open (range i) :=
(A_open_iff i).symm

-- X/A is the pushout of A → X along A → *.
def quotient_space.is_pushout :
  Is_pushout i (Top.point_induced A) (quotient_space.map i) (j i) :=
po i

-- The complementary space X-A.
-- TODO: Maybe use `subspace` for this and the next definition?
def quotient_space.image_complement : Top := Top.mk_ob (XminusA i)

-- The space X/A with its base point removed.
def quotient_space.minus_base_point : Top := Top.mk_ob (XmodAminus i)

-- The map X-A → X/A - {*}.
def quotient_space.map_complement :
  quotient_space.image_complement i ⟶ quotient_space.minus_base_point i :=
Top.mk_hom (q' i) (continuous_q' i)

section inverse
-- For the inverse map to be continuous, we need a condition on A.
variables (h : is_closed (range i) ∨ is_open (range i))

-- Inverse to the above map.
def quotient_space.map_complement_inverse :
  quotient_space.minus_base_point i ⟶ quotient_space.image_complement i :=
Top.mk_hom (q'_inv i)
  (h.cases_on
    (assume h_closed, continuous_q'_inv_of_A_closed i h_closed)
    (assume h_open, continuous_q'_inv_of_A_open i h_open))

-- The map X-A → X/A - {*} as a homeomorphism.
def quotient_space.homeomorphism_complement :
  Top.homeomorphism (quotient_space.image_complement i) (quotient_space.minus_base_point i) :=
{ hom := quotient_space.map_complement i,
  inv := quotient_space.map_complement_inverse i h,
  hom_inv_id' := Top.hom_eq (q'_equiv i).left_inv,
  inv_hom_id' := Top.hom_eq (q'_equiv i).right_inv }

end inverse

end homotopy_theory.topological_spaces


/-
Copyright (c) 2014 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
import data.num.bitwise
import data.int.char_zero
import data.nat.gcd
import data.nat.psub

/-!
# Properties of the binary representation of integers
-/

local attribute [simp] add_assoc

namespace pos_num
variables {α : Type*}

@[simp, norm_cast] theorem cast_one [has_one α] [has_add α] :
  ((1 : pos_num) : α) = 1 := rfl
@[simp] theorem cast_one' [has_one α] [has_add α] : (pos_num.one : α) = 1 := rfl
@[simp, norm_cast] theorem cast_bit0 [has_one α] [has_add α] (n : pos_num) :
  (n.bit0 : α) = _root_.bit0 n := rfl
@[simp, norm_cast] theorem cast_bit1 [has_one α] [has_add α] (n : pos_num) :
  (n.bit1 : α) = _root_.bit1 n := rfl

@[simp, norm_cast] theorem cast_to_nat [add_monoid_with_one α] :
  ∀ n : pos_num, ((n : ℕ) : α) = n
| 1        := nat.cast_one
| (bit0 p) := (nat.cast_bit0 _).trans $ congr_arg _root_.bit0 p.cast_to_nat
| (bit1 p) := (nat.cast_bit1 _).trans $ congr_arg _root_.bit1 p.cast_to_nat

@[simp, norm_cast] theorem to_nat_to_int (n : pos_num) : ((n : ℕ) : ℤ) = n :=
cast_to_nat _

@[simp, norm_cast] theorem cast_to_int [add_group_with_one α] (n : pos_num) :
  ((n : ℤ) : α) = n :=
by rw [← to_nat_to_int, int.cast_coe_nat, cast_to_nat]

theorem succ_to_nat : ∀ n, (succ n : ℕ) = n + 1
| 1        := rfl
| (bit0 p) := rfl
| (bit1 p) := (congr_arg _root_.bit0 (succ_to_nat p)).trans $
  show ↑p + 1 + ↑p + 1 = ↑p + ↑p + 1 + 1, by simp [add_left_comm]

theorem one_add (n : pos_num) : 1 + n = succ n := by cases n; refl
theorem add_one (n : pos_num) : n + 1 = succ n := by cases n; refl

@[norm_cast]
theorem add_to_nat : ∀ m n, ((m + n : pos_num) : ℕ) = m + n
| 1        b        := by rw [one_add b, succ_to_nat, add_comm]; refl
| a        1        := by rw [add_one a, succ_to_nat]; refl
| (bit0 a) (bit0 b) := (congr_arg _root_.bit0 (add_to_nat a b)).trans $ add_add_add_comm _ _ _ _
| (bit0 a) (bit1 b) := (congr_arg _root_.bit1 (add_to_nat a b)).trans $
  show ((a + b) + (a + b) + 1 : ℕ) = (a + a) + (b + b + 1), by simp [add_left_comm]
| (bit1 a) (bit0 b) := (congr_arg _root_.bit1 (add_to_nat a b)).trans $
  show ((a + b) + (a + b) + 1 : ℕ) = (a + a + 1) + (b + b), by simp [add_comm, add_left_comm]
| (bit1 a) (bit1 b) :=
  show (succ (a + b) + succ (a + b) : ℕ) = (a + a + 1) + (b + b + 1),
  by rw [succ_to_nat, add_to_nat]; simp [add_left_comm]

theorem add_succ : ∀ (m n : pos_num), m + succ n = succ (m + n)
| 1        b        := by simp [one_add]
| (bit0 a) 1        := congr_arg bit0 (add_one a)
| (bit1 a) 1        := congr_arg bit1 (add_one a)
| (bit0 a) (bit0 b) := rfl
| (bit0 a) (bit1 b) := congr_arg bit0 (add_succ a b)
| (bit1 a) (bit0 b) := rfl
| (bit1 a) (bit1 b) := congr_arg bit1 (add_succ a b)

theorem bit0_of_bit0 : Π n, _root_.bit0 n = bit0 n
| 1        := rfl
| (bit0 p) := congr_arg bit0 (bit0_of_bit0 p)
| (bit1 p) := show bit0 (succ (_root_.bit0 p)) = _, by rw bit0_of_bit0; refl

theorem bit1_of_bit1 (n : pos_num) : _root_.bit1 n = bit1 n :=
show _root_.bit0 n + 1 = bit1 n, by rw [add_one, bit0_of_bit0]; refl

@[norm_cast]
theorem mul_to_nat (m) : ∀ n, ((m * n : pos_num) : ℕ) = m * n
| 1        := (mul_one _).symm
| (bit0 p) := show (↑(m * p) + ↑(m * p) : ℕ) = ↑m * (p + p), by rw [mul_to_nat, left_distrib]
| (bit1 p) := (add_to_nat (bit0 (m * p)) m).trans $
  show (↑(m * p) + ↑(m * p) + ↑m : ℕ) = ↑m * (p + p) + m, by rw [mul_to_nat, left_distrib]

theorem to_nat_pos : ∀ n : pos_num, 0 < (n : ℕ)
| 1        := zero_lt_one
| (bit0 p) := let h := to_nat_pos p in add_pos h h
| (bit1 p) := nat.succ_pos _

theorem cmp_to_nat_lemma {m n : pos_num} : (m:ℕ) < n → (bit1 m : ℕ) < bit0 n :=
show (m:ℕ) < n → (m + m + 1 + 1 : ℕ) ≤ n + n,
by intro h; rw [nat.add_right_comm m m 1, add_assoc]; exact add_le_add h h

theorem cmp_swap (m) : ∀n, (cmp m n).swap = cmp n m :=
by induction m with m IH m IH; intro n;
   cases n with n n; try {unfold cmp}; try {refl}; rw ←IH; cases cmp m n; refl

theorem cmp_to_nat : ∀ (m n), (ordering.cases_on (cmp m n) ((m:ℕ) < n) (m = n) ((n:ℕ) < m) : Prop)
| 1        1        := rfl
| (bit0 a) 1        := let h : (1:ℕ) ≤ a := to_nat_pos a in add_le_add h h
| (bit1 a) 1        := nat.succ_lt_succ $ to_nat_pos $ bit0 a
| 1        (bit0 b) := let h : (1:ℕ) ≤ b := to_nat_pos b in add_le_add h h
| 1        (bit1 b) := nat.succ_lt_succ $ to_nat_pos $ bit0 b
| (bit0 a) (bit0 b) := begin
    have := cmp_to_nat a b, revert this, cases cmp a b; dsimp; intro,
    { exact add_lt_add this this },
    { rw this },
    { exact add_lt_add this this }
  end
| (bit0 a) (bit1 b) := begin dsimp [cmp],
    have := cmp_to_nat a b, revert this, cases cmp a b; dsimp; intro,
    { exact nat.le_succ_of_le (add_lt_add this this) },
    { rw this, apply nat.lt_succ_self },
    { exact cmp_to_nat_lemma this }
  end
| (bit1 a) (bit0 b) := begin dsimp [cmp],
    have := cmp_to_nat a b, revert this, cases cmp a b; dsimp; intro,
    { exact cmp_to_nat_lemma this },
    { rw this, apply nat.lt_succ_self },
    { exact nat.le_succ_of_le (add_lt_add this this) },
  end
| (bit1 a) (bit1 b) := begin
    have := cmp_to_nat a b, revert this, cases cmp a b; dsimp; intro,
    { exact nat.succ_lt_succ (add_lt_add this this) },
    { rw this },
    { exact nat.succ_lt_succ (add_lt_add this this) }
  end

@[norm_cast]
theorem lt_to_nat {m n : pos_num} : (m:ℕ) < n ↔ m < n :=
show (m:ℕ) < n ↔ cmp m n = ordering.lt, from
match cmp m n, cmp_to_nat m n with
| ordering.lt, h := by simp at h; simp [h]
| ordering.eq, h := by simp at h; simp [h, lt_irrefl]; exact dec_trivial
| ordering.gt, h := by simp [not_lt_of_gt h]; exact dec_trivial
end

@[norm_cast]
theorem le_to_nat {m n : pos_num} : (m:ℕ) ≤ n ↔ m ≤ n :=
by rw ← not_lt; exact not_congr lt_to_nat

end pos_num

namespace num
variables {α : Type*}
open pos_num

theorem add_zero (n : num) : n + 0 = n := by cases n; refl
theorem zero_add (n : num) : 0 + n = n := by cases n; refl

theorem add_one : ∀ n : num, n + 1 = succ n
| 0       := rfl
| (pos p) := by cases p; refl

theorem add_succ : ∀ (m n : num), m + succ n = succ (m + n)
| 0       n       := by simp [zero_add]
| (pos p) 0       := show pos (p + 1) = succ (pos p + 0),
                     by rw [pos_num.add_one, add_zero]; refl
| (pos p) (pos q) := congr_arg pos (pos_num.add_succ _ _)

theorem bit0_of_bit0 : ∀ n : num, bit0 n = n.bit0
| 0       := rfl
| (pos p) := congr_arg pos p.bit0_of_bit0

theorem bit1_of_bit1 : ∀ n : num, bit1 n = n.bit1
| 0       := rfl
| (pos p) := congr_arg pos p.bit1_of_bit1

@[simp] lemma of_nat'_zero : num.of_nat' 0 = 0 :=
by simp [num.of_nat']

lemma of_nat'_bit (b n) : of_nat' (nat.bit b n) = cond b num.bit1 num.bit0 (of_nat' n) :=
nat.binary_rec_eq rfl _ _

@[simp] lemma of_nat'_one : num.of_nat' 1 = 1 :=
by erw [of_nat'_bit tt 0, cond, of_nat'_zero]; refl

lemma bit1_succ : ∀ n : num, n.bit1.succ = n.succ.bit0
| 0 := rfl
| (pos n) := rfl

lemma of_nat'_succ : ∀ {n}, of_nat' (n + 1) = of_nat' n + 1 :=
nat.binary_rec (by simp; refl) $ λ b n ih,
begin
  cases b,
  { erw [of_nat'_bit tt n, of_nat'_bit],
    simp only [← bit1_of_bit1, ← bit0_of_bit0, cond, _root_.bit1] },
  { erw [show n.bit tt + 1 = (n + 1).bit ff, by simp [nat.bit, _root_.bit1, _root_.bit0]; cc,
      of_nat'_bit, of_nat'_bit, ih],
    simp only [cond, add_one, bit1_succ], },
end

@[simp] theorem add_of_nat' (m n) : num.of_nat' (m + n) = num.of_nat' m + num.of_nat' n :=
by induction n; simp [nat.add_zero, of_nat'_succ, add_zero, nat.add_succ, add_one, add_succ, *]

@[simp, norm_cast] theorem cast_zero [has_zero α] [has_one α] [has_add α] :
  ((0 : num) : α) = 0 := rfl

@[simp] theorem cast_zero' [has_zero α] [has_one α] [has_add α] :
  (num.zero : α) = 0 := rfl

@[simp, norm_cast] theorem cast_one [has_zero α] [has_one α] [has_add α] :
  ((1 : num) : α) = 1 := rfl

@[simp] theorem cast_pos [has_zero α] [has_one α] [has_add α]
  (n : pos_num) : (num.pos n : α) = n := rfl

theorem succ'_to_nat : ∀ n, (succ' n : ℕ) = n + 1
| 0       := (_root_.zero_add _).symm
| (pos p) := pos_num.succ_to_nat _

theorem succ_to_nat (n) : (succ n : ℕ) = n + 1 := succ'_to_nat n

@[simp, norm_cast] theorem cast_to_nat [add_monoid_with_one α] : ∀ n : num, ((n : ℕ) : α) = n
| 0       := nat.cast_zero
| (pos p) := p.cast_to_nat

@[norm_cast]
theorem add_to_nat : ∀ m n, ((m + n : num) : ℕ) = m + n
| 0       0       := rfl
| 0       (pos q) := (_root_.zero_add _).symm
| (pos p) 0       := rfl
| (pos p) (pos q) := pos_num.add_to_nat _ _

@[norm_cast]
theorem mul_to_nat : ∀ m n, ((m * n : num) : ℕ) = m * n
| 0       0       := rfl
| 0       (pos q) := (zero_mul _).symm
| (pos p) 0       := rfl
| (pos p) (pos q) := pos_num.mul_to_nat _ _

theorem cmp_to_nat : ∀ (m n), (ordering.cases_on (cmp m n) ((m:ℕ) < n) (m = n) ((n:ℕ) < m) : Prop)
| 0       0       := rfl
| 0       (pos b) := to_nat_pos _
| (pos a) 0       := to_nat_pos _
| (pos a) (pos b) :=
  by { have := pos_num.cmp_to_nat a b; revert this; dsimp [cmp];
       cases pos_num.cmp a b, exacts [id, congr_arg pos, id] }

@[norm_cast]
theorem lt_to_nat {m n : num} : (m:ℕ) < n ↔ m < n :=
show (m:ℕ) < n ↔ cmp m n = ordering.lt, from
match cmp m n, cmp_to_nat m n with
| ordering.lt, h := by simp at h; simp [h]
| ordering.eq, h := by simp at h; simp [h, lt_irrefl]; exact dec_trivial
| ordering.gt, h := by simp [not_lt_of_gt h]; exact dec_trivial
end

@[norm_cast]
theorem le_to_nat {m n : num} : (m:ℕ) ≤ n ↔ m ≤ n :=
by rw ← not_lt; exact not_congr lt_to_nat

end num

namespace pos_num

@[simp] theorem of_to_nat' : Π (n : pos_num), num.of_nat' (n : ℕ) = num.pos n
| 1        := by erw [@num.of_nat'_bit tt 0, num.of_nat'_zero]; refl
| (bit0 p) := by erw [@num.of_nat'_bit ff, of_to_nat']; refl
| (bit1 p) := by erw [@num.of_nat'_bit tt, of_to_nat']; refl
end pos_num

namespace num

@[simp, norm_cast] theorem of_to_nat' : Π (n : num), num.of_nat' (n : ℕ) = n
| 0       := of_nat'_zero
| (pos p) := p.of_to_nat'

@[norm_cast] theorem to_nat_inj {m n : num} : (m : ℕ) = n ↔ m = n :=
⟨λ h, function.left_inverse.injective of_to_nat' h, congr_arg _⟩

/--
This tactic tries to turn an (in)equality about `num`s to one about `nat`s by rewriting.
```lean
example (n : num) (m : num) : n ≤ n + m :=
begin
  num.transfer_rw,
  exact nat.le_add_right _ _
end
```
-/
meta def transfer_rw : tactic unit :=
`[repeat {rw ← to_nat_inj <|> rw ← lt_to_nat <|> rw ← le_to_nat},
  repeat {rw add_to_nat <|> rw mul_to_nat <|> rw cast_one <|> rw cast_zero}]

/--
This tactic tries to prove (in)equalities about `num`s by transfering them to the `nat` world and
then trying to call `simp`.
```lean
example (n : num) (m : num) : n ≤ n + m := by num.transfer
```
-/
meta def transfer : tactic unit := `[intros, transfer_rw, try {simp}]

instance : add_monoid num :=
{ add := (+),
  zero := 0,
  zero_add := zero_add,
  add_zero := add_zero,
  add_assoc := by transfer }

instance : add_monoid_with_one num :=
{ nat_cast := num.of_nat',
  one := 1,
  nat_cast_zero := of_nat'_zero,
  nat_cast_succ := λ _, of_nat'_succ,
  .. num.add_monoid }

instance : comm_semiring num :=
by refine_struct
{ mul := (*),
  one := 1,
  add := (+),
  zero := 0,
  npow := @npow_rec num ⟨1⟩ ⟨(*)⟩,
  .. num.add_monoid, .. num.add_monoid_with_one };
try { intros, refl }; try { transfer };
simp [add_comm, mul_add, add_mul, mul_assoc, mul_comm, mul_left_comm]

instance : ordered_cancel_add_comm_monoid num :=
{ add_left_cancel            := by {intros a b c, transfer_rw, apply add_left_cancel},
  lt                         := (<),
  lt_iff_le_not_le           := by {intros a b, transfer_rw, apply lt_iff_le_not_le},
  le                         := (≤),
  le_refl                    := by transfer,
  le_trans                   := by {intros a b c, transfer_rw, apply le_trans},
  le_antisymm                := by {intros a b, transfer_rw, apply le_antisymm},
  add_le_add_left            := by {intros a b h c, revert h, transfer_rw,
    exact λ h, add_le_add_left h c},
  le_of_add_le_add_left      := by {intros a b c, transfer_rw, apply le_of_add_le_add_left},
  ..num.comm_semiring }

instance : linear_ordered_semiring num :=
{ le_total                   := by {intros a b, transfer_rw, apply le_total},
  zero_le_one                := dec_trivial,
  mul_lt_mul_of_pos_left     := by {intros a b c, transfer_rw, apply mul_lt_mul_of_pos_left},
  mul_lt_mul_of_pos_right    := by {intros a b c, transfer_rw, apply mul_lt_mul_of_pos_right},
  decidable_lt               := num.decidable_lt,
  decidable_le               := num.decidable_le,
  decidable_eq               := num.decidable_eq,
  exists_pair_ne             := ⟨0, 1, dec_trivial⟩,
  ..num.comm_semiring, ..num.ordered_cancel_add_comm_monoid }

@[simp, norm_cast] theorem add_of_nat (m n) : ((m + n : ℕ) : num) = m + n :=
add_of_nat' _ _

@[simp, norm_cast] theorem to_nat_to_int (n : num) : ((n : ℕ) : ℤ) = n :=
cast_to_nat _

@[simp, norm_cast] theorem cast_to_int {α} [add_group_with_one α] (n : num) : ((n : ℤ) : α) = n :=
by rw [← to_nat_to_int, int.cast_coe_nat, cast_to_nat]

theorem to_of_nat : Π (n : ℕ), ((n : num) : ℕ) = n
| 0     := by rw [nat.cast_zero, cast_zero]
| (n+1) := by rw [nat.cast_succ, add_one, succ_to_nat, to_of_nat]

@[simp, norm_cast]
theorem of_nat_cast {α} [add_monoid_with_one α] (n : ℕ) : ((n : num) : α) = n :=
by rw [← cast_to_nat, to_of_nat]

@[simp, norm_cast] theorem of_nat_inj {m n : ℕ} : (m : num) = n ↔ m = n :=
⟨λ h, function.left_inverse.injective to_of_nat h, congr_arg _⟩

@[simp, norm_cast] theorem of_to_nat : Π (n : num), ((n : ℕ) : num) = n := of_to_nat'

@[norm_cast]
theorem dvd_to_nat (m n : num) : (m : ℕ) ∣ n ↔ m ∣ n :=
⟨λ ⟨k, e⟩, ⟨k, by rw [← of_to_nat n, e]; simp⟩,
 λ ⟨k, e⟩, ⟨k, by simp [e, mul_to_nat]⟩⟩

end num

namespace pos_num
variables {α : Type*}
open num

@[simp, norm_cast] theorem of_to_nat : Π (n : pos_num), ((n : ℕ) : num) = num.pos n := of_to_nat'

@[norm_cast] theorem to_nat_inj {m n : pos_num} : (m : ℕ) = n ↔ m = n :=
⟨λ h, num.pos.inj $ by rw [← pos_num.of_to_nat, ← pos_num.of_to_nat, h],
 congr_arg _⟩

theorem pred'_to_nat : ∀ n, (pred' n : ℕ) = nat.pred n
| 1        := rfl
| (bit0 n) :=
  have nat.succ ↑(pred' n) = ↑n,
  by rw [pred'_to_nat n, nat.succ_pred_eq_of_pos (to_nat_pos n)],
  match pred' n, this : ∀ k : num, nat.succ ↑k = ↑n →
    ↑(num.cases_on k 1 bit1 : pos_num) = nat.pred (_root_.bit0 n) with
  | 0, (h : ((1:num):ℕ) = n) := by rw ← to_nat_inj.1 h; refl
  | num.pos p, (h : nat.succ ↑p = n) :=
    by rw ← h; exact (nat.succ_add p p).symm
  end
| (bit1 n) := rfl

@[simp] theorem pred'_succ' (n) : pred' (succ' n) = n :=
num.to_nat_inj.1 $ by rw [pred'_to_nat, succ'_to_nat,
  nat.add_one, nat.pred_succ]

@[simp] theorem succ'_pred' (n) : succ' (pred' n) = n :=
to_nat_inj.1 $ by rw [succ'_to_nat, pred'_to_nat,
  nat.add_one, nat.succ_pred_eq_of_pos (to_nat_pos _)]

instance : has_dvd pos_num := ⟨λ m n, pos m ∣ pos n⟩

@[norm_cast] theorem dvd_to_nat {m n : pos_num} : (m:ℕ) ∣ n ↔ m ∣ n :=
num.dvd_to_nat (pos m) (pos n)

theorem size_to_nat : ∀ n, (size n : ℕ) = nat.size n
| 1        := nat.size_one.symm
| (bit0 n) := by rw [size, succ_to_nat, size_to_nat, cast_bit0,
                     nat.size_bit0 $ ne_of_gt $ to_nat_pos n]
| (bit1 n) := by rw [size, succ_to_nat, size_to_nat, cast_bit1,
                     nat.size_bit1]

theorem size_eq_nat_size : ∀ n, (size n : ℕ) = nat_size n
| 1        := rfl
| (bit0 n) := by rw [size, succ_to_nat, nat_size, size_eq_nat_size]
| (bit1 n) := by rw [size, succ_to_nat, nat_size, size_eq_nat_size]

theorem nat_size_to_nat (n) : nat_size n = nat.size n :=
by rw [← size_eq_nat_size, size_to_nat]

theorem nat_size_pos (n) : 0 < nat_size n :=
by cases n; apply nat.succ_pos

/--
This tactic tries to turn an (in)equality about `pos_num`s to one about `nat`s by rewriting.
```lean
example (n : pos_num) (m : pos_num) : n ≤ n + m :=
begin
  pos_num.transfer_rw,
  exact nat.le_add_right _ _
end
```
-/
meta def transfer_rw : tactic unit :=
`[repeat {rw ← to_nat_inj <|> rw ← lt_to_nat <|> rw ← le_to_nat},
  repeat {rw add_to_nat <|> rw mul_to_nat <|> rw cast_one <|> rw cast_zero}]

/--
This tactic tries to prove (in)equalities about `pos_num`s by transferring them to the `nat` world
and then trying to call `simp`.
```lean
example (n : pos_num) (m : pos_num) : n ≤ n + m := by pos_num.transfer
```
-/
meta def transfer : tactic unit :=
`[intros, transfer_rw, try {simp [add_comm, add_left_comm, mul_comm, mul_left_comm]}]

instance : add_comm_semigroup pos_num :=
by refine {add := (+), ..}; transfer

instance : comm_monoid pos_num :=
by refine_struct {mul := (*), one := (1 : pos_num), npow := @npow_rec pos_num ⟨1⟩ ⟨(*)⟩};
try { intros, refl }; transfer

instance : distrib pos_num :=
by refine {add := (+), mul := (*), ..}; {transfer, simp [mul_add, mul_comm]}

instance : linear_order pos_num :=
{ lt              := (<),
  lt_iff_le_not_le := by {intros a b, transfer_rw, apply lt_iff_le_not_le},
  le              := (≤),
  le_refl         := by transfer,
  le_trans        := by {intros a b c, transfer_rw, apply le_trans},
  le_antisymm     := by {intros a b, transfer_rw, apply le_antisymm},
  le_total        := by {intros a b, transfer_rw, apply le_total},
  decidable_lt    := by apply_instance,
  decidable_le    := by apply_instance,
  decidable_eq    := by apply_instance }

@[simp] theorem cast_to_num (n : pos_num) : ↑n = num.pos n :=
by rw [← cast_to_nat, ← of_to_nat n]

@[simp, norm_cast]
theorem bit_to_nat (b n) : (bit b n : ℕ) = nat.bit b n :=
by cases b; refl

@[simp, norm_cast]
theorem cast_add [add_monoid_with_one α] (m n) : ((m + n : pos_num) : α) = m + n :=
by rw [← cast_to_nat, add_to_nat, nat.cast_add, cast_to_nat, cast_to_nat]

@[simp, norm_cast, priority 500]
theorem cast_succ [add_monoid_with_one α] (n : pos_num) : (succ n : α) = n + 1 :=
by rw [← add_one, cast_add, cast_one]

@[simp, norm_cast]
theorem cast_inj [add_monoid_with_one α] [char_zero α] {m n : pos_num} : (m:α) = n ↔ m = n :=
by rw [← cast_to_nat m, ← cast_to_nat n, nat.cast_inj, to_nat_inj]

@[simp]
theorem one_le_cast [linear_ordered_semiring α] (n : pos_num) : (1 : α) ≤ n :=
by rw [← cast_to_nat, ← nat.cast_one, nat.cast_le]; apply to_nat_pos

@[simp]
theorem cast_pos [linear_ordered_semiring α] (n : pos_num) : 0 < (n : α) :=
lt_of_lt_of_le zero_lt_one (one_le_cast n)

@[simp, norm_cast]
theorem cast_mul [semiring α] (m n) : ((m * n : pos_num) : α) = m * n :=
by rw [← cast_to_nat, mul_to_nat, nat.cast_mul, cast_to_nat, cast_to_nat]

@[simp]
theorem cmp_eq (m n) : cmp m n = ordering.eq ↔ m = n :=
begin
  have := cmp_to_nat m n,
  cases cmp m n; simp at this ⊢; try {exact this};
  { simp [show m ≠ n, from λ e, by rw e at this; exact lt_irrefl _ this] }
end

@[simp, norm_cast]
theorem cast_lt [linear_ordered_semiring α] {m n : pos_num} : (m:α) < n ↔ m < n :=
by rw [← cast_to_nat m, ← cast_to_nat n, nat.cast_lt, lt_to_nat]

@[simp, norm_cast]
theorem cast_le [linear_ordered_semiring α] {m n : pos_num} : (m:α) ≤ n ↔ m ≤ n :=
by rw ← not_lt; exact not_congr cast_lt

end pos_num

namespace num
variables {α : Type*}
open pos_num

theorem bit_to_nat (b n) : (bit b n : ℕ) = nat.bit b n :=
by cases b; cases n; refl

theorem cast_succ' [add_monoid_with_one α] (n) : (succ' n : α) = n + 1 :=
by rw [← pos_num.cast_to_nat, succ'_to_nat, nat.cast_add_one, cast_to_nat]

theorem cast_succ [add_monoid_with_one α] (n) : (succ n : α) = n + 1 := cast_succ' n

@[simp, norm_cast] theorem cast_add [semiring α] (m n) : ((m + n : num) : α) = m + n :=
by rw [← cast_to_nat, add_to_nat, nat.cast_add, cast_to_nat, cast_to_nat]

@[simp, norm_cast] theorem cast_bit0 [semiring α] (n : num) : (n.bit0 : α) = _root_.bit0 n :=
by rw [← bit0_of_bit0, _root_.bit0, cast_add]; refl

@[simp, norm_cast] theorem cast_bit1 [semiring α] (n : num) : (n.bit1 : α) = _root_.bit1 n :=
by rw [← bit1_of_bit1, _root_.bit1, bit0_of_bit0, cast_add, cast_bit0]; refl

@[simp, norm_cast] theorem cast_mul [semiring α] : ∀ m n, ((m * n : num) : α) = m * n
| 0       0       := (zero_mul _).symm
| 0       (pos q) := (zero_mul _).symm
| (pos p) 0       := (mul_zero _).symm
| (pos p) (pos q) := pos_num.cast_mul _ _

theorem size_to_nat : ∀ n, (size n : ℕ) = nat.size n
| 0       := nat.size_zero.symm
| (pos p) := p.size_to_nat

theorem size_eq_nat_size : ∀ n, (size n : ℕ) = nat_size n
| 0       := rfl
| (pos p) := p.size_eq_nat_size

theorem nat_size_to_nat (n) : nat_size n = nat.size n :=
by rw [← size_eq_nat_size, size_to_nat]

@[simp, priority 999] theorem of_nat'_eq : ∀ n, num.of_nat' n = n :=
nat.binary_rec (by simp) $ λ b n IH, begin
  rw of_nat' at IH ⊢,
  rw [nat.binary_rec_eq, IH],
  { cases b; simp [nat.bit, bit0_of_bit0, bit1_of_bit1] },
  { refl }
end

theorem zneg_to_znum (n : num) : -n.to_znum = n.to_znum_neg := by cases n; refl
theorem zneg_to_znum_neg (n : num) : -n.to_znum_neg = n.to_znum := by cases n; refl

theorem to_znum_inj {m n : num} : m.to_znum = n.to_znum ↔ m = n :=
⟨λ h, by cases m; cases n; cases h; refl, congr_arg _⟩

@[simp, norm_cast squash] theorem cast_to_znum [has_zero α] [has_one α] [has_add α] [has_neg α] :
  ∀ n : num, (n.to_znum : α) = n
| 0           := rfl
| (num.pos p) := rfl

@[simp] theorem cast_to_znum_neg [add_group α] [has_one α] :
  ∀ n : num, (n.to_znum_neg : α) = -n
| 0           := neg_zero.symm
| (num.pos p) := rfl

@[simp] theorem add_to_znum (m n : num) : num.to_znum (m + n) = m.to_znum + n.to_znum :=
by cases m; cases n; refl

end num

namespace pos_num
open num

theorem pred_to_nat {n : pos_num} (h : 1 < n) : (pred n : ℕ) = nat.pred n :=
begin
  unfold pred,
  have := pred'_to_nat n,
  cases e : pred' n,
  { have : (1:ℕ) ≤ nat.pred n :=
      nat.pred_le_pred ((@cast_lt ℕ _ _ _).2 h),
    rw [← pred'_to_nat, e] at this,
    exact absurd this dec_trivial },
  { rw [← pred'_to_nat, e], refl }
end

theorem sub'_one (a : pos_num) : sub' a 1 = (pred' a).to_znum :=
by cases a; refl

theorem one_sub' (a : pos_num) : sub' 1 a = (pred' a).to_znum_neg :=
by cases a; refl

theorem lt_iff_cmp {m n} : m < n ↔ cmp m n = ordering.lt := iff.rfl

theorem le_iff_cmp {m n} : m ≤ n ↔ cmp m n ≠ ordering.gt :=
not_congr $ lt_iff_cmp.trans $
by rw ← cmp_swap; cases cmp m n; exact dec_trivial

end pos_num

namespace num
variables {α : Type*}
open pos_num

theorem pred_to_nat : ∀ (n : num), (pred n : ℕ) = nat.pred n
| 0       := rfl
| (pos p) := by rw [pred, pos_num.pred'_to_nat]; refl

theorem ppred_to_nat : ∀ (n : num), coe <$> ppred n = nat.ppred n
| 0       := rfl
| (pos p) := by rw [ppred, option.map_some, nat.ppred_eq_some.2];
  rw [pos_num.pred'_to_nat, nat.succ_pred_eq_of_pos (pos_num.to_nat_pos _)]; refl

theorem cmp_swap (m n) : (cmp m n).swap = cmp n m :=
by cases m; cases n; try {unfold cmp}; try {refl}; apply pos_num.cmp_swap

theorem cmp_eq (m n) : cmp m n = ordering.eq ↔ m = n :=
begin
  have := cmp_to_nat m n,
  cases cmp m n; simp at this ⊢; try {exact this};
  { simp [show m ≠ n, from λ e, by rw e at this; exact lt_irrefl _ this] }
end

@[simp, norm_cast]
theorem cast_lt [linear_ordered_semiring α] {m n : num} : (m:α) < n ↔ m < n :=
by rw [← cast_to_nat m, ← cast_to_nat n, nat.cast_lt, lt_to_nat]

@[simp, norm_cast]
theorem cast_le [linear_ordered_semiring α] {m n : num} : (m:α) ≤ n ↔ m ≤ n :=
by rw ← not_lt; exact not_congr cast_lt

@[simp, norm_cast]
theorem cast_inj [linear_ordered_semiring α] {m n : num} : (m:α) = n ↔ m = n :=
by rw [← cast_to_nat m, ← cast_to_nat n, nat.cast_inj, to_nat_inj]

theorem lt_iff_cmp {m n} : m < n ↔ cmp m n = ordering.lt := iff.rfl

theorem le_iff_cmp {m n} : m ≤ n ↔ cmp m n ≠ ordering.gt :=
not_congr $ lt_iff_cmp.trans $
by rw ← cmp_swap; cases cmp m n; exact dec_trivial

theorem bitwise_to_nat {f : num → num → num} {g : bool → bool → bool}
  (p : pos_num → pos_num → num)
  (gff : g ff ff = ff)
  (f00 : f 0 0 = 0)
  (f0n : ∀ n, f 0 (pos n) = cond (g ff tt) (pos n) 0)
  (fn0 : ∀ n, f (pos n) 0 = cond (g tt ff) (pos n) 0)
  (fnn : ∀ m n, f (pos m) (pos n) = p m n)
  (p11 : p 1 1 = cond (g tt tt) 1 0)
  (p1b : ∀ b n, p 1 (pos_num.bit b n) = bit (g tt b) (cond (g ff tt) (pos n) 0))
  (pb1 : ∀ a m, p (pos_num.bit a m) 1 = bit (g a tt) (cond (g tt ff) (pos m) 0))
  (pbb : ∀ a b m n, p (pos_num.bit a m) (pos_num.bit b n) = bit (g a b) (p m n))
  : ∀ m n : num, (f m n : ℕ) = nat.bitwise g m n :=
begin
  intros, cases m with m; cases n with n;
  try { change zero with 0 };
  try { change ((0:num):ℕ) with 0 },
  { rw [f00, nat.bitwise_zero]; refl },
  { unfold nat.bitwise, rw [f0n, nat.binary_rec_zero],
    cases g ff tt; refl },
  { unfold nat.bitwise,
    generalize h : (pos m : ℕ) = m', revert h,
    apply nat.bit_cases_on m' _, intros b m' h,
    rw [fn0, nat.binary_rec_eq, nat.binary_rec_zero, ←h],
    cases g tt ff; refl,
    apply nat.bitwise_bit_aux gff },
  { rw fnn,
    have : ∀b (n : pos_num), (cond b ↑n 0 : ℕ) = ↑(cond b (pos n) 0 : num) :=
      by intros; cases b; refl,
    induction m with m IH m IH generalizing n; cases n with n n,
    any_goals { change one with 1 },
    any_goals { change pos 1 with 1 },
    any_goals { change pos_num.bit0 with pos_num.bit ff },
    any_goals { change pos_num.bit1 with pos_num.bit tt },
    any_goals { change ((1:num):ℕ) with nat.bit tt 0 },
    all_goals
    { repeat
      { rw show ∀ b n, (pos (pos_num.bit b n) : ℕ) = nat.bit b ↑n,
           by intros; cases b; refl },
      rw nat.bitwise_bit },
    any_goals { assumption },
    any_goals { rw [nat.bitwise_zero, p11], cases g tt tt; refl },
    any_goals { rw [nat.bitwise_zero_left, this, ← bit_to_nat, p1b] },
    any_goals { rw [nat.bitwise_zero_right _ gff, this, ← bit_to_nat, pb1] },
    all_goals { rw [← show ∀ n, ↑(p m n) = nat.bitwise g ↑m ↑n, from IH],
      rw [← bit_to_nat, pbb] } }
end

@[simp, norm_cast] theorem lor_to_nat   : ∀ m n, (lor    m n : ℕ) = nat.lor    m n :=
by apply bitwise_to_nat (λx y, pos (pos_num.lor x y)); intros; try {cases a}; try {cases b}; refl
@[simp, norm_cast] theorem land_to_nat  : ∀ m n, (land   m n : ℕ) = nat.land   m n :=
by apply bitwise_to_nat pos_num.land; intros; try {cases a}; try {cases b}; refl
@[simp, norm_cast] theorem ldiff_to_nat : ∀ m n, (ldiff  m n : ℕ) = nat.ldiff  m n :=
by apply bitwise_to_nat pos_num.ldiff; intros; try {cases a}; try {cases b}; refl
@[simp, norm_cast] theorem lxor_to_nat  : ∀ m n, (lxor   m n : ℕ) = nat.lxor   m n :=
by apply bitwise_to_nat pos_num.lxor; intros; try {cases a}; try {cases b}; refl

@[simp, norm_cast] theorem shiftl_to_nat (m n) : (shiftl m n : ℕ) = nat.shiftl m n :=
begin
  cases m; dunfold shiftl, {symmetry, apply nat.zero_shiftl},
  simp, induction n with n IH, {refl},
  simp [pos_num.shiftl, nat.shiftl_succ], rw ←IH
end

@[simp, norm_cast] theorem shiftr_to_nat (m n) : (shiftr m n : ℕ) = nat.shiftr m n :=
begin
  cases m with m; dunfold shiftr, {symmetry, apply nat.zero_shiftr},
  induction n with n IH generalizing m, {cases m; refl},
  cases m with m m; dunfold pos_num.shiftr,
  { rw [nat.shiftr_eq_div_pow], symmetry, apply nat.div_eq_of_lt,
    exact @nat.pow_lt_pow_of_lt_right 2 dec_trivial 0 (n+1) (nat.succ_pos _) },
  { transitivity, apply IH,
    change nat.shiftr m n = nat.shiftr (bit1 m) (n+1),
    rw [add_comm n 1, nat.shiftr_add],
    apply congr_arg (λx, nat.shiftr x n), unfold nat.shiftr,
    change (bit1 ↑m : ℕ) with nat.bit tt m,
    rw nat.div2_bit },
  { transitivity, apply IH,
    change nat.shiftr m n = nat.shiftr (bit0 m) (n + 1),
    rw [add_comm n 1, nat.shiftr_add],
    apply congr_arg (λx, nat.shiftr x n), unfold nat.shiftr,
    change (bit0 ↑m : ℕ) with nat.bit ff m,
    rw nat.div2_bit }
end

@[simp] theorem test_bit_to_nat (m n) : test_bit m n = nat.test_bit m n :=
begin
  cases m with m; unfold test_bit nat.test_bit,
  { change (zero : nat) with 0, rw nat.zero_shiftr, refl },
  induction n with n IH generalizing m;
  cases m; dunfold pos_num.test_bit, {refl},
  { exact (nat.bodd_bit _ _).symm },
  { exact (nat.bodd_bit _ _).symm },
  { change ff = nat.bodd (nat.shiftr 1 (n + 1)),
    rw [add_comm, nat.shiftr_add], change nat.shiftr 1 1 with 0,
    rw nat.zero_shiftr; refl },
  { change pos_num.test_bit m n = nat.bodd (nat.shiftr (nat.bit tt m) (n + 1)),
    rw [add_comm, nat.shiftr_add], unfold nat.shiftr,
    rw nat.div2_bit, apply IH },
  { change pos_num.test_bit m n = nat.bodd (nat.shiftr (nat.bit ff m) (n + 1)),
    rw [add_comm, nat.shiftr_add], unfold nat.shiftr,
    rw nat.div2_bit, apply IH },
end

end num

namespace znum
variables {α : Type*}
open pos_num

@[simp, norm_cast] theorem cast_zero [has_zero α] [has_one α] [has_add α] [has_neg α] :
  ((0 : znum) : α) = 0 := rfl

@[simp] theorem cast_zero' [has_zero α] [has_one α] [has_add α] [has_neg α] :
  (znum.zero : α) = 0 := rfl

@[simp, norm_cast] theorem cast_one [has_zero α] [has_one α] [has_add α] [has_neg α] :
  ((1 : znum) : α) = 1 := rfl

@[simp] theorem cast_pos [has_zero α] [has_one α] [has_add α] [has_neg α]
  (n : pos_num) : (pos n : α) = n := rfl

@[simp] theorem cast_neg [has_zero α] [has_one α] [has_add α] [has_neg α]
  (n : pos_num) : (neg n : α) = -n := rfl

@[simp, norm_cast] theorem cast_zneg [add_group α] [has_one α] : ∀ n, ((-n : znum) : α) = -n
| 0       := neg_zero.symm
| (pos p) := rfl
| (neg p) := (neg_neg _).symm

theorem neg_zero : (-0 : znum) = 0 := rfl
theorem zneg_pos (n : pos_num) : -pos n = neg n := rfl
theorem zneg_neg (n : pos_num) : -neg n = pos n := rfl
theorem zneg_zneg (n : znum) : - -n = n := by cases n; refl
theorem zneg_bit1 (n : znum) : -n.bit1 = (-n).bitm1 := by cases n; refl
theorem zneg_bitm1 (n : znum) : -n.bitm1 = (-n).bit1 := by cases n; refl

theorem zneg_succ (n : znum) : -n.succ = (-n).pred :=
by cases n; try {refl}; rw [succ, num.zneg_to_znum_neg]; refl

theorem zneg_pred (n : znum) : -n.pred = (-n).succ :=
by rw [← zneg_zneg (succ (-n)), zneg_succ, zneg_zneg]

@[simp] theorem abs_to_nat : ∀ n, (abs n : ℕ) = int.nat_abs n
| 0       := rfl
| (pos p) := congr_arg int.nat_abs p.to_nat_to_int
| (neg p) := show int.nat_abs ((p:ℕ):ℤ) = int.nat_abs (- p),
  by rw [p.to_nat_to_int, int.nat_abs_neg]

@[simp] theorem abs_to_znum : ∀ n : num, abs n.to_znum = n
| 0           := rfl
| (num.pos p) := rfl

@[simp, norm_cast] theorem cast_to_int [add_group_with_one α] : ∀ n : znum, ((n : ℤ) : α) = n
| 0       := by rw [cast_zero, cast_zero, int.cast_zero]
| (pos p) := by rw [cast_pos, cast_pos, pos_num.cast_to_int]
| (neg p) := by rw [cast_neg, cast_neg, int.cast_neg, pos_num.cast_to_int]

theorem bit0_of_bit0 : ∀ n : znum, _root_.bit0 n = n.bit0
| 0       := rfl
| (pos a) := congr_arg pos a.bit0_of_bit0
| (neg a) := congr_arg neg a.bit0_of_bit0

theorem bit1_of_bit1 : ∀ n : znum, _root_.bit1 n = n.bit1
| 0       := rfl
| (pos a) := congr_arg pos a.bit1_of_bit1
| (neg a) := show pos_num.sub' 1 (_root_.bit0 a) = _,
  by rw [pos_num.one_sub', a.bit0_of_bit0]; refl

@[simp, norm_cast] theorem cast_bit0 [add_group_with_one α] :
  ∀ n : znum, (n.bit0 : α) = bit0 n
| 0       := (add_zero _).symm
| (pos p) := by rw [znum.bit0, cast_pos, cast_pos]; refl
| (neg p) := by rw [znum.bit0, cast_neg, cast_neg, pos_num.cast_bit0,
                    _root_.bit0, _root_.bit0, neg_add_rev]

@[simp, norm_cast] theorem cast_bit1 [add_group_with_one α] :
  ∀ n : znum, (n.bit1 : α) = bit1 n
| 0       := by simp [znum.bit1, _root_.bit1, _root_.bit0]
| (pos p) := by rw [znum.bit1, cast_pos, cast_pos]; refl
| (neg p) := begin
    rw [znum.bit1, cast_neg, cast_neg],
    cases e : pred' p with a;
    have : p = _ := (succ'_pred' p).symm.trans
      (congr_arg num.succ' e),
    { change p=1 at this, subst p,
      simp [_root_.bit1, _root_.bit0] },
    { rw [num.succ'] at this, subst p,
      have : (↑(-↑a:ℤ) : α) = -1 + ↑(-↑a + 1 : ℤ), {simp [add_comm]},
      simpa [_root_.bit1, _root_.bit0, -add_comm] },
  end

@[simp] theorem cast_bitm1 [add_group_with_one α]
  (n : znum) : (n.bitm1 : α) = bit0 n - 1 :=
begin
  conv { to_lhs, rw ← zneg_zneg n },
  rw [← zneg_bit1, cast_zneg, cast_bit1],
  have : ((-1 + n + n : ℤ) : α) = (n + n + -1 : ℤ), {simp [add_comm, add_left_comm]},
  simpa [_root_.bit1, _root_.bit0, sub_eq_add_neg, -int.add_neg_one]
end

theorem add_zero (n : znum) : n + 0 = n := by cases n; refl
theorem zero_add (n : znum) : 0 + n = n := by cases n; refl

theorem add_one : ∀ n : znum, n + 1 = succ n
| 0       := rfl
| (pos p) := congr_arg pos p.add_one
| (neg p) := by cases p; refl

end znum

namespace pos_num
variables {α : Type*}

theorem cast_to_znum : ∀ n : pos_num, (n : znum) = znum.pos n
| 1        := rfl
| (bit0 p) := (znum.bit0_of_bit0 p).trans $ congr_arg _ (cast_to_znum p)
| (bit1 p) := (znum.bit1_of_bit1 p).trans $ congr_arg _ (cast_to_znum p)

local attribute [-simp] int.add_neg_one

theorem cast_sub' [add_group_with_one α] : ∀ m n : pos_num, (sub' m n : α) = m - n
| a        1        := by rw [sub'_one, num.cast_to_znum,
                              ← num.cast_to_nat, pred'_to_nat, ← nat.sub_one];
                          simp [pos_num.cast_pos]
| 1        b        := by rw [one_sub', num.cast_to_znum_neg, ← neg_sub, neg_inj,
                              ← num.cast_to_nat, pred'_to_nat, ← nat.sub_one];
                          simp [pos_num.cast_pos]
| (bit0 a) (bit0 b) := begin
    rw [sub', znum.cast_bit0, cast_sub'],
    have : ((a + -b + (a + -b) : ℤ) : α) = a + a + (-b + -b), {simp [add_left_comm]},
    simpa [_root_.bit0, sub_eq_add_neg]
  end
| (bit0 a) (bit1 b) := begin
    rw [sub', znum.cast_bitm1, cast_sub'],
    have : ((-b + (a + (-b + -1)) : ℤ) : α) = (a + -1 + (-b + -b):ℤ),
    { simp [add_comm, add_left_comm] },
    simpa [_root_.bit1, _root_.bit0, sub_eq_add_neg]
  end
| (bit1 a) (bit0 b) := begin
    rw [sub', znum.cast_bit1, cast_sub'],
    have : ((-b + (a + (-b + 1)) : ℤ) : α) = (a + 1 + (-b + -b):ℤ),
    { simp [add_comm, add_left_comm] },
    simpa [_root_.bit1, _root_.bit0, sub_eq_add_neg]
  end
| (bit1 a) (bit1 b) := begin
    rw [sub', znum.cast_bit0, cast_sub'],
    have : ((-b + (a + -b) : ℤ) : α) = a + (-b + -b), {simp [add_left_comm]},
    simpa [_root_.bit1, _root_.bit0, sub_eq_add_neg]
  end

theorem to_nat_eq_succ_pred (n : pos_num) : (n:ℕ) = n.pred' + 1 :=
by rw [← num.succ'_to_nat, n.succ'_pred']

theorem to_int_eq_succ_pred (n : pos_num) : (n:ℤ) = (n.pred' : ℕ) + 1 :=
by rw [← n.to_nat_to_int, to_nat_eq_succ_pred]; refl

end pos_num

namespace num
variables {α : Type*}

@[simp] theorem cast_sub' [add_group_with_one α] : ∀ m n : num, (sub' m n : α) = m - n
| 0       0       := (sub_zero _).symm
| (pos a) 0       := (sub_zero _).symm
| 0       (pos b) := (zero_sub _).symm
| (pos a) (pos b) := pos_num.cast_sub' _ _

theorem to_znum_succ : ∀ n : num, n.succ.to_znum = n.to_znum.succ
| 0 := rfl
| (pos n) := rfl

theorem to_znum_neg_succ : ∀ n : num, n.succ.to_znum_neg = n.to_znum_neg.pred
| 0 := rfl
| (pos n) := rfl

@[simp] theorem pred_succ : ∀ n : znum, n.pred.succ = n
| 0 := rfl
| (znum.neg p) := show to_znum_neg (pos p).succ'.pred' = _, by rw [pos_num.pred'_succ']; refl
| (znum.pos p) := by rw [znum.pred, ← to_znum_succ, num.succ, pos_num.succ'_pred', to_znum]

theorem succ_of_int' : ∀ n, znum.of_int' (n + 1) = znum.of_int' n + 1
| (n : ℕ) := by erw [znum.of_int', znum.of_int', num.of_nat'_succ,
  num.add_one, to_znum_succ, znum.add_one]
| -[1+ 0] := by erw [znum.of_int', znum.of_int', of_nat'_succ, of_nat'_zero]; refl
| -[1+ n+1] := by erw [znum.of_int', znum.of_int', @num.of_nat'_succ (n+1), num.add_one,
  to_znum_neg_succ, @of_nat'_succ n, num.add_one, znum.add_one, pred_succ]

theorem of_int'_to_znum : ∀ n : ℕ, to_znum n = znum.of_int' n
| 0 := rfl
| (n+1) := by rw [nat.cast_succ, num.add_one, to_znum_succ, of_int'_to_znum, nat.cast_succ,
  succ_of_int', znum.add_one]

theorem mem_of_znum' : ∀ {m : num} {n : znum}, m ∈ of_znum' n ↔ n = to_znum m
| 0       0      := ⟨λ _, rfl, λ _, rfl⟩
| (pos m) 0      := ⟨λ h, by cases h, λ h, by cases h⟩
| m (znum.pos p) := option.some_inj.trans $
  by cases m; split; intro h; try {cases h}; refl
| m (znum.neg p) := ⟨λ h, by cases h, λ h, by cases m; cases h⟩

theorem of_znum'_to_nat : ∀ (n : znum), coe <$> of_znum' n = int.to_nat' n
| 0            := rfl
| (znum.pos p) := show _ = int.to_nat' p, by rw [← pos_num.to_nat_to_int p]; refl
| (znum.neg p) := congr_arg (λ x, int.to_nat' (-x)) $
  show ((p.pred' + 1 : ℕ) : ℤ) = p, by rw ← succ'_to_nat; simp

@[simp] theorem of_znum_to_nat : ∀ (n : znum), (of_znum n : ℕ) = int.to_nat n
| 0            := rfl
| (znum.pos p) := show _ = int.to_nat p, by rw [← pos_num.to_nat_to_int p]; refl
| (znum.neg p) := congr_arg (λ x, int.to_nat (-x)) $
  show ((p.pred' + 1 : ℕ) : ℤ) = p, by rw ← succ'_to_nat; simp

@[simp] theorem cast_of_znum [add_group_with_one α] (n : znum) :
  (of_znum n : α) = int.to_nat n :=
by rw [← cast_to_nat, of_znum_to_nat]

@[simp, norm_cast] theorem sub_to_nat (m n) : ((m - n : num) : ℕ) = m - n :=
show (of_znum _ : ℕ) = _, by rw [of_znum_to_nat, cast_sub',
  ← to_nat_to_int, ← to_nat_to_int, int.to_nat_sub]

end num

namespace znum
variables {α : Type*}

@[simp, norm_cast] theorem cast_add [add_group_with_one α] : ∀ m n, ((m + n : znum) : α) = m + n
| 0       a       := by cases a; exact (_root_.zero_add _).symm
| b       0       := by cases b; exact (_root_.add_zero _).symm
| (pos a) (pos b) := pos_num.cast_add _ _
| (pos a) (neg b) := by simpa only [sub_eq_add_neg] using pos_num.cast_sub' _ _
| (neg a) (pos b) :=
have (↑b + -↑a : α) = -↑a + ↑b, by rw [← pos_num.cast_to_int a, ← pos_num.cast_to_int b,
  ← int.cast_neg, ← int.cast_add (-a)]; simp [add_comm],
(pos_num.cast_sub' _ _).trans $ (sub_eq_add_neg _ _).trans this
| (neg a) (neg b) := show -(↑(a + b) : α) = -a + -b, by rw [
  pos_num.cast_add, neg_eq_iff_neg_eq, neg_add_rev, neg_neg, neg_neg,
  ← pos_num.cast_to_int a, ← pos_num.cast_to_int b, ← int.cast_add]; simp [add_comm]

@[simp] theorem cast_succ [add_group_with_one α] (n) : ((succ n : znum) : α) = n + 1 :=
by rw [← add_one, cast_add, cast_one]

@[simp, norm_cast] theorem mul_to_int : ∀ m n, ((m * n : znum) : ℤ) = m * n
| 0       a       := by cases a; exact (_root_.zero_mul _).symm
| b       0       := by cases b; exact (_root_.mul_zero _).symm
| (pos a) (pos b) := pos_num.cast_mul a b
| (pos a) (neg b) := show -↑(a * b) = ↑a * -↑b, by rw [pos_num.cast_mul, neg_mul_eq_mul_neg]
| (neg a) (pos b) := show -↑(a * b) = -↑a * ↑b, by rw [pos_num.cast_mul, neg_mul_eq_neg_mul]
| (neg a) (neg b) := show ↑(a * b) = -↑a * -↑b, by rw [pos_num.cast_mul, neg_mul_neg]

theorem cast_mul [ring α] (m n) : ((m * n : znum) : α) = m * n :=
by rw [← cast_to_int, mul_to_int, int.cast_mul, cast_to_int, cast_to_int]

theorem of_int'_neg : ∀ n : ℤ, of_int' (-n) = -of_int' n
| -[1+ n] := show of_int' (n + 1 : ℕ) = _, by simp only [of_int', num.zneg_to_znum_neg]
| 0 := show num.to_znum _ = -num.to_znum _, by rw [num.of_nat'_zero]; refl
| (n+1 : ℕ) := show num.to_znum_neg _ = -num.to_znum _, by rw [num.zneg_to_znum]; refl

theorem of_to_int' : ∀ (n : znum), znum.of_int' n = n
| 0       := by erw [of_int', num.of_nat'_zero, num.to_znum]
| (pos a) := by rw [cast_pos, ← pos_num.cast_to_nat, ← num.of_int'_to_znum, pos_num.of_to_nat]; refl
| (neg a) := by rw [cast_neg, of_int'_neg, ← pos_num.cast_to_nat, ← num.of_int'_to_znum,
  pos_num.of_to_nat]; refl

theorem to_int_inj {m n : znum} : (m : ℤ) = n ↔ m = n :=
⟨λ h, function.left_inverse.injective of_to_int' h, congr_arg _⟩

theorem cmp_to_int : ∀ (m n), (ordering.cases_on (cmp m n) ((m:ℤ) < n) (m = n) ((n:ℤ) < m) : Prop)
| 0       0       := rfl
| (pos a) (pos b) := begin
    have := pos_num.cmp_to_nat a b; revert this; dsimp [cmp];
    cases pos_num.cmp a b; dsimp;
    [simp, exact congr_arg pos, simp [gt]]
  end
| (neg a) (neg b) := begin
    have := pos_num.cmp_to_nat b a; revert this; dsimp [cmp];
    cases pos_num.cmp b a; dsimp;
    [simp, simp {contextual := tt}, simp [gt]]
  end
| (pos a) 0       := pos_num.cast_pos _
| (pos a) (neg b) := lt_trans (neg_lt_zero.2 $ pos_num.cast_pos _) (pos_num.cast_pos _)
| 0       (neg b) := neg_lt_zero.2 $ pos_num.cast_pos _
| (neg a) 0       := neg_lt_zero.2 $ pos_num.cast_pos _
| (neg a) (pos b) := lt_trans (neg_lt_zero.2 $ pos_num.cast_pos _) (pos_num.cast_pos _)
| 0       (pos b) := pos_num.cast_pos _

@[norm_cast]
theorem lt_to_int {m n : znum} : (m:ℤ) < n ↔ m < n :=
show (m:ℤ) < n ↔ cmp m n = ordering.lt, from
match cmp m n, cmp_to_int m n with
| ordering.lt, h := by simp at h; simp [h]
| ordering.eq, h := by simp at h; simp [h, lt_irrefl]; exact dec_trivial
| ordering.gt, h := by simp [not_lt_of_gt h]; exact dec_trivial
end

theorem le_to_int {m n : znum} : (m:ℤ) ≤ n ↔ m ≤ n :=
by rw ← not_lt; exact not_congr lt_to_int

@[simp, norm_cast]
theorem cast_lt [linear_ordered_ring α] {m n : znum} : (m:α) < n ↔ m < n :=
by rw [← cast_to_int m, ← cast_to_int n, int.cast_lt, lt_to_int]

@[simp, norm_cast]
theorem cast_le [linear_ordered_ring α] {m n : znum} : (m:α) ≤ n ↔ m ≤ n :=
by rw ← not_lt; exact not_congr cast_lt

@[simp, norm_cast]
theorem cast_inj [linear_ordered_ring α] {m n : znum} : (m:α) = n ↔ m = n :=
by rw [← cast_to_int m, ← cast_to_int n, int.cast_inj, to_int_inj]

/--
This tactic tries to turn an (in)equality about `znum`s to one about `int`s by rewriting.
```lean
example (n : znum) (m : znum) : n ≤ n + m * m :=
begin
  znum.transfer_rw,
  exact le_add_of_nonneg_right (mul_self_nonneg _)
end
```
-/
meta def transfer_rw : tactic unit :=
`[repeat {rw ← to_int_inj <|> rw ← lt_to_int <|> rw ← le_to_int},
  repeat {rw cast_add <|> rw mul_to_int <|> rw cast_one <|> rw cast_zero}]

/--
This tactic tries to prove (in)equalities about `znum`s by transfering them to the `int` world and
then trying to call `simp`.
```lean
example (n : znum) (m : znum) : n ≤ n + m * m :=
begin
  znum.transfer,
  exact mul_self_nonneg _
end
```
-/
meta def transfer : tactic unit :=
`[intros, transfer_rw, try {simp [add_comm, add_left_comm, mul_comm, mul_left_comm]}]

instance : linear_order znum :=
{ lt               := (<),
  lt_iff_le_not_le := by {intros a b, transfer_rw, apply lt_iff_le_not_le},
  le               := (≤),
  le_refl          := by transfer,
  le_trans         := by {intros a b c, transfer_rw, apply le_trans},
  le_antisymm      := by {intros a b, transfer_rw, apply le_antisymm},
  le_total         := by {intros a b, transfer_rw, apply le_total},
  decidable_eq     := znum.decidable_eq,
  decidable_le     := znum.decidable_le,
  decidable_lt     := znum.decidable_lt }

instance : add_comm_group znum :=
{ add              := (+),
  add_assoc        := by transfer,
  zero             := 0,
  zero_add         := zero_add,
  add_zero         := add_zero,
  add_comm         := by transfer,
  neg              := has_neg.neg,
  add_left_neg     := by transfer }

instance : add_monoid_with_one znum :=
{ one := 1,
  nat_cast := λ n, znum.of_int' n,
  nat_cast_zero := show (num.of_nat' 0).to_znum = 0, by rw num.of_nat'_zero; refl,
  nat_cast_succ := λ n, show (num.of_nat' (n+1)).to_znum = (num.of_nat' n).to_znum + 1,
    by rw [num.of_nat'_succ, num.add_one, num.to_znum_succ, znum.add_one],
  .. znum.add_comm_group }

instance : linear_ordered_comm_ring znum :=
{ mul              := (*),
  mul_assoc        := by transfer,
  one              := 1,
  one_mul          := by transfer,
  mul_one          := by transfer,
  left_distrib     := by {transfer, simp [mul_add]},
  right_distrib    := by {transfer, simp [mul_add, mul_comm]},
  mul_comm         := by transfer,
  exists_pair_ne   := ⟨0, 1, dec_trivial⟩,
  add_le_add_left  := by {intros a b h c, revert h, transfer_rw, exact λ h, add_le_add_left h c},
  mul_pos          := λ a b, show 0 < a → 0 < b → 0 < a * b, by {transfer_rw, apply mul_pos},
  zero_le_one      := dec_trivial,
  ..znum.linear_order, ..znum.add_comm_group, ..znum.add_monoid_with_one }

@[simp, norm_cast] theorem cast_sub [ring α] (m n) : ((m - n : znum) : α) = m - n :=
by simp [sub_eq_neg_add]

@[simp, norm_cast]

@[simp] theorem of_int'_eq : ∀ n : ℤ, znum.of_int' n = n
| (n : ℕ) := rfl
| -[1+ n] := begin
  show num.to_znum_neg (n+1 : ℕ) = -(n+1 : ℕ),
  rw [← neg_inj, neg_neg, nat.cast_succ, num.add_one, num.zneg_to_znum_neg, num.to_znum_succ,
    nat.cast_succ, znum.add_one],
  refl
end

@[simp] theorem of_nat_to_znum (n : ℕ) : num.to_znum n = n := rfl

@[simp, norm_cast] theorem of_to_int (n : znum) : ((n : ℤ) : znum) = n :=
by rw [← of_int'_eq, of_to_int']

theorem to_of_int (n : ℤ) : ((n : znum) : ℤ) = n :=
int.induction_on' n 0 (by simp) (by simp) (by simp)

@[simp] theorem of_nat_to_znum_neg (n : ℕ) : num.to_znum_neg n = -n :=
by rw [← of_nat_to_znum, num.zneg_to_znum]

@[simp, norm_cast] theorem of_int_cast [add_group_with_one α] (n : ℤ) : ((n : znum) : α) = n :=
by rw [← cast_to_int, to_of_int]

@[simp, norm_cast] theorem of_nat_cast [add_group_with_one α] (n : ℕ) : ((n : znum) : α) = n :=
by rw [← int.cast_coe_nat, of_int_cast, int.cast_coe_nat]

@[simp, norm_cast] theorem dvd_to_int (m n : znum) : (m : ℤ) ∣ n ↔ m ∣ n :=
⟨λ ⟨k, e⟩, ⟨k, by rw [← of_to_int n, e]; simp⟩,
 λ ⟨k, e⟩, ⟨k, by simp [e]⟩⟩

end znum

namespace pos_num

theorem divmod_to_nat_aux {n d : pos_num} {q r : num}
  (h₁ : (r:ℕ) + d * _root_.bit0 q = n)
  (h₂ : (r:ℕ) < 2 * d) :
  ((divmod_aux d q r).2 + d * (divmod_aux d q r).1 : ℕ) = ↑n ∧
  ((divmod_aux d q r).2 : ℕ) < d :=
begin
  unfold divmod_aux,
  have : ∀ {r₂}, num.of_znum' (num.sub' r (num.pos d)) = some r₂ ↔ (r : ℕ) = r₂ + d,
  { intro r₂,
    apply num.mem_of_znum'.trans,
    rw [← znum.to_int_inj, num.cast_to_znum,
      num.cast_sub', sub_eq_iff_eq_add, ← int.coe_nat_inj'],
    simp },
  cases e : num.of_znum' (num.sub' r (num.pos d)) with r₂;
    simp [divmod_aux],
  { refine ⟨h₁, lt_of_not_ge (λ h, _)⟩,
    cases nat.le.dest h with r₂ e',
    rw [← num.to_of_nat r₂, add_comm] at e',
    cases e.symm.trans (this.2 e'.symm) },
  { have := this.1 e,
    split,
    { rwa [_root_.bit1, add_comm _ 1, mul_add, mul_one,
        ← add_assoc, ← this] },
    { rwa [this, two_mul, add_lt_add_iff_right] at h₂ } }
end

theorem divmod_to_nat (d n : pos_num) :
  (n / d : ℕ) = (divmod d n).1 ∧
  (n % d : ℕ) = (divmod d n).2 :=
begin
  rw nat.div_mod_unique (pos_num.cast_pos _),
  induction n with n IH n IH,
  { exact divmod_to_nat_aux (by simp; refl)
      (nat.mul_le_mul_left 2
        (pos_num.cast_pos d : (0 : ℕ) < d)) },
  { unfold divmod,
    cases divmod d n with q r, simp only [divmod] at IH ⊢,
    apply divmod_to_nat_aux; simp,
    { rw [_root_.bit1, _root_.bit1, add_right_comm,
        bit0_eq_two_mul (n : ℕ), ← IH.1,
        mul_add, ← bit0_eq_two_mul,
        mul_left_comm, ← bit0_eq_two_mul] },
    { rw ← bit0_eq_two_mul,
      exact nat.bit1_lt_bit0 IH.2 } },
  { unfold divmod,
    cases divmod d n with q r, simp only [divmod] at IH ⊢,
    apply divmod_to_nat_aux; simp,
    { rw [bit0_eq_two_mul (n : ℕ), ← IH.1,
        mul_add, ← bit0_eq_two_mul,
        mul_left_comm, ← bit0_eq_two_mul] },
    { rw ← bit0_eq_two_mul,
      exact nat.bit0_lt IH.2 } }
end

@[simp] theorem div'_to_nat (n d) : (div' n d : ℕ) = n / d :=
(divmod_to_nat _ _).1.symm

@[simp] theorem mod'_to_nat (n d) : (mod' n d : ℕ) = n % d :=
(divmod_to_nat _ _).2.symm

end pos_num

namespace num

@[simp] protected lemma div_zero (n : num) : n / 0 = 0 :=
show n.div 0 = 0, by { cases n, refl, simp [num.div] }

@[simp, norm_cast] theorem div_to_nat : ∀ n d, ((n / d : num) : ℕ) = n / d
| 0       0       := by simp
| 0       (pos d) := (nat.zero_div _).symm
| (pos n) 0       := (nat.div_zero _).symm
| (pos n) (pos d) := pos_num.div'_to_nat _ _

@[simp] protected lemma mod_zero (n : num) : n % 0 = n :=
show n.mod 0 = n, by { cases n, refl, simp [num.mod] }

@[simp, norm_cast] theorem mod_to_nat : ∀ n d, ((n % d : num) : ℕ) = n % d
| 0       0       := by simp
| 0       (pos d) := (nat.zero_mod _).symm
| (pos n) 0       := (nat.mod_zero _).symm
| (pos n) (pos d) := pos_num.mod'_to_nat _ _

theorem gcd_to_nat_aux : ∀ {n} {a b : num},
  a ≤ b → (a * b).nat_size ≤ n → (gcd_aux n a b : ℕ) = nat.gcd a b
| 0            0       b       ab h := (nat.gcd_zero_left _).symm
| 0            (pos a) 0       ab h := (not_lt_of_ge ab).elim rfl
| 0            (pos a) (pos b) ab h :=
  (not_lt_of_le h).elim $ pos_num.nat_size_pos _
| (nat.succ n) 0       b       ab h := (nat.gcd_zero_left _).symm
| (nat.succ n) (pos a) b       ab h := begin
  simp [gcd_aux],
  rw [nat.gcd_rec, gcd_to_nat_aux, mod_to_nat], {refl},
  { rw [← le_to_nat, mod_to_nat],
    exact le_of_lt (nat.mod_lt _ (pos_num.cast_pos _)) },
  rw [nat_size_to_nat, mul_to_nat, nat.size_le] at h ⊢,
  rw [mod_to_nat, mul_comm],
  rw [pow_succ', ← nat.mod_add_div b (pos a)] at h,
  refine lt_of_mul_lt_mul_right (lt_of_le_of_lt _ h) (nat.zero_le 2),
  rw [mul_two, mul_add],
  refine add_le_add_left (nat.mul_le_mul_left _
    (le_trans (le_of_lt (nat.mod_lt _ (pos_num.cast_pos _))) _)) _,
  suffices : 1 ≤ _, simpa using nat.mul_le_mul_left (pos a) this,
  rw [nat.le_div_iff_mul_le a.cast_pos, one_mul],
  exact le_to_nat.2 ab
end

@[simp] theorem gcd_to_nat : ∀ a b, (gcd a b : ℕ) = nat.gcd a b :=
have ∀ a b : num, (a * b).nat_size ≤ a.nat_size + b.nat_size,
begin
  intros,
  simp [nat_size_to_nat],
  rw [nat.size_le, pow_add],
  exact mul_lt_mul'' (nat.lt_size_self _)
    (nat.lt_size_self _) (nat.zero_le _) (nat.zero_le _)
end,
begin
  intros, unfold gcd, split_ifs,
  { exact gcd_to_nat_aux h (this _ _) },
  { rw nat.gcd_comm,
    exact gcd_to_nat_aux (le_of_not_le h) (this _ _) }
end

theorem dvd_iff_mod_eq_zero {m n : num} : m ∣ n ↔ n % m = 0 :=
by rw [← dvd_to_nat, nat.dvd_iff_mod_eq_zero,
  ← to_nat_inj, mod_to_nat]; refl

instance decidable_dvd : decidable_rel ((∣) : num → num → Prop)
| a b := decidable_of_iff' _ dvd_iff_mod_eq_zero

end num

instance pos_num.decidable_dvd : decidable_rel ((∣) : pos_num → pos_num → Prop)
| a b := num.decidable_dvd _ _

namespace znum

@[simp] protected lemma div_zero (n : znum) : n / 0 = 0 :=
show n.div 0 = 0, by cases n; refl <|> simp [znum.div]

@[simp, norm_cast] theorem div_to_int : ∀ n d, ((n / d : znum) : ℤ) = n / d
| 0       0       := by simp [int.div_zero]
| 0       (pos d) := (int.zero_div _).symm
| 0       (neg d) := (int.zero_div _).symm
| (pos n) 0       := (int.div_zero _).symm
| (neg n) 0       := (int.div_zero _).symm
| (pos n) (pos d) := (num.cast_to_znum _).trans $
  by rw ← num.to_nat_to_int; simp
| (pos n) (neg d) := (num.cast_to_znum_neg _).trans $
  by rw ← num.to_nat_to_int; simp
| (neg n) (pos d) := show - _ = (-_/↑d), begin
    rw [n.to_int_eq_succ_pred, d.to_int_eq_succ_pred,
      ← pos_num.to_nat_to_int, num.succ'_to_nat,
      num.div_to_nat],
    change -[1+ n.pred' / ↑d] = -[1+ n.pred' / (d.pred' + 1)],
    rw d.to_nat_eq_succ_pred
  end
| (neg n) (neg d) := show ↑(pos_num.pred' n / num.pos d).succ' = (-_ / -↑d), begin
    rw [n.to_int_eq_succ_pred, d.to_int_eq_succ_pred,
      ← pos_num.to_nat_to_int, num.succ'_to_nat,
      num.div_to_nat],
    change (nat.succ (_/d) : ℤ) = nat.succ (n.pred'/(d.pred' + 1)),
    rw d.to_nat_eq_succ_pred
  end

@[simp, norm_cast] theorem mod_to_int : ∀ n d, ((n % d : znum) : ℤ) = n % d
| 0       d := (int.zero_mod _).symm
| (pos n) d := (num.cast_to_znum _).trans $
  by rw [← num.to_nat_to_int, cast_pos, num.mod_to_nat,
    ← pos_num.to_nat_to_int, abs_to_nat]; refl
| (neg n) d := (num.cast_sub' _ _).trans $
  by rw [← num.to_nat_to_int, cast_neg, ← num.to_nat_to_int,
    num.succ_to_nat, num.mod_to_nat, abs_to_nat,
    ← int.sub_nat_nat_eq_coe, n.to_int_eq_succ_pred]; refl

@[simp] theorem gcd_to_nat (a b) : (gcd a b : ℕ) = int.gcd a b :=
(num.gcd_to_nat _ _).trans $ by simpa

theorem dvd_iff_mod_eq_zero {m n : znum} : m ∣ n ↔ n % m = 0 :=
by rw [← dvd_to_int, int.dvd_iff_mod_eq_zero,
  ← to_int_inj, mod_to_int]; refl

instance : decidable_rel ((∣) : znum → znum → Prop)
| a b := decidable_of_iff' _ dvd_iff_mod_eq_zero

end znum

namespace int

/-- Cast a `snum` to the corresponding integer. -/
def of_snum : snum → ℤ :=
snum.rec' (λ a, cond a (-1) 0) (λa p IH, cond a (bit1 IH) (bit0 IH))

instance snum_coe : has_coe snum ℤ := ⟨of_snum⟩
end int

instance : has_lt snum := ⟨λa b, (a : ℤ) < b⟩
instance : has_le snum := ⟨λa b, (a : ℤ) ≤ b⟩


structure Foo where
  x : Nat
  y : Nat

structure Boo where
  w : Nat
  z : Nat

structure Bla extends Foo, Boo where
  bit : Bool

#check Bla.mk -- Foo → Boo → Bool → Bla
#check Bla.mk { x := 10, y := 20 } { w := 30, z := 40 } true
#check { x := 10, y := 20, w := 30, z := 40, bit := true : Bla }
#check { toFoo := { x := 10, y := 20 },
         toBoo := { w := 30, z := 40 },
         bit := true : Bla }

theorem ex :
    Bla.mk { x := x, y := y } { w := w, z := z } b
    =
    { x := x, y := y, w := w, z := z, bit := b } :=
  rfl
#check @ex


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import algebra.group.basic
import category_theory.pi.basic
import category_theory.shift

/-!
# The category of graded objects

For any type `β`, a `β`-graded object over some category `C` is just
a function `β → C` into the objects of `C`.
We put the "pointwise" category structure on these, as the non-dependent specialization of
`category_theory.pi`.

We describe the `comap` functors obtained by precomposing with functions `β → γ`.

As a consequence a fixed element (e.g. `1`) in an additive group `β` provides a shift
functor on `β`-graded objects

When `C` has coproducts we construct the `total` functor `graded_object β C ⥤ C`,
show that it is faithful, and deduce that when `C` is concrete so is `graded_object β C`.
-/

open category_theory.pi
open category_theory.limits

namespace category_theory

universes w v u

/-- A type synonym for `β → C`, used for `β`-graded objects in a category `C`. -/
def graded_object (β : Type w) (C : Type u) : Type (max w u) := β → C

-- Satisfying the inhabited linter...
instance inhabited_graded_object (β : Type w) (C : Type u) [inhabited C] :
  inhabited (graded_object β C) :=
⟨λ b, inhabited.default C⟩

/--
A type synonym for `β → C`, used for `β`-graded objects in a category `C`
with a shift functor given by translation by `s`.
-/
@[nolint unused_arguments] -- `s` is here to distinguish type synonyms asking for different shifts
abbreviation graded_object_with_shift {β : Type w} [add_comm_group β] (s : β) (C : Type u) :
  Type (max w u) := graded_object β C

namespace graded_object

variables {C : Type u} [category.{v} C]

instance category_of_graded_objects (β : Type w) : category.{(max w v)} (graded_object β C) :=
category_theory.pi (λ _, C)

/-- The projection of a graded object to its `i`-th component. -/
@[simps] def eval {β : Type w} (b : β) : graded_object β C ⥤ C :=
{ obj := λ X, X b,
  map := λ X Y f, f b, }

section
variable (C)

/--
The natural isomorphism comparing between
pulling back along two propositionally equal functions.
-/
@[simps]
def comap_eq {β γ : Type w} {f g : β → γ} (h : f = g) : comap (λ _, C) f ≅ comap (λ _, C) g :=
{ hom := { app := λ X b, eq_to_hom begin dsimp [comap], subst h, end },
  inv := { app := λ X b, eq_to_hom begin dsimp [comap], subst h, end }, }

lemma comap_eq_symm {β γ : Type w} {f g : β → γ} (h : f = g) :
  comap_eq C h.symm = (comap_eq C h).symm :=
by tidy

lemma comap_eq_trans {β γ : Type w} {f g h : β → γ} (k : f = g) (l : g = h) :
  comap_eq C (k.trans l) = comap_eq C k ≪≫ comap_eq C l :=
begin
  ext X b,
  simp,
end

/--
The equivalence between β-graded objects and γ-graded objects,
given an equivalence between β and γ.
-/
@[simps]
def comap_equiv {β γ : Type w} (e : β ≃ γ) :
  (graded_object β C) ≌ (graded_object γ C) :=
{ functor := comap (λ _, C) (e.symm : γ → β),
  inverse := comap (λ _, C) (e : β → γ),
  counit_iso := (comap_comp (λ _, C) _ _).trans (comap_eq C (by { ext, simp } )),
  unit_iso := (comap_eq C (by { ext, simp } )).trans (comap_comp _ _ _).symm,
  functor_unit_iso_comp' := λ X, by { ext b, dsimp, simp, }, }  -- See note [dsimp, simp].

end

instance has_shift {β : Type*} [add_comm_group β] (s : β) :
  has_shift (graded_object_with_shift s C) :=
{ shift := comap_equiv C
  { to_fun := λ b, b-s,
    inv_fun := λ b, b+s,
    left_inv := λ x, (by simp),
    right_inv := λ x, (by simp), } }

@[simp] lemma shift_functor_obj_apply {β : Type*} [add_comm_group β] (s : β) (X : β → C) (t : β) :
  (shift (graded_object_with_shift s C)).functor.obj X t = X (t + s) :=
rfl

@[simp] lemma shift_functor_map_apply {β : Type*} [add_comm_group β] (s : β)
  {X Y : graded_object_with_shift s C} (f : X ⟶ Y) (t : β) :
  (shift (graded_object_with_shift s C)).functor.map f t = f (t + s) :=
rfl

instance has_zero_morphisms [has_zero_morphisms C] (β : Type w) :
  has_zero_morphisms.{(max w v)} (graded_object β C) :=
{ has_zero := λ X Y,
  { zero := λ b, 0 } }

@[simp]
lemma zero_apply [has_zero_morphisms C] (β : Type w) (X Y : graded_object β C) (b : β) :
  (0 : X ⟶ Y) b = 0 := rfl

section
open_locale zero_object

instance has_zero_object [has_zero_object C] [has_zero_morphisms C] (β : Type w) :
  has_zero_object.{(max w v)} (graded_object β C) :=
{ zero := λ b, (0 : C),
  unique_to := λ X, ⟨⟨λ b, 0⟩, λ f, (by ext)⟩,
  unique_from := λ X, ⟨⟨λ b, 0⟩, λ f, (by ext)⟩, }
end

end graded_object

namespace graded_object
-- The universes get a little hairy here, so we restrict the universe level for the grading to 0.
-- Since we're typically interested in grading by ℤ or a finite group, this should be okay.
-- If you're grading by things in higher universes, have fun!
variables (β : Type)
variables (C : Type u) [category.{v} C]
variables [has_coproducts C]

/--
The total object of a graded object is the coproduct of the graded components.
-/
noncomputable def total : graded_object β C ⥤ C :=
{ obj := λ X, ∐ (λ i : ulift.{v} β, X i.down),
  map := λ X Y f, limits.sigma.map (λ i, f i.down) }.

variables [has_zero_morphisms C]

/--
The `total` functor taking a graded object to the coproduct of its graded components is faithful.
To prove this, we need to know that the coprojections into the coproduct are monomorphisms,
which follows from the fact we have zero morphisms and decidable equality for the grading.
-/
instance : faithful (total β C) :=
{ map_injective' := λ X Y f g w,
  begin
    classical,
    ext i,
    replace w := sigma.ι (λ i : ulift.{v} β, X i.down) ⟨i⟩ ≫= w,
    erw [colimit.ι_map, colimit.ι_map] at w,
    exact mono.right_cancellation _ _ w,
  end }

end graded_object

namespace graded_object

noncomputable theory

variables (β : Type)
variables (C : Type (u+1)) [large_category C] [concrete_category C]
  [has_coproducts C] [has_zero_morphisms C]

instance : concrete_category (graded_object β C) :=
{ forget := total β C ⋙ forget C }

instance : has_forget₂ (graded_object β C) C :=
{ forget₂ := total β C }

end graded_object

end category_theory


/-
Copyright (c) 2016 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Leonardo de Moura
-/
namespace smt
universes u v
def array (α : Type u) (β : Type v) := α → β

variables {α : Type u} {β : Type v}
open tactic

def select (a : array α β) (i : α) : β :=
a i

lemma arrayext (a₁ a₂ : array α β) : (∀ i, select a₁ i = select a₂ i) → a₁ = a₂ :=
funext

variable [decidable_eq α]

def store (a : array α β) (i : α) (v : β) : array α β :=
λ j, if j = i then v else select a j

@[simp] lemma select_store (a : array α β) (i : α) (v : β) : select (store a i v) i = v :=
by unfold smt.store smt.select; rewrite if_pos; reflexivity

@[simp] lemma select_store_ne (a : array α β) (i j : α) (v : β) : j ≠ i → select (store a i v) j = select a j :=
by intros; unfold smt.store smt.select; rewrite if_neg; assumption

end smt


/-
Copyright (c) 2018 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro, Johannes Hölzl, Simon Hudon, Kenny Lau
-/
import data.multiset.basic
import control.traversable.lemmas
import control.traversable.instances

/-!
# Functoriality of `multiset`.
-/

universes u

namespace multiset

open list

instance : functor multiset :=
{ map := @map }

@[simp] lemma fmap_def {α' β'} {s : multiset α'} (f : α' → β') : f <$> s = s.map f := rfl

instance : is_lawful_functor multiset :=
by refine { .. }; intros; simp

open is_lawful_traversable is_comm_applicative

variables {F : Type u → Type u} [applicative F] [is_comm_applicative F]
variables {α' β' : Type u} (f : α' → F β')

def traverse : multiset α' → F (multiset β') :=
quotient.lift (functor.map coe ∘ traversable.traverse f)
begin
  introv p, unfold function.comp,
  induction p,
  case perm.nil { refl },
  case perm.cons
  { have : multiset.cons <$> f p_x <*> (coe <$> traverse f p_l₁) =
      multiset.cons <$> f p_x <*> (coe <$> traverse f p_l₂),
    { rw [p_ih] },
    simpa with functor_norm },
  case perm.swap
  { have : (λa b (l:list β'), (↑(a :: b :: l) : multiset β')) <$> f p_y <*> f p_x =
      (λa b l, ↑(a :: b :: l)) <$> f p_x <*> f p_y,
    { rw [is_comm_applicative.commutative_map],
      congr, funext a b l, simpa [flip] using perm.swap b a l },
    simp [(∘), this] with functor_norm },
  case perm.trans { simp [*] }
end

instance : monad multiset :=
{ pure := λ α x, {x},
  bind := @bind,
  .. multiset.functor }

@[simp] lemma pure_def {α} : (pure : α → multiset α) = singleton := rfl
@[simp] lemma bind_def {α β} : (>>=) = @bind α β := rfl

instance : is_lawful_monad multiset :=
{ bind_pure_comp_eq_map := λ α β f s, multiset.induction_on s rfl $ λ a s ih, by simp,
  pure_bind := λ α β x f, by simp [pure],
  bind_assoc := @bind_assoc }

open functor
open traversable is_lawful_traversable

@[simp]
lemma lift_coe {α β : Type*} (x : list α) (f : list α → β)
  (h : ∀ a b : list α, a ≈ b → f a = f b) :
  quotient.lift f h (x : multiset α) = f x :=
quotient.lift_mk _ _ _

@[simp]
lemma map_comp_coe {α β} (h : α → β) :
  functor.map h ∘ coe = (coe ∘ functor.map h : list α → multiset β) :=
by funext; simp [functor.map]

lemma id_traverse {α : Type*} (x : multiset α) :
  traverse id.mk x = x :=
quotient.induction_on x begin intro, simp [traverse], refl end

lemma comp_traverse {G H : Type* → Type*}
               [applicative G] [applicative H]
               [is_comm_applicative G] [is_comm_applicative H]
               {α β γ : Type*}
               (g : α → G β) (h : β → H γ) (x : multiset α) :
  traverse (comp.mk ∘ functor.map h ∘ g) x =
  comp.mk (functor.map (traverse h) (traverse g x)) :=
quotient.induction_on x
(by intro;
    simp [traverse,comp_traverse] with functor_norm;
    simp [(<$>),(∘)] with functor_norm)

lemma map_traverse {G : Type* → Type*}
               [applicative G] [is_comm_applicative G]
               {α β γ : Type*}
               (g : α → G β) (h : β → γ)
               (x : multiset α) :
  functor.map (functor.map h) (traverse g x) =
  traverse (functor.map h ∘ g) x :=
quotient.induction_on x
(by intro; simp [traverse] with functor_norm;
    rw [is_lawful_functor.comp_map, map_traverse])

lemma traverse_map {G : Type* → Type*}
               [applicative G] [is_comm_applicative G]
               {α β γ : Type*}
               (g : α → β) (h : β → G γ)
               (x : multiset α) :
  traverse h (map g x) =
  traverse (h ∘ g) x :=
quotient.induction_on x
(by intro; simp [traverse];
    rw [← traversable.traverse_map h g];
    [ refl, apply_instance ])

lemma naturality {G H : Type* → Type*}
                [applicative G] [applicative H]
                [is_comm_applicative G] [is_comm_applicative H]
                (eta : applicative_transformation G H)
                {α β : Type*} (f : α → G β) (x : multiset α) :
  eta (traverse f x) = traverse (@eta _ ∘ f) x :=
quotient.induction_on x
(by intro; simp [traverse,is_lawful_traversable.naturality] with functor_norm)

end multiset