/-
Copyright (c) 2018 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon

! This file was ported from Lean 3 source module control.traversable.instances
! leanprover-community/mathlib commit 18a5306c091183ac90884daa9373fa3b178e8607
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Control.Applicative
import Mathlib.Control.Traversable.Basic
import Mathlib.Data.List.Forall2
import Mathlib.Data.Set.Functor

/-!
# IsLawfulTraversable instances

This file provides instances of `IsLawfulTraversable` for types from the core library: `Option`,
`List` and `Sum`.
-/

universe u v

section Option

open Functor

variable {F G : Type u → Type u}

variable [Applicative F] [Applicative G]

variable [LawfulApplicative F] [LawfulApplicative G]

theorem Option.id_traverse {α} (x : Option α) : Option.traverse (pure : α → Id α) x = x := by
  cases x <;> rfl
#align option.id_traverse Option.id_traverse

theorem Option.comp_traverse {α β γ} (f : β → F γ) (g : α → G β) (x : Option α) :
    Option.traverse (Comp.mk ∘ (· <$> ·) f ∘ g) x =
      Comp.mk (Option.traverse f <$> Option.traverse g x) :=
  by cases x <;> simp! [functor_norm] <;> rfl
#align option.comp_traverse Option.comp_traverse

theorem Option.traverse_eq_map_id {α β} (f : α → β) (x : Option α) :
    Option.traverse ((pure : _ → Id _) ∘ f) x = (pure : _ → Id _) (f <$> x) := by cases x <;> rfl
#align option.traverse_eq_map_id Option.traverse_eq_map_id

variable (η : ApplicativeTransformation F G)

theorem Option.naturality {α β} (f : α → F β) (x : Option α) :
    η (Option.traverse f x) = Option.traverse (@η _ ∘ f) x := by
  -- Porting note: added `ApplicativeTransformation` theorems
  cases' x with x <;> simp! [*, functor_norm, ApplicativeTransformation.preserves_map,
    ApplicativeTransformation.preserves_seq, ApplicativeTransformation.preserves_pure]
#align option.naturality Option.naturality

end Option

instance : IsLawfulTraversable Option :=
  { show LawfulMonad Option from inferInstance with
    id_traverse := Option.id_traverse
    comp_traverse := Option.comp_traverse
    traverse_eq_map_id := Option.traverse_eq_map_id
    naturality := Option.naturality }

namespace List

variable {F G : Type u → Type u}

variable [Applicative F] [Applicative G]

section

variable [LawfulApplicative F] [LawfulApplicative G]

open Applicative Functor List

protected theorem id_traverse {α} (xs : List α) : List.traverse (pure : α → Id α) xs = xs := by
  induction xs <;> simp! [*, List.traverse, functor_norm]; rfl
#align list.id_traverse List.id_traverse

protected theorem comp_traverse {α β γ} (f : β → F γ) (g : α → G β) (x : List α) :
    List.traverse (Comp.mk ∘ (· <$> ·) f ∘ g) x = Comp.mk (List.traverse f <$> List.traverse g x) :=
  by induction x <;> simp! [*, functor_norm] <;> rfl
#align list.comp_traverse List.comp_traverse

protected theorem traverse_eq_map_id {α β} (f : α → β) (x : List α) :
    List.traverse ((pure : _ → Id _) ∘ f) x = (pure : _ → Id _) (f <$> x) := by
  induction x <;> simp! [*, functor_norm]; rfl
#align list.traverse_eq_map_id List.traverse_eq_map_id

variable (η : ApplicativeTransformation F G)

protected theorem naturality {α β} (f : α → F β) (x : List α) :
    η (List.traverse f x) = List.traverse (@η _ ∘ f) x := by
  -- Porting note: added `ApplicativeTransformation` theorems
  induction x <;> simp! [*, functor_norm, ApplicativeTransformation.preserves_map,
    ApplicativeTransformation.preserves_seq, ApplicativeTransformation.preserves_pure]
#align list.naturality List.naturality

instance : IsLawfulTraversable.{u} List :=
  { show LawfulMonad List from inferInstance with
    id_traverse := List.id_traverse
    comp_traverse := List.comp_traverse
    traverse_eq_map_id := List.traverse_eq_map_id
    naturality := List.naturality }

end

section Traverse

variable {α' β' : Type u} (f : α' → F β')

@[simp]
theorem traverse_nil : traverse f ([] : List α') = (pure [] : F (List β')) :=
  rfl
#align list.traverse_nil List.traverse_nil

@[simp]
theorem traverse_cons (a : α') (l : List α') :
    traverse f (a :: l) = (· :: ·) <$> f a <*> traverse f l :=
  rfl
#align list.traverse_cons List.traverse_cons

variable [LawfulApplicative F]

@[simp]
theorem traverse_append :
    ∀ as bs : List α', traverse f (as ++ bs) = (· ++ ·) <$> traverse f as <*> traverse f bs
  | [], bs => by simp [functor_norm]
  | a :: as, bs => by simp [traverse_append as bs, functor_norm]; congr
#align list.traverse_append List.traverse_append

theorem mem_traverse {f : α' → Set β'} :
    ∀ (l : List α') (n : List β'), n ∈ traverse f l ↔ Forall₂ (fun b a => b ∈ f a) n l
  | [], [] => by simp
  | a :: as, [] => by simp
  | [], b :: bs => by simp
  | a :: as, b :: bs => by simp [mem_traverse as bs]
#align list.mem_traverse List.mem_traverse

end Traverse

end List

namespace Sum

section Traverse

variable {σ : Type u}

variable {F G : Type u → Type u}

variable [Applicative F] [Applicative G]

open Applicative Functor

protected theorem traverse_map {α β γ : Type u} (g : α → β) (f : β → G γ) (x : σ ⊕ α) :
    Sum.traverse f (g <$> x) = Sum.traverse (f ∘ g) x := by
  cases x <;> simp [Sum.traverse, id_map, functor_norm] <;> rfl
#align sum.traverse_map Sum.traverse_map

variable [LawfulApplicative F] [LawfulApplicative G]

protected theorem id_traverse {σ α} (x : σ ⊕ α) :
  Sum.traverse (pure : α → Id α) x = x := by cases x <;> rfl
#align sum.id_traverse Sum.id_traverse

protected theorem comp_traverse {α β γ : Type u} (f : β → F γ) (g : α → G β) (x : σ ⊕ α) :
    Sum.traverse (Comp.mk ∘ (· <$> ·) f ∘ g) x =
    Comp.mk.{u} (Sum.traverse f <$> Sum.traverse g x) := by
  cases x <;> simp! [Sum.traverse, map_id, functor_norm] <;> rfl
#align sum.comp_traverse Sum.comp_traverse

protected theorem traverse_eq_map_id {α β} (f : α → β) (x : σ ⊕ α) :
    Sum.traverse ((pure : _ → Id _) ∘ f) x = (pure : _ → Id _) (f <$> x) := by
  induction x <;> simp! [*, functor_norm] <;> rfl
#align sum.traverse_eq_map_id Sum.traverse_eq_map_id

protected theorem map_traverse {α β γ} (g : α → G β) (f : β → γ) (x : σ ⊕ α) :
    (· <$> ·) f <$> Sum.traverse g x = Sum.traverse ((· <$> ·) f ∘ g) x := by
  cases x <;> simp [Sum.traverse, id_map, functor_norm] <;> congr
#align sum.map_traverse Sum.map_traverse

variable (η : ApplicativeTransformation F G)

