import tactic.induction
import tactic.linarith

universes u v w

--------------------------------------------------------------------------------
-- Setup: Some Inductive Types
--------------------------------------------------------------------------------

inductive le : ℕ → ℕ → Type
| zero {n} : le 0 n
| succ {n m} : le n m → le (n + 1) (m + 1)

inductive lt : ℕ → ℕ → Type
| zero {n} : lt 0 (n + 1)
| succ {n m} : lt n m → lt (n + 1) (m + 1)

inductive Fin : ℕ → Type
| zero {n} : Fin (n + 1)
| succ {n} : Fin n → Fin (n + 1)

inductive List (α : Sort*) : Sort*
| nil {} : List
| cons {} (x : α) (xs : List) : List

namespace List

def append {α} : List α → List α → List α
| nil ys := ys
| (cons x xs) ys := cons x (append xs ys)

end List

inductive Vec (α : Sort u) : ℕ → Sort (max 1 u)
| nil : Vec 0
| cons {n} : α → Vec n → Vec (n + 1)

namespace Vec

inductive eq {α} : ∀ n m, Vec α n → Vec α m → Prop
| nil : eq 0 0 nil nil
| cons {n m} {xs : Vec α n} {ys : Vec α m} {x y : α} :
  x = y →
  eq n m xs ys →
  eq (n + 1) (m + 1) (cons x xs) (cons y ys)

end Vec

inductive Two : Type | zero | one

inductive ℕ' : Type
| intro : ℕ → ℕ'

--------------------------------------------------------------------------------
-- Unit Tests
--------------------------------------------------------------------------------

example (k) : 0 + k = k :=
begin
  induction' k,
  { refl },
  { simp }
end

example {k} (fk : Fin k) : Fin (k + 1) :=
begin
  induction' fk,
  { exact Fin.zero },
  { exact Fin.succ ih }
end

example {α} (l : List α) : l.append List.nil = l :=
begin
  induction' l,
  { refl },
  { dsimp only [List.append],
    exact (congr_arg _ ih) }
end

example {k l} (h : lt k l) : le k l :=
begin
  induction' h,
  { exact le.zero },
  { exact le.succ ih }
end