protected theorem naturality {α β} (f : α → F β) (x : σ ⊕ α) :
    η (Sum.traverse f x) = Sum.traverse (@η _ ∘ f) x := by
  -- Porting note: added `ApplicativeTransformation` theorems
  cases x <;> simp! [Sum.traverse, functor_norm, ApplicativeTransformation.preserves_map,
    ApplicativeTransformation.preserves_seq, ApplicativeTransformation.preserves_pure]
#align sum.naturality Sum.naturality

end Traverse

instance {σ : Type u} : IsLawfulTraversable.{u} (Sum σ) :=
  { show LawfulMonad (Sum σ) from inferInstance with
    id_traverse := Sum.id_traverse
    comp_traverse := Sum.comp_traverse
    traverse_eq_map_id := Sum.traverse_eq_map_id
    naturality := Sum.naturality }

end Sum


/-
Copyright (c) 2019 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl
-/
import measure_theory.integration

/-!
# The Giry monad

Let X be a measurable space. The collection of all measures on X again
forms a measurable space. This construction forms a monad on
measurable spaces and measurable functions, called the Giry monad.

Note that most sources use the term "Giry monad" for the restriction
to *probability* measures. Here we include all measures on X.

See also `measure_theory/category/Meas.lean`, containing an upgrade of the type-level
monad to an honest monad of the functor `Measure : Meas ⥤ Meas`.

## References

* <https://ncatlab.org/nlab/show/Giry+monad>

## Tags

giry monad
-/

noncomputable theory
open_locale classical big_operators ennreal

open classical set filter

variables {α β γ δ ε : Type*}

namespace measure_theory

namespace measure

variables [measurable_space α] [measurable_space β]

/-- Measurability structure on `measure`: Measures are measurable w.r.t. all projections -/
instance : measurable_space (measure α) :=
⨆ (s : set α) (hs : measurable_set s), (borel ℝ≥0∞).comap (λμ, μ s)

lemma measurable_coe {s : set α} (hs : measurable_set s) : measurable (λμ : measure α, μ s) :=
measurable.of_comap_le $ le_supr_of_le s $ le_supr_of_le hs $ le_refl _

lemma measurable_of_measurable_coe (f : β → measure α)
  (h : ∀(s : set α) (hs : measurable_set s), measurable (λb, f b s)) :
  measurable f :=
measurable.of_le_map $ bsupr_le $ assume s hs, measurable_space.comap_le_iff_le_map.2 $
  by rw [measurable_space.map_comp]; exact h s hs

lemma measurable_measure {μ : α → measure β} :
  measurable μ ↔ ∀(s : set β) (hs : measurable_set s), measurable (λb, μ b s) :=
⟨λ hμ s hs, (measurable_coe hs).comp hμ, measurable_of_measurable_coe μ⟩

lemma measurable_map (f : α → β) (hf : measurable f) :
  measurable (λμ : measure α, map f μ) :=
measurable_of_measurable_coe _ $ assume s hs,
  suffices measurable (λ (μ : measure α), μ (f ⁻¹' s)),
    by simpa [map_apply, hs, hf],
  measurable_coe (hf hs)

lemma measurable_dirac :
  measurable (measure.dirac : α → measure α) :=
measurable_of_measurable_coe _ $ assume s hs,
  begin
    simp only [dirac_apply', hs],
    exact measurable_one.indicator hs
  end

lemma measurable_lintegral {f : α → ℝ≥0∞} (hf : measurable f) :
  measurable (λμ : measure α, ∫⁻ x, f x ∂μ) :=
begin
  simp only [lintegral_eq_supr_eapprox_lintegral, hf, simple_func.lintegral],
  refine measurable_supr (λ n, finset.measurable_sum _ (λ i _, _)),
  refine measurable.const_mul _ _,
  exact measurable_coe ((simple_func.eapprox f n).measurable_set_preimage _)
end

/-- Monadic join on `measure` in the category of measurable spaces and measurable
functions. -/
def join (m : measure (measure α)) : measure α :=
measure.of_measurable
  (λs hs, ∫⁻ μ, μ s ∂m)
  (by simp)
  begin
    assume f hf h,
    simp [measure_Union h hf],
    apply lintegral_tsum,
    assume i, exact measurable_coe (hf i)
  end

@[simp] lemma join_apply {m : measure (measure α)} :
  ∀{s : set α}, measurable_set s → join m s = ∫⁻ μ, μ s ∂m :=
measure.of_measurable_apply

@[simp] lemma join_zero : (0 : measure (measure α)).join = 0 :=
by { ext1 s hs, simp [hs] }

lemma measurable_join : measurable (join : measure (measure α) → measure α) :=
measurable_of_measurable_coe _ $ assume s hs,
  by simp only [join_apply hs]; exact measurable_lintegral (measurable_coe hs)

lemma lintegral_join {m : measure (measure α)} {f : α → ℝ≥0∞} (hf : measurable f) :
  ∫⁻ x, f x ∂(join m) = ∫⁻ μ, ∫⁻ x, f x ∂μ ∂m :=
begin
  rw [lintegral_eq_supr_eapprox_lintegral hf],
  have : ∀n x,
    join m (⇑(simple_func.eapprox (λ (a : α), f a) n) ⁻¹' {x}) =
      ∫⁻ μ, μ ((⇑(simple_func.eapprox (λ (a : α), f a) n) ⁻¹' {x})) ∂m :=
    assume n x, join_apply (simple_func.measurable_set_preimage _ _),
  simp only [simple_func.lintegral, this],
  transitivity,
  have : ∀(s : ℕ → finset ℝ≥0∞) (f : ℕ → ℝ≥0∞ → measure α → ℝ≥0∞)
    (hf : ∀n r, measurable (f n r)) (hm : monotone (λn μ, ∑ r in s n, r * f n r μ)),
    (⨆n:ℕ, ∑ r in s n, r * ∫⁻ μ, f n r μ ∂m) =
    ∫⁻ μ, ⨆n:ℕ, ∑ r in s n, r * f n r μ ∂m,
  { assume s f hf hm,
    symmetry,
    transitivity,
    apply lintegral_supr,
    { assume n,
      exact finset.measurable_sum _ (assume r _, (hf _ _).const_mul _) },
    { exact hm },
    congr, funext n,
    transitivity,
    apply lintegral_finset_sum,
    { assume r _, exact (hf _ _).const_mul _ },
    congr, funext r,
    apply lintegral_const_mul,
    exact hf _ _ },
  specialize this (λn, simple_func.range (simple_func.eapprox f n)),
  specialize this
    (λn r μ, μ (⇑(simple_func.eapprox (λ (a : α), f a) n) ⁻¹' {r})),
  refine this _ _; clear this,
  { assume n r,
    apply measurable_coe,
    exact simple_func.measurable_set_preimage _ _ },
  { change monotone (λn μ, (simple_func.eapprox f n).lintegral μ),
    assume n m h μ,
    refine simple_func.lintegral_mono _ (le_refl _),
    apply simple_func.monotone_eapprox,
    assumption },
  congr, funext μ,
  symmetry,
  apply lintegral_eq_supr_eapprox_lintegral,
  exact hf
end

/-- Monadic bind on `measure`, only works in the category of measurable spaces and measurable
functions. When the function `f` is not measurable the result is not well defined. -/
def bind (m : measure α) (f : α → measure β) : measure β := join (map f m)

@[simp] lemma bind_zero_left (f : α → measure β) : bind 0 f = 0 :=
by simp [bind]

@[simp] lemma bind_zero_right (m : measure α) :
  bind m (0 : α → measure β) = 0 :=
begin
  ext1 s hs,
  simp only [bind, hs, join_apply, coe_zero, pi.zero_apply],
  rw [lintegral_map (measurable_coe hs) measurable_zero],
  simp
end

@[simp] lemma bind_zero_right' (m : measure α) :
  bind m (λ _, 0 : α → measure β) = 0 :=
bind_zero_right m

@[simp] lemma bind_apply {m : measure α} {f : α → measure β} {s : set β}
  (hs : measurable_set s) (hf : measurable f) :
  bind m f s = ∫⁻ a, f a s ∂m :=
by rw [bind, join_apply hs, lintegral_map (measurable_coe hs) hf]

lemma measurable_bind' {g : α → measure β} (hg : measurable g) : measurable (λm, bind m g) :=
measurable_join.comp (measurable_map _ hg)

lemma lintegral_bind {m : measure α} {μ : α → measure β} {f : β → ℝ≥0∞}
  (hμ : measurable μ) (hf : measurable f) :
  ∫⁻ x, f x ∂ (bind m μ) = ∫⁻ a, ∫⁻ x, f x ∂(μ a) ∂m:=
(lintegral_join hf).trans (lintegral_map (measurable_lintegral hf) hμ)

lemma bind_bind {γ} [measurable_space γ] {m : measure α} {f : α → measure β} {g : β → measure γ}
  (hf : measurable f) (hg : measurable g) :
  bind (bind m f) g = bind m (λa, bind (f a) g) :=
measure.ext $ assume s hs,
begin
  rw [bind_apply hs hg, bind_apply hs ((measurable_bind' hg).comp hf), lintegral_bind hf],
  { congr, funext a,
    exact (bind_apply hs hg).symm },
  exact (measurable_coe hs).comp hg
end

lemma bind_dirac {f : α → measure β} (hf : measurable f) (a : α) : bind (dirac a) f = f a :=
measure.ext $ λ s hs, by rw [bind_apply hs hf, lintegral_dirac' a ((measurable_coe hs).comp hf)]

lemma dirac_bind {m : measure α} : bind m dirac = m :=
measure.ext $ assume s hs,
by simp [bind_apply hs measurable_dirac, dirac_apply' _ hs, lintegral_indicator 1 hs]

lemma join_eq_bind (μ : measure (measure α)) : join μ = bind μ id :=
by rw [bind, map_id]

lemma join_map_map {f : α → β} (hf : measurable f) (μ : measure (measure α)) :
  join (map (map f) μ) = map f (join μ) :=
measure.ext $ assume s hs,
  begin
    rw [join_apply hs, map_apply hf hs, join_apply,
      lintegral_map (measurable_coe hs) (measurable_map f hf)],
    { congr, funext ν, exact map_apply hf hs },
    exact hf hs
  end

lemma join_map_join (μ : measure (measure (measure α))) :
  join (map join μ) = join (join μ) :=
begin
  show bind μ join = join (join μ),
  rw [join_eq_bind, join_eq_bind, bind_bind measurable_id measurable_id],
  apply congr_arg (bind μ),
  funext ν,
  exact join_eq_bind ν
end

lemma join_map_dirac (μ : measure α) : join (map dirac μ) = μ :=
dirac_bind

lemma join_dirac (μ : measure α) : join (dirac μ) = μ :=
eq.trans (join_eq_bind (dirac μ)) (bind_dirac measurable_id _)

end measure

end measure_theory


import .phys.time.time
import .phys.time_series.geom3d
import .std.time_std
import .std.geom3d_std
import .phys.time_series.geom3d
import data.real.basic
noncomputable theory

def milliseconds := (0.001)           -- names not clear, inverted?
def milliseconds_to_seconds := 1000   -- names not clear, inverted?
def seconds := 1                      -- think about this more
def nanoseconds := (0.000000001)
def nanoseconds_to_seconds := 1000000000

-- TODO: Should come from resp. std libraries and be distributed to them accordingly
namespace std
def time (p :scalar) : time time_std_space := mk_time time_std_space p
def duration (d :scalar) : duration time_std_space := mk_duration _ d
def position (x y z :scalar) : position3d geom3d_std_space := mk_position3d _ x y z
def displacement (x y z :scalar) : displacement3d geom3d_std_space := mk_displacement3d _ x y z
end std
/-
We need to assume a physical interpretation of the data
representing our coordinate system on time.

The only referenced time coordinate system in this example is a system time - which
is not a UTC timestamp, rather, a zero-initiated time expressed in milliseconds, indicating
the time since the robot was booted. We define this ACS in terms of UTC (to avoid using std_space directly as requested last week?).

(1) ORIGIN: 0

(2) BASIS VECTORS
    basis0
      - points to the future
      - unit length is 1 millisecond
(3) ACS is given by [Origin, b0]
-/

namespace system_boot_time_ms
axiom δ : scalar
axiom ε : scalar
def origin := std.time δ
def basis := std.duration (ε*milliseconds)
def frame := mk_time_frame origin basis
def coords := mk_time_space frame
def time (t :scalar) := mk_time coords t
def duration (d :scalar) := mk_duration coords d
end system_boot_time_ms

/-
We also need an ACS for calls to "synchronize_stamp". These calls return actual system times in UTC,
so we shift up the coordinate to a more reasonable origin point and now define the units in seconds.

(1) ORIGIN: 1629311979 (current timestamp)

(2) BASIS VECTORS
    basis0
      - points to the future
      - unit length is 1 second (as in UTC)
(3) ACS is given by [Origin, b0]
-/

namespace utc
axiom δ : scalar
axiom ε : scalar
def origin := std.time δ
def basis := std.duration (ε*seconds)
def frame := mk_time_frame origin basis
def coords := mk_time_space frame
def time (t :scalar) := mk_time coords t
def duration (d :scalar) := mk_duration coords d
end utc

/-
Lastly, we need a system time in nanoseconds, used in calls to "synchronize stamp".

(1) ORIGIN: 0

(2) BASIS VECTORS
    basis0
      - points to the future
      - unit length is 1 nanoseconds (as in UTC)
(3) ACS is given by [Origin, b0]
-/

namespace utc_ns
def origin := utc.time 0
def basis := utc.duration (nanoseconds)
def frame := mk_time_frame origin basis
def coords := mk_time_space frame
def time (t :scalar) := mk_time coords t
def duration (d :scalar) := mk_duration coords d
end utc_ns

/-
We need to assume a physical interpretation of the data
representing our coordinate system on geom3d. See geom3d_std.lean
for more details on the coordinate system and physical interpretation.

We define a world frame. It's not fully clear if this is necessary from the codebase,
but we will use this world space and define several body frames in terms of it. In the name,
we recognize that the rice420.coords implementation's origin can be interpreted as ENU.

Note also:
https://git.scc.kit.edu/uqdpy/mavros/tree/master/mavros

"The translation from GPS coordinates to local geocentric coordinates require the definition
of a local origin on the map frame, in ECEF, and calculate the offset to it in ENU. All
the conversions are supported by GeographicLib classes and methods and implemented in the
global_position plugin."
-/
namespace map_enu  -- it's generic/parametric: for example, world -> Rice 440, as follows
def origin := std.position 0 0 0      -- looking in from doorway, the back lower left corner
def basis_0 := std.displacement 1 0 0 -- right/east along wall; unit is 1m; right
def basis_1 := std.displacement 0 1 0 -- to door along weset wall; 1m; right
def basis_2 := std.displacement 0 0 1 -- up along NW corner; 1m; right handed
def frame := mk_geom3d_frame origin basis_0 basis_1 basis_2
def coords := mk_geom3d_space frame
def position (x y z : scalar) := mk_position3d coords x y z
def displacement (x y z : scalar) := mk_displacement3d coords x y z
end map_enu

/-

The local origin frame is used, *I believe* is a world-fixed frame, whereas "fcu" would be the pose, perhaps
coming from IMU data, representing the current pose/ACS of the robot itself.

We define the robot to be 3 meters to the right of the left wall, 4 meters
in north of the bottom wall, and 1 meter above the ground. It's orientation is "local NED", which
actually should be referred to as "ESD" more like. Please see diagram in one of the related issues:
https://github.com/mavlink/mavros/issues/216

Note also:
https://git.scc.kit.edu/uqdpy/mavros/tree/master/mavros

"The translation from GPS coordinates to local geocentric coordinates require the definition
of a local origin on the map frame, in ECEF, and calculate the offset to it in ENU. All
the conversions are supported by GeographicLib classes and methods and implemented in the
global_position plugin."
-/
namespace local_origin_local_ned  -- it's generic/parametric: for example, world -> Rice 440, as follows
def origin := map_enu.position 0 0 0      -- looking in from doorway, the back lower left corner
def basis_0 := map_enu.displacement 1 0 0 -- right/east along wall; unit is 1m; right
def basis_1 := map_enu.displacement 0 1 0 -- to door along weset wall; 1m; right
def basis_2 := map_enu.displacement 0 0 1 -- up along NW corner; 1m; right handed
def frame := mk_geom3d_frame origin basis_0 basis_1 basis_2
def coords := mk_geom3d_space frame
def position (x y z : scalar) := mk_position3d coords x y z
def displacement (x y z : scalar) := mk_displacement3d coords x y z
end local_origin_local_ned

/-
We define a separate ACS for the local origin now oriented in terms of ENU, as necessary to integrate with ROS

For short-range Cartesian representations of geographic locations, use the east north up [5] (ENU) convention:

X east
Y north
Z up

, required for such things as visualization of local positions in RVIZ.

-/
namespace local_origin_enu  -- it's generic/parametric: for example, world -> Rice 440, as follows
def origin := local_origin_local_ned.position 0 0 0      -- looking in from doorway, the back lower left corner
def basis_0 := local_origin_local_ned.displacement 1 0 0 -- right/east along wall; unit is 1m; right
def basis_1 := local_origin_local_ned.displacement 0 (-1) 0 -- to door along weset wall; 1m; right
def basis_2 := local_origin_local_ned.displacement 0 0 (-1) -- up along NW corner; 1m; right handed
def frame := mk_geom3d_frame origin basis_0 basis_1 basis_2
def coords := mk_geom3d_space frame
def position (x y z : scalar) := mk_position3d coords x y z
def displacement (x y z : scalar) := mk_displacement3d coords x y z
end local_origin_enu

/-
https://github.com/mavlink/mavros/issues/216
-/

open classical
local attribute [instance] prop_decidable

structure UAS :=
  (imu_orientation : orientation3d local_origin_enu.coords)

/-

tf::Quaternion UAS::get_attitude_orientation()
{
	lock_guard lock(mutex);
	return imu_orientation;
}

-/
def UAS.get_attitude_orientation (uas : UAS) : orientation3d local_origin_enu.coords :=
  uas.imu_orientation

/-
ros::Time UAS::synchronise_stamp(uint32_t time_boot_ms) {
	// copy offset from atomic var
	uint64_t offset_ns = time_offset;

	if (offset_ns > 0) {
		uint64_t stamp_ns = static_cast<uint64_t>(time_boot_ms) * 1000000UL + offset_ns;
		return ros_time_from_ns(stamp_ns);
	}
	else
		return ros::Time::now();
}
-/

#check time_std_space.mk_time_transform_to utc.coords

#check system_boot_time_ms.coords

axiom time_offset : scalar
def UAS.synchronise_stamp (uas : UAS) : time system_boot_time_ms.coords → time utc.coords :=
  λ time_boot_ms,
  let offset_ns : duration utc_ns.coords := mk_duration _ time_offset in

  if offset_ns > 0 then
    let stamp_ns :=
      (system_boot_time_ms.coords.mk_time_transform_to utc_ns.coords).transform_time time_boot_ms in
    (utc_ns.coords.mk_time_transform_to utc.coords).transform_time stamp_ns
  else
    mk_time _ 0

/-

	ros::Publisher local_position;
	tf::TransformBroadcaster tf_broadcaster;
-/

structure Publisher :=
  mk::

def Publisher.publish
  (p : Publisher) : timestamped utc.coords (pose3d local_origin_enu.coords) → punit :=
  λp, punit.star

structure TransformBroadcaster :=
  mk::

def TransformBroadcaster.sendTransform
  (tb : TransformBroadcaster) : timestamped utc.coords (pose3d local_origin_enu.coords) → punit :=
  λp, punit.star

structure LocalPositionPlugin :=
 (uas : UAS)
 (local_position : Publisher)
 (tf_broadcaster : TransformBroadcaster)

def pose3d.setOrigin {f : geom3d_frame} {sp : geom3d_space f} (p: pose3d sp) : position3d sp → punit :=
  λ pos,
  let p0 : pose3d sp := {
    position := pos,
    ..p
  } in
  punit.star

def pose3d.setRotation {f : geom3d_frame} {sp : geom3d_space f} (p: pose3d sp) : orientation3d sp → punit :=
  λ ort,
  let p0 : pose3d sp := {
    orientation := ort,
    ..p
  } in
  punit.star

def poseTFToMsg {f : geom3d_frame} {sp : geom3d_space f} (p1 p2 : pose3d sp ) : punit :=
  let p2_0 := p1 in
  punit.star

/-

  void handle_local_position_ned(const mavlink_message_t *msg, uint8_t sysid, uint8_t compid) {

  This functions accepts one argument, of type "mavlink_message_t", which is a dataframe that can contain
  various types of data. In this case, it's a position in the "local_origin" frame. So, we interpret the argument
  as such.
-/
def LocalPositionPlugin.handle_local_position_ned (lpp : LocalPositionPlugin) :
  timestamped system_boot_time_ms.coords (position3d local_origin_local_ned.coords) → punit :=
  λ msg,
  /-

    static inline void mavlink_msg_local_position_ned_decode(const mavlink_message_t* msg, mavlink_local_position_ned_t* local_position_ned)
    {
    #if MAVLINK_NEED_BYTE_SWAP
      local_position_ned->time_boot_ms = mavlink_msg_local_position_ned_get_time_boot_ms(msg);
      local_position_ned->x = mavlink_msg_local_position_ned_get_x(msg);
      local_position_ned->y = mavlink_msg_local_position_ned_get_y(msg);
      local_position_ned->z = mavlink_msg_local_position_ned_get_z(msg);
      local_position_ned->vx = mavlink_msg_local_position_ned_get_vx(msg);
      local_position_ned->vy = mavlink_msg_local_position_ned_get_vy(msg);
      local_position_ned->vz = mavlink_msg_local_position_ned_get_vz(msg);
    #else
      memcpy(local_position_ned, _MAV_PAYLOAD(msg), 28);
    #endif

    mavlink_local_position_ned_t pos_ned;
		mavlink_msg_local_position_ned_decode(msg, &pos_ned);

    As seen above, we are simply moving the generic dataframe type into a more-specific position type, "mavlink_local_position_ned_t"
    To do that, we use the mavlink_msg_local_position_ned_decode function, which, as seen in the definition (omitted some parts),
    requires indexing into a byte array at certain offsets. So, I am avoiding formalizing that for now. Regardless,
    the semantics of the call is simply that we're assigning to pos_ned from the value contained in msg - which is treated
    as a simple assignment given we're intepreting both as local_origin positions.
  -/
  let pos_ned : timestamped system_boot_time_ms.coords (position3d local_origin_local_ned.coords) := inhabited.default _ in
  let pos_ned0 : timestamped system_boot_time_ms.coords (position3d local_origin_local_ned.coords) := msg in
  /-
  tf::Transform transform;
		transform.setOrigin(tf::Vector3(pos_ned.y, pos_ned.x, -pos_ned.z));
		transform.setRotation(uas->get_attitude_orientation());-/
  let transform : pose3d local_origin_enu.coords := inhabited.default _ in
  let setOriginCall := transform.setOrigin (mk_position3d _ (pos_ned.value.y) (pos_ned.value.x) (-pos_ned.value.z)) in
  let setRotationCall := transform.setRotation lpp.uas.get_attitude_orientation in
  /-
	auto pose = boost::make_shared<geometry_msgs::PoseStamped>();

	tf::poseTFToMsg(transform, pose->pose);
  -/
  let pose : timestamped utc.coords (pose3d local_origin_enu.coords) := inhabited.default _ in
  let poseTFToMsgCall := poseTFToMsg transform pose.value in
  let pose0 : timestamped utc.coords (pose3d local_origin_enu.coords) := {
    timestamp := lpp.uas.synchronise_stamp pos_ned.timestamp,
    ..pose
  } in

  let if0 : punit :=
    if true then
      punit.star
    else
      punit.star in

  let publishCall := lpp.local_position.publish pose in
  /-
  pose->header.frame_id = frame_id;
		pose->header.stamp = uas->synchronise_stamp(pos_ned.time_boot_ms);

		if (send_tf)
			tf_broadcaster.sendTransform(
					tf::StampedTransform(
						transform,
						pose->header.stamp,
						frame_id, child_frame_id));

		local_position.publish(pose);
  -/

  /-
  tf::Transform transform;
		transform.setOrigin(tf::Vector3(pos_ned.y, pos_ned.x, -pos_ned.z));
		transform.setRotation(uas->get_attitude_orientation());

		auto pose = boost::make_shared<geometry_msgs::PoseStamped>();

		tf::poseTFToMsg(transform, pose->pose);
		pose->header.frame_id = frame_id;
		pose->header.stamp = uas->synchronise_stamp(pos_ned.time_boot_ms);

		if (send_tf)
			tf_broadcaster.sendTransform(
					tf::StampedTransform(
						transform,
						pose->header.stamp,
						frame_id, child_frame_id));

		local_position.publish(pose);
  -/

/-
  	void handle_local_position_ned(const mavlink_message_t *msg, uint8_t sysid, uint8_t compid) {
		mavlink_local_position_ned_t pos_ned;
		mavlink_msg_local_position_ned_decode(msg, &pos_ned);

    static inline void mavlink_msg_local_position_ned_decode(const mavlink_message_t* msg, mavlink_local_position_ned_t* local_position_ned)
    {
    #if MAVLINK_NEED_BYTE_SWAP
      local_position_ned->time_boot_ms = mavlink_msg_local_position_ned_get_time_boot_ms(msg);
      local_position_ned->x = mavlink_msg_local_position_ned_get_x(msg);
      local_position_ned->y = mavlink_msg_local_position_ned_get_y(msg);
      local_position_ned->z = mavlink_msg_local_position_ned_get_z(msg);
      local_position_ned->vx = mavlink_msg_local_position_ned_get_vx(msg);
      local_position_ned->vy = mavlink_msg_local_position_ned_get_vy(msg);
      local_position_ned->vz = mavlink_msg_local_position_ned_get_vz(msg);
    #else
      memcpy(local_position_ned, _MAV_PAYLOAD(msg), 28);
    #endif
    }

		ROS_DEBUG_THROTTLE_NAMED(10, "position", "Local position NED: boot_ms:%06d "
				"position:(%1.3f %1.3f %1.3f) speed:(%1.3f %1.3f %1.3f)",
				pos_ned.time_boot_ms,
				pos_ned.x, pos_ned.y, pos_ned.z,
				pos_ned.vx, pos_ned.vy, pos_ned.vz);

		/* TODO: check convertion to ENU
		 * I think XZY is not body-fixed, but orientation does.
		 * Perhaps this adds additional errorprone to us.
		 * Need more tests. Issue #49.
		 *
		 * orientation in ENU, body-fixed
		 */
		tf::Transform transform;
		transform.setOrigin(tf::Vector3(pos_ned.y, pos_ned.x, -pos_ned.z));
		transform.setRotation(uas->get_attitude_orientation());

		auto pose = boost::make_shared<geometry_msgs::PoseStamped>();

		tf::poseTFToMsg(transform, pose->pose);
		pose->header.frame_id = frame_id;
		pose->header.stamp = uas->synchronise_stamp(pos_ned.time_boot_ms);

		if (send_tf)
			tf_broadcaster.sendTransform(
					tf::StampedTransform(
						transform,
						pose->header.stamp,
						frame_id, child_frame_id));

		local_position.publish(pose);
	}

	void send_vision_transform(const tf::Transform &transform, const ros::Time &stamp) {
		// origin and RPY in ENU frame
		tf::Vector3 position = transform.getOrigin();
		double roll, pitch, yaw;
		tf::Matrix3x3 orientation(transform.getBasis());
		orientation.getRPY(roll, pitch, yaw);

		/* Issue #60.
		 * Note: this now affects pose callbacks too, but i think its not big deal.
		 */
		if (last_transform_stamp == stamp) {
			ROS_DEBUG_THROTTLE_NAMED(10, "vision_pose", "Vision: Same transform as last one, dropped.");
			return;
		}
		last_transform_stamp = stamp;

		// TODO: check conversion. Issue #49.
		vision_position_estimate(stamp.toNSec() / 1000,
				position.y(), position.x(), -position.z(),
				roll, -pitch, -yaw);	// ??? please check!
	}
-/


/-
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 α] [has_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 :=
by rw [← int.nat_cast_eq_coe_nat, cast_to_nat]

@[simp, norm_cast] theorem cast_to_int [add_group α] [has_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 _ _)

@[simp, norm_cast] theorem add_of_nat (m) : ∀ n, ((m + n : ℕ) : num) = m + n
| 0     := (add_zero _).symm
| (n+1) := show ((m + n : ℕ) + 1 : num) = m + (↑ n + 1),
           by rw [add_one, add_one, add_succ, add_of_nat]

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, 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 α] [has_one α] : ∀ n : num, ((n : ℕ) : α) = n
| 0       := nat.cast_zero
| (pos p) := p.cast_to_nat

@[simp, norm_cast] theorem to_nat_to_int (n : num) : ((n : ℕ) : ℤ) = n :=
by rw [← int.nat_cast_eq_coe_nat, cast_to_nat]

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

@[norm_cast]
theorem to_of_nat : Π (n : ℕ), ((n : num) : ℕ) = n
| 0     := rfl
| (n+1) := by rw [nat.cast_add_one, add_one, succ_to_nat, to_of_nat]

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

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

@[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), ((n : ℕ) : num) = num.pos n
| 1        := rfl
| (bit0 p) :=
  show ↑(p + p : ℕ) = num.pos p.bit0,
  by rw [num.add_of_nat, of_to_nat];
    exact congr_arg num.pos p.bit0_of_bit0
| (bit1 p) :=
  show ((p + p : ℕ) : num) + 1 = num.pos p.bit1,
  by rw [num.add_of_nat, of_to_nat];
    exact congr_arg num.pos p.bit1_of_bit1
end pos_num

namespace num

@[simp, norm_cast] theorem of_to_nat : Π (n : num), ((n : ℕ) : num) = n
| 0           := rfl
| (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 : comm_semiring num :=
by refine_struct
{ add      := (+),
  zero     := 0,
  zero_add := zero_add,
  add_zero := add_zero,
  mul      := (*),
  one      := 1,
  nsmul    := @nsmul_rec num ⟨0⟩ ⟨(+)⟩,
  npow     := @npow_rec num ⟨1⟩ ⟨(*)⟩ };
try { intros, refl }; try { transfer }; simp [mul_add, mul_left_comm, mul_comm, add_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 }

@[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

@[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 α] [has_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 α] [has_one α] (n : pos_num) : (succ n : α) = n + 1 :=
by rw [← add_one, cast_add, cast_one]

@[simp, norm_cast]
theorem cast_inj [add_monoid α] [has_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 α] [has_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 α] [has_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] theorem of_nat'_zero : num.of_nat' 0 = 0 :=
by simp [num.of_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, norm_cast]

@[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 α] [has_one α] : ∀ n : znum, ((n : ℤ) : α) = n
| 0       := rfl
| (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 α] [has_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 α] [has_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 α] [has_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 α] [has_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 α] [has_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' _ _

@[simp] theorem of_nat_to_znum : ∀ n : ℕ, to_znum n = n
| 0     := rfl
| (n+1) := by rw [nat.cast_add_one, nat.cast_add_one,
  znum.add_one, add_one, ← of_nat_to_znum]; cases (n:num); refl

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

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 α] [has_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 α] [has_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 α] [has_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]

@[simp, norm_cast] theorem of_to_int : Π (n : znum), ((n : ℤ) : znum) = n
| 0       := rfl
| (pos a) := by rw [cast_pos, ← pos_num.cast_to_nat,
  int.cast_coe_nat', ← num.of_nat_to_znum, pos_num.of_to_nat]; refl
| (neg a) := by rw [cast_neg, neg_of_int, ← pos_num.cast_to_nat,
  int.cast_coe_nat', ← num.of_nat_to_znum_neg, pos_num.of_to_nat]; refl

@[norm_cast]
theorem to_of_int : Π (n : ℤ), ((n : znum) : ℤ) = n
| (n : ℕ) := by rw [int.cast_coe_nat,
  ← num.of_nat_to_znum, num.cast_to_znum, ← num.cast_to_nat,
  int.nat_cast_eq_coe_nat, num.to_of_nat]
| -[1+ n] := by rw [int.cast_neg_succ_of_nat, cast_zneg,
  add_one, cast_succ, int.neg_succ_of_nat_eq,
  ← num.of_nat_to_znum, num.cast_to_znum, ← num.cast_to_nat,
  int.nat_cast_eq_coe_nat, num.to_of_nat]

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

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

@[simp, norm_cast] theorem of_nat_cast [add_group α] [has_one α] (n : ℕ) : ((n : znum) : α) = n :=
of_int_cast n

@[simp] theorem of_int'_eq : ∀ n, znum.of_int' n = n
| (n : ℕ) := to_int_inj.1 $ by simp [znum.of_int']
| -[1+ n] := to_int_inj.1 $ by simp [znum.of_int']

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 : 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 }

@[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⟩


import data.set
import tactic.suggest
import tactic.basic
import data.vector
import data.vector.basic
import data.vector.zip

import vector.additional

import category_theory.concrete_category.bundled

open category_theory

namespace UA
  universes u_lang u_str u_strA u_strB

  section

    /- a signature `σ` is just a set of operation symbols, with specified (finite) arity. -/

    class signature := (F : Type u_lang) (arity_of : F → ℕ)
    abbreviation arity_of [σ : signature] (f) := signature.arity_of f

    /- The universes `u_strX` of the structures may be distinct, and different to `u_lang`.
    -- We wrap the main defenitions in a section,
    -- so that they become universe polymorphic within this file. -/

    section

      /- `action_on` is a realisation of operations on a given type. -/

      @[class] def action_on [σ : signature.{u_lang}] (medium : Type u_str) : Type (max u_lang u_str) :=
      Π f, (vector medium (arity_of f)) → medium

      parameter [σ : signature.{u_lang}]
      include σ

      /- A `structure` is a `medium` equipped with the relevant `action`. -/

      def Structure : Type (max u_lang (u_str+1)) := bundled (action_on.{u_lang u_str})

      abbreviation Structure.medium (self : Structure) := self.α
      abbreviation Structure.action (self : Structure) := self.str

      /- Coersions and instances -/

      instance Structure_to_action_on (A : Structure) : action_on A.medium := A.action
      instance Structure_to_sort : has_coe_to_sort Structure _ := ⟨λ str, str.medium⟩
      instance Structure_to_fun : has_coe_to_fun Structure _ := ⟨λ str, str.action⟩

    end

    /- `action_on_` and `Structure_` are subtle varients, where we require the media have
    -- universe levels at least `u_lang`. This ensures structures have the same levels as their
    -- underlying sets, as is required by much of the category theory infastructure in mathlib -/

    section
      parameter [σ : signature.{u_lang}]
      include σ

      abbreviation action_on_ : Type (max u_lang u_str) → Type (max u_lang u_str) :=
      λ α, action_on.{u_lang (max u_lang u_str)} α

      abbreviation Structure_ : Type ((max u_lang u_str)+1) :=
      Structure.{u_lang (max u_lang u_str)}

    end

    parameter [σ : signature.{u_lang}]
    include σ

    /- `direct product` of two stuctures -/

    instance dir_prod_action (α : Type u_strA) (β : Type u_strB)
    [actA : action_on α] [actB : action_on β] : action_on (α × β) :=
    λ f input, (actA f (vector.map prod.fst input), actB f (vector.map prod.snd input))

    def dir_prod (A : Structure) (B : Structure) : Structure :=
    ⟨ A.medium × B.medium, dir_prod_action A.medium B.medium⟩

    /- Simplification lemmas -/

    open vector

    variables {α : Type u_strA} [actA : action_on α]
    variables {β : Type u_strB} [actB : action_on β]
    include actA actB
    variable {f : σ.F}
    variable {x : vector α (arity_of f)}
    variable {y : vector β (arity_of f)}
    variable {xy : vector (α × β) (arity_of f)}

    @[simp] lemma action_of_product:
    dir_prod_action α β f xy = (actA f (map prod.fst xy), actB f (map prod.snd xy)) :=
    begin
      rw prod.ext_iff,
      simp,

      split,
      apply congr_arg (actA f),
      apply vector.ext,
      intro i,
      simp,

      apply congr_arg (actB f),
      apply vector.ext,
      intro i,
      simp,
    end

    @[simp] lemma action_of_product_zip:
    dir_prod_action α β f (zip x y) = (actA f x, actB f y) :=
    begin
      rw action_of_product,
      simp,
    end

  end
end UA


/-
Copyright (c) 2019 Seul Baek. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Seul Baek

! This file was ported from Lean 3 source module tactic.omega.nat.main
! leanprover-community/mathlib commit dc34b216eb1a1548161e35d328ea1ab798017033
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Tactic.Omega.ProveUnsats
import Mathbin.Tactic.Omega.Nat.Dnf
import Mathbin.Tactic.Omega.Nat.NegElim
import Mathbin.Tactic.Omega.Nat.SubElim

/-
Main procedure for linear natural number arithmetic.
-/
open Tactic

namespace Omega

namespace Nat

open Omega.Nat

run_cmd
  mk_simp_attr `sugar_nat

attribute [sugar_nat]
  Ne not_le not_lt Nat.lt_iff_add_one_le Nat.succ_eq_add_one or_false_iff false_or_iff and_true_iff true_and_iff GE.ge GT.gt mul_add add_mul mul_comm one_mul mul_one imp_iff_not_or iff_iff_not_or_and_or_not

/- ./././Mathport/Syntax/Translate/Expr.lean:330:4: warning: unsupported (TODO): `[tacs] -/
unsafe def desugar :=
  sorry
#align omega.nat.desugar omega.nat.desugar

theorem univClose_of_unsat_negElim_not (m) (p : Preform) :
    (negElim (¬* p)).Unsat → UnivClose p (fun _ => 0) m :=
  by
  intro h1; apply univ_close_of_valid
  apply valid_of_unsat_not; intro h2; apply h1
  apply preform.sat_of_implies_of_sat implies_neg_elim h2
#align omega.nat.univ_close_of_unsat_neg_elim_not Omega.Nat.univClose_of_unsat_negElim_not

/-- Return expr of proof that argument is free of subtractions -/
unsafe def preterm.prove_sub_free : Preterm → tactic expr
  | &m => return q(trivial)
  | m ** n => return q(trivial)
  | t +* s => do
    let x ← preterm.prove_sub_free t
    let y ← preterm.prove_sub_free s
    return q(@And.intro (Preterm.SubFree $(q(t))) (Preterm.SubFree $(q(s))) $(x) $(y))
  | _ -* _ => failed
#align omega.nat.preterm.prove_sub_free omega.nat.preterm.prove_sub_free

/-- Return expr of proof that argument is free of negations -/
unsafe def prove_neg_free : Preform → tactic expr
  | t =* s => return q(trivial)
  | t ≤* s => return q(trivial)
  | p ∨* q => do
    let x ← prove_neg_free p
    let y ← prove_neg_free q
    return q(@And.intro (Preform.NegFree $(q(p))) (Preform.NegFree $(q(q))) $(x) $(y))
  | p ∧* q => do
    let x ← prove_neg_free p
    let y ← prove_neg_free q
    return q(@And.intro (Preform.NegFree $(q(p))) (Preform.NegFree $(q(q))) $(x) $(y))
  | _ => failed
#align omega.nat.prove_neg_free omega.nat.prove_neg_free

/-- Return expr of proof that argument is free of subtractions -/
unsafe def prove_sub_free : Preform → tactic expr
  | t =* s => do
    let x ← preterm.prove_sub_free t
    let y ← preterm.prove_sub_free s
    return q(@And.intro (Preterm.SubFree $(q(t))) (Preterm.SubFree $(q(s))) $(x) $(y))
  | t ≤* s => do
    let x ← preterm.prove_sub_free t
    let y ← preterm.prove_sub_free s
    return q(@And.intro (Preterm.SubFree $(q(t))) (Preterm.SubFree $(q(s))) $(x) $(y))
  | ¬* p => prove_sub_free p
  | p ∨* q => do
    let x ← prove_sub_free p
    let y ← prove_sub_free q
    return q(@And.intro (Preform.SubFree $(q(p))) (Preform.SubFree $(q(q))) $(x) $(y))
  | p ∧* q => do
    let x ← prove_sub_free p
    let y ← prove_sub_free q
    return q(@And.intro (Preform.SubFree $(q(p))) (Preform.SubFree $(q(q))) $(x) $(y))
#align omega.nat.prove_sub_free omega.nat.prove_sub_free

/-- Given a p : preform, return the expr of a term t : p.unsat, where p is subtraction- and
negation-free. -/
unsafe def prove_unsat_sub_free (p : Preform) : tactic expr := do
  let x ← prove_neg_free p
  let y ← prove_sub_free p
  let z ← prove_unsats (dnf p)
  return q(unsat_of_unsat_dnf $(q(p)) $(x) $(y) $(z))
#align omega.nat.prove_unsat_sub_free omega.nat.prove_unsat_sub_free

/-- Given a p : preform, return the expr of a term t : p.unsat, where p is negation-free. -/
unsafe def prove_unsat_neg_free : Preform → tactic expr
  | p =>
    match p.subTerms with
    | none => prove_unsat_sub_free p
    | some (t, s) => do
      let x ← prove_unsat_neg_free (subElim t s p)
      return q(unsat_of_unsat_subElim $(q(t)) $(q(s)) $(q(p)) $(x))
#align omega.nat.prove_unsat_neg_free omega.nat.prove_unsat_neg_free

/-- Given a (m : nat) and (p : preform), return the expr of (t : univ_close m p). -/
unsafe def prove_univ_close (m : Nat) (p : Preform) : tactic expr := do
  let x ← prove_unsat_neg_free (negElim (¬* p))
  to_expr ``(univClose_of_unsat_negElim_not $(q(m)) $(q(p)) $(x))
#align omega.nat.prove_univ_close omega.nat.prove_univ_close

-- failed to format: unknown constant 'term.pseudo.antiquot'
/-- Reification to imtermediate shadow syntax that retains exprs -/ unsafe
  def
    to_exprterm
    : expr → tactic exprterm
    | q( $ ( x ) * $ ( y ) ) => do let m ← eval_expr' Nat y return ( exprterm.exp m x )
      |
        q( $ ( t1x ) + $ ( t2x ) )
        =>
        do let t1 ← to_exprterm t1x let t2 ← to_exprterm t2x return ( exprterm.add t1 t2 )
      |
        q( $ ( t1x ) - $ ( t2x ) )
        =>
        do let t1 ← to_exprterm t1x let t2 ← to_exprterm t2x return ( exprterm.sub t1 t2 )
      |
        x
        =>
        ( do let m ← eval_expr' Nat x return ( exprterm.cst m ) ) <|> ( return <| exprterm.exp 1 x )
#align omega.nat.to_exprterm omega.nat.to_exprterm

-- failed to format: unknown constant 'term.pseudo.antiquot'
/-- Reification to imtermediate shadow syntax that retains exprs -/ unsafe
  def
    to_exprform
    : expr → tactic exprform
    |
        q( $ ( tx1 ) = $ ( tx2 ) )
        =>
        do let t1 ← to_exprterm tx1 let t2 ← to_exprterm tx2 return ( exprform.eq t1 t2 )
      |
        q( $ ( tx1 ) ≤ $ ( tx2 ) )
        =>
        do let t1 ← to_exprterm tx1 let t2 ← to_exprterm tx2 return ( exprform.le t1 t2 )
      | q( ¬ $ ( px ) ) => do let p ← to_exprform px return ( exprform.not p )
      |
        q( $ ( px ) ∨ $ ( qx ) )
        =>
        do let p ← to_exprform px let q ← to_exprform qx return ( exprform.or p q )
      |
        q( $ ( px ) ∧ $ ( qx ) )
        =>
        do let p ← to_exprform px let q ← to_exprform qx return ( exprform.and p q )
      | q( _ → $ ( px ) ) => to_exprform px
      | x => ( trace "Cannot reify expr : " >> trace x ) >> failed
#align omega.nat.to_exprform omega.nat.to_exprform

/-- List of all unreified exprs -/
unsafe def exprterm.exprs : exprterm → List expr
  | exprterm.cst _ => []
  | exprterm.exp _ x => [x]
  | exprterm.add t s => List.union t.exprs s.exprs
  | exprterm.sub t s => List.union t.exprs s.exprs
#align omega.nat.exprterm.exprs omega.nat.exprterm.exprs

/-- List of all unreified exprs -/
unsafe def exprform.exprs : exprform → List expr
  | exprform.eq t s => List.union t.exprs s.exprs
  | exprform.le t s => List.union t.exprs s.exprs
  | exprform.not p => p.exprs
  | exprform.or p q => List.union p.exprs q.exprs
  | exprform.and p q => List.union p.exprs q.exprs
#align omega.nat.exprform.exprs omega.nat.exprform.exprs

/-- Reification to an intermediate shadow syntax which eliminates exprs,
    but still includes non-canonical terms -/
unsafe def exprterm.to_preterm (xs : List expr) : exprterm → tactic Preterm
  | exprterm.cst k => return (&k)
  | exprterm.exp k x =>
    let m := xs.indexOfₓ x
    if m < xs.length then return (k ** m) else failed
  | exprterm.add xa xb => do
    let a ← xa.to_preterm
    let b ← xb.to_preterm
    return (a +* b)
  | exprterm.sub xa xb => do
    let a ← xa.to_preterm
    let b ← xb.to_preterm
    return (a -* b)
#align omega.nat.exprterm.to_preterm omega.nat.exprterm.to_preterm

/-- Reification to an intermediate shadow syntax which eliminates exprs,
    but still includes non-canonical terms -/
unsafe def exprform.to_preform (xs : List expr) : exprform → tactic Preform
  | exprform.eq xa xb => do
    let a ← xa.to_preterm xs
    let b ← xb.to_preterm xs
    return (a =* b)
  | exprform.le xa xb => do
    let a ← xa.to_preterm xs
    let b ← xb.to_preterm xs
    return (a ≤* b)
  | exprform.not xp => do
    let p ← xp.to_preform
    return (¬* p)
  | exprform.or xp xq => do
    let p ← xp.to_preform
    let q ← xq.to_preform
    return (p ∨* q)
  | exprform.and xp xq => do
    let p ← xp.to_preform
    let q ← xq.to_preform
    return (p ∧* q)
#align omega.nat.exprform.to_preform omega.nat.exprform.to_preform

/-- Reification to an intermediate shadow syntax which eliminates exprs,
    but still includes non-canonical terms. -/
unsafe def to_preform (x : expr) : tactic (Preform × Nat) := do
  let xf ← to_exprform x
  let xs := xf.exprs
  let f ← xf.to_preform xs
  return (f, xs)
#align omega.nat.to_preform omega.nat.to_preform

/-- Return expr of proof of current LNA goal -/
unsafe def prove : tactic expr := do
  let (p, m) ← target >>= to_preform
  trace_if_enabled `omega p
  prove_univ_close m p
#align omega.nat.prove omega.nat.prove

/-- Succeed iff argument is expr of ℕ -/
unsafe def eq_nat (x : expr) : tactic Unit :=
  if x = q(Nat) then skip else failed
#align omega.nat.eq_nat omega.nat.eq_nat

-- failed to format: unknown constant 'term.pseudo.antiquot'
/-- Check whether argument is expr of a well-formed formula of LNA-/ unsafe
  def
    wff
    : expr → tactic Unit
    | q( ¬ $ ( px ) ) => wff px
      | q( $ ( px ) ∨ $ ( qx ) ) => wff px >> wff qx
      | q( $ ( px ) ∧ $ ( qx ) ) => wff px >> wff qx
      | q( $ ( px ) ↔ $ ( qx ) ) => wff px >> wff qx
      |
        q( $ ( expr.pi _ _ px qx ) )
        =>
        Monad.cond
          ( if expr.has_var px then return true else is_prop px )
            ( wff px >> wff qx )
            ( eq_nat px >> wff qx )
      | q( @ LT.lt $ ( dx ) $ ( h ) _ _ ) => eq_nat dx
      | q( @ LE.le $ ( dx ) $ ( h ) _ _ ) => eq_nat dx
      | q( @ Eq $ ( dx ) _ _ ) => eq_nat dx
      | q( @ GE.ge $ ( dx ) $ ( h ) _ _ ) => eq_nat dx
      | q( @ GT.gt $ ( dx ) $ ( h ) _ _ ) => eq_nat dx
      | q( @ Ne $ ( dx ) _ _ ) => eq_nat dx
      | q( True ) => skip
      | q( False ) => skip
      | _ => failed
#align omega.nat.wff omega.nat.wff

/-- Succeed iff argument is expr of term whose type is wff -/
unsafe def wfx (x : expr) : tactic Unit :=
  infer_type x >>= wff
#align omega.nat.wfx omega.nat.wfx

/-- Intro all universal quantifiers over nat -/
unsafe def intro_nats_core : tactic Unit := do
  let x ← target
  match x with
    | expr.pi _ _ q(Nat) _ => intro_fresh >> intro_nats_core
    | _ => skip
#align omega.nat.intro_nats_core omega.nat.intro_nats_core

unsafe def intro_nats : tactic Unit := do
  let expr.pi _ _ q(Nat) _ ← target
  intro_nats_core
#align omega.nat.intro_nats omega.nat.intro_nats

/-- If the goal has universal quantifiers over natural, introduce all of them.
Otherwise, revert all hypotheses that are formulas of linear natural number arithmetic. -/
unsafe def preprocess : tactic Unit :=
  intro_nats <|> revert_cond_all wfx >> desugar
#align omega.nat.preprocess omega.nat.preprocess

end Nat

end Omega

open Omega.Nat

/-- The core omega tactic for natural numbers. -/
unsafe def omega_nat (is_manual : Bool) : tactic Unit :=
  andthen (andthen desugar (if is_manual then skip else preprocess)) ((prove >>= apply) >> skip)
#align omega_nat omega_nat


/-
Copyright (c) 2022 Markus Himmel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Markus Himmel
-/
import category_theory.abelian.subobject
import category_theory.limits.essentially_small
import category_theory.preadditive.injective
import category_theory.preadditive.generator
import category_theory.preadditive.yoneda.limits

/-!
# A complete abelian category with enough injectives and a separator has an injective coseparator

## Future work
* Once we know that Grothendieck categories have enough injectives, we can use this to conclude
  that Grothendieck categories have an injective coseparator.

## References
* [Peter J Freyd, *Abelian Categories* (Theorem 3.37)][freyd1964abelian]

-/

open category_theory category_theory.limits opposite

universes v u

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

theorem has_injective_coseparator [has_limits C] [enough_injectives C] (G : C)
  (hG : is_separator G) : ∃ G : C, injective G ∧ is_coseparator G :=
begin
  haveI : well_powered C := well_powered_of_is_detector G hG.is_detector,
  haveI : has_products_of_shape (subobject (op G)) C := has_products_of_shape_of_small _ _,
  let T : C := injective.under (pi_obj (λ P : subobject (op G), unop P)),
  refine ⟨T, infer_instance, (preadditive.is_coseparator_iff _).2 (λ X Y f hf, _)⟩,
  refine (preadditive.is_separator_iff _).1 hG _ (λ h, _),
  suffices hh : factor_thru_image (h ≫ f) = 0,
  { rw [← limits.image.fac (h ≫ f), hh, zero_comp] },
  let R := subobject.mk (factor_thru_image (h ≫ f)).op,
  let q₁ : image (h ≫ f) ⟶ unop R :=
    (subobject.underlying_iso (factor_thru_image (h ≫ f)).op).unop.hom,
  let q₂ : unop (R : Cᵒᵖ) ⟶ pi_obj (λ P : subobject (op G), unop P) :=
    section_ (pi.π (λ P : subobject (op G), unop P) R),
  let q : image (h ≫ f) ⟶ T := q₁ ≫ q₂ ≫ injective.ι _,
  exact zero_of_comp_mono q (by rw [← injective.comp_factor_thru q (limits.image.ι (h ≫ f)),
    limits.image.fac_assoc, category.assoc, hf, comp_zero])
end

theorem has_projective_separator [has_colimits C] [enough_projectives C] (G : C)
  (hG : is_coseparator G) : ∃ G : C, projective G ∧ is_separator G :=
begin
  obtain ⟨T, hT₁, hT₂⟩ := has_injective_coseparator (op G) ((is_separator_op_iff _).2 hG),
  exactI ⟨unop T, infer_instance, (is_separator_unop_iff _).2 hT₂⟩
end

end category_theory.abelian