example {k l} : lt k l → le k l :=
begin
  induction' k; induction' l; intro hlt,
  { cases' hlt },
  { exact le.zero },
  { cases' hlt },
  { cases' hlt,
    exact le.succ (@ih m hlt), }
end

example {α n m} {xs : Vec α n} {ys : Vec α m} (h : Vec.eq n m xs ys) : n = m :=
begin
  induction' h,
  case nil {
    refl },
  case cons {
    exact congr_arg nat.succ ih, }
end

-- A simple induction with complex index arguments.
example {k} (h : lt (k + 1) k) : false :=
begin
  induction' h,
  { exact ih }
end

-- A more complex induction with complex index arguments. Note the dependencies
-- between index arguments.
example {α : Sort u} {x y n m} {xs : Vec α n} {ys : Vec α m}
  : Vec.eq (n + 1) (m + 1) (Vec.cons x xs) (Vec.cons y ys)
  → Vec.eq n m xs ys :=
begin
  intro h,
  induction' h,
  exact h_1
end

-- It also works with cases'.
example {α : Sort u} {x y n m} {xs : Vec α n} {ys : Vec α m}
  : Vec.eq (n + 1) (m + 1) (Vec.cons x xs) (Vec.cons y ys)
  → Vec.eq n m xs ys :=
begin
  intro h,
  cases' h,
  exact h_1
end

-- This example requires elimination of cyclic generalised index equations.
example (n : ℕ) (h : n = n + 3) : false :=
begin
  success_if_fail { cases h },
  induction' h
end

-- It also works with cases'.
example (n : ℕ) (h : n = n + 3) : false :=
begin
  success_if_fail { cases h },
  cases' h
end

-- This example used to fail because it involves a nested inductive as a complex
-- index.
inductive rose₁ : Type
| tip : rose₁
| node : list rose₁ → rose₁

example (rs) (h : rose₁.tip = rose₁.node rs) : false :=
begin
  cases' h
end

-- This example checks whether we can deal with infinitely branching inductive
-- types.
inductive inf_tree (α : Type) : Type
| tip : inf_tree
| node (a : α) (f : ∀ (n : ℕ), inf_tree) : inf_tree

namespace inf_tree

inductive all {α} (P : α → Prop) : inf_tree α → Prop
| tip : all tip
| node {a} {f : ℕ → inf_tree α} : P a → (∀ n, all (f n)) → all (node a f)

example {α} (t : inf_tree α) : all (λ _, true) t :=
begin
  induction' t,
  { exact all.tip },
  { exact all.node trivial ih }
end

end inf_tree

-- This example tests type-based naming.
example (k : ℕ') (i : ℕ') : ℕ :=
begin
  induction' k,
  induction' i,
  exact (n + m)
end

-- For constructor arguments that are propositions, the default name is "h".
-- For non-propositions, it is "x".
inductive nat_or_positive
| nat : ℕ' → nat_or_positive
| positive (n : ℕ) : n > 0 → nat_or_positive

example (n : nat_or_positive) : unit :=
begin
  cases' n,
  case nat {
    guard_hyp x : ℕ',
    exact () },
  case positive {
    guard_hyp n : ℕ,
    guard_hyp h : n > 0,
    exact () }
end

-- By default, induction' generates the most general possible induction
-- hypothesis.
example {n m : ℕ} : n + m = m + n :=
begin
  induction' m,
  case zero { simp },
  case succ : k IH {
    guard_hyp k : ℕ,
    guard_hyp n : ℕ,
    guard_hyp IH : ∀ {n}, n + k = k + n,
    ac_refl }
end

-- Here's an example where this is more useful.
example {n m : ℕ} (h : n + n = m + m) : n = m :=
begin
  induction' n with n ih,
  case zero {
    cases' m,
    { refl },
    { cases' h } },
  case succ {
    cases' m,
    { cases' h },
    { rw @ih m,
      simp only [nat.succ_eq_add_one] at h,
      replace h : n + n + 2 = m + m + 2 := by linarith,
      injections } }
end

-- If we don't want a hypothesis to be generalised, we can say so with a
-- "fixing" clause.
example {n m : ℕ} : n + m = m + n :=
begin
  induction' m fixing n,
  case zero { simp },
  case succ : k IH {
    guard_hyp k : ℕ,
    guard_hyp n : ℕ,
    guard_hyp IH : n + k = k + n,
    ac_refl }
end

-- We can also fix all hypotheses. This gives us the behaviour of stock
-- `induction`. Hypotheses which depend on the major premise (or its index
-- arguments) still get generalised.
example {n m k : ℕ} (h : n + m = k) : n + m = k :=
begin
  induction' n fixing *,
  case zero { simp [*] },
  case succ : n IH {
    guard_hyp n : ℕ,
    guard_hyp m : ℕ,
    guard_hyp k : ℕ,
    guard_hyp h : n.succ + m = k,
    guard_hyp IH : n + m = k → n + m = k,
    -- Neither m nor k were generalised.
    exact h }
end

-- We can also generalise only certain hypotheses using a `generalizing`
-- clause. This gives us the behaviour of stock `induction ... generalizing`.
-- Hypotheses which depend on the major premise get generalised even if they are
-- not mentioned in the `generalizing` clause.
example {n m k : ℕ} (h : n + m = k) : n + m = k :=
begin
  induction' n generalizing k,
  case zero { simp [*] },
  case succ : n IH {
    guard_hyp n : ℕ,
    guard_hyp m : ℕ,
    guard_hyp k : ℕ,
    guard_hyp h : n.succ + m = k,
    guard_hyp IH : ∀ {k}, n + m = k → n + m = k,
    -- k was generalised, but m was not.
    exact h }
end

-- Sometimes generalising a hypothesis H does not give us a more general
-- induction hypothesis. In such cases, induction' should not generalise H. The
-- following example is not realistic, but situations like this can occur in
-- practice; see accufact_1_eq_fact below.
example (n m k : ℕ) : m + k = k + m :=
begin
  induction' m,
  case zero { simp },
  case succ {
    guard_hyp ih : ∀ k, m + k = k + m,
    -- k was generalised because this makes the IH more general.
    -- n was not generalised -- if it had been, the IH would be
    --
    --     ∀ n k, m + k = k + m
    --
    -- with one useless additional argument.
    ac_refl }
end

-- This example checks that constructor arguments don't 'steal' the names of
-- generalised hypotheses.
example (n : list ℕ) (n : ℕ) : list ℕ :=
begin
  -- this performs induction on (n : ℕ)
  induction' n,
  { exact n },
  { guard_hyp n : list ℕ,
    guard_hyp n_1 : ℕ,
    -- n is the list, which was automatically generalized and keeps its name.
    -- n_1 is the recursive argument of `nat.succ`. It would be called `n` if
    -- there wasn't already an `n` in the context.
    exact (n_1 :: n) }
end

-- This example tests whether `induction'` gets confused when there are
-- additional cases around.
example (k : ℕ) (t : Two) : 0 + k = k :=
begin
  cases t,
  induction' k,
  { refl },
  { simp },
  induction' k,
  { refl },
  { simp }
end

-- The type of the induction premise can be a complex expression so long as it
-- normalises to an inductive (possibly applied to params/indexes).
example (n) : 0 + n = n :=
begin
  let T := ℕ,
  change T at n,
  induction' n; simp
end

-- Fail if the type of the induction premise is not an inductive type
example {α} (x : α) (f : α → α) : unit :=
begin
  success_if_fail { induction' x },
  success_if_fail { induction' f },
  exact ()
end

-- The following example used to trigger a bug where eliminate would generate
-- hypotheses with duplicate names.
structure fraction : Type :=
(num           : ℤ)
(denom         : ℤ)
(denom_ne_zero : denom ≠ 0)

lemma fraction.ext (a b : fraction) (hnum : fraction.num a = fraction.num b)
    (hdenom : fraction.denom a = fraction.denom b) :
  a = b :=
begin
  cases' a,
  cases' b,
  guard_hyp num : ℤ,
  guard_hyp denom : ℤ,
  guard_hyp num_1 : ℤ,
  guard_hyp denom_1 : ℤ,
  rw fraction.mk.inj_eq,
  exact and.intro hnum hdenom
end

-- A "with" clause can be used to give the names of constructor arguments (as
-- for `cases`, `induction` etc).
example (x : ℕ × ℕ) (y : Vec ℕ 2) (z : List ℕ) : unit :=
begin
  cases' x with i j k l,
  guard_hyp i : ℕ,
  guard_hyp j : ℕ,
  clear i j,

  cases' y with i j k l,
  -- Note that i is 'skipped' because it is used to name the (n : ℕ)
  -- argument of `cons`, but that argument is cleared by index unification. I
  -- find this a little strange, but `cases` also behaves like this.
  guard_hyp j : ℕ,
  guard_hyp k : Vec ℕ 1,
  clear j k,

  cases' z with i j k l,
  case nil { exact () },
  case cons {
    guard_hyp i : ℕ,
    guard_hyp j : List ℕ,
    exact () }
end

-- "with" also works with induction'.
example (x : List ℕ) : unit :=
begin
  induction' x with i j k l,
  case nil { exact () },
  case cons {
    guard_hyp i : ℕ,
    guard_hyp j : List ℕ,
    guard_hyp k : unit,
    exact () }
end

-- An underscore in a "with" clause means "use the auto-generated name for this
-- argument".
example (x : List ℕ) : unit :=
begin
  induction' x with _ j _ l,
  case nil { exact () },
  case cons {
    guard_hyp x : ℕ,
    guard_hyp j : List ℕ,
    guard_hyp ih : unit,
    exact () }
end

namespace with_tests

inductive test
| intro (n) (f : fin n) (m) (g : fin m)

-- A hyphen in a "with" clause means "clear this hypothesis and its reverse
-- dependencies".
example (h : test) : unit :=
begin
  cases' h with - F M G,
  guard_hyp M : ℕ,
  guard_hyp G : fin M,
  success_if_fail { guard_hyp n },
  success_if_fail { guard_hyp F },
  exact ()
end

-- Names given in a "with" clause are used verbatim, even if this results in
-- shadowing.
example (x : ℕ) (h : test) : unit :=
begin
  cases' h with x y y -,
  /-
  Expected goal:

  x x : ℕ,
  y : fin x,
  y : ℕ
  ⊢ unit

  It's hard to give a good test case here because we would need a variant of
  `guard_hyp` that is sensitive to shadowing. But we can at least check that the
  hyps don't have the names they would get if we avoided shadowing.
  -/
  success_if_fail { guard_hyp x_1 },
  success_if_fail { guard_hyp y_1 },
  exact ()
end

end with_tests

-- induction' and cases' can be used to perform induction/case analysis on
-- arbitrary expressions (not just hypotheses). A very synthetic example:
example {α} : α ∨ ¬ α :=
begin
  cases' classical.em α with a nota,
  { exact (or.inl a) },
  { exact (or.inr nota) }
end

-- Cases'/induction' can add an equation witnessing the case split it
-- performed. Again, a highly synthetic example:
example {α} (xs : list α)
  : xs.reverse.length = 0 ∨ ∃ m, xs.reverse.length = m + 1 :=
begin
  cases' eq : xs.length,
  case zero {
    left,
    rw list.length_reverse,
    exact eq },
  case succ : l {
    right,
    rw list.length_reverse,
    use l,
    exact eq }
end

-- Index equation simplification can deal with equations that aren't in normal
-- form.
example {α} (x : α) (xs) : list.take 1 (x :: xs) ≠ [] :=
begin
  intro contra,
  cases' contra
end

-- Index generalisation should leave early occurrences of complex index terms
-- alone. This means that given the major premise `e : E (f y) y` where `y` is a
-- complex term, index generalisation should give us
--
--     e : E (f y) i,
--
-- *not*
--
--     e : E (f i) i.
--
-- Otherwise we get problems with examples like this:
inductive ℕ₂ : Type
| zero
| succ (n : ℕ₂) : ℕ₂

namespace ℕ₂

def plus : ℕ₂ → ℕ₂ → ℕ₂
| zero y := y
| (succ x) y := succ (plus x y)

example (x : ℕ₂) (h : plus zero x = zero) : x = zero :=
begin
  cases' h,
  guard_target zero = plus zero zero,
  refl
  -- If index generalisation blindly replaced all occurrences of zero, we would
  -- get
  --
  --     index = zero        → plus index x = index → x = index
  --
  -- and after applying the recursor
  --
  --     plus index x = zero                        → x = plus index x
  --
  -- This leaves the goal provable, but very confusing.
end

-- TODO Here's a test case (due to Floris van Doorn) where index generalisation
-- is over-eager: it replaces the complex index `zero` everywhere in the goal,
-- which makes the goal type-incorrect. `cases` does not exhibit this problem.
example (x : ℕ₂) (h : plus zero x = zero) :
  (⟨x, h⟩ : ∃ x, plus zero x = zero) = ⟨zero, rfl⟩ :=
begin
  success_if_fail { cases' h },
  cases h,
  refl
end

end ℕ₂

-- For whatever reason, the eliminator for `false` has an explicit argument
-- where all other eliminators have an implicit one. `eliminate_hyp` has to
-- work around this to ensure that we can eliminate a `false` hyp.
example {α} (h : false) : α :=
begin
  cases' h
end

-- Index equation simplification also works with nested datatypes.
inductive rose (α : Type) : Type
| leaf : rose
| node (val : α) (children : list rose) : rose

namespace rose

inductive nonempty {α} : rose α → Prop
| node (v c cs) : nonempty (node v (c :: cs))

lemma nonempty_node_elim {α} {v : α} {cs} (h : nonempty (node v cs)) : ¬ cs.empty :=
begin
  induction' h,
  finish
end

end rose

-- The following test cases, provided by Patrick Massot, test interactions with
-- several 'advanced' Lean features.
namespace topological_space_tests

class topological_space (X : Type) :=
  (is_open  : set X → Prop)
  (univ_mem : is_open set.univ)
  (union    : ∀ (B : set (set X)) (h : ∀ b ∈ B, is_open b), is_open (⋃₀ B))
  (inter    : ∀ (A B : set X) (hA : is_open A) (hB : is_open B), is_open (A ∩ B))

open topological_space (is_open)

inductive generated_open (X : Type) (g : set (set X)) : set X → Prop
| generator : ∀ A ∈ g, generated_open A
| inter     : ∀ A B, generated_open A → generated_open B → generated_open (A ∩ B)
| union     : ∀ (B : set (set X)), (∀ b ∈ B, generated_open b) → generated_open (⋃₀ B)
| univ      : generated_open set.univ

def generate_from (X : Type) (g : set (set X)) : topological_space X :=
{ is_open   := generated_open X g,
  univ_mem  := generated_open.univ,
  inter     := generated_open.inter,
  union     := generated_open.union }

inductive generated_filter {X : Type*} (g : set (set X)) : set X → Prop
| generator {A} : A ∈ g → generated_filter A
| inter   {A B} : generated_filter A → generated_filter B → generated_filter (A ∩ B)
| subset  {A B} : generated_filter A → A ⊆ B → generated_filter B
| univ          : generated_filter set.univ

def neighbourhood {X : Type} [topological_space X] (x : X) (V : set X) : Prop :=
∃ (U : set X), is_open U ∧ x ∈ U ∧ U ⊆ V

axiom nhd_inter {X : Type*} [topological_space X] {x : X} {U V : set X}
  (hU : neighbourhood x U) (hV : neighbourhood x V) : neighbourhood x (U ∩ V)

axiom nhd_superset {X : Type*} [topological_space X] {x : X} {U V : set X}
  (hU : neighbourhood x U) (hUV : U ⊆ V) : neighbourhood x V

axiom nhd_univ {X : Type*} [topological_space X] {x : X} : neighbourhood x set.univ

-- This example fails if auto-generalisation refuses to revert before
-- frozen local instances.
example {X : Type} [T : topological_space X] {s : set (set X)}
  (h : T = generate_from X s) {U x} :
  generated_filter {V | V ∈ s ∧ x ∈ V} U → neighbourhood x U :=
begin
  rw h,
  intro U_in,
  induction' U_in fixing T h with U hU U V U_gen V_gen hU hV U V U_gen hUV hU,
  { exact ⟨U, generated_open.generator U hU.1, hU.2, set.subset.refl U⟩ },
  { exact @nhd_inter _ (generate_from X s) _ _ _ hU hV },
  { exact @nhd_superset _ (generate_from X s) _  _ _ hU hUV },
  { apply nhd_univ }
end

-- This example fails if auto-generalisation tries to generalise `let`
-- hypotheses.
example {X : Type} [T : topological_space X] {s : set (set X)}
  (h : T = generate_from X s) {U x} :
  generated_filter {V | V ∈ s ∧ x ∈ V} U → neighbourhood x U :=
begin
  rw h,
  letI := generate_from X s,
  intro U_in,
  induction' U_in fixing T h with U hU U V U_gen V_gen hU hV U V U_gen hUV hU,
  { exact ⟨U, generated_open.generator U hU.1, hU.2, set.subset.refl U⟩ },
  { exact nhd_inter hU hV },
  { exact nhd_superset hU hUV },
  { apply nhd_univ }
end

-- This example fails if infinitely branching inductive types like
-- `generated_open` are not handled properly. In particular, it tests the
-- interaction of infinitely branching types with complex indices.
example {X : Type*} [T : topological_space X] {s : set (set X)}
  (h : T = generate_from X s) {U : set X} {x : X} :
  neighbourhood x U → generated_filter {V | V ∈ s ∧ x ∈ V} U :=
begin
  rw h, letI := generate_from X s,
  clear h,
  rintros ⟨V, V_op, x_in, hUV⟩,
  apply generated_filter.subset _ hUV,
  clear hUV,
  induction' V_op fixing _inst T s U,
  { apply generated_filter.generator,
    split ; assumption },
  { cases x_in,
    apply generated_filter.inter ; tauto },
  { rw set.mem_sUnion at x_in,
    rcases x_in with ⟨W, hW, hxW⟩,
    exact generated_filter.subset (ih W hW hxW) (set.subset_sUnion_of_mem hW)},
  { apply generated_filter.univ }
end

end topological_space_tests

--------------------------------------------------------------------------------
-- Logical Verification Use Cases
--------------------------------------------------------------------------------

-- The following examples were provided by Jasmin Blanchette. They are taken
-- from his course 'Logical Verification'.

/- Head induction for transitive closure -/

inductive star {α : Sort*} (r : α → α → Prop) (a : α) : α → Prop
| refl {}    : star a
| tail {b c} : star b → r b c → star c

namespace star

variables {α : Sort*} {r : α → α → Prop} {a b c d : α}

lemma head (hab : r a b) (hbc : star r b c) :
  star r a c :=
begin
  induction' hbc fixing hab,
  case refl {
    exact refl.tail hab },
  case tail : c d hbc hcd hac {
    exact hac.tail hcd }
end

-- In this example, induction' must apply the dependent recursor for star; the
-- nondependent one doesn't apply.
lemma head_induction_on {b} {P : ∀a : α, star r a b → Prop} {a} (h : star r a b)
  (refl : P b refl)
  (head : ∀{a c} (h' : r a c) (h : star r c b), P c h → P a (h.head h')) :
  P a h :=
begin
  induction' h,
  case refl {
    exact refl },
  case tail : b c hab hbc ih {
    apply ih,
    { exact head hbc _ refl, },
    { intros _ _ hab _, exact head hab _} }
end

end star

/- Factorial -/

def accufact : ℕ → ℕ → ℕ
| a 0       := a
| a (n + 1) := accufact ((n + 1) * a) n

lemma accufact_1_eq_fact (n : ℕ) :
  accufact 1 n = nat.factorial n :=
have accufact_eq_fact_mul : ∀m a, accufact a m = nat.factorial m * a :=
  begin
    intros m a,
    induction' m,
    case zero {
      simp [nat.factorial, accufact] },
    case succ {
      simp [nat.factorial, accufact, ih, nat.succ_eq_add_one],
      cc }
  end,
by simp [accufact_eq_fact_mul n 1]

/- Substitution -/

namespace expressions

inductive exp : Type
| Var  : string → exp
| Num  : ℤ → exp
| Plus : exp → exp → exp

export exp

def subst (ρ : string → exp) : exp → exp
| (Var y)      := ρ y
| (Num i)      := Num i
| (Plus e₁ e₂) := Plus (subst e₁) (subst e₂)

lemma subst_Var (e : exp) :
  subst (λx, Var x) e = e :=
begin
  induction' e,
  case Var {
    guard_hyp s : string,
    rw [subst] },
  case Num {
    guard_hyp n : ℤ,
    rw [subst] },
  case Plus {
    guard_hyp e : exp,
    guard_hyp e_1 : exp,
    guard_hyp ih_e,
    guard_hyp ih_e_1,
    rw [subst],
    rw ih_e,
    rw ih_e_1 }
end

end expressions

/- Less-than -/

namespace less_than

inductive lt : nat → nat → Type
| zero_succ (n : nat) : lt 0 (1 + n)
| succ_succ {n m : nat} : lt n m → lt (1 + n) (1 + m)

inductive lte : nat → nat → Type
| zero (n : nat) : lte 0 n
| succ {n m : nat} : lte n m → lte (1 + n) (1 + m)

lemma lt_lte {n m} : lt n m → lte n m :=
begin
  intro lt_n_m,
  induction' lt_n_m,
  case zero_succ : i {
    constructor },
  case succ_succ : i j lt_i_j ih {
    constructor,
    apply ih }
end

end less_than

/- Sortedness -/

inductive sorted : list ℕ → Prop
| nil : sorted []
| single {x : ℕ} : sorted [x]
| two_or_more {x y : ℕ} {zs : list ℕ} (hle : x ≤ y)
    (hsorted : sorted (y :: zs)) :
  sorted (x :: y :: zs)

/- In this example it's important that cases' *doesn't* normalise the values of
indexes when simplifying index equations. -/
lemma not_sorted_17_13 :
  ¬ sorted [17, 13] :=
begin
  intro h,
  cases' h,
  guard_hyp hle : 17 ≤ 13,
  linarith
end

/- Palindromes -/

namespace palindrome

inductive palindrome {α : Type} : list α → Prop
| nil : palindrome []
| single (x : α) : palindrome [x]
| sandwich (x : α) (xs : list α) (hpal : palindrome xs) :
  palindrome ([x] ++ xs ++ [x])

axiom reverse_append_sandwich {α : Type} (x : α) (ys : list α) :
  list.reverse ([x] ++ ys ++ [x]) = [x] ++ list.reverse ys ++ [x]

lemma rev_palindrome {α : Type} (xs : list α) (hpal : palindrome xs) :
  palindrome (list.reverse xs) :=
begin
  induction' hpal,
  case nil {
    exact palindrome.nil },
  case single {
    exact palindrome.single _ },
  case sandwich {
    rw reverse_append_sandwich,
    apply palindrome.sandwich,
    apply ih }
end

end palindrome

/- Transitive Closure -/

namespace transitive_closure

inductive tc {α : Type} (r : α → α → Prop) : α → α → Prop
| base (x y : α) (hr : r x y) : tc x y
| step (x y z : α) (hr : r x y) (ht : tc y z) : tc x z

/- The transitive closure is a nice example with lots of variables to keep track
of. We start with a lemma where the variable names do not collide with those
appearing in the definition of the inductive predicate. -/

lemma tc_pets₁ {α : Type} (r : α → α → Prop) (c : α) :
  ∀a b, tc r a b → r b c → tc r a c :=
begin
  intros a b htab hrbc,
  induction' htab fixing c,
  case base : _ _ hrab {
    exact tc.step _ _ _ hrab (tc.base _ _ hrbc) },
  case step : _ x _ hrax {
    exact tc.step _ _ _ hrax (ih hrbc) }
end

/- The same proof, but this time the variable names clash. Also, this time we
let `induction'` generalize `z`. -/

lemma tc_pets₂ {α : Type} (r : α → α → Prop) (z : α) :
  ∀x y, tc r x y → r y z → tc r x z :=
begin
  intros x y htxy hryz,
  induction' htxy,
  case base : _ _ hrxy {
    exact tc.step _ _ _ hrxy (tc.base _ _ hryz) },
  case step : _ x' y hrxx' htx'y ih {
    exact tc.step _ _ _ hrxx' (ih _ hryz) }
end

/- Another proof along the same lines. -/

lemma tc_trans {α : Type} (r : α → α → Prop) (c : α) :
  ∀a b : α, tc r a b → tc r b c → tc r a c :=
begin
  intros a b htab htbc,
  induction' htab,
  case base {
    exact tc.step _ _ _ hr htbc },
  case step {
    exact tc.step _ _ _ hr (ih _ htbc) }
end

/- ... and with clashing variable names: -/

lemma tc_trans' {α : Type} (r : α → α → Prop) {x y z} :
  tc r x y → tc r y z → tc r x z :=
begin
  intros h₁ h₂,
  induction' h₁,
  case base {
    exact tc.step _ _ _ hr h₂ },
  case step {
    exact tc.step _ _ _ hr (ih h₂) }
end

end transitive_closure

/- Evenness -/

inductive Even : ℕ → Prop
| zero    : Even 0
| add_two : ∀k : ℕ, Even k → Even (k + 2)

lemma not_even_2_mul_add_1 (n : ℕ) :
  ¬ Even (2 * n + 1) :=
begin
  intro h,
  induction' h,
  -- No case tag since there's only one goal. I don't really like this, but
  -- this is the behaviour of induction/cases.
  {
    apply ih (n - 1),
    cases' n,
    case zero {
      linarith },
    case succ {
      simp [nat.succ_eq_add_one] at *,
      linarith } }
end

/- Big-Step Semantics -/

namespace semantics

def state :=
string → ℕ

def state.update (name : string) (val : ℕ) (s : state) : state :=
λname', if name' = name then val else s name'

notation s `{` name ` ↦ ` val `}` := state.update name val s

inductive stmt : Type
| skip   : stmt
| assign : string → (state → ℕ) → stmt
| seq    : stmt → stmt → stmt
| ite    : (state → Prop) → stmt → stmt → stmt
| while  : (state → Prop) → stmt → stmt

export stmt

infixr ` ;; ` : 90 := stmt.seq

/- Our first version is partly uncurried, like in the Logical Verification
course, and also like in Concrete Semantics. This makes the binary infix
notation possible. -/

inductive big_step : stmt × state → state → Prop
| skip {s} :
  big_step (skip, s) s
| assign {x a s} :
  big_step (assign x a, s) (s{x ↦ a s})
| seq {S T s t u} (hS : big_step (S, s) t)
    (hT : big_step (T, t) u) :
  big_step (seq S T, s) u
| ite_true {b : state → Prop} {S T s t} (hcond : b s)
    (hbody : big_step (S, s) t) :
  big_step (ite b S T, s) t
| ite_false {b : state → Prop} {S T s t} (hcond : ¬ b s)
    (hbody : big_step (T, s) t) :
  big_step (ite b S T, s) t
| while_true {b : state → Prop} {S s t u} (hcond : b s)
    (hbody : big_step (S, s) t)
    (hrest : big_step (while b S, t) u) :
  big_step (while b S, s) u
| while_false {b : state → Prop} {S s} (hcond : ¬ b s) :
  big_step (while b S, s) s

infix ` ⟹ `:110 := big_step

open big_step

lemma not_big_step_while_true {S s t} :
  ¬ (while (λ_, true) S, s) ⟹ t :=
begin
  intro hw,
  induction' hw,
  case while_true {
    exact ih_hw_1 },
  case while_false {
    exact hcond trivial }
end

/- The same with a curried version of the predicate. It should make no
difference whether a predicate is curried or uncurried. -/

inductive curried_big_step : stmt → state → state → Prop
| skip {s} :
  curried_big_step skip s s
| assign {x a s} :
  curried_big_step (assign x a) s (s{x ↦ a s})
| seq {S T s t u} (hS : curried_big_step S s t)
    (hT : curried_big_step T t u) :
  curried_big_step (seq S T) s u
| ite_true {b : state → Prop} {S T s t} (hcond : b s)
    (hbody : curried_big_step S s t) :
  curried_big_step (ite b S T) s t
| ite_false {b : state → Prop} {S T s t} (hcond : ¬ b s)
    (hbody : curried_big_step T s t) :
  curried_big_step (ite b S T) s t
| while_true {b : state → Prop} {S s t u} (hcond : b s)
    (hbody : curried_big_step S s t)
    (hrest : curried_big_step (while b S) t u) :
  curried_big_step (while b S) s u
| while_false {b : state → Prop} {S s} (hcond : ¬ b s) :
  curried_big_step (while b S) s s

lemma not_curried_big_step_while_true {S s t} :
  ¬ curried_big_step (while (λ_, true) S) s t :=
begin
  intro hw,
  induction' hw,
  case while_true {
    exact ih_hw_1, },
  case while_false {
    exact hcond trivial }
end

end semantics

/- Small-Step Semantics -/

namespace semantics

inductive small_step : stmt × state → stmt × state → Prop
| assign {x a s} :
  small_step (assign x a, s) (skip, s{x ↦ a s})
| seq_step {S S' T s s'} (hS : small_step (S, s) (S', s')) :
  small_step (seq S T, s) (seq S' T, s')
| seq_skip {T s} :
  small_step (seq skip T, s) (T, s)
| ite_true {b : state → Prop} {S T s} (hcond : b s) :
  small_step (ite b S T, s) (S, s)
| ite_false {b : state → Prop} {S T s} (hcond : ¬ b s) :
  small_step (ite b S T, s) (T, s)
| while {b : state → Prop} {S s} :
  small_step (while b S, s) (ite b (seq S (while b S)) skip, s)

lemma small_step_if_equal_states {S T s t s' t'}
    (hstep : small_step (S, s) (T, t)) (hs : s' = s) (ht : t' = t) :
  small_step (S, s') (T, t') :=
begin
  induction' hstep,
  { rw [hs, ht],
    exact small_step.assign, },
  { apply small_step.seq_step,
    exact ih hs ht, },
  { rw [hs, ht],
    exact small_step.seq_skip, },
  { rw [hs, ht],
    exact small_step.ite_true hcond, },
  { rw [hs, ht],
    exact small_step.ite_false hcond, },
  { rw [hs, ht],
    exact small_step.while, }
end

infixr ` ⇒ ` := small_step
infixr ` ⇒* ` : 100 := star small_step

/- More lemmas about big-step and small-step semantics. These are taken from the
Logical Verification course materials. They provide lots of good test cases for
cases'/induction'. -/

namespace star

variables {α : Sort*} {r : α → α → Prop} {a b c d : α}

attribute [refl] star.refl

@[trans] lemma trans (hab : star r a b) (hbc : star r b c) :
  star r a c :=
begin
  induction' hbc,
  case refl {
    assumption },
  case tail : c d hbc hcd hac {
    exact (star.tail (hac hab)) hcd }
end

lemma single (hab : r a b) :
  star r a b :=
star.refl.tail hab

lemma trans_induction_on {α : Sort*} {r : α → α → Prop}
    {p : ∀{a b : α}, star r a b → Prop} {a b : α} (h : star r a b)
    (ih₁ : ∀a, @p a a star.refl) (ih₂ : ∀{a b} (h : r a b), p (single h))
    (ih₃ : ∀{a b c} (h₁ : star r a b) (h₂ : star r b c), p h₁ →
       p h₂ → p (trans h₁ h₂)) :
  p h :=
begin
  induction' h,
  case refl {
    exact ih₁ a },
  case tail : b c hab hbc ih {
    exact ih₃ hab (single hbc) (ih ih₁ @ih₂ @ih₃) (ih₂ hbc) }
end

lemma lift {β : Sort*} {s : β → β → Prop} (f : α → β)
  (h : ∀a b, r a b → s (f a) (f b)) (hab : star r a b) :
  star s (f a) (f b) :=
begin
  apply trans_induction_on hab,
  exact (λ a, star.refl),
  exact (λ a b, star.single ∘ h _ _),
  exact (λ a b c _ _, star.trans)
end

end star

lemma big_step_deterministic {S s l r} (hl : (S, s) ⟹ l)
    (hr : (S, s) ⟹ r) :
  l = r :=
begin
  induction' hl,
  case skip : t {
    cases' hr,
    refl },
  case assign : x a s {
    cases' hr,
    refl },
  case seq : S T s t l hS hT ihS ihT {
    cases' hr with _ _ _ _ _ _ _ t' _ hS' hT',
    cases' ihS hS',
    cases' ihT hT',
    refl },
  case ite_true : b S T s t hb hS ih {
    cases' hr,
    { apply ih,
      assumption },
    { apply ih,
      cc } },
  case ite_false : b S T s t hb hT ih {
    cases' hr,
    { apply ih,
      cc },
    { apply ih,
      assumption } },
  case while_true : b S s t u hb hS hw ihS ihw {
    cases' hr,
    { cases' ihS hr,
      cases' ihw hr_1,
      refl },
    { cc } },
  { cases' hr,
    { cc },
    { refl } }
end

@[simp] lemma big_step_skip_iff {s t} :
  (stmt.skip, s) ⟹ t ↔ t = s :=
begin
  apply iff.intro,
  { intro h,
    cases' h,
    refl },
  { intro h,
    rw h,
    exact big_step.skip }
end

@[simp] lemma big_step_assign_iff {x a s t} :
  (stmt.assign x a, s) ⟹ t ↔ t = s{x ↦ a s} :=
begin
  apply iff.intro,
  { intro h,
    cases' h,
    refl },
  { intro h,
    rw h,
    exact big_step.assign }
end

@[simp] lemma big_step_seq_iff {S T s t} :
  (S ;; T, s) ⟹ t ↔ (∃u, (S, s) ⟹ u ∧ (T, u) ⟹ t) :=
begin
  apply iff.intro,
  { intro h,
    cases' h,
    apply exists.intro,
    apply and.intro; assumption },
  { intro h,
    cases' h,
    cases' h,
    apply big_step.seq; assumption }
end

@[simp] lemma big_step_ite_iff {b S T s t} :
  (stmt.ite b S T, s) ⟹ t ↔
  (b s ∧ (S, s) ⟹ t) ∨ (¬ b s ∧ (T, s) ⟹ t) :=
begin
  apply iff.intro,
  { intro h,
    cases' h,
    { apply or.intro_left,
      cc },
    { apply or.intro_right,
      cc } },
  { intro h,
    cases' h; cases' h,
    { apply big_step.ite_true; assumption },
    { apply big_step.ite_false; assumption } }
end

lemma big_step_while_iff {b S s u} :
  (stmt.while b S, s) ⟹ u ↔
  (∃t, b s ∧ (S, s) ⟹ t ∧ (stmt.while b S, t) ⟹ u)
  ∨ (¬ b s ∧ u = s) :=
begin
  apply iff.intro,
  { intro h,
    cases' h,
    { apply or.intro_left,
      apply exists.intro t,
      cc },
    { apply or.intro_right,
      cc } },
  { intro h,
    cases' h,
    case or.inl {
      cases' h with t h,
      cases' h with hb h,
      cases' h with hS hwhile,
      exact big_step.while_true hb hS hwhile },
    case or.inr {
      cases' h with hb hus,
      rw hus,
      exact big_step.while_false hb } }
end

lemma big_step_while_true_iff {b : state → Prop} {S s u}
    (hcond : b s) :
  (stmt.while b S, s) ⟹ u ↔
  (∃t, (S, s) ⟹ t ∧ (stmt.while b S, t) ⟹ u) :=
by rw big_step_while_iff; simp [hcond]

@[simp] lemma big_step_while_false_iff {b : state → Prop}
    {S s t} (hcond : ¬ b s) :
  (stmt.while b S, s) ⟹ t ↔ t = s :=
by rw big_step_while_iff; simp [hcond]

lemma small_step_final (S s) :
  (¬ ∃T t, (S, s) ⇒ (T, t)) ↔ S = stmt.skip :=
begin
  induction' S,
  case skip {
    simp,
    intros T t hstep,
    cases' hstep },
  case assign : x a {
    simp,
    apply exists.intro stmt.skip,
    apply exists.intro (s{x ↦ a s}),
    exact small_step.assign },
  case seq : S T ihS ihT {
    simp,
    cases' classical.em (S = stmt.skip),
    case inl {
      rw h,
      apply exists.intro T,
      apply exists.intro s,
      exact small_step.seq_skip },
    case inr {
      simp [h, auto.not_forall_eq, auto.not_not_eq] at ihS,
      cases' ihS s with S' hS',
      cases' hS' with s' hs',
      apply exists.intro (S' ;; T),
      apply exists.intro s',
      exact small_step.seq_step hs' } },
  case ite : b S T ihS ihT {
    simp,
    cases' classical.em (b s),
    case inl {
      apply exists.intro S,
      apply exists.intro s,
      exact small_step.ite_true h },
    case inr {
      apply exists.intro T,
      apply exists.intro s,
      exact small_step.ite_false h } },
  case while : b S ih {
    simp,
    apply exists.intro (stmt.ite b (S ;; stmt.while b S) stmt.skip),
    apply exists.intro s,
    exact small_step.while }
end

lemma small_step_deterministic {S s Ll Rr}
    (hl : (S, s) ⇒ Ll) (hr : (S, s) ⇒ Rr) :
  Ll = Rr :=
begin
  induction' hl,
  case assign : x a s {
    cases' hr,
    refl },
  case seq_step : S S₁ T s s₁ hS₁ ih {
    cases' hr,
    case seq_step : S S₂ _ _ s₂ hS₂ {
      have hSs₁₂ := ih hS₂,
      cc },
    case seq_skip {
      cases' hS₁ } },
  case seq_skip : T s {
    cases' hr,
    { cases' hr },
    { refl } },
  case ite_true : b S T s hcond {
    cases' hr,
    case ite_true {
      refl },
    case ite_false {
      cc } },
  case ite_false : b S T s hcond {
    cases' hr,
    case ite_true {
      cc },
    case ite_false {
      refl } },
  case while : b S s {
    cases' hr,
    refl }
end

lemma small_step_skip {S s t} :
  ¬ ((stmt.skip, s) ⇒ (S, t)) :=
by intro h; cases' h

@[simp] lemma small_step_seq_iff {S T s Ut} :
  (S ;; T, s) ⇒ Ut ↔
  (∃S' t, (S, s) ⇒ (S', t) ∧ Ut = (S' ;; T, t))
  ∨ (S = stmt.skip ∧ Ut = (T, s)) :=
begin
  apply iff.intro,
  { intro h,
    cases' h,
    { apply or.intro_left,
      apply exists.intro S',
      apply exists.intro s',
      cc },
    { apply or.intro_right,
      cc } },
  { intro h,
    cases' h,
    { cases' h,
      cases' h,
      cases' h,
      rw right,
      apply small_step.seq_step,
      assumption },
    { cases' h,
      rw left,
      rw right,
      apply small_step.seq_skip } }
end

@[simp] lemma small_step_ite_iff {b S T s Us} :
  (stmt.ite b S T, s) ⇒ Us ↔
  (b s ∧ Us = (S, s)) ∨ (¬ b s ∧ Us = (T, s)) :=
begin
  apply iff.intro,
  { intro h,
    cases' h,
    { apply or.intro_left,
      cc },
    { apply or.intro_right,
      cc } },
  { intro h,
    cases' h,
    { cases' h,
      rw right,
      apply small_step.ite_true,
      assumption },
    { cases' h,
      rw right,
      apply small_step.ite_false,
      assumption } }
end

lemma star_small_step_seq {S T s u}
    (h : (S, s) ⇒* (stmt.skip, u)) :
  (S ;; T, s) ⇒* (stmt.skip ;; T, u) :=
begin
  apply star.lift (λSs, (prod.fst Ss ;; T, prod.snd Ss)) _ h,
  intros Ss Ss' h,
  cases' Ss,
  cases' Ss',
  apply small_step.seq_step,
  assumption
end

lemma star_small_step_of_big_step {S s t} (h : (S, s) ⟹ t) :
  (S, s) ⇒* (stmt.skip, t) :=
begin
  induction' h,
  case skip {
    refl },
  case assign {
    exact star.single small_step.assign },
  case seq : S T s t u hS hT ihS ihT {
    transitivity,
    exact star_small_step_seq ihS,
    apply star.head small_step.seq_skip ihT },
  case ite_true : b S T s t hs hst ih {
    exact star.head (small_step.ite_true hs) ih },
  case ite_false : b S T s t hs hst ih {
    exact star.head (small_step.ite_false hs) ih },
  case while_true : b S s t u hb hS hw ihS ihw {
    exact (star.head small_step.while
      (star.head (small_step.ite_true hb)
         (star.trans (star_small_step_seq ihS)
            (star.head small_step.seq_skip ihw)))) },
  case while_false : b S s hb {
    exact star.tail (star.single small_step.while)
      (small_step.ite_false hb) }
end

lemma big_step_of_small_step_of_big_step {S₀ S₁ s₀ s₁ s₂}
  (h₁ : (S₀, s₀) ⇒ (S₁, s₁)) :
  (S₁, s₁) ⟹ s₂ → (S₀, s₀) ⟹ s₂ :=
begin
  induction' h₁;
    simp [*, big_step_while_true_iff, or_imp_distrib] {contextual := tt},
  case seq_step {
    intros u hS' hT,
    apply exists.intro u,
    exact and.intro (ih hS') hT },
end

lemma big_step_of_star_small_step {S s t} :
  (S, s) ⇒* (stmt.skip, t) → (S, s) ⟹ t :=
begin
  generalize hSs : (S, s) = Ss,
  intro h,
  induction h
      using star.head_induction_on
      with _ S's' h h' ih
      generalizing S s;
    cases' hSs,
  { exact big_step.skip },
  { cases' S's' with S' s',
    apply big_step_of_small_step_of_big_step h,
    apply ih,
    refl }
end

end semantics


/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl
-/
import data.set.image
import order.lattice
import order.max

/-!
# Directed indexed families and sets

> THIS FILE IS SYNCHRONIZED WITH MATHLIB4.
> Any changes to this file require a corresponding PR to mathlib4.

This file defines directed indexed families and directed sets. An indexed family/set is
directed iff each pair of elements has a shared upper bound.

## Main declarations

* `directed r f`: Predicate stating that the indexed family `f` is `r`-directed.
* `directed_on r s`: Predicate stating that the set `s` is `r`-directed.
* `is_directed α r`: Prop-valued mixin stating that `α` is `r`-directed. Follows the style of the
  unbundled relation classes such as `is_total`.
-/

open function

universes u v w

variables {α : Type u} {β : Type v} {ι : Sort w} (r r' s : α → α → Prop)
local infix ` ≼ ` : 50 := r

/-- A family of elements of α is directed (with respect to a relation `≼` on α)
  if there is a member of the family `≼`-above any pair in the family.  -/
def directed (f : ι → α) := ∀ x y, ∃ z, f x ≼ f z ∧ f y ≼ f z

/-- A subset of α is directed if there is an element of the set `≼`-above any
  pair of elements in the set. -/
def directed_on (s : set α) := ∀ (x ∈ s) (y ∈ s), ∃ z ∈ s, x ≼ z ∧ y ≼ z

variables {r r'}

theorem directed_on_iff_directed {s} : @directed_on α r s ↔ directed r (coe : s → α) :=
by simp [directed, directed_on]; refine ball_congr (λ x hx, by simp; refl)

alias directed_on_iff_directed ↔ directed_on.directed_coe _

theorem directed_on_range {f : β → α} :
  directed r f ↔ directed_on r (set.range f) :=
by simp_rw [directed, directed_on, set.forall_range_iff, set.exists_range_iff]

theorem directed_on_image {s} {f : β → α} :
  directed_on r (f '' s) ↔ directed_on (f ⁻¹'o r) s :=
by simp only [directed_on, set.ball_image_iff, set.bex_image_iff, order.preimage]

lemma directed_on.mono' {s : set α} (hs : directed_on r s)
  (h : ∀ ⦃a⦄, a ∈ s → ∀ ⦃b⦄, b ∈ s → r a b → r' a b) :
  directed_on r' s :=
λ x hx y hy, let ⟨z, hz, hxz, hyz⟩ := hs _ hx _ hy in ⟨z, hz, h hx hz hxz, h hy hz hyz⟩

lemma directed_on.mono {s : set α} (h : directed_on r s) (H : ∀ {a b}, r a b → r' a b) :
  directed_on r' s :=
h.mono' $ λ _ _ _ _, H

theorem directed_comp {ι} {f : ι → β} {g : β → α} :
  directed r (g ∘ f) ↔ directed (g ⁻¹'o r) f := iff.rfl

theorem directed.mono {s : α → α → Prop} {ι} {f : ι → α}
  (H : ∀ a b, r a b → s a b) (h : directed r f) : directed s f :=
λ a b, let ⟨c, h₁, h₂⟩ := h a b in ⟨c, H _ _ h₁, H _ _ h₂⟩

theorem directed.mono_comp {ι} {rb : β → β → Prop} {g : α → β} {f : ι → α}
  (hg : ∀ ⦃x y⦄, x ≼ y → rb (g x) (g y)) (hf : directed r f) :
  directed rb (g ∘ f) :=
directed_comp.2 $ hf.mono hg

/-- A monotone function on a sup-semilattice is directed. -/
lemma directed_of_sup [semilattice_sup α] {f : α → β} {r : β → β → Prop}
  (H : ∀ ⦃i j⦄, i ≤ j → r (f i) (f j)) : directed r f :=
λ a b, ⟨a ⊔ b, H le_sup_left, H le_sup_right⟩

lemma monotone.directed_le [semilattice_sup α] [preorder β] {f : α → β} :
  monotone f → directed (≤) f :=
directed_of_sup

lemma antitone.directed_ge [semilattice_sup α] [preorder β] {f : α → β} (hf : antitone f) :
  directed (≥) f :=
directed_of_sup hf

/-- A set stable by supremum is `≤`-directed. -/
lemma directed_on_of_sup_mem [semilattice_sup α] {S : set α}
  (H : ∀ ⦃i j⦄, i ∈ S → j ∈ S → i ⊔ j ∈ S) : directed_on (≤) S :=
λ a ha b hb, ⟨a ⊔ b, H ha hb, le_sup_left, le_sup_right⟩

lemma directed.extend_bot [preorder α] [order_bot α] {e : ι → β} {f : ι → α}
  (hf : directed (≤) f) (he : function.injective e) :
  directed (≤) (function.extend e f ⊥) :=
begin
  intros a b,
  rcases (em (∃ i, e i = a)).symm with ha | ⟨i, rfl⟩,
  { use b, simp [function.extend_apply' _ _ _ ha] },
  rcases (em (∃ i, e i = b)).symm with hb | ⟨j, rfl⟩,
  { use e i, simp [function.extend_apply' _ _ _ hb] },
  rcases hf i j with ⟨k, hi, hj⟩,
  use (e k),
  simp only [he.extend_apply, *, true_and]
end

/-- An antitone function on an inf-semilattice is directed. -/
lemma directed_of_inf [semilattice_inf α] {r : β → β → Prop} {f : α → β}
  (hf : ∀ a₁ a₂, a₁ ≤ a₂ → r (f a₂) (f a₁)) : directed r f :=
λ x y, ⟨x ⊓ y, hf _ _ inf_le_left, hf _ _ inf_le_right⟩

lemma monotone.directed_ge [semilattice_inf α] [preorder β] {f : α → β} (hf : monotone f) :
  directed (≥) f :=
directed_of_inf hf

lemma antitone.directed_le [semilattice_inf α] [preorder β] {f : α → β} (hf : antitone f) :
  directed (≤) f :=
directed_of_inf hf

/-- A set stable by infimum is `≥`-directed. -/
lemma directed_on_of_inf_mem [semilattice_inf α] {S : set α}
  (H : ∀ ⦃i j⦄, i ∈ S → j ∈ S → i ⊓ j ∈ S) : directed_on (≥) S :=
λ a ha b hb, ⟨a ⊓ b, H ha hb, inf_le_left, inf_le_right⟩

/-- `is_directed α r` states that for any elements `a`, `b` there exists an element `c` such that
`r a c` and `r b c`. -/
class is_directed (α : Type*) (r : α → α → Prop) : Prop :=
(directed (a b : α) : ∃ c, r a c ∧ r b c)

lemma directed_of (r : α → α → Prop) [is_directed α r] (a b : α) : ∃ c, r a c ∧ r b c :=
is_directed.directed _ _

lemma directed_id [is_directed α r] : directed r id := by convert directed_of r
lemma directed_id_iff : directed r id ↔ is_directed α r := ⟨λ h, ⟨h⟩, @directed_id _ _⟩

lemma directed_on_univ [is_directed α r] : directed_on r set.univ :=
λ a _ b _, let ⟨c, hc⟩ := directed_of r a b in ⟨c, trivial, hc⟩

lemma directed_on_univ_iff : directed_on r set.univ ↔ is_directed α r :=
⟨λ h, ⟨λ a b, let ⟨c, _, hc⟩ := h a trivial b trivial in ⟨c, hc⟩⟩, @directed_on_univ _ _⟩

@[priority 100]  -- see Note [lower instance priority]
instance is_total.to_is_directed [is_total α r] : is_directed α r :=
⟨λ a b, or.cases_on (total_of r a b) (λ h, ⟨b, h, refl _⟩) (λ h, ⟨a, refl _, h⟩)⟩

lemma is_directed_mono [is_directed α r] (h : ∀ ⦃a b⦄, r a b → s a b) : is_directed α s :=
⟨λ a b, let ⟨c, ha, hb⟩ := is_directed.directed a b in ⟨c, h ha, h hb⟩⟩

lemma exists_ge_ge [has_le α] [is_directed α (≤)] (a b : α) : ∃ c, a ≤ c ∧ b ≤ c :=
directed_of (≤) a b

lemma exists_le_le [has_le α] [is_directed α (≥)] (a b : α) : ∃ c, c ≤ a ∧ c ≤ b :=
directed_of (≥) a b

instance order_dual.is_directed_ge [has_le α] [is_directed α (≤)] : is_directed αᵒᵈ (≥) :=
by assumption

instance order_dual.is_directed_le [has_le α] [is_directed α (≥)] : is_directed αᵒᵈ (≤) :=
by assumption

section preorder
variables [preorder α] {a : α}

protected lemma is_min.is_bot [is_directed α (≥)] (h : is_min a) : is_bot a :=
λ b, let ⟨c, hca, hcb⟩ := exists_le_le a b in (h hca).trans hcb

protected lemma is_max.is_top [is_directed α (≤)] (h : is_max a) : is_top a :=
h.to_dual.is_bot

lemma directed_on.is_bot_of_is_min {s : set α} (hd : directed_on (≥) s)
  {m} (hm : m ∈ s) (hmin : ∀ a ∈ s, a ≤ m → m ≤ a) : ∀ a ∈ s, m ≤ a :=
λ a as, let ⟨x, xs, xm, xa⟩ := hd m hm a as in (hmin x xs xm).trans xa

lemma directed_on.is_top_of_is_max {s : set α} (hd : directed_on (≤) s)
  {m} (hm : m ∈ s) (hmax : ∀ a ∈ s, m ≤ a → a ≤ m) : ∀ a ∈ s, a ≤ m :=
@directed_on.is_bot_of_is_min αᵒᵈ _ s hd m hm hmax

lemma is_top_or_exists_gt [is_directed α (≤)] (a : α) : is_top a ∨ (∃ b, a < b) :=
(em (is_max a)).imp is_max.is_top not_is_max_iff.mp

lemma is_bot_or_exists_lt [is_directed α (≥)] (a : α) : is_bot a ∨ (∃ b, b < a) :=
@is_top_or_exists_gt αᵒᵈ _ _ a

lemma is_bot_iff_is_min [is_directed α (≥)] : is_bot a ↔ is_min a :=
⟨is_bot.is_min, is_min.is_bot⟩

lemma is_top_iff_is_max [is_directed α (≤)] : is_top a ↔ is_max a := ⟨is_top.is_max, is_max.is_top⟩

variables (β) [partial_order β]

theorem exists_lt_of_directed_ge [is_directed β (≥)] [nontrivial β] : ∃ a b : β, a < b :=
begin
  rcases exists_pair_ne β with ⟨a, b, hne⟩,
  rcases is_bot_or_exists_lt a with ha|⟨c, hc⟩,
  exacts [⟨a, b, (ha b).lt_of_ne hne⟩, ⟨_, _, hc⟩]
end

theorem exists_lt_of_directed_le [is_directed β (≤)] [nontrivial β] : ∃ a b : β, a < b :=
let ⟨a, b, h⟩ := exists_lt_of_directed_ge βᵒᵈ in ⟨b, a, h⟩

end preorder

@[priority 100]  -- see Note [lower instance priority]
instance semilattice_sup.to_is_directed_le [semilattice_sup α] : is_directed α (≤) :=
⟨λ a b, ⟨a ⊔ b, le_sup_left, le_sup_right⟩⟩

@[priority 100]  -- see Note [lower instance priority]
instance semilattice_inf.to_is_directed_ge [semilattice_inf α] : is_directed α (≥) :=
⟨λ a b, ⟨a ⊓ b, inf_le_left, inf_le_right⟩⟩

@[priority 100]  -- see Note [lower instance priority]
instance order_top.to_is_directed_le [has_le α] [order_top α] : is_directed α (≤) :=
⟨λ a b, ⟨⊤, le_top, le_top⟩⟩

@[priority 100]  -- see Note [lower instance priority]
instance order_bot.to_is_directed_ge [has_le α] [order_bot α] : is_directed α (≥) :=
⟨λ a b, ⟨⊥, bot_le, bot_le⟩⟩


/-
Copyright (c) 2021 Tianchen Zhao. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Tianchen Zhao
-/
import order.segment

/-!
# sidedness

This file defines sidedness (two points lie on the same side of a line, or same side of
a point) using `incidence_order_geometry.between` and apply them to prove some theorems
of betweenness.

## Main definitions

* `same_side_line` defines a relation that two points lie on the same side of a line,
`diff_side_line` meaning that they lie on different side of a line.

* `same_side_pt` defines, on a line, two points lie on the same side with respect to
a point, `diff_side_pt` meaning the opposite.

## References

* See [Geometry: Euclid and Beyond]

-/

open_locale classical
open set

variable [B : incidence_order_geometry]

open incidence_geometry incidence_order_geometry

include B

/--Two points `a` `b` are on the same side of a line if seg `a` `b`
doesn't intersects with the line.
-/
def same_side_line (l : set pts) (a b : pts) : Prop := ¬(l ♥ (a-ₛb).inside)

/--seg `a` `b` intersects with the line and not at `a` or `b`. -/
def diff_side_line (l : set pts) (a b : pts) : Prop :=
(l ♥ (a-ₛb).inside) ∧ a ∉ l ∧ b ∉ l

lemma plane_separation
{l : set pts} {a b : pts} (ha : a ∉ l) (hb : b ∉ l) :
(same_side_line l a b ∨ diff_side_line l a b) ∧ ¬(same_side_line l a b ∧ diff_side_line l a b) :=
begin
  unfold same_side_line diff_side_line, unfold two_pt_seg,
  split,
  { apply not_or_of_imp, intro h,
    exact ⟨h, ha, hb⟩ },
  { intro hf,
    exact hf.1 hf.2.1 }
end

lemma not_same_side_line {l : set pts} {a b : pts} (ha : a ∉ l) (hb : b ∉ l) :
¬(same_side_line l a b) ↔ (diff_side_line l a b) :=
begin
  split,
  { intro hns,
    cases (plane_separation ha hb).1 with hs hd,
    exact absurd hs hns, exact hd },
  { intros hd hs,
    exact absurd (by exact ⟨hs, hd⟩) (plane_separation ha hb).2 }
end

lemma not_diff_side_line {l : set pts} {a b : pts} (ha : a ∉ l) (hb : b ∉ l) :
¬(diff_side_line l a b) ↔ (same_side_line l a b) :=
by rw [←not_iff_not.mpr (not_same_side_line ha hb), not_not]

lemma same_side_line_refl {l : set pts} {a : pts} (ha : a ∉ l) : same_side_line l a a :=
begin
  unfold same_side_line intersect,
  rw seg_singleton, rw not_nonempty_iff_eq_empty, ext1, simp,
  intros h hxa, rw hxa at h, exact ha h
end

lemma same_side_line_symm {l : set pts} {a b : pts} :
same_side_line l a b → same_side_line l b a :=
by {unfold same_side_line, rw seg_symm, simp}

lemma diff_side_line_symm {l : set pts} {a b : pts} :
diff_side_line l a b → diff_side_line l b a :=
by {unfold diff_side_line, rw seg_symm, tauto}

lemma same_side_line_notin {x y : pts} {l : set pts} :
same_side_line l x y → x ∉ l ∧ y ∉ l :=
begin
  intro hlxy, unfold same_side_line intersect at hlxy, rw not_nonempty_iff_eq_empty at hlxy,
  split,
  { intro hxl,
    have : x ∈ l ∩ (x-ₛy).inside,
      simp, exact ⟨hxl, by {unfold two_pt_seg, simp}⟩,
    rw hlxy at this, exact this },
  { intro hyl,
    have : y ∈ l ∩ (x-ₛy).inside,
    { simp, exact ⟨hyl, by {unfold two_pt_seg, simp}⟩ },
    rw hlxy at this, exact this }
end

lemma same_side_line_neq {a b x y : pts} :
same_side_line (a-ₗb) x y → x ≠ a ∧ x ≠ b :=
begin
  intro hxy,
  split; intro hf; rw hf at hxy,
  exact (same_side_line_notin hxy).1 (pt_left_in_line a b),
  exact (same_side_line_notin hxy).1 (pt_right_in_line a b)
end

lemma same_side_line_neq' {a b x y : pts} :
same_side_line (a-ₗb) x y → y ≠ a ∧ y ≠ b :=
λhxy, same_side_line_neq (same_side_line_symm hxy)

lemma same_side_line_noncol {a b c d : pts} :
same_side_line (a-ₗb) c d → a ≠ b → noncol a b c ∧ noncol a b d :=
begin
  intros hcd hab,
  split; intro h,
  exact (same_side_line_notin hcd).1 (col_in12 h hab),
  exact (same_side_line_notin hcd).2 (col_in12 h hab)
end

lemma diff_side_line_neq {a b x y : pts} :
diff_side_line (a-ₗb) x y → x ≠ a ∧ x ≠ b :=
begin
  intro hxy,
  split; intro hf;
  rw hf at hxy,
  exact hxy.2.1 (pt_left_in_line a b),
  exact hxy.2.1 (pt_right_in_line a b)
end

lemma diff_side_line_neq' {a b x y : pts} :
diff_side_line (a-ₗb) x y → y ≠ a ∧ y ≠ b :=
λhxy, diff_side_line_neq (diff_side_line_symm hxy)

lemma diff_side_line_neq'' {a b : pts} {l : set pts}
(hlab : diff_side_line l a b) : a ≠ b :=
begin
  have hal := hlab.2.1,
  intro hab, rw ←hab at hlab,
  rw ←not_same_side_line at hlab,
  exact hlab (same_side_line_refl hal),
  exact hal, exact hal
end

lemma diff_side_line_noncol {a b c d : pts} :
diff_side_line (a-ₗb) c d → a ≠ b → noncol a b c ∧ noncol a b d :=
λhcd hab, ⟨noncol_in12' hab hcd.2.1, noncol_in12' hab hcd.2.2⟩

private lemma same_side_line_trans_noncol {l : set pts} (hl : l ∈ lines) {a b c : pts} :
noncol a b c → same_side_line l a b → same_side_line l b c → same_side_line l a c :=
begin
  unfold same_side_line, intros h hlab hlbc,
  rw seg_symm at hlbc, intro hlac,
  cases (pasch (noncol23 h) hl (same_side_line_notin hlab).1 (same_side_line_notin hlbc).1
    (same_side_line_notin hlab).2 hlac).1 with hf hf,
  exact hlab hf, exact hlbc hf
end

lemma same_side_line_trans {l : set pts} (hl : l ∈ lines) {a b c : pts} :
same_side_line l a b → same_side_line l b c → same_side_line l a c :=
begin
  by_cases col a b c; intros hlab hlbc,
    by_cases hab : a = b,
      rw ←hab at hlbc, exact hlbc,
    by_cases hbc : b = c,
      rw hbc at hlab, exact hlab,
    by_cases hac : a = c,
      rw hac, exact same_side_line_refl (same_side_line_notin hlbc).2,
    rcases h with ⟨m, hm, ham, hbm, hcm⟩,
    have hd : ∃ d : pts, d ∈ l ∧ d ∉ m,
      rcases two_pt_on_one_line hl with ⟨x, y, hxy, hxl, hyl⟩,
      have hlm : l ≠ m, intro hlm, rw ←hlm at ham, exact (same_side_line_notin hlab).1 ham,
      by_contra, push_neg at h,
      exact hxy (two_line_one_pt hl hm hlm hxl (h x hxl) hyl (h y hyl)),
    rcases hd with ⟨d, hdl, hdm⟩,
    have habd : noncol a b d,
      apply noncol_in12' hab,
      rw two_pt_one_line (line_in_lines hab) hm hab
        (pt_left_in_line a b) (pt_right_in_line a b) ham hbm,
      exact hdm,
    have had := (noncol_neq habd).2.1,
    cases between_extend had.symm with e hdae,
    have hae := (between_neq hdae).2.2,
    have hlae : same_side_line l a e,
      intro hlae, cases hlae with f hf,
      simp at hf,
      have hflae : f ∈ l ∧ f ∈ (a-ₗe),
        from ⟨hf.1, seg_in_line a e hf.2⟩,
      have hdlae : d ∈ l ∧ d ∈ (a-ₗe),
        from ⟨hdl, col_in23 (between_col hdae) hae⟩,
      have hneq : l ≠ (a-ₗe),
        intro hf, have := (same_side_line_notin hlab).1,
        rw hf at this, exact this (pt_left_in_line a e),
      have hdf := two_line_one_pt hl (line_in_lines (between_neq hdae).2.2)
        hneq hdlae.1 hdlae.2 hflae.1 hflae.2,
      rw hdf at hdae,
      unfold two_pt_seg at hf, simp at hf,
      have := between_neq hdae,
      rcases hf.2 with hf | hf | hf,
      exact this.1 hf, exact this.2.1 hf,
      exact between_contra.1 ⟨hf, hdae⟩,
    have hbae := noncol132 (col_noncol (col12 (between_col hdae)) (noncol23 habd) hae),
    have hebc := noncol132 (col_noncol ⟨m, hm, hbm, ham, hcm⟩ hbae hbc),
    have haec := noncol23 (col_noncol ⟨m, hm, ham, hbm, hcm⟩ (noncol12 hbae) hac),
    have hlbe := same_side_line_trans_noncol hl hbae (same_side_line_symm hlab) hlae,
    have hlec := same_side_line_trans_noncol hl hebc (same_side_line_symm hlbe) hlbc,
    exact same_side_line_trans_noncol hl haec hlae hlec,
  exact same_side_line_trans_noncol hl h hlab hlbc
end

/--Two points `a` `b` are on the same side of the point `o` if
they are col and `o` is not in seg `a` `b`.
-/
def same_side_pt (o a b : pts) : Prop :=
o ∉ (a-ₛb).inside ∧ col o a b

/--`o` is in seg `a` `b` but is not `a` and `b`. -/
def diff_side_pt (o a b : pts) : Prop :=
o ∈ (a-ₛb).inside ∧ a ≠ o ∧ b ≠ o

lemma same_side_pt_neq {o a b : pts} (hoab : same_side_pt o a b) : a ≠ o ∧ b ≠ o :=
begin
  unfold same_side_pt at hoab, unfold two_pt_seg at hoab,
  split,
  intro hao, rw hao at hoab,
  simp at hoab, exact hoab,
  intro hbo, rw hbo at hoab,
  simp at hoab, exact hoab
end

lemma diff_side_pt_col {o a b : pts} : diff_side_pt o a b → col o a b :=
begin
  intro hoab,
  by_cases a = b,
    rw h, exact ⟨(b-ₗo), line_in_lines hoab.2.2,
      pt_right_in_line b o, pt_left_in_line b o, pt_left_in_line b o⟩,
  exact ⟨(a-ₗb), line_in_lines h,
    (seg_in_line a b) hoab.1, pt_left_in_line a b, pt_right_in_line a b⟩
end

theorem line_separation
{p a b : pts} (hpab : col p a b) (hap : a ≠ p) (hbp : b ≠ p) :
(same_side_pt p a b ∨ diff_side_pt p a b) ∧
¬(same_side_pt p a b ∧ diff_side_pt p a b) :=
begin
  unfold same_side_pt diff_side_pt,
  split,
  { by_cases hp : p ∈ (a-ₛb).inside,
    right, exact ⟨hp, hap, hbp⟩,
    left, exact ⟨hp, hpab⟩ },
  { push_neg,
    intros h₁ h₂, exact absurd h₂ h₁.1 }
end

lemma not_same_side_pt
{p a b : pts} (hpab : col p a b) (ha : a ≠ p) (hb : b ≠ p) :
(¬same_side_pt p a b ↔ diff_side_pt p a b) :=
begin
  have := line_separation hpab ha hb,
  split,
  intro hs,
  cases this.1 with h h,
  exact absurd h hs, exact h,
  intro hd,
  cases (not_and_distrib.mp this.2) with h h,
  exact h, exact absurd hd h
end

lemma not_diff_side_pt
{p a b : pts} (hpab : col p a b) (ha : a ≠ p) (hb : b ≠ p) :
(¬diff_side_pt p a b ↔ same_side_pt p a b) :=
by rw [←not_iff_not.mpr (not_same_side_pt hpab ha hb), not_not]

lemma same_side_pt_refl {a b : pts} (hab : a ≠ b) : same_side_pt a b b :=
begin
  split, rw seg_singleton, exact hab,
  exact ⟨a-ₗb, line_in_lines hab, pt_left_in_line a b, pt_right_in_line a b, pt_right_in_line a b⟩
end

lemma same_side_pt_symm {a b c : pts} :
same_side_pt a b c → same_side_pt a c b :=
begin
  unfold same_side_pt,
  intro habc, split,
  rw seg_symm, exact habc.1,
  rcases habc.2 with ⟨l, hl, hal, hbl, hcl⟩,
  exact ⟨l, hl, hal, hcl, hbl⟩
end

lemma diff_side_pt_symm {a b c : pts} :
diff_side_pt a b c → diff_side_pt a c b :=
by { unfold diff_side_pt, rw seg_symm, tauto }

lemma same_side_pt_line {a b c : pts} (habc : same_side_pt a b c) {l : set pts}
(hl : l ∈ lines) (hal : a ∈ l) (hbl : b ∉ l) (hcl : c ∉ l) : same_side_line l b c :=
begin
  by_cases hbc : b = c,
    rw ←hbc, exact same_side_line_refl hbl,
  rintros ⟨x, hxl, hxbc⟩,
  apply habc.1,
  have hneq : l ≠ (b-ₗc),
    intro hf, rw hf at hbl, exact hbl (pt_left_in_line b c),
  rw two_line_one_pt hl (line_in_lines hbc) hneq
    hal (col_in23 habc.2 hbc) hxl ((seg_in_line b c) hxbc),
  exact hxbc
end

lemma between_diff_side_pt {a b c : pts} :
between a b c ↔ diff_side_pt b a c :=
begin
  split,
  exact λh, ⟨by {left, exact h}, (between_neq h).1, (between_neq h).2.2.symm⟩,
  { intro h,
    rcases h.1 with h | hf | hf,
    exact h,
    exact absurd hf h.2.1.symm,
    exact absurd hf h.2.2.symm }
end

lemma diff_side_pt_neq' {a b c : pts} (habc : diff_side_pt a b c) : b ≠ c :=
by { rw ←between_diff_side_pt at habc, exact (between_neq habc).2.1 }

lemma diff_side_pt_line {a b c : pts} (habc : diff_side_pt a b c) {l : set pts}
(hl : l ∈ lines) (hal : a ∈ l) (hbl : b ∉ l) (hcl : c ∉ l) : diff_side_line l b c :=
⟨⟨a, hal, by {left, exact between_diff_side_pt.2 habc}⟩, hbl, hcl⟩

private lemma between_same_side_pt_prep {a b c : pts} :
between a b c → same_side_pt a b c :=
begin
  intro habc,
  have hab := (between_neq habc).1,
  have hac := (between_neq habc).2.1,
  split,
  { intro hf, replace hf := seg_in_neq hab hac hf,
    exact between_contra.1 ⟨habc, hf⟩ },
  exact between_col habc
end

lemma between_same_side_pt {a b c : pts} :
between a b c ↔ same_side_pt a b c ∧ same_side_pt c a b :=
begin
  split,
  { intro habc, split,
    exact between_same_side_pt_prep habc,
    rw between_symm at habc,
    exact same_side_pt_symm (between_same_side_pt_prep habc) },
  { rintros ⟨habc, hcab⟩,
    have hab := (same_side_pt_neq habc).1.symm,
    have hac := (same_side_pt_neq habc).2.symm,
    have hbc := (same_side_pt_neq hcab).2,
    rcases between_tri habc.2 hab hac hbc with h | h | h,
    exact h,
    exfalso, apply hcab.1, left, exact h,
    exfalso, apply habc.1, left, exact h }
end

lemma same_side_line_pt {a b c : pts} (habc : col a b c) (l : set pts)
(hl : l ∈ lines) (hal : a ∈ l) (hbl : b ∉ l) (hcl : c ∉ l) (hlbc : same_side_line l b c) :
same_side_pt a b c :=
begin
  have hba : b ≠ a,
    intro hf, rw hf at hbl, exact hbl hal,
  have hca : c ≠ a,
    intro hf, rw hf at hcl, exact hcl hal,
  rw ←(not_diff_side_pt habc hba hca),
  intro hf,
  have := (diff_side_pt_line hf) hl hal hbl hcl,
  exact (plane_separation hbl hcl).2 ⟨hlbc, this⟩
end

lemma diff_side_line_pt {a b c : pts} (habc : col a b c) (l : set pts)
(hl : l ∈ lines) (hal : a ∈ l) (hbl : b ∉ l) (hcl : c ∉ l) (hlbc : diff_side_line l b c) :
diff_side_pt a b c :=
begin
  have hba : b ≠ a,
    intro hf, rw hf at hbl, exact hbl hal,
  have hca : c ≠ a,
    intro hf, rw hf at hcl, exact hcl hal,
  rw ←not_same_side_pt habc hba hca,
  intro hf,
  have := same_side_pt_line hf hl hal hbl hcl,
  exact (plane_separation hbl hcl).2 ⟨this, hlbc⟩
end

lemma line_pt_exist {a b c : pts} (habc : col a b c) (hab : a ≠ b) (hac : a ≠ c) :
∃ l ∈ lines, a ∈ l ∧ b ∉ l ∧ c ∉ l :=
begin
  rcases habc with ⟨l, hl, hal, hbl, hcl⟩,
  have hd : ∃ d : pts, noncol a b d ∧ d ∉ l,
    cases noncol_exist hab with d habd, use d, split, exact habd,
    intro hdl, exact habd ⟨l, hl, hal, hbl, hdl⟩,
  rcases hd with ⟨d, habd, hdl⟩,
  have hb : b ∉ (a-ₗd),
    intro hb, exact habd ⟨(a-ₗd), line_in_lines (noncol_neq habd).2.1,
      pt_left_in_line a d, hb, pt_right_in_line a d⟩,
  have hc : c ∉ (a-ₗd),
    intro hc, rw two_pt_one_line hl (line_in_lines (noncol_neq habd).2.1)
      hac hal hcl (pt_left_in_line a d) hc at hbl,
    exact hb hbl,
  exact ⟨(a-ₗd), line_in_lines (noncol_neq habd).2.1, pt_left_in_line a d, hb, hc⟩
end

lemma same_side_pt_trans {a b c d : pts} :
same_side_pt a b c → same_side_pt a c d → same_side_pt a b d :=
begin
  intros habc hacd,
  have hac := (same_side_pt_neq habc).2.symm,
  rcases line_pt_exist habc.2 (same_side_pt_neq habc).1.symm hac
    with ⟨l, hl, hal, hbl, hcl⟩,
  have hdl : d ∉ l,
    intro hdl,
    rcases hacd.2 with ⟨m, hm, ham, hcm, hdm⟩,
    rw two_pt_one_line hm hl (same_side_pt_neq hacd).2.symm ham hdm hal hdl at hcm,
    exact hcl hcm,
  apply same_side_line_pt,
  exact col_trans (col23 habc.2) hacd.2 hac,
  exact hl, exact hal, exact hbl,
  exact hdl,
  exact same_side_line_trans hl (same_side_pt_line habc hl hal hbl hcl)
    (same_side_pt_line hacd hl hal hcl hdl)
end

lemma between_same_side_pt' {a b c d : pts} (habc : between a b c)
(hbcd : same_side_pt b c d) : between a b d :=
begin
  have hbc := (between_neq habc).2.2,
  rw [between_diff_side_pt, ←not_same_side_pt],
  { intro hf, rw [between_diff_side_pt, ←not_same_side_pt] at habc,
    exact habc (same_side_pt_trans hf (same_side_pt_symm hbcd)),
    exact (diff_side_pt_col habc),
    exact habc.2.1, exact habc.2.2 },
  exact col_trans (col123 (between_col habc)) hbcd.2 hbc,
  exact (between_neq habc).1,
  exact (same_side_pt_neq hbcd).2
end

lemma between_trans {a b c d : pts} :
between a b c → between b c d → between a b d ∧ between a c d :=
begin
  have : ∀ {a b c d : pts}, between a b c → between b c d → between a b d ,
    intros a b c d habc hbcd,
    have hab := (between_neq habc).1,
    have hbc := (between_neq habc).2.2,
    have hbd := (between_neq hbcd).2.1,
    rw [between_diff_side_pt, ←not_same_side_pt],
    { intro hf,
      have habc' := between_col habc,
      rw [between_diff_side_pt, ←not_same_side_pt] at habc,
      apply habc,
      exact (same_side_pt_trans hf (same_side_pt_symm (between_same_side_pt.1 hbcd).1)),
      exact col12 habc', exact hab, exact hbc.symm },
    exact col_trans (col123 (between_col habc)) (between_col hbcd) hbc,
    exact hab, exact hbd.symm,
  intros habc hbcd, split, exact this habc hbcd,
  rw between_symm at habc hbcd, rw between_symm,
  exact this hbcd habc
end

lemma between_trans' {a b c d : pts} :
between a b d → between b c d → between a b c ∧ between a c d :=
begin
  have : ∀ {a b c d : pts}, between a b d → between b c d → between a b c,
    intros a b c d habd hbcd,
    have hab := (between_neq habd).1,
    have hbc := (between_neq hbcd).1,
    have hbd := (between_neq hbcd).2.1,
    rw [between_diff_side_pt, ←not_same_side_pt],
    { intro hf,
      have habd' := between_col habd,
      rw [between_diff_side_pt, ←not_same_side_pt] at habd,
      apply habd,
      exact (same_side_pt_trans hf (between_same_side_pt.1 hbcd).1),
      exact col12 habd', exact hab, exact hbd.symm },
    exact col_trans (col123 (between_col habd)) (col23 (between_col hbcd)) hbd,
    exact hab, exact hbc.symm,
  intros habd hbcd,
  have habc := this habd hbcd,
  exact ⟨habc, (between_trans habc hbcd).2⟩
end

lemma same_side_pt_between {a b c : pts} :
same_side_pt a b c → b ≠ c → between a b c ∨ between a c b :=
begin
  intros habc hbc,
  rcases between_tri habc.2 (same_side_pt_neq habc).1.symm
    (same_side_pt_neq habc).2.symm hbc with h | h | h,
  left, exact h,
  right, exact h,
  { rw [between_diff_side_pt, ←not_same_side_pt habc.2] at h, exact absurd habc h,
    exact (same_side_pt_neq habc).1,
    exact (same_side_pt_neq habc).2 }
end

lemma between_same_side_pt_between {a b c d : pts} :
between a b c → same_side_pt b c d → between a b d :=
begin
  intros habc hbcd,
  by_cases hcd : c = d,
    rw hcd at habc, exact habc,
  cases same_side_pt_between hbcd hcd,
  exact (between_trans habc h).1,
  exact (between_trans' habc h).1
end

lemma diff_side_pt_cancel {a b c d : pts} :
diff_side_pt a b c → diff_side_pt a b d → same_side_pt a c d :=
begin
  intros hbac hbad,
  have hab := hbac.2.1.symm,
  have hac := hbac.2.2.symm,
  have hbc := diff_side_pt_neq' hbac,
  have hbd := diff_side_pt_neq' hbad,
  by_cases hcd : c = d,
    rw ←hcd, exact same_side_pt_refl hac,
  rw ←between_diff_side_pt at hbac hbad,
  rw [←not_diff_side_pt, ←between_diff_side_pt],
  { intro hcad,
    have hbcd := col_trans (between_col hbac) (between_col hbad) hab.symm,
    rcases between_tri hbcd hbc hbd hcd with hbcd | hbdc | hcbd,
    exact between_contra.2.1 ⟨(between_trans' hbcd hcad).1, hbac⟩,
    { rw between_symm at hcad,
      exact between_contra.2.1 ⟨(between_trans' hbdc hcad).1, hbad⟩ },
    { rw between_symm at hbac,
      exact between_contra.2.1 ⟨(between_trans' hcbd hbad).1, hbac⟩ } },
  exact col_trans (col12 (between_col hbac)) (col12 (between_col hbad)) hab,
  exact (between_neq hbac).2.2.symm,
  exact (between_neq hbad).2.2.symm,
end

lemma diff_side_line_cancel {l : set pts} (hl : l ∈ lines) {a b c : pts} :
diff_side_line l a b → diff_side_line l b c → same_side_line l a c :=
begin
  intros h₁ h₂,
  have hab : a ≠ b,
    have hal := h₁.2.1,
    intro hf, rw [←hf, ←not_same_side_line] at h₁,
    exact h₁ (same_side_line_refl hal), exact hal, exact hal,
  by_cases hac : a = c,
    rw ←hac, exact same_side_line_refl h₁.2.1,
  have hbc : b ≠ c,
    have hbl := h₁.2.2,
    intro hf, rw [←hf, ←not_same_side_line] at h₂,
    exact h₂ (same_side_line_refl hbl), exact hbl, exact hbl,
  by_cases habc : col a b c,
  { cases h₁.1 with x hx,
    cases h₂.1 with y hy,
    have hxa : x ≠ a,
      intro hf, rw hf at hx, exact h₁.2.1 hx.1,
    have hxb : x ≠ b,
      intro hf, rw hf at hx, exact h₁.2.2 hx.1,
    have haxb := seg_in_neq hxa hxb hx.2,
    have hyb : y ≠ b,
      intro hf, rw hf at hy, exact h₁.2.2 hy.1,
    have hyc : y ≠ c,
      intro hf, rw hf at hy, exact h₂.2.2 hy.1,
    have hbyc := seg_in_neq hyb hyc hy.2,
    have hxy : x = y,
      apply two_line_one_pt hl (line_in_lines hab),
      intro hf, rw hf at h₁, exact h₁.2.2 (pt_right_in_line a b),
      exact hx.1, exact (seg_in_line a b) hx.2,
      exact hy.1, exact col_in21 (col_trans (col123 habc) (col23 (between_col hbyc)) hbc) hab,
    rw ←hxy at hbyc,
    apply same_side_pt_line,
    exact diff_side_pt_cancel (diff_side_pt_symm (between_diff_side_pt.1 haxb))
      (between_diff_side_pt.1 hbyc),
    exact hl, exact hx.1,
    exact h₁.2.1, exact h₂.2.2 },
  by_contra h₃,
  rw not_same_side_line h₁.2.1 h₂.2.2 at h₃,
  unfold diff_side_line at h₁ h₂ h₃,
  exact (pasch habc hl h₁.2.1 h₁.2.2 h₂.2.2 h₁.1).2 ⟨h₃.1, h₂.1⟩
end

lemma diff_same_side_line {l : set pts} (hl : l ∈ lines) {a b c : pts} :
diff_side_line l a b → same_side_line l b c → diff_side_line l a c :=
begin
  intros hlab hlbc,
  rw ←not_same_side_line hlab.2.1 (same_side_line_notin hlbc).2,
  rw ←not_same_side_line at hlab, intro hlac,
  exact hlab (same_side_line_trans hl hlac (same_side_line_symm hlbc)),
  exact hlab.2.1, exact hlab.2.2
end

lemma same_diff_side_line {l : set pts} (hl : l ∈ lines) {a b c : pts} :
same_side_line l a b → diff_side_line l b c → diff_side_line l a c := λhlab hlbc,
diff_side_line_symm (diff_same_side_line hl (diff_side_line_symm hlbc) (same_side_line_symm hlab))

lemma diff_same_side_pt {a b c d : pts} :
diff_side_pt a b c → same_side_pt a b d → diff_side_pt a c d :=
begin
  intros habc habd,
  rw ←not_same_side_pt, rw ←not_same_side_pt at habc,
  intro hacd, exact habc (same_side_pt_trans habd (same_side_pt_symm hacd)),
  exact (diff_side_pt_col habc), exact habc.2.1, exact habc.2.2,
  exact col_trans (diff_side_pt_col habc) habd.2 habc.2.1.symm,
  exact habc.2.2, exact (same_side_pt_neq habd).2
end

private lemma two_pt_seg_pt_prep {a b a' b' : pts} :
(a-ₛb) = (a'-ₛb') → a = a' → b = b' :=
begin
  intros haba'b' haa',
  replace haba'b' : (a-ₛb).inside = (a-ₛb').inside, rw [haba'b', ←haa'],
  by_contra hbb',
  by_cases hab : a = b, rw hab at haba'b',
  { rw seg_singleton at haba'b',
    cases (two_pt_between hbb') with x hbxb',
    have hx : x ∈ (b-ₛb').inside,
      unfold two_pt_seg, simp, right, right, exact hbxb',
    rw ←haba'b' at hx, simp at hx, exact (between_neq hbxb').1 hx.symm },
  by_cases hab' : a = b', rw hab' at haba'b',
  { rw seg_singleton at haba'b',
    cases (two_pt_between hbb') with x hbxb',
    have hx : x ∈ (b-ₛb').inside,
      unfold two_pt_seg, simp, right, right, exact hbxb',
    rw [seg_symm, haba'b'] at hx, simp at hx, exact (between_neq hbxb').2.2 hx },
  by_cases habb' : col a b b',
  { rcases between_tri habb' hab hab' hbb' with h | h | h,
    cases (two_pt_between (between_neq h).2.2) with x hbxb',
    have haxb' := (between_trans' h hbxb').2,
    have h₁ : x ∈ (a-ₛb').inside,
      unfold two_pt_seg, simp, right, right, exact haxb',
    have h₂ : x ∉ (a-ₛb).inside,
      unfold two_pt_seg, simp, intro hf,
      rcases hf with hf | hf | hf,
      exact (between_neq (between_trans' h hbxb').2).1 hf.symm,
      exact (between_neq hbxb').1 hf.symm,
      have habx := (between_trans' h hbxb').1,
      exact between_contra.2.1 ⟨hf, habx⟩,
    rw haba'b' at h₂, exact absurd h₁ h₂,
    cases (two_pt_between (between_neq h).2.2) with x hb'xb,
    have haxb := (between_trans' h hb'xb).2,
    have h₁ : x ∈ (a-ₛb).inside,
      unfold two_pt_seg, simp, right, right, exact haxb,
    have h₂ : x ∉ (a-ₛb').inside,
      unfold two_pt_seg, simp, intro hf,
      rcases hf with hf | hf | hf,
      exact (between_neq (between_trans' h hb'xb).2).1 hf.symm,
      exact (between_neq hb'xb).1 hf.symm,
      have hab'x := (between_trans' h hb'xb).1,
      exact between_contra.2.1 ⟨hf, hab'x⟩,
    rw haba'b' at h₁, exact absurd h₁ h₂,
    cases (two_pt_between hab) with x haxb,
    have h₁ : x ∈ (a-ₛb).inside,
      unfold two_pt_seg, simp, right, right, exact haxb,
    have h₂ : x ∉ (a-ₛb').inside,
      unfold two_pt_seg, simp, intro hf,
      rw between_symm at h,
      rcases hf with hf | hf | hf,
      exact (between_neq haxb).1 hf.symm,
      exact (between_neq (between_trans' h haxb).2).1 hf.symm,
      have hb'ax := (between_trans' h haxb).1,
      rw between_symm at hf,
      exact between_contra.2.1 ⟨hf, hb'ax⟩,
      rw haba'b' at h₁, exact absurd h₁ h₂ },
  cases (two_pt_between hab) with x haxb,
  have h : x ∈ (a-ₛb').inside,
    rw ←haba'b', unfold two_pt_seg, simp, right, right, exact haxb,
  unfold two_pt_seg at h, simp at h, rcases h with h | h | h,
  exact absurd h (between_neq haxb).1.symm,
  rw h at haxb, exact habb' (col23 (between_col haxb)),
  exact habb' (col_trans (between_col haxb) (between_col h) (between_neq haxb).1)
end

lemma two_pt_seg_pt {a b a' b' : B.pts} :
(a-ₛb) = (a'-ₛb') → (a = a' ∧ b = b') ∨ (a = b' ∧ b = a') :=
begin
  intros haba'b',
  by_cases haa' : a = a',
    left, exact ⟨haa', two_pt_seg_pt_prep haba'b' haa'⟩,
  by_cases hab' : a = b',
    right, rw seg_symm a' b' at haba'b', exact ⟨hab', two_pt_seg_pt_prep haba'b' hab'⟩,
  have ha'ab' := (seg_in_neq haa' hab' (by {rw ←haba'b', exact pt_left_in_seg a b })),
  by_cases ha'b : a' = b,
    right, rw seg_symm at haba'b', exact ⟨two_pt_seg_pt_prep haba'b' ha'b.symm, ha'b.symm⟩,
  have haa'b := (seg_in_neq (ne.symm haa') ha'b (by {rw haba'b', exact pt_left_in_seg a' b' })),
  by_cases hbb' : b = b',
  { rw [seg_symm, seg_symm a' b'] at haba'b',
    left, exact ⟨two_pt_seg_pt_prep haba'b' hbb', hbb'⟩ },
  have ha'bb' := (seg_in_neq (ne.symm ha'b) hbb' (by {rw ←haba'b', exact pt_right_in_seg a b })),
  rw between_symm at ha'ab',
  have hb'a'b := (between_trans ha'ab' haa'b).2,
  rw between_symm at ha'bb',
  exfalso, exact between_contra.2.1 ⟨hb'a'b, ha'bb'⟩
end


/-
Copyright (c) 2022 Jujian Zhang. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jujian Zhang

! This file was ported from Lean 3 source module group_theory.divisible
! leanprover-community/mathlib commit 0a0ec35061ed9960bf0e7ffb0335f44447b58977
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.GroupTheory.Subgroup.Pointwise
import Mathlib.GroupTheory.QuotientGroup
import Mathlib.Algebra.Group.Pi

/-!
# Divisible Group and rootable group

In this file, we define a divisible add monoid and a rootable monoid with some basic properties.

## Main definition

* `DivisibleBy A α`: An additive monoid `A` is said to be divisible by `α` iff for all `n ≠ 0 ∈ α`
  and `y ∈ A`, there is an `x ∈ A` such that `n • x = y`. In this file, we adopt a constructive
  approach, i.e. we ask for an explicit `div : A → α → A` function such that `div a 0 = 0` and
  `n • div a n = a` for all `n ≠ 0 ∈ α`.
* `RootableBy A α`: A monoid `A` is said to be rootable by `α` iff for all `n ≠ 0 ∈ α` and `y ∈ A`,
  there is an `x ∈ A` such that `x^n = y`. In this file, we adopt a constructive approach, i.e. we
  ask for an explicit `root : A → α → A` function such that `root a 0 = 1` and `(root a n)ⁿ = a` for
  all `n ≠ 0 ∈ α`.

## Main results

For additive monoids and groups:

* `divisibleByOfSMulRightSurj` : the constructive definition of divisiblity is implied by
  the condition that `n • x = a` has solutions for all `n ≠ 0` and `a ∈ A`.
* `smul_right_surj_of_divisibleBy` : the constructive definition of divisiblity implies
  the condition that `n • x = a` has solutions for all `n ≠ 0` and `a ∈ A`.
* `Prod.divisibleBy` : `A × B` is divisible for any two divisible additive monoids.
* `Pi.divisibleBy` : any product of divisble additive monoids is divisible.
* `AddGroup.divisibleByIntOfDivisibleByNat` : for additive groups, int divisiblity is implied
  by nat divisiblity.
* `AddGroup.divisibleByNatOfDivisibleByInt` : for additive groups, nat divisiblity is implied
  by int divisiblity.
* `AddCommGroup.divisibleByIntOfSmulTopEqTop`: the constructive definition of divisiblity
  is implied by the condition that `n • A = A` for all `n ≠ 0`.
* `AddCommGroup.smul_top_eq_top_of_divisibleBy_int`: the constructive definition of divisiblity
  implies the condition that `n • A = A` for all `n ≠ 0`.
* `divisibleByIntOfCharZero` : any field of characteristic zero is divisible.
* `QuotientAddGroup.divisibleBy` : quotient group of divisible group is divisible.
* `Function.Surjective.divisibleBy` : if `A` is divisible and `A →+ B` is surjective, then `B`
  is divisible.

and their multiplicative counterparts:

* `rootableByOfPowLeftSurj` : the constructive definition of rootablity is implied by the
  condition that `xⁿ = y` has solutions for all `n ≠ 0` and `a ∈ A`.
* `pow_left_surj_of_rootableBy` : the constructive definition of rootablity implies the
  condition that `xⁿ = y` has solutions for all `n ≠ 0` and `a ∈ A`.
* `Prod.rootableBy` : any product of two rootable monoids is rootable.
* `Pi.rootableBy` : any product of rootable monoids is rootable.
* `Group.rootableByIntOfRootableByNat` : in groups, int rootablity is implied by nat
  rootablity.
* `Group.rootableByNatOfRootableByInt` : in groups, nat rootablity is implied by int
  rootablity.
* `QuotientGroup.rootableBy` : quotient group of rootable group is rootable.
* `Function.Surjective.rootableBy` : if `A` is rootable and `A →* B` is surjective, then `B` is
  rootable.

TODO: Show that divisibility implies injectivity in the category of `AddCommGroup`.
-/

open Pointwise

section AddMonoid

variable (A α : Type _) [AddMonoid A] [SMul α A] [Zero α]

/--
An `AddMonoid A` is `α`-divisible iff `n • x = a` has a solution for all `n ≠ 0 ∈ α` and `a ∈ A`.
Here we adopt a constructive approach where we ask an explicit `div : A → α → A` function such that
* `div a 0 = 0` for all `a ∈ A`
* `n • div a n = a` for all `n ≠ 0 ∈ α` and `a ∈ A`.
-/
class DivisibleBy where
  div : A → α → A
  div_zero : ∀ a, div a 0 = 0
  div_cancel : ∀ {n : α} (a : A), n ≠ 0 → n • div a n = a
#align divisible_by DivisibleBy

end AddMonoid

section Monoid

variable (A α : Type _) [Monoid A] [Pow A α] [Zero α]

/-- A `Monoid A` is `α`-rootable iff `xⁿ = a` has a solution for all `n ≠ 0 ∈ α` and `a ∈ A`.
Here we adopt a constructive approach where we ask an explicit `root : A → α → A` function such that
* `root a 0 = 1` for all `a ∈ A`
* `(root a n)ⁿ = a` for all `n ≠ 0 ∈ α` and `a ∈ A`.
-/
@[to_additive]
class RootableBy where
  root : A → α → A
  root_zero : ∀ a, root a 0 = 1
  root_cancel : ∀ {n : α} (a : A), n ≠ 0 → root a n ^ n = a
#align rootable_by RootableBy

@[to_additive smul_right_surj_of_divisibleBy]
theorem pow_left_surj_of_rootableBy [RootableBy A α] {n : α} (hn : n ≠ 0) :
    Function.Surjective (fun a => a ^ n : A → A) := fun x =>
  ⟨RootableBy.root x n, RootableBy.root_cancel _ hn⟩
#align pow_left_surj_of_rootable_by pow_left_surj_of_rootableBy
#align smul_right_surj_of_divisible_by smul_right_surj_of_divisibleBy

/--
A `Monoid A` is `α`-rootable iff the `pow _ n` function is surjective, i.e. the constructive version
implies the textbook approach.
-/
@[to_additive divisibleByOfSMulRightSurj
      "An `AddMonoid A` is `α`-divisible iff `n • _` is a surjective function, i.e. the constructive
      version implies the textbook approach."]
noncomputable def rootableByOfPowLeftSurj
    (H : ∀ {n : α}, n ≠ 0 → Function.Surjective (fun a => a ^ n : A → A)) : RootableBy A α where
  root a n := @dite _ (n = 0) (Classical.dec _) (fun _ => (1 : A)) fun hn => (H hn a).choose
  root_zero _ := by classical exact dif_pos rfl
  root_cancel a hn := by
    dsimp only
    rw [dif_neg hn]
    exact (H hn a).choose_spec
#align rootable_by_of_pow_left_surj rootableByOfPowLeftSurj
#align divisible_by_of_smul_right_surj divisibleByOfSMulRightSurj

section Pi

variable {ι β : Type _} (B : ι → Type _) [∀ i : ι, Pow (B i) β]

variable [Zero β] [∀ i : ι, Monoid (B i)] [∀ i, RootableBy (B i) β]

@[to_additive]
instance Pi.rootableBy : RootableBy (∀ i, B i) β where
  root x n i := RootableBy.root (x i) n
  root_zero _x := funext fun _i => RootableBy.root_zero _
  root_cancel _x hn := funext fun _i => RootableBy.root_cancel _ hn
#align pi.rootable_by Pi.rootableBy
#align pi.divisible_by Pi.divisibleBy

end Pi

section Prod

variable {β B B' : Type _} [Pow B β] [Pow B' β]

variable [Zero β] [Monoid B] [Monoid B'] [RootableBy B β] [RootableBy B' β]

@[to_additive]
instance Prod.rootableBy : RootableBy (B × B') β where
  root p n := (RootableBy.root p.1 n, RootableBy.root p.2 n)
  root_zero _p := Prod.ext (RootableBy.root_zero _) (RootableBy.root_zero _)
  root_cancel _p hn := Prod.ext (RootableBy.root_cancel _ hn) (RootableBy.root_cancel _ hn)
#align prod.rootable_by Prod.rootableBy
#align prod.divisible_by Prod.divisibleBy

end Prod

end Monoid

namespace AddCommGroup

variable (A : Type _) [AddCommGroup A]

theorem smul_top_eq_top_of_divisibleBy_int [DivisibleBy A ℤ] {n : ℤ} (hn : n ≠ 0) :
    n • (⊤ : AddSubgroup A) = ⊤ :=
  AddSubgroup.map_top_of_surjective _ fun a => ⟨DivisibleBy.div a n, DivisibleBy.div_cancel _ hn⟩
#align add_comm_group.smul_top_eq_top_of_divisible_by_int AddCommGroup.smul_top_eq_top_of_divisibleBy_int

/-- If for all `n ≠ 0 ∈ ℤ`, `n • A = A`, then `A` is divisible.
-/
noncomputable def divisibleByIntOfSmulTopEqTop
    (H : ∀ {n : ℤ} (_hn : n ≠ 0), n • (⊤ : AddSubgroup A) = ⊤) : DivisibleBy A ℤ where
  div a n :=
    if hn : n = 0 then 0 else (show a ∈ n • (⊤ : AddSubgroup A) by rw [H hn]; trivial).choose
  div_zero a := dif_pos rfl
  div_cancel a hn := by
    simp_rw [dif_neg hn]
    generalize_proofs h1
    exact h1.choose_spec.2
#align add_comm_group.divisible_by_int_of_smul_top_eq_top AddCommGroup.divisibleByIntOfSmulTopEqTop

end AddCommGroup

instance (priority := 100) divisibleByIntOfCharZero {𝕜} [DivisionRing 𝕜] [CharZero 𝕜] :
    DivisibleBy 𝕜 ℤ where
  div q n := q / n
  div_zero q := by norm_num
  div_cancel {n} q hn := by
    rw [zsmul_eq_mul, (Int.cast_commute n _).eq, div_mul_cancel q (Int.cast_ne_zero.mpr hn)]
#align divisible_by_int_of_char_zero divisibleByIntOfCharZero

namespace Group

variable (A : Type _) [Group A]

open Int in
/-- A group is `ℤ`-rootable if it is `ℕ`-rootable.
-/
@[to_additive "An additive group is `ℤ`-divisible if it is `ℕ`-divisible."]
def rootableByIntOfRootableByNat [RootableBy A ℕ] : RootableBy A ℤ where
  root a z :=
    match z with
    | (n : ℕ) => RootableBy.root a n
    | -[n+1] => (RootableBy.root a (n + 1))⁻¹
  root_zero a := RootableBy.root_zero a
  root_cancel {n} a hn := by
    induction n
    · change RootableBy.root a _ ^ _ = a
      norm_num
      rw [RootableBy.root_cancel]
      rw [Int.ofNat_eq_coe] at hn
      exact_mod_cast hn
    · change (RootableBy.root a _)⁻¹ ^ _ = a
      norm_num
      rw [RootableBy.root_cancel]
      norm_num
#align group.rootable_by_int_of_rootable_by_nat Group.rootableByIntOfRootableByNat
#align add_group.divisible_by_int_of_divisible_by_nat AddGroup.divisibleByIntOfDivisibleByNat

/-- A group is `ℕ`-rootable if it is `ℤ`-rootable
-/
@[to_additive "An additive group is `ℕ`-divisible if it `ℤ`-divisible."]
def rootableByNatOfRootableByInt [RootableBy A ℤ] : RootableBy A ℕ where
  root a n := RootableBy.root a (n : ℤ)
  root_zero a := RootableBy.root_zero a
  root_cancel {n} a hn := by
    -- Porting note: replaced `norm_num`
    simpa only [zpow_coe_nat] using RootableBy.root_cancel a (show (n : ℤ) ≠ 0 by exact_mod_cast hn)
#align group.rootable_by_nat_of_rootable_by_int Group.rootableByNatOfRootableByInt
#align add_group.divisible_by_nat_of_divisible_by_int AddGroup.divisibleByNatOfDivisibleByInt

end Group

section Hom

-- Porting note: reordered variables to fix `to_additive` on `QuotientGroup.rootableBy`
variable {A B α : Type _}

variable [Zero α] [Monoid A] [Monoid B] [Pow A α] [Pow B α] [RootableBy A α]

variable (f : A → B)

/--
If `f : A → B` is a surjective homomorphism and `A` is `α`-rootable, then `B` is also `α`-rootable.
-/
@[to_additive
      "If `f : A → B` is a surjective homomorphism and `A` is `α`-divisible, then `B` is also
      `α`-divisible."]
noncomputable def Function.Surjective.rootableBy (hf : Function.Surjective f)
    (hpow : ∀ (a : A) (n : α), f (a ^ n) = f a ^ n) : RootableBy B α :=
  rootableByOfPowLeftSurj _ _ fun {n} hn x =>
    let ⟨y, hy⟩ := hf x
    ⟨f <| RootableBy.root y n,
      (by rw [← hpow (RootableBy.root y n) n, RootableBy.root_cancel _ hn, hy] : _ ^ n = x)⟩
#align function.surjective.rootable_by Function.Surjective.rootableByₓ
#align function.surjective.divisible_by Function.Surjective.divisibleByₓ

@[to_additive DivisibleBy.surjective_smul]
theorem RootableBy.surjective_pow (A α : Type _) [Monoid A] [Pow A α] [Zero α] [RootableBy A α]
    {n : α} (hn : n ≠ 0) : Function.Surjective fun a : A => a ^ n := fun a =>
  ⟨RootableBy.root a n, RootableBy.root_cancel a hn⟩
#align rootable_by.surjective_pow RootableBy.surjective_pow
#align divisible_by.surjective_smul DivisibleBy.surjective_smul

end Hom

section Quotient

variable (α : Type _) {A : Type _} [CommGroup A] (B : Subgroup A)

/-- Any quotient group of a rootable group is rootable. -/
@[to_additive "Any quotient group of a divisible group is divisible"]
noncomputable instance QuotientGroup.rootableBy [RootableBy A ℕ] : RootableBy (A ⧸ B) ℕ :=
  QuotientGroup.mk_surjective.rootableBy _ fun _ _ => rfl
#align quotient_group.rootable_by QuotientGroup.rootableBy
#align quotient_add_group.divisible_by QuotientAddGroup.divisibleBy

end Quotient