/-
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, Mario Carneiro

! This file was ported from Lean 3 source module topology.instances.nat
! leanprover-community/mathlib commit f47581155c818e6361af4e4fda60d27d020c226b
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Topology.Instances.Int

/-!
# Topology on the natural numbers

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

The structure of a metric space on `ℕ` is introduced in this file, induced from `ℝ`.
-/

noncomputable section

open Metric Set Filter

namespace Nat

noncomputable instance : Dist ℕ :=
  ⟨fun x y => dist (x : ℝ) y⟩

/- warning: nat.dist_eq -> Nat.dist_eq is a dubious translation:
lean 3 declaration is
  forall (x : Nat) (y : Nat), Eq.{1} Real (Dist.dist.{0} Nat Nat.hasDist x y) (Abs.abs.{0} Real (Neg.toHasAbs.{0} Real Real.hasNeg Real.hasSup) (HSub.hSub.{0, 0, 0} Real Real Real (instHSub.{0} Real Real.hasSub) ((fun (a : Type) (b : Type) [self : HasLiftT.{1, 1} a b] => self.0) Nat Real (HasLiftT.mk.{1, 1} Nat Real (CoeTCₓ.coe.{1, 1} Nat Real (Nat.castCoe.{0} Real Real.hasNatCast))) x) ((fun (a : Type) (b : Type) [self : HasLiftT.{1, 1} a b] => self.0) Nat Real (HasLiftT.mk.{1, 1} Nat Real (CoeTCₓ.coe.{1, 1} Nat Real (Nat.castCoe.{0} Real Real.hasNatCast))) y)))
but is expected to have type
  forall (x : Nat) (y : Nat), Eq.{1} Real (Dist.dist.{0} Nat Nat.instDistNat x y) (Abs.abs.{0} Real (Neg.toHasAbs.{0} Real Real.instNegReal Real.instSupReal) (HSub.hSub.{0, 0, 0} Real Real Real (instHSub.{0} Real Real.instSubReal) (Nat.cast.{0} Real Real.natCast x) (Nat.cast.{0} Real Real.natCast y)))
Case conversion may be inaccurate. Consider using '#align nat.dist_eq Nat.dist_eqₓ'. -/
theorem dist_eq (x y : ℕ) : dist x y = |x - y| :=
  rfl
#align nat.dist_eq Nat.dist_eq

/- warning: nat.dist_coe_int -> Nat.dist_coe_int is a dubious translation:
lean 3 declaration is
  forall (x : Nat) (y : Nat), Eq.{1} Real (Dist.dist.{0} Int Int.hasDist ((fun (a : Type) (b : Type) [self : HasLiftT.{1, 1} a b] => self.0) Nat Int (HasLiftT.mk.{1, 1} Nat Int (CoeTCₓ.coe.{1, 1} Nat Int (coeBase.{1, 1} Nat Int Int.hasCoe))) x) ((fun (a : Type) (b : Type) [self : HasLiftT.{1, 1} a b] => self.0) Nat Int (HasLiftT.mk.{1, 1} Nat Int (CoeTCₓ.coe.{1, 1} Nat Int (coeBase.{1, 1} Nat Int Int.hasCoe))) y)) (Dist.dist.{0} Nat Nat.hasDist x y)
but is expected to have type
  forall (x : Nat) (y : Nat), Eq.{1} Real (Dist.dist.{0} Int Int.instDistInt (Nat.cast.{0} Int instNatCastInt x) (Nat.cast.{0} Int instNatCastInt y)) (Dist.dist.{0} Nat Nat.instDistNat x y)
Case conversion may be inaccurate. Consider using '#align nat.dist_coe_int Nat.dist_coe_intₓ'. -/
theorem dist_coe_int (x y : ℕ) : dist (x : ℤ) (y : ℤ) = dist x y :=
  rfl
#align nat.dist_coe_int Nat.dist_coe_int

/- warning: nat.dist_cast_real -> Nat.dist_cast_real is a dubious translation:
lean 3 declaration is
  forall (x : Nat) (y : Nat), Eq.{1} Real (Dist.dist.{0} Real (PseudoMetricSpace.toHasDist.{0} Real Real.pseudoMetricSpace) ((fun (a : Type) (b : Type) [self : HasLiftT.{1, 1} a b] => self.0) Nat Real (HasLiftT.mk.{1, 1} Nat Real (CoeTCₓ.coe.{1, 1} Nat Real (Nat.castCoe.{0} Real Real.hasNatCast))) x) ((fun (a : Type) (b : Type) [self : HasLiftT.{1, 1} a b] => self.0) Nat Real (HasLiftT.mk.{1, 1} Nat Real (CoeTCₓ.coe.{1, 1} Nat Real (Nat.castCoe.{0} Real Real.hasNatCast))) y)) (Dist.dist.{0} Nat Nat.hasDist x y)
but is expected to have type
  forall (x : Nat) (y : Nat), Eq.{1} Real (Dist.dist.{0} Real (PseudoMetricSpace.toDist.{0} Real Real.pseudoMetricSpace) (Nat.cast.{0} Real Real.natCast x) (Nat.cast.{0} Real Real.natCast y)) (Dist.dist.{0} Nat Nat.instDistNat x y)
Case conversion may be inaccurate. Consider using '#align nat.dist_cast_real Nat.dist_cast_realₓ'. -/
@[norm_cast, simp]
theorem dist_cast_real (x y : ℕ) : dist (x : ℝ) y = dist x y :=
  rfl
#align nat.dist_cast_real Nat.dist_cast_real

/- warning: nat.pairwise_one_le_dist -> Nat.pairwise_one_le_dist is a dubious translation:
lean 3 declaration is
  Pairwise.{0} Nat (fun (m : Nat) (n : Nat) => LE.le.{0} Real Real.hasLe (OfNat.ofNat.{0} Real 1 (OfNat.mk.{0} Real 1 (One.one.{0} Real Real.hasOne))) (Dist.dist.{0} Nat Nat.hasDist m n))
but is expected to have type
  Pairwise.{0} Nat (fun (m : Nat) (n : Nat) => LE.le.{0} Real Real.instLEReal (OfNat.ofNat.{0} Real 1 (One.toOfNat1.{0} Real Real.instOneReal)) (Dist.dist.{0} Nat Nat.instDistNat m n))
Case conversion may be inaccurate. Consider using '#align nat.pairwise_one_le_dist Nat.pairwise_one_le_distₓ'. -/
theorem pairwise_one_le_dist : Pairwise fun m n : ℕ => 1 ≤ dist m n :=
  by
  intro m n hne
  rw [← dist_coe_int]
  apply Int.pairwise_one_le_dist
  exact_mod_cast hne
#align nat.pairwise_one_le_dist Nat.pairwise_one_le_dist

/- warning: nat.uniform_embedding_coe_real -> Nat.uniformEmbedding_coe_real is a dubious translation:
lean 3 declaration is
  UniformEmbedding.{0, 0} Nat Real Nat.uniformSpace (PseudoMetricSpace.toUniformSpace.{0} Real Real.pseudoMetricSpace) ((fun (a : Type) (b : Type) [self : HasLiftT.{1, 1} a b] => self.0) Nat Real (HasLiftT.mk.{1, 1} Nat Real (CoeTCₓ.coe.{1, 1} Nat Real (Nat.castCoe.{0} Real Real.hasNatCast))))
but is expected to have type
  UniformEmbedding.{0, 0} Nat Real instUniformSpaceNat (PseudoMetricSpace.toUniformSpace.{0} Real Real.pseudoMetricSpace) (Nat.cast.{0} Real Real.natCast)
Case conversion may be inaccurate. Consider using '#align nat.uniform_embedding_coe_real Nat.uniformEmbedding_coe_realₓ'. -/
theorem uniformEmbedding_coe_real : UniformEmbedding (coe : ℕ → ℝ) :=
  uniformEmbedding_bot_of_pairwise_le_dist zero_lt_one pairwise_one_le_dist
#align nat.uniform_embedding_coe_real Nat.uniformEmbedding_coe_real

/- warning: nat.closed_embedding_coe_real -> Nat.closedEmbedding_coe_real is a dubious translation:
lean 3 declaration is
  ClosedEmbedding.{0, 0} Nat Real Nat.topologicalSpace (UniformSpace.toTopologicalSpace.{0} Real (PseudoMetricSpace.toUniformSpace.{0} Real Real.pseudoMetricSpace)) ((fun (a : Type) (b : Type) [self : HasLiftT.{1, 1} a b] => self.0) Nat Real (HasLiftT.mk.{1, 1} Nat Real (CoeTCₓ.coe.{1, 1} Nat Real (Nat.castCoe.{0} Real Real.hasNatCast))))
but is expected to have type
  ClosedEmbedding.{0, 0} Nat Real instTopologicalSpaceNat (UniformSpace.toTopologicalSpace.{0} Real (PseudoMetricSpace.toUniformSpace.{0} Real Real.pseudoMetricSpace)) (Nat.cast.{0} Real Real.natCast)
Case conversion may be inaccurate. Consider using '#align nat.closed_embedding_coe_real Nat.closedEmbedding_coe_realₓ'. -/
theorem closedEmbedding_coe_real : ClosedEmbedding (coe : ℕ → ℝ) :=
  closedEmbedding_of_pairwise_le_dist zero_lt_one pairwise_one_le_dist
#align nat.closed_embedding_coe_real Nat.closedEmbedding_coe_real

instance : MetricSpace ℕ :=
  Nat.uniformEmbedding_coe_real.comapMetricSpace _

/- warning: nat.preimage_ball -> Nat.preimage_ball is a dubious translation:
lean 3 declaration is
  forall (x : Nat) (r : Real), Eq.{1} (Set.{0} Nat) (Set.preimage.{0, 0} Nat Real ((fun (a : Type) (b : Type) [self : HasLiftT.{1, 1} a b] => self.0) Nat Real (HasLiftT.mk.{1, 1} Nat Real (CoeTCₓ.coe.{1, 1} Nat Real (Nat.castCoe.{0} Real Real.hasNatCast)))) (Metric.ball.{0} Real Real.pseudoMetricSpace ((fun (a : Type) (b : Type) [self : HasLiftT.{1, 1} a b] => self.0) Nat Real (HasLiftT.mk.{1, 1} Nat Real (CoeTCₓ.coe.{1, 1} Nat Real (Nat.castCoe.{0} Real Real.hasNatCast))) x) r)) (Metric.ball.{0} Nat (MetricSpace.toPseudoMetricSpace.{0} Nat Nat.metricSpace) x r)
but is expected to have type
  forall (x : Nat) (r : Real), Eq.{1} (Set.{0} Nat) (Set.preimage.{0, 0} Nat Real (Nat.cast.{0} Real Real.natCast) (Metric.ball.{0} Real Real.pseudoMetricSpace (Nat.cast.{0} Real Real.natCast x) r)) (Metric.ball.{0} Nat (MetricSpace.toPseudoMetricSpace.{0} Nat Nat.instMetricSpaceNat) x r)
Case conversion may be inaccurate. Consider using '#align nat.preimage_ball Nat.preimage_ballₓ'. -/
theorem preimage_ball (x : ℕ) (r : ℝ) : coe ⁻¹' ball (x : ℝ) r = ball x r :=
  rfl
#align nat.preimage_ball Nat.preimage_ball

/- warning: nat.preimage_closed_ball -> Nat.preimage_closedBall is a dubious translation:
lean 3 declaration is
  forall (x : Nat) (r : Real), Eq.{1} (Set.{0} Nat) (Set.preimage.{0, 0} Nat Real ((fun (a : Type) (b : Type) [self : HasLiftT.{1, 1} a b] => self.0) Nat Real (HasLiftT.mk.{1, 1} Nat Real (CoeTCₓ.coe.{1, 1} Nat Real (Nat.castCoe.{0} Real Real.hasNatCast)))) (Metric.closedBall.{0} Real Real.pseudoMetricSpace ((fun (a : Type) (b : Type) [self : HasLiftT.{1, 1} a b] => self.0) Nat Real (HasLiftT.mk.{1, 1} Nat Real (CoeTCₓ.coe.{1, 1} Nat Real (Nat.castCoe.{0} Real Real.hasNatCast))) x) r)) (Metric.closedBall.{0} Nat (MetricSpace.toPseudoMetricSpace.{0} Nat Nat.metricSpace) x r)
but is expected to have type
  forall (x : Nat) (r : Real), Eq.{1} (Set.{0} Nat) (Set.preimage.{0, 0} Nat Real (Nat.cast.{0} Real Real.natCast) (Metric.closedBall.{0} Real Real.pseudoMetricSpace (Nat.cast.{0} Real Real.natCast x) r)) (Metric.closedBall.{0} Nat (MetricSpace.toPseudoMetricSpace.{0} Nat Nat.instMetricSpaceNat) x r)
Case conversion may be inaccurate. Consider using '#align nat.preimage_closed_ball Nat.preimage_closedBallₓ'. -/
theorem preimage_closedBall (x : ℕ) (r : ℝ) : coe ⁻¹' closedBall (x : ℝ) r = closedBall x r :=
  rfl
#align nat.preimage_closed_ball Nat.preimage_closedBall

/- warning: nat.closed_ball_eq_Icc -> Nat.closedBall_eq_Icc is a dubious translation:
lean 3 declaration is
  forall (x : Nat) (r : Real), Eq.{1} (Set.{0} Nat) (Metric.closedBall.{0} Nat (MetricSpace.toPseudoMetricSpace.{0} Nat Nat.metricSpace) x r) (Set.Icc.{0} Nat (PartialOrder.toPreorder.{0} Nat (OrderedCancelAddCommMonoid.toPartialOrder.{0} Nat (StrictOrderedSemiring.toOrderedCancelAddCommMonoid.{0} Nat Nat.strictOrderedSemiring))) (Nat.ceil.{0} Real Real.orderedSemiring (FloorRing.toFloorSemiring.{0} Real Real.linearOrderedRing Real.floorRing) (HSub.hSub.{0, 0, 0} Real Real Real (instHSub.{0} Real Real.hasSub) ((fun (a : Type) (b : Type) [self : HasLiftT.{1, 1} a b] => self.0) Nat Real (HasLiftT.mk.{1, 1} Nat Real (CoeTCₓ.coe.{1, 1} Nat Real (Nat.castCoe.{0} Real Real.hasNatCast))) x) r)) (Nat.floor.{0} Real Real.orderedSemiring (FloorRing.toFloorSemiring.{0} Real Real.linearOrderedRing Real.floorRing) (HAdd.hAdd.{0, 0, 0} Real Real Real (instHAdd.{0} Real Real.hasAdd) ((fun (a : Type) (b : Type) [self : HasLiftT.{1, 1} a b] => self.0) Nat Real (HasLiftT.mk.{1, 1} Nat Real (CoeTCₓ.coe.{1, 1} Nat Real (Nat.castCoe.{0} Real Real.hasNatCast))) x) r)))
but is expected to have type
  forall (x : Nat) (r : Real), Eq.{1} (Set.{0} Nat) (Metric.closedBall.{0} Nat (MetricSpace.toPseudoMetricSpace.{0} Nat Nat.instMetricSpaceNat) x r) (Set.Icc.{0} Nat (PartialOrder.toPreorder.{0} Nat (StrictOrderedSemiring.toPartialOrder.{0} Nat Nat.strictOrderedSemiring)) (Nat.ceil.{0} Real Real.orderedSemiring (FloorRing.toFloorSemiring.{0} Real Real.instLinearOrderedRingReal Real.instFloorRingRealInstLinearOrderedRingReal) (HSub.hSub.{0, 0, 0} Real Real Real (instHSub.{0} Real Real.instSubReal) (Nat.cast.{0} Real Real.natCast x) r)) (Nat.floor.{0} Real Real.orderedSemiring (FloorRing.toFloorSemiring.{0} Real Real.instLinearOrderedRingReal Real.instFloorRingRealInstLinearOrderedRingReal) (HAdd.hAdd.{0, 0, 0} Real Real Real (instHAdd.{0} Real Real.instAddReal) (Nat.cast.{0} Real Real.natCast x) r)))
Case conversion may be inaccurate. Consider using '#align nat.closed_ball_eq_Icc Nat.closedBall_eq_Iccₓ'. -/
theorem closedBall_eq_Icc (x : ℕ) (r : ℝ) : closedBall x r = Icc ⌈↑x - r⌉₊ ⌊↑x + r⌋₊ :=
  by
  rcases le_or_lt 0 r with (hr | hr)
  · rw [← preimage_closed_ball, Real.closedBall_eq_Icc, preimage_Icc]
    exact add_nonneg (cast_nonneg x) hr
  · rw [closed_ball_eq_empty.2 hr]
    apply (Icc_eq_empty _).symm
    rw [not_le]
    calc
      ⌊(x : ℝ) + r⌋₊ ≤ ⌊(x : ℝ)⌋₊ := by
        apply floor_mono
        linarith
      _ < ⌈↑x - r⌉₊ := by
        rw [floor_coe, Nat.lt_ceil]
        linarith

#align nat.closed_ball_eq_Icc Nat.closedBall_eq_Icc

instance : ProperSpace ℕ :=
  ⟨by
    intro x r
    rw [closed_ball_eq_Icc]
    exact (Set.finite_Icc _ _).IsCompact⟩

instance : NoncompactSpace ℕ :=
  noncompactSpace_of_neBot <| by simp [Filter.atTop_neBot]

end Nat


import .NN .misc system.io

variables {α : Type} [has_mul α] [add_comm_monoid α] [has_le α]
variables {k m n : nat}

structure LP (α : Type) (m n : nat) :=
(obf : N α)
(lhs : NN α)
(rhs : N α)

def LP.feasible : LP α m n → N α → Prop
| ⟨c, A, b⟩ x :=  N.le m (mul_vec n A x) b ∧ (N.le n (N.zero α) x)

def LP.is_feasible (P : LP α m n) : Prop :=
∃ x : N α, P.feasible x

instance LP.feasible.decidable [decidable_rel ((≤) : α → α → Prop)]
  (P : LP α m n) (x : N α) : decidable (P.feasible x) :=
by {cases P, unfold LP.feasible, apply_instance }
open tactic

meta def Nx.repr (vx : expr) : nat → tactic string
| 0       := return ""
| (k + 1) :=
  do vs ← Nx.repr k,
     a ← to_expr ``(%%vx %%`(k)) >>= eval_expr rat,
     return $ string.join [vs, " ", a.repr]

meta def NNx.repr_aux (Ax : expr) : nat → nat → tactic string
| 0       n := return ""
| (m + 1) n :=
  do vs ← NNx.repr_aux m n,
     a ← to_expr ``(%%Ax %%`(m) %%`(n)) >>= eval_expr rat,
     return $ string.join [vs, " ", a.repr]

meta def NNx.repr (Ax : expr) (m : nat) : nat → tactic string
| 0       := return ""
| 1       := NNx.repr_aux Ax m 0
| (n + 1) :=
  do As ← NNx.repr n,
     vs ← NNx.repr_aux Ax m n,
     return $ string.join [As, "\n", vs]

meta def put_LP : tactic (string × string × string) :=
do `(LP.is_feasible %%lp) ← target,
  `(⟨%%cx, %%Ax, %%bx⟩ : LP _ _ _) ← pure lp,
  `(LP _ %%mx %%nx) ← infer_type lp,
   m ← eval_expr nat mx,
   n ← eval_expr nat nx,
   cs ← Nx.repr cx n,
   As ← NNx.repr Ax m n,
   bs ← Nx.repr bx m,
   return ⟨cs, As, bs⟩

open tactic

-- meta instance int.has_reflect : has_reflect ℤ := by tactic.mk_has_reflect_instance

meta def rat.has_reflect' : Π x : ℚ, Σ y : ℚ, Σ' h : x = y, reflected y
| ⟨x,y,h,h'⟩ := ⟨rat.mk_nat x y, by { rw [rat.num_denom',rat.mk_nat_eq] } , `(_)⟩

-- meta instance : has_reflect ℚ
-- | x :=
-- match rat.has_reflect' x with
-- | ⟨ ._, rfl, h ⟩ := h
-- end

meta def cvxopt_lp (cs As bs : string) : tactic string :=
unsafe_run_io $ do
cwd ← io.env.get_cwd,
io.cmd {
  cmd  := "python3",
  args := ["src/lp.py", cs, As, bs],
  cwd  := cwd
}

open parser

def digits : list char :=
[ '0', '1', '2', '3', '4', '5', '6', '7', '8', '9' ]

def parser_digits : parser string := many_char (one_of digits)

def parser_sign : parser bool :=
(ch '+' >> return tt) <|> (ch '-' >> return ff) <|> (return tt)

def parser_dnat : parser string :=
do d ← one_of digits,
   ch '.',
   ds ← parser_digits,
   return ⟨d::ds.data⟩

def drop_zeroes : string → string := string.drop_chars '0'

def drop_trailing_nl (s : string) : string :=
(s.reverse.drop_chars '\n').reverse

def parser_mantissa : parser rat :=
do b ← parser_sign,
   ds ← parser_dnat,
   let i := int.of_nat (drop_zeroes ds).to_nat,
   let numer : int := if b then i else -i,
   let denom : ℕ := 10 ^ ds.length.pred,
   return (rat.mk_nat numer denom)

def parser_magnitude : parser rat :=
do b ← parser_sign,
   ds ← parser_digits,
   let m : ℕ := 10 ^ (drop_zeroes ds).to_nat,
   return (if b then (rat.mk_nat m 1) else (rat.mk_nat 1 m))

def parser_scinot : parser rat :=
do r ← parser_mantissa,
   ch 'e',
   s ← parser_magnitude,
   return (r * s)

def ws : parser unit := many' (ch ' ')

def parser_entry : parser rat :=
ch '[' *> ws *> parser_scinot <* ws <* ch ']'

def parser_vector : parser (list rat) :=
sep_by (ch '\n') parser_entry

meta def LP.show_is_feasible : tactic unit :=
do ⟨cs, As, bs⟩ ← put_LP,
   vs ← cvxopt_lp cs As bs,
   match run_string parser_vector (drop_trailing_nl vs) with
   | (sum.inl _)  := fail "Cannot parse vector"
   | (sum.inr rs) :=
     do vx ← to_expr ``(@N.of_list rat _ %%`(rs)),
        existsi vx,
        exact_dec_trivial
   end

def ex_c : N rat := N.of_list [2, 1]
def ex_A : NN rat := NN.of_lists rat [[-1, 1], [-1, -1], [0, -1], [1, -2]]
def ex_b : N rat := N.of_list [1, -2, 0, 4]

example : LP.is_feasible (⟨ex_c, ex_A, ex_b⟩ : LP _ 4 2) :=
by LP.show_is_feasible


import set_theory.cardinal.basic
import local.cardinal
import local.subgraph
universe univ

namespace simple_graph
namespace subgraph
variables {V : Type univ} {G : simple_graph V} {M : G.subgraph}
variables {u v : V}
variables {p: path G u v}

lemma is_matching_iff_forall_degree' {M : G.subgraph}:
  M.is_matching ↔ ∀ (v : V), v ∈ M.verts → cardinal.mk (M.neighbor_set v) = 1 :=
by simpa [degree_eq_one_iff_unique_adj']

theorem is_matching.of_adj (huv: G.adj u v): (G.subgraph_of_adj huv).is_matching :=
by simp [is_matching, G.ne_of_adj huv, (G.ne_of_adj huv).symm]

theorem is_matching.unique_edge {M: subgraph G} (hM: M.is_matching) {v: V}:
  ∀ {e₁ e₂}, e₁ ∈ M.edge_set → e₂ ∈ M.edge_set → v ∈ e₁ → v ∈ e₂ → e₁ = e₂ :=
begin
  simp only [sym2.forall, mem_edge_set],
  intros x₁ y₁,
  simp only [sym2.forall, mem_edge_set, sym2.mem_iff],
  intros x₂ y₂ hxy₁ hxy₂ hv₁ hv₂,
  cases hv₁ with hv₁ hv₁;
  cases hv₂ with hv₂ hv₂;
  induction hv₁;
  induction hv₂;
  simp only [
    M.ne_of_adj hxy₁, (M.ne_of_adj hxy₁).symm,
    M.ne_of_adj hxy₂, (M.ne_of_adj hxy₂).symm,
    true_and, and_true, and_false, or_false, false_or,
    eq_self_iff_true,
    sym2.rel_iff, quotient.eq],
  exact exists_unique.unique (hM (M.edge_vert hxy₁)) hxy₁ hxy₂,
  exact exists_unique.unique (hM (M.edge_vert hxy₁)) hxy₁ (M.adj_symm hxy₂),
  exact exists_unique.unique (hM (M.edge_vert (M.adj_symm hxy₁))) (M.adj_symm hxy₁) hxy₂,
  exact exists_unique.unique (hM (M.edge_vert (M.adj_symm hxy₁))) (M.adj_symm hxy₁) (M.adj_symm hxy₂),
end

noncomputable def is_matching.other {M : subgraph G} (hM : M.is_matching)
  (v: V): V := begin
  classical,
  exact dite (v ∈ M.verts) (λ h, (hM h).some) (λ _, v),
end

theorem is_matching.other_adj {M: subgraph G} (hM: M.is_matching) {v: V} (hv: v ∈ M.verts):
  M.adj v (hM.other v) :=
by simpa [is_matching.other, hv] using (hM hv).some_spec.1

theorem is_matching.other_adj' {M: subgraph G} (hM: M.is_matching) {v: V} (hv: v ∈ M.verts):
  M.adj (hM.other v) v := M.adj_symm (hM.other_adj hv)

theorem is_matching.other_of_adj {M: subgraph G} (hM: M.is_matching) {u v: V} (h: M.adj u v):
  hM.other u = v := exists_unique.unique (hM (M.edge_vert h)) (hM.other_adj (M.edge_vert h)) h

theorem is_matching.other_of_adj' {M: subgraph G} (hM: M.is_matching) {u v: V} (h: M.adj u v):
  u = hM.other v := eq.symm (hM.other_of_adj (M.adj_symm h))

theorem is_matching.ne_of_mem {M: subgraph G} (hM: M.is_matching) {v: V} (hv: v ∈ M.verts):
  v ≠ (hM.other v) := M.ne_of_adj (hM.other_adj hv)

theorem is_matching.other_id {M: subgraph G} (hM: M.is_matching) {v: V} (hv: v ∉ M.verts):
  hM.other v = v :=
by simp [is_matching.other, hv]

theorem is_matching.other_adj_iff {M: subgraph G} (hM: M.is_matching) {v: V}:
  (v ∈ M.verts) ↔ M.adj v (hM.other v) :=
begin
  refine ⟨ hM.other_adj, _ ⟩,
  contrapose!,
  intro h,
  rw [hM.other_id h],
  exact M.loopless _,
end

theorem is_matching.other_of_adj_iff {M: subgraph G} (hM: M.is_matching) {v u: V} (hv: v ∈ M.verts):
  M.adj u v ↔ u = (hM.other v) := ⟨ λ h, hM.other_of_adj'  h, λ h, h.symm ▸ (hM.other_adj' hv) ⟩

theorem is_matching.other_of_adj_iff' {M: subgraph G} (hM: M.is_matching) {v u: V} (hv: v ∈ M.verts):
  M.adj v u ↔ u = (hM.other v) := (eq_iff_iff.mpr (M.adj_comm u v)) ▸ hM.other_of_adj_iff hv

theorem is_matching.other_id_iff {M: subgraph G} (hM: M.is_matching) (v: V):
  (v ∉ M.verts) ↔ hM.other v = v :=
begin
  refine ⟨ hM.other_id, _ ⟩,
  contrapose!,
  intros hmem heq,
  apply M.loopless v,
  conv { congr, skip, skip, rw [← heq] },
  exact hM.other_adj hmem
end

theorem is_matching.other_id_iff' {M: subgraph G} (hM: M.is_matching) (v: V):
  (v ∉ M.verts) ↔ v = hM.other v:= by rw[hM.other_id_iff v, eq_comm]

@[simp]
theorem is_matching.other_subtype_ne {M: subgraph G} (hM: M.is_matching) {v: V} (hv: v ∈ M.verts):
  v ≠ (hM.other v) := by simpa [← is_matching.other_id_iff'] using hv

@[simp]
theorem is_matching.other_subtype_ne' {M: subgraph G} (hM: M.is_matching) {v: V} (hv: v ∈ M.verts):
  (hM.other v) ≠ v := ne.symm (hM.other_subtype_ne hv)

theorem is_matching.other_mem_verts {M: subgraph G} (hM: M.is_matching) {v: V} (hv: v ∈ M.verts):
  (hM.other v) ∈ M.verts := M.edge_vert (M.adj_symm (hM.other_adj hv))

theorem is_matching.other_inverse {M: subgraph G} (hM: M.is_matching) (v: V):
  hM.other (hM.other v) = v :=
begin
  by_cases v ∈ M.verts,
  { exact exists_unique.unique
      (hM (hM.other_mem_verts h))
      (hM.other_adj (hM.other_mem_verts h))
      (M.adj_symm (hM.other_adj h)) },
  { rw [hM.other_id h, hM.other_id h] }
end

theorem is_matching.other_mem_verts' {M: subgraph G} (hM: M.is_matching) {v: V} (hv: hM.other v ∈ M.verts):
  v ∈ M.verts := hM.other_inverse v ▸ M.edge_vert (hM.other_adj' hv)

theorem is_matching.other_inj_iff {M: subgraph G} (hM: M.is_matching) (u v: V):
  hM.other u = hM.other v ↔ u = v := ⟨ λ p, by rw [← hM.other_inverse u, p, hM.other_inverse v], congr_arg _ ⟩

theorem is_matching.other_inj_iff' {M: subgraph G} (hM: M.is_matching) (u v: V):
  hM.other u = v ↔ u = hM.other v :=
by conv_lhs { rw [← hM.other_inj_iff, hM.other_inverse] }

theorem is_matching.other_image {M: subgraph G} (hM: M.is_matching) {v: V} {s: set V}:
  v ∈ s.image hM.other → hM.other v ∈ s :=
by simp [set.mem_image, hM.other_inj_iff']

theorem is_matching.other_image' {M: subgraph G} (hM: M.is_matching) {v: V} {s: set V}:
  v ∈ s.image hM.other → hM.other v ∈ s :=
by simp [set.mem_image, hM.other_inj_iff']

theorem is_matching.edge_of_other {M: subgraph G} (hM: M.is_matching) {v: V} {e: sym2 V} (hv: hM.other v ∈ e) (he: e ∈ M.edge_set):
  v ∈ e :=
begin
  revert e,
  simp only [sym2.forall, sym2.mem_iff, mem_edge_set],
  intros x y hv hxy,
  cases hv;
  induction hv;
  rw [← hM.other_inverse v],
  exact or.inr (hM.other_of_adj hxy),
  exact or.inl (hM.other_of_adj' hxy).symm,
end

theorem is_matching.other_unique_edge {M: subgraph G} (hM: M.is_matching) {v: V}:
  ∀ {e₁ e₂}, e₁ ∈ M.edge_set → e₂ ∈ M.edge_set → v ∈ e₁ → hM.other v ∈ e₂ → e₁ = e₂ :=
begin
  simp only [sym2.forall, mem_edge_set],
  intros x₁ y₁,
  simp only [sym2.forall, mem_edge_set, sym2.mem_iff],
  intros x₂ y₂ hxy₁ hxy₂ hv₁ hv₂,
  have hxy₁' := hM.other_of_adj hxy₁,
  have hxy₂' := hM.other_of_adj hxy₂,
  cases hv₁ with hv₁ hv₁;
  cases hv₂ with hv₂ hv₂;
  induction hv₁;
  induction hv₂;
  simp only [hM.other_inj_iff, hM.other_inverse, hM.other_inj_iff', @eq_comm _ v] at hxy₁' hxy₂';
  induction hxy₁';
  induction hxy₂';
  try { refl };
  exact sym2.eq_swap,
end

theorem is_matching.unique_symm_diff (hM: M.is_matching) {N: G.subgraph} {x y z: V}:
  (M.adj x y) → (¬ M.adj x z) → N.adj x y → N.adj x z → (∀ {v}, N.adj x v → y = v ∨ z = v) →
  ∃! v, (M ∆ N).adj x v :=
begin
  intros hmxy hmxz hnxy hnxz hn,
  apply symm_diff_adj_unique_right,
  { simp only [subgraph.sdiff_adj_iff, not_and, not_not],
    intros u hu,
    rwa [(hM (M.edge_vert hmxy)).unique hu hmxy] },
  refine ⟨z, ⟨hnxz, hmxz⟩, _,⟩,
  simp only [subgraph.sdiff_adj_iff, not_and, not_not, and_imp],
  intros u hnu hmu,
  cases hn hnu,
  { induction h,
    contradiction },
  { rw [h] }
end

def is_matching.is_maximum (m: M.is_matching) :=
  ∀ M': G.subgraph, M'.is_matching → cardinal.mk M'.verts ≤ cardinal.mk M.verts

end subgraph
end simple_graph


import GMLAlgebra.Basic
import GMLAlgebra.Monoid
import GMLAlgebra.Groupoid

namespace Algebra
variable {α} (s : GroupSig α)

local infixr:70 " ⋆ " => s.op
local postfix:max "⁻¹" => s.inv
local notation "e" => s.id

class Group extends Semigroup (no_index s.toSemigroupSig) : Prop where
  protected op_right_id (x) : x ⋆ e = x
  protected op_right_inv (x) : x ⋆ x⁻¹ = e

protected def Group.infer [OpAssoc s.op] [OpRightInv s.op s.inv s.id] [OpRightId s.op s.id] : Group s where
  op_assoc := op_assoc _
  op_right_id := op_right_id _
  op_right_inv := op_right_inv _

namespace Group
variable {s} [self : Group s]

local instance : OpRightId (no_index s.op) (no_index s.id) := ⟨Group.op_right_id⟩
instance : OpRightInv (no_index s.op) (no_index s.inv) (no_index s.id) := ⟨Group.op_right_inv⟩

instance : Groupoid (no_index s.toGroupoidSig) where
  dop_assoc _ _ _ _ := op_assoc s.op
  dop_right_id _ _ := op_right_id s.op
  dop_right_inv _ _ := op_right_inv s.op

local instance : OpRightCancel (no_index s.op) := ⟨dop_right_cancel s.toGroupoidSig.op (a:=()) (b:=()) (c:=())⟩

local instance : OpLeftId (no_index s.op) (no_index s.id) := ⟨dop_left_id s.toGroupoidSig.op (a:=()) (b:=())⟩

instance : OpLeftInv (no_index s.op) (no_index s.inv) (no_index s.id) := ⟨dop_left_inv s.toGroupoidSig.op (a:=()) (b:=())⟩

local instance : OpLeftCancel (no_index s.op) := ⟨dop_left_cancel s.toCategorySig.op (a:=()) (b:=()) (c:=())⟩

instance : InvOp (no_index s.inv) (no_index s.op) := ⟨dinv_op s.toGroupoidSig.inv (a:=()) (b:=()) (c:=())⟩

instance : InvInvol (no_index s.inv) := ⟨dinv_invol s.toGroupoidSig.inv (a:=()) (b:=())⟩

instance : InvId (no_index s.inv) (no_index s.id) := ⟨dinv_id s.toGroupoidSig.inv (a:=())⟩

instance toCancelMonoid : CancelMonoid (no_index s.toMonoidSig) := CancelMonoid.infer _

end Group

class CommGroup extends Group s, CommMonoid (no_index s.toMonoidSig) : Prop where

protected def CommGroup.infer [OpAssoc s.op] [OpComm s.op] [OpRightId s.op s.id] [OpRightInv s.op s.inv s.id] : CommGroup s where
  op_assoc := op_assoc _
  op_comm := op_comm _
  op_right_id := op_right_id _
  op_right_inv := op_right_inv _

namespace CommGroup
variable {s} [self : CommGroup s]

protected theorem inv_hom (x y) : (x ⋆ y)⁻¹ = x⁻¹ ⋆ y⁻¹ := calc
  _ = y⁻¹ ⋆ x⁻¹ := by rw [inv_op s.inv x y]
  _ = x⁻¹ ⋆ y⁻¹ := by rw [op_comm (.⋆.) x⁻¹ y⁻¹]
instance : InvHom (no_index s.inv) (no_index s.op) := ⟨CommGroup.inv_hom⟩

instance toCancelCommMonoid : CancelCommMonoid (no_index s.toMonoidSig) := CancelCommMonoid.infer _

end CommGroup

end Algebra


/-
Copyright (c) 2021 Yury Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury Kudryashov

! This file was ported from Lean 3 source module analysis.calculus.fderiv_analytic
! leanprover-community/mathlib commit 17ef379e997badd73e5eabb4d38f11919ab3c4b3
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Analysis.Calculus.Deriv
import Mathbin.Analysis.Analytic.Basic
import Mathbin.Analysis.Calculus.ContDiff

/-!
# Frechet derivatives of analytic functions.

A function expressible as a power series at a point has a Frechet derivative there.
Also the special case in terms of `deriv` when the domain is 1-dimensional.
-/

open Filter Asymptotics

open ENNReal

variable {𝕜 : Type _} [NontriviallyNormedField 𝕜]

variable {E : Type _} [NormedAddCommGroup E] [NormedSpace 𝕜 E]

variable {F : Type _} [NormedAddCommGroup F] [NormedSpace 𝕜 F]

section fderiv

variable {p : FormalMultilinearSeries 𝕜 E F} {r : ℝ≥0∞}

variable {f : E → F} {x : E} {s : Set E}

theorem HasFpowerSeriesAt.hasStrictFderivAt (h : HasFpowerSeriesAt f p x) :
    HasStrictFderivAt f (continuousMultilinearCurryFin1 𝕜 E F (p 1)) x :=
  by
  refine' h.is_O_image_sub_norm_mul_norm_sub.trans_is_o (is_o.of_norm_right _)
  refine' is_o_iff_exists_eq_mul.2 ⟨fun y => ‖y - (x, x)‖, _, eventually_eq.rfl⟩
  refine' (continuous_id.sub continuous_const).norm.tendsto' _ _ _
  rw [_root_.id, sub_self, norm_zero]
#align has_fpower_series_at.has_strict_fderiv_at HasFpowerSeriesAt.hasStrictFderivAt

theorem HasFpowerSeriesAt.hasFderivAt (h : HasFpowerSeriesAt f p x) :
    HasFderivAt f (continuousMultilinearCurryFin1 𝕜 E F (p 1)) x :=
  h.HasStrictFderivAt.HasFderivAt
#align has_fpower_series_at.has_fderiv_at HasFpowerSeriesAt.hasFderivAt

theorem HasFpowerSeriesAt.differentiableAt (h : HasFpowerSeriesAt f p x) : DifferentiableAt 𝕜 f x :=
  h.HasFderivAt.DifferentiableAt
#align has_fpower_series_at.differentiable_at HasFpowerSeriesAt.differentiableAt

theorem AnalyticAt.differentiableAt : AnalyticAt 𝕜 f x → DifferentiableAt 𝕜 f x
  | ⟨p, hp⟩ => hp.DifferentiableAt
#align analytic_at.differentiable_at AnalyticAt.differentiableAt

theorem AnalyticAt.differentiableWithinAt (h : AnalyticAt 𝕜 f x) : DifferentiableWithinAt 𝕜 f s x :=
  h.DifferentiableAt.DifferentiableWithinAt
#align analytic_at.differentiable_within_at AnalyticAt.differentiableWithinAt

theorem HasFpowerSeriesAt.fderiv_eq (h : HasFpowerSeriesAt f p x) :
    fderiv 𝕜 f x = continuousMultilinearCurryFin1 𝕜 E F (p 1) :=
  h.HasFderivAt.fderiv
#align has_fpower_series_at.fderiv_eq HasFpowerSeriesAt.fderiv_eq

theorem HasFpowerSeriesOnBall.differentiableOn [CompleteSpace F]
    (h : HasFpowerSeriesOnBall f p x r) : DifferentiableOn 𝕜 f (EMetric.ball x r) := fun y hy =>
  (h.analyticAt_of_mem hy).DifferentiableWithinAt
#align has_fpower_series_on_ball.differentiable_on HasFpowerSeriesOnBall.differentiableOn

theorem AnalyticOn.differentiableOn (h : AnalyticOn 𝕜 f s) : DifferentiableOn 𝕜 f s := fun y hy =>
  (h y hy).DifferentiableWithinAt
#align analytic_on.differentiable_on AnalyticOn.differentiableOn

theorem HasFpowerSeriesOnBall.hasFderivAt [CompleteSpace F] (h : HasFpowerSeriesOnBall f p x r)
    {y : E} (hy : (‖y‖₊ : ℝ≥0∞) < r) :
    HasFderivAt f (continuousMultilinearCurryFin1 𝕜 E F (p.changeOrigin y 1)) (x + y) :=
  (h.changeOrigin hy).HasFpowerSeriesAt.HasFderivAt
#align has_fpower_series_on_ball.has_fderiv_at HasFpowerSeriesOnBall.hasFderivAt

theorem HasFpowerSeriesOnBall.fderiv_eq [CompleteSpace F] (h : HasFpowerSeriesOnBall f p x r)
    {y : E} (hy : (‖y‖₊ : ℝ≥0∞) < r) :
    fderiv 𝕜 f (x + y) = continuousMultilinearCurryFin1 𝕜 E F (p.changeOrigin y 1) :=
  (h.HasFderivAt hy).fderiv
#align has_fpower_series_on_ball.fderiv_eq HasFpowerSeriesOnBall.fderiv_eq

/-- If a function has a power series on a ball, then so does its derivative. -/
theorem HasFpowerSeriesOnBall.fderiv [CompleteSpace F] (h : HasFpowerSeriesOnBall f p x r) :
    HasFpowerSeriesOnBall (fderiv 𝕜 f)
      ((continuousMultilinearCurryFin1 𝕜 E F :
            (E[×1]→L[𝕜] F) →L[𝕜] E →L[𝕜] F).compFormalMultilinearSeries
        (p.changeOriginSeries 1))
      x r :=
  by
  suffices A :
    HasFpowerSeriesOnBall
      (fun z => continuousMultilinearCurryFin1 𝕜 E F (p.change_origin (z - x) 1))
      ((continuousMultilinearCurryFin1 𝕜 E F :
            (E[×1]→L[𝕜] F) →L[𝕜] E →L[𝕜] F).compFormalMultilinearSeries
        (p.change_origin_series 1))
      x r
  · apply A.congr
    intro z hz
    dsimp
    rw [← h.fderiv_eq, add_sub_cancel'_right]
    simpa only [edist_eq_coe_nnnorm_sub, EMetric.mem_ball] using hz
  suffices B :
    HasFpowerSeriesOnBall (fun z => p.change_origin (z - x) 1) (p.change_origin_series 1) x r
  exact
    (continuousMultilinearCurryFin1 𝕜 E
              F).toContinuousLinearEquiv.toContinuousLinearMap.compHasFpowerSeriesOnBall
      B
  simpa using
    ((p.has_fpower_series_on_ball_change_origin 1 (h.r_pos.trans_le h.r_le)).mono h.r_pos
          h.r_le).comp_sub
      x
#align has_fpower_series_on_ball.fderiv HasFpowerSeriesOnBall.fderiv

/-- If a function is analytic on a set `s`, so is its Fréchet derivative. -/
theorem AnalyticOn.fderiv [CompleteSpace F] (h : AnalyticOn 𝕜 f s) : AnalyticOn 𝕜 (fderiv 𝕜 f) s :=
  by
  intro y hy
  rcases h y hy with ⟨p, r, hp⟩
  exact hp.fderiv.analytic_at
#align analytic_on.fderiv AnalyticOn.fderiv

/-- If a function is analytic on a set `s`, so are its successive Fréchet derivative. -/
theorem AnalyticOn.iteratedFderiv [CompleteSpace F] (h : AnalyticOn 𝕜 f s) (n : ℕ) :
    AnalyticOn 𝕜 (iteratedFderiv 𝕜 n f) s :=
  by
  induction' n with n IH
  · rw [iteratedFderiv_zero_eq_comp]
    exact ((continuousMultilinearCurryFin0 𝕜 E F).symm : F →L[𝕜] E[×0]→L[𝕜] F).comp_analyticOn h
  · rw [iteratedFderiv_succ_eq_comp_left]
    apply
      (continuousMultilinearCurryLeftEquiv 𝕜 (fun i : Fin (n + 1) => E)
              F).toContinuousLinearEquiv.toContinuousLinearMap.comp_analyticOn
    exact IH.fderiv
#align analytic_on.iterated_fderiv AnalyticOn.iteratedFderiv

/-- An analytic function is infinitely differentiable. -/
theorem AnalyticOn.contDiffOn [CompleteSpace F] (h : AnalyticOn 𝕜 f s) {n : ℕ∞} :
    ContDiffOn 𝕜 n f s := by
  let t := { x | AnalyticAt 𝕜 f x }
  suffices : ContDiffOn 𝕜 n f t; exact this.mono h
  have H : AnalyticOn 𝕜 f t := fun x hx => hx
  have t_open : IsOpen t := isOpen_analyticAt 𝕜 f
  apply contDiffOn_of_continuousOn_differentiableOn
  · intro m hm
    apply (H.iterated_fderiv m).ContinuousOn.congr
    intro x hx
    exact iteratedFderivWithin_of_isOpen _ t_open hx
  · intro m hm
    apply (H.iterated_fderiv m).DifferentiableOn.congr
    intro x hx
    exact iteratedFderivWithin_of_isOpen _ t_open hx
#align analytic_on.cont_diff_on AnalyticOn.contDiffOn

end fderiv

section deriv

variable {p : FormalMultilinearSeries 𝕜 𝕜 F} {r : ℝ≥0∞}

variable {f : 𝕜 → F} {x : 𝕜} {s : Set 𝕜}

protected theorem HasFpowerSeriesAt.hasStrictDerivAt (h : HasFpowerSeriesAt f p x) :
    HasStrictDerivAt f (p 1 fun _ => 1) x :=
  h.HasStrictFderivAt.HasStrictDerivAt
#align has_fpower_series_at.has_strict_deriv_at HasFpowerSeriesAt.hasStrictDerivAt

protected theorem HasFpowerSeriesAt.hasDerivAt (h : HasFpowerSeriesAt f p x) :
    HasDerivAt f (p 1 fun _ => 1) x :=
  h.HasStrictDerivAt.HasDerivAt
#align has_fpower_series_at.has_deriv_at HasFpowerSeriesAt.hasDerivAt

protected theorem HasFpowerSeriesAt.deriv (h : HasFpowerSeriesAt f p x) :
    deriv f x = p 1 fun _ => 1 :=
  h.HasDerivAt.deriv
#align has_fpower_series_at.deriv HasFpowerSeriesAt.deriv

/-- If a function is analytic on a set `s`, so is its derivative. -/
theorem AnalyticOn.deriv [CompleteSpace F] (h : AnalyticOn 𝕜 f s) : AnalyticOn 𝕜 (deriv f) s :=
  (ContinuousLinearMap.apply 𝕜 F (1 : 𝕜)).comp_analyticOn h.fderiv
#align analytic_on.deriv AnalyticOn.deriv

/-- If a function is analytic on a set `s`, so are its successive derivatives. -/
theorem AnalyticOn.iterated_deriv [CompleteSpace F] (h : AnalyticOn 𝕜 f s) (n : ℕ) :
    AnalyticOn 𝕜 ((deriv^[n]) f) s := by
  induction' n with n IH
  · exact h
  · simpa only [Function.iterate_succ', Function.comp_apply] using IH.deriv
#align analytic_on.iterated_deriv AnalyticOn.iterated_deriv

end deriv


import Src.Prover.Func

namespace prover
noncomputable section

section union

def Union (a : Set) : Set :=
filter (some' # ax_union a) # λ b => ∃ c, c ∈ a ∧ b ∈ c

prefix:110 (priority := high) "⋃ " => Union

theorem mem_Union {a b} : b ∈ ⋃ a ↔ ∃ c, c ∈ a ∧ b ∈ c :=
iff_intro
(λ h => and_elim (mp mem_filter h) # λ _ => id)
(λ h => mpr mem_filter # and_intro
  (exi_elim h # λ c h₁ => some_spec (ax_union a) c b # and_symm h₁) h)

def union (a b : Set) : Set :=
⋃ upair a b

infixl:65 (priority := high) " ∪ " => union

theorem mem_union {a b c} : c ∈ a ∪ b ↔ c ∈ a ∨ c ∈ b :=
iff_trans mem_Union # iff_intro
(λ h => exi_elim h # λ d h₁ => and_elim h₁ # λ h₂ h₃ => or_elim (mp mem_upair h₂)
  (λ h₄ => or_inl # mp (mp eq_iff_mem h₄ c) h₃)
  (λ h₄ => or_inr # mp (mp eq_iff_mem h₄ c) h₃))
(λ h => or_elim h
  (λ h₁ => exi_intro a # and_intro left_mem_upair h₁)
  (λ h₁ => exi_intro b # and_intro right_mem_upair h₁))

theorem Union_emp : ⋃ ∅ = ∅ :=
mp empty_iff_eq_emp # mpr empty_iff # λ a h => exi_elim (mp mem_Union h) # λ b h₁ =>
not_mem_emp # and_left h₁

theorem Union_singleton {a} : ⋃ singleton a = a :=
mpr eq_iff_mem # λ b => iff_trans mem_Union # iff_intro
(λ h => exi_elim h # λ c h₁ => and_elim h₁ # λ h₂ h₃ =>
  mp (mp eq_iff_mem (mp mem_singleton h₂) b) h₃)
(λ h => exi_intro a # and_intro mem_singleton_self h)

theorem union_self {a} : a ∪ a = a :=
mpr eq_iff_mem # λ b => iff_trans mem_union or_self

theorem union_comm {a b} : a ∪ b = b ∪ a :=
mpr eq_iff_mem # λ c => iff_trans mem_union # iff_trans' mem_union or_symm'

end union

section insert

def insert (a b : Set) : Set :=
a ∪ singleton b

theorem mem_insert {a b c} : c ∈ insert a b ↔ c ∈ a ∨ c = b :=
iff_trans mem_union # iff_rec' (λ x => _ ∨ x ↔ _) mem_singleton iff_refl

theorem mem_of_mem_of_eq {a b c} (h₁ : a = b) (h₂ : c ∈ a) : c ∈ b :=
mp (mp eq_iff_mem h₁ c) h₂

theorem mem_of_mem_of_eq' {a b c} (h₁ : a = b) (h₂ : c ∈ b) : c ∈ a :=
mem_of_mem_of_eq (eq_symm h₁) h₂

theorem mem_of_mem_of_eq₁ {a b c} (h₁ : a = b) (h₂ : a ∈ c) : b ∈ c :=
eq_rec (λ x => x ∈ c) h₁ h₂

theorem mem_of_mem_of_eq₁' {a b c} (h₁ : a = b) (h₂ : b ∈ c) : a ∈ c :=
mem_of_mem_of_eq₁ (eq_symm h₁) h₂

theorem insert_eq_of_mem {a b} (h : b ∈ a) : insert a b = a :=
mpr eq_iff_mem # λ c => iff_trans mem_insert # iff_intro
(λ h₁ => or_elim h₁ id # λ h₂ => eq_rec' (λ x => x ∈ a) h₂ h) (λ h₁ => or_inl h₁)

end insert

section inter

def Inter (a : Set) : Set :=
filter (⋃ a) # λ b => ∀ c, c ∈ a → b ∈ c

prefix:110 (priority := high) "⋂ " => Inter

theorem mem_Inter {a b} : b ∈ ⋂ a ↔ b ∈ ⋃ a ∧ ∀ c, c ∈ a → b ∈ c :=
iff_trans mem_filter iff_refl

def inter (a b : Set) : Set :=
⋂ upair a b

infixl:65 (priority := high) " ∩ " => inter

theorem mem_inter {a b c} : c ∈ a ∩ b ↔ c ∈ a ∧ c ∈ b :=
iff_trans mem_Inter # iff_intro
(λ h => and_elim h # λ h₁ h₂ => and_intro (h₂ a left_mem_upair) (h₂ b right_mem_upair))
(λ h => and_intro (mpr mem_union # or_of_and h) # λ d h₁ => or_elim (mp mem_upair h₁)
  (λ h₂ => mem_of_mem_of_eq' h₂ # and_left h)
  (λ h₂ => mem_of_mem_of_eq' h₂ # and_right h))

theorem inter_self {a} : a ∩ a = a :=
mpr eq_iff_mem # λ b => iff_trans mem_inter and_self

theorem inter_comm {a b} : a ∩ b = b ∩ a :=
mpr eq_iff_mem # λ c => iff_trans mem_inter # iff_trans' mem_inter and_symm'

end inter

def succ (n : Set) : Set :=
insert n n

theorem mem_succ {n a} : a ∈ succ n ↔ a ∈ n ∨ a = n :=
mem_insert

def succ_is_succ {n} : is_succ (succ n) n :=
λ _ => mem_succ

theorem succ_zero : succ 0 = 1 :=
mpr eq_iff_mem # λ a => iff_trans mem_succ # iff_symm # iff_trans mem_one #
iff_intro or_inr # λ h => or_elim h (λ h₁ => exfalso # not_mem_zero h₁) id

theorem succ_one : succ 1 = 2 :=
mpr eq_iff_mem # λ a => iff_trans mem_succ # iff_symm # iff_trans mem_two #
or_iff_or_right # iff_symm mem_one

theorem is_succ_iff {n1 n} : is_succ n1 n ↔ n1 = succ n :=
iff_intro
(λ h => mpr eq_iff_mem # λ a => iff_symm # iff_trans mem_succ # iff_symm # h a)
(λ h => eq_rec' (λ x => is_succ x n) h succ_is_succ)

def Nat_like (S : Set) : Prop :=
0 ∈ S ∧ ∀ n, n ∈ S → succ n ∈ S

def ℕ : Set :=
⋂ filter (powerset some_inf) Nat_like

theorem Nat_like_some_inf : Nat_like some_inf :=
and_intro zero_mem_some_inf # λ n h => exi_elim (some_spec ax_inf') # λ a h₁ =>
and_right (and_right h₁) n h (succ n) succ_is_succ

theorem Nat_subset_some_inf : ℕ ⊆ some_inf :=
λ n h => and_right (mp mem_filter h) some_inf # mpr mem_filter #
and_intro mem_powerset_self Nat_like_some_inf

theorem zero_mem_Nat : 0 ∈ ℕ :=
mpr mem_Inter # and_intro
(mpr mem_Union # exi_intro some_inf # and_symm # and_intro zero_mem_some_inf #
  mpr mem_filter # and_intro mem_powerset_self Nat_like_some_inf)
(λ a h => and_left # and_right # mp mem_filter h)

theorem zero_mem_of_Nat_like {a} (h : Nat_like a) : 0 ∈ a :=
and_left h

theorem succ_mem_of_Nat_like {a n} (h₁ : Nat_like a) (h₂ : n ∈ a) : succ n ∈ a :=
and_right h₁ n h₂

theorem Nat_subset_of_subset_some_inf_of_Nat_like {a}
  (h₁ : Nat_like a) (h₂ : a ⊆ some_inf) : ℕ ⊆ a :=
λ n h₃ => and_right (mp mem_filter h₃) a # mpr mem_filter #
and_intro (mpr mem_powerset h₂) h₁

theorem succ_mem_Nat {n} (h : n ∈ ℕ) : succ n ∈ ℕ :=
mpr mem_Inter # and_intro
(mpr mem_Union # exi_intro some_inf # and_intro
  (mpr mem_filter # and_intro mem_powerset_self Nat_like_some_inf)
  (succ_mem_of_Nat_like Nat_like_some_inf # Nat_subset_some_inf n h))
(λ a h₁ => and_elim (mp mem_filter h₁) # λ h₂ h₃ =>
  hv (Nat_subset_of_subset_some_inf_of_Nat_like h₃ (mp mem_powerset h₂) n h) #
  succ_mem_of_Nat_like h₃)

theorem Nat_like_Nat : Nat_like ℕ :=
and_intro zero_mem_Nat # λ _ => succ_mem_Nat

theorem succ_ne_zero {n} : succ n ≠ 0 :=
λ h => mpr empty_iff_eq_emp h # exi_intro n # mpr mem_succ # or_inr rfl

theorem zero_ne_succ {n} : 0 ≠ succ n :=
ne_symm succ_ne_zero

theorem succ_inj_aux {m n a} (h₁ : succ m = succ n) (h₂ : a ∈ m) : a ∈ n :=
hv (iff_trans (mp eq_iff_mem h₁ a) mem_succ) # λ h₃ =>
hv (iff_symm # iff_trans (iff_symm h₃) mem_succ) # λ h₄ =>
or_elim (mp h₄ # or_inl h₂) id # λ h₅ => exfalso #
hv (iff_trans (mp eq_iff_mem h₁ m) mem_succ) # λ h₆ =>
hv (iff_symm # iff_trans (iff_symm h₆) mem_succ) # λ h₇ =>
or_elim (mp h₇ # or_inr rfl)
(λ h₈ => mem_asymm h₈ # mem_of_mem_of_eq₁ h₅ h₂)
(λ h₈ => @mem_irrefl a # mem_of_mem_of_eq' (eq_trans h₅ # eq_symm h₈) h₂)

theorem succ_inj {m n} (h : succ m = succ n) : m = n :=
mpr eq_iff_mem # λ a => iff_intro (succ_inj_aux h) (succ_inj_aux # eq_symm h)

theorem Nat_like_filter_of_ind (P : Set → Prop) {a} (h : Nat_like a)
  (h₁ : P 0) (h₂ : ∀ n, n ∈ a → P n → P (succ n)) : Nat_like (filter a P) :=
and_intro (mpr mem_filter # and_intro (zero_mem_of_Nat_like h) h₁) #
λ n h₃ => mpr mem_filter # and_elim (mp mem_filter h₃) # λ h₄ h₅ =>
and_symm # and_intro (h₂ n h₄ h₅) # succ_mem_of_Nat_like h h₄

theorem filter_subset_self {P : Set → Prop} {a} : filter a P ⊆ a :=
λ b h => and_left # mp mem_filter h

theorem filter_subset_of_subset {P : Set → Prop} {a b} (h : a ⊆ b) : filter a P ⊆ b :=
λ c h₁ => h c # and_left # mp mem_filter h₁

theorem Nat_ind (P : Set → Prop) {n}
  (h : n ∈ ℕ) (h₁ : P 0) (h₂ : ∀ n, n ∈ ℕ → P n → P (succ n)) : P n :=
hv (Nat_like_filter_of_ind P Nat_like_Nat h₁ h₂) # λ h₄ =>
hv (Nat_subset_of_subset_some_inf_of_Nat_like h₄
(filter_subset_of_subset Nat_subset_some_inf)) # λ h₅ =>
and_right # mp mem_filter (h₅ n h)

theorem ne_succ_self {n} (h : n ∈ ℕ) : n ≠ succ n :=
Nat_ind (λ x => x ≠ succ x) h zero_ne_succ #
λ n h₁ h₂ => cpos_nn h₂ # λ h₂ => succ_inj h₂

section pred

def pred (n : Set) : Set :=
some (λ k => succ k = n)

theorem pred_succ {n} : pred (succ n) = n :=
succ_inj # @some_spec _ _ (λ k => succ k = succ n) # exi_intro n rfl

theorem pred_one : pred 1 = 0 :=
eq_rec (λ x => pred x = 0) succ_zero pred_succ

end pred

section le

def le (m n : Set) : Prop :=
∃ (f : Set → Set), f 0 = m ∧ (∀ (k : Set), k ∈ ℕ → f (succ k) = succ (f k)) ∧
∃ (k : Set), k ∈ ℕ ∧ f k = n

infix:50 (priority := high) " ≤ " => le

theorem zero_le {n} (h : n ∈ ℕ) : 0 ≤ n :=
exi_intro id # and_intro rfl # and_intro (λ _ _ => rfl) # exi_intro n # and_intro h rfl

theorem le_of_succ_le_succ {m n}
  (h₁ : m ∈ ℕ) (h₂ : n ∈ ℕ) (h : succ m ≤ succ n) : m ≤ n :=
exi_elim h # λ f h₃ => exi_intro (λ x => pred (f x)) # and_elim h₃ # λ h₃ h₄ =>
and_elim h₄ # λ h₄ h₅ => and_intro (eq_rec' (λ x => pred x = m) h₃ pred_succ) #
and_intro
(λ k hk => eq_rec' (λ x => pred x = succ (pred (f k))) (h₄ k hk) #
  eq_rec' (λ x => x = succ (pred (f k))) pred_succ # eq_symm #
  Nat_ind (λ x => succ (pred (f x)) = f x) hk
  (eq_rec' (λ x => succ (pred x) = x) h₃ # congr_arg pred_succ) #
  λ k hk ih => eq_rec' (λ x => succ (pred x) = x) (h₄ k hk) # congr_arg pred_succ)
(exi_elim h₅ # λ k hk => and_elim hk # λ hk h₆ => exi_intro k # and_intro hk #
  eq_rec' (λ x => pred x = n) h₆ pred_succ)

theorem succ_le_succ_of_le {m n}
  (h₁ : m ∈ ℕ) (h₂ : n ∈ ℕ) (h : m ≤ n) : succ m ≤ succ n :=
exi_elim h # λ f h₃ => exi_intro (λ x => succ (f x)) # and_elim h₃ # λ h₃ h₄ =>
and_elim h₄ # λ h₄ h₅ => and_intro (congr_arg h₃) # and_intro
(λ k hk => eq_rec' (λ x => succ x = _) (h₄ k hk) rfl)
(exi_elim h₅ # λ k hk => and_elim hk # λ hk h₆ => exi_intro k # and_intro hk #
  congr_arg h₆)

theorem succ_le_succ_iff {m n} (h₁ : m ∈ ℕ) (h₂ : n ∈ ℕ) : succ m ≤ succ n ↔ m ≤ n :=
iff_intro (le_of_succ_le_succ h₁ h₂) (succ_le_succ_of_le h₁ h₂)

theorem le_refl {n} (h : n ∈ ℕ) : n ≤ n :=
Nat_ind (λ x => x ≤ x) h (zero_le zero_mem_Nat) #
λ n h ih => succ_le_succ_of_le h h ih

theorem le_succ_of_le {m n} (h₁ : m ∈ ℕ) (h₂ : n ∈ ℕ) (h₃ : m ≤ n) : m ≤ succ n :=
exi_elim h₃ # λ f h₁ => exi_intro f # and_elim h₁ # λ h₁ h₂ => and_elim h₂ #
λ h₂ h₃ => and_intro h₁ # and_intro h₂ # exi_elim h₃ # λ k hk => and_elim hk #
λ hk h₄ => exi_intro (succ k) # and_intro (succ_mem_Nat hk) # eq_trans (h₂ k hk) #
congr_arg h₄

theorem le_succ_self {n} (h : n ∈ ℕ) : n ≤ succ n :=
le_succ_of_le h h # le_refl h

theorem not_succ_le_zero {n} (h : n ∈ ℕ) : ¬succ n ≤ 0 :=
λ h₁ => exi_elim h₁ # λ f h₁ => and_elim h₁ # λ h₁ h₂ => and_elim h₂ # λ h₂ h₃ =>
exi_elim h₃ # λ k h₃ => and_elim h₃ # λ h₃ h₄ => Nat_ind (λ x => f x ≠ 0) h₃
(eq_rec' (λ x => x ≠ 0) h₁ succ_ne_zero)
(λ k h₃ ih => eq_rec' (λ x => x ≠ 0) (h₂ k h₃) succ_ne_zero) h₄

def lt (m n : Set) : Prop :=
m ≤ n ∧ m ≠ n

infix:50 (priority := high) " < " => lt

theorem lt_iff_le_and_ne {m n} (h₁ : m ∈ ℕ) (h₂ : n ∈ ℕ) : m < n ↔ m ≤ n ∧ m ≠ n :=
iff_refl

theorem le_of_eq {m n} (h₁ : m ∈ ℕ) (h₂ : n ∈ ℕ) (h₃ : m = n) : m ≤ n :=
eq_rec' (λ x => x ≤ n) h₃ # le_refl h₂

theorem eq_iff_lt_or_eq {m n} (h₁ : m ∈ ℕ) (h₂ : n ∈ ℕ) : m ≤ n ↔ m < n ∨ m = n :=
iff_intro (λ h => by_cases (m = n) or_inr # λ h₃ => or_inl # and_intro h h₃)
(λ h => or_elim h and_left # le_of_eq h₁ h₂)

theorem not_succ_le_self {n} (h : n ∈ ℕ) : ¬succ n ≤ n :=
Nat_ind (λ x => ¬succ x ≤ x) h (not_succ_le_zero zero_mem_Nat) #
λ n h ih => cpos_nn ih # λ ih => le_of_succ_le_succ (succ_mem_Nat h) h ih

theorem Nat_cases (P : Set → Prop) {n}
  (h₁ : n ∈ ℕ) (h₂ : P 0) (h₃ : ∀ n, n ∈ ℕ → P (succ n)) : P n :=
Nat_ind P h₁ h₂ # λ n h ih => h₃ n h

theorem eq_zero_or_succ {n} (h : n ∈ ℕ) : n = 0 ∨ ∃ m, n = succ m :=
Nat_cases (λ x => x = 0 ∨ ∃ m, x = succ m) h (or_inl rfl) #
λ n h => or_inr # exi_intro n rfl

-- theorem lt_succ_iff_le {m n} (h₁ : m ∈ ℕ) (h₂ : n ∈ ℕ) : m < succ n ↔ m ≤ n :=
-- sorry

-- theorem Nat_strong_ind (P : Set → Prop) {n} (h : n ∈ ℕ)
--   (h₁ : )

-- theorem le_trans {m n k} (h₁ : m ∈ ℕ) (h₂ : n ∈ ℕ) (h₃ : k ∈ ℕ)
--   (h₄ : m ≤ n) (h₅ : n ≤ k) : m ≤ k :=
-- _

end le


/-
Copyright (c) 2017 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
import data.nat.basic
import data.equiv.denumerable
import data.set.finite
import order.rel_iso
import order.preorder_hom
import order.conditionally_complete_lattice
import logic.function.iterate

namespace rel_embedding

variables {α : Type*} {r : α → α → Prop} [is_strict_order α r]

/-- If `f` is a strictly `r`-increasing sequence, then this returns `f` as an order embedding. -/
def nat_lt (f : ℕ → α) (H : ∀ n:ℕ, r (f n) (f (n+1))) :
  ((<) : ℕ → ℕ → Prop) ↪r r :=
of_monotone f $ λ a b h, begin
  induction b with b IH, {exact (nat.not_lt_zero _ h).elim},
  cases nat.lt_succ_iff_lt_or_eq.1 h with h e,
  { exact trans (IH h) (H _) },
  { subst b, apply H }
end

@[simp]
lemma nat_lt_apply {f : ℕ → α} {H : ∀ n:ℕ, r (f n) (f (n+1))} {n : ℕ} : nat_lt f H n = f n := rfl

/-- If `f` is a strictly `r`-decreasing sequence, then this returns `f` as an order embedding. -/
def nat_gt (f : ℕ → α) (H : ∀ n:ℕ, r (f (n+1)) (f n)) :
  ((>) : ℕ → ℕ → Prop) ↪r r :=
by haveI := is_strict_order.swap r; exact rel_embedding.swap (nat_lt f H)

theorem well_founded_iff_no_descending_seq :
  well_founded r ↔ ¬ nonempty (((>) : ℕ → ℕ → Prop) ↪r r) :=
⟨λ ⟨h⟩ ⟨⟨f, o⟩⟩,
  suffices ∀ a, acc r a → ∀ n, a ≠ f n, from this (f 0) (h _) 0 rfl,
  λ a ac, begin
    induction ac with a _ IH, intros n h, subst a,
    exact IH (f (n+1)) (o.2 (nat.lt_succ_self _)) _ rfl
  end,
λ N, ⟨λ a, classical.by_contradiction $ λ na,
  let ⟨f, h⟩ := classical.axiom_of_choice $
    show ∀ x : {a // ¬ acc r a}, ∃ y : {a // ¬ acc r a}, r y.1 x.1,
    from λ ⟨x, h⟩, classical.by_contradiction $ λ hn, h $
      ⟨_, λ y h, classical.by_contradiction $ λ na, hn ⟨⟨y, na⟩, h⟩⟩ in
  N ⟨nat_gt (λ n, (f^[n] ⟨a, na⟩).1) $ λ n,
    by { rw [function.iterate_succ'], apply h }⟩⟩⟩

end rel_embedding

namespace nat

variables (s : set ℕ) [decidable_pred s] [infinite s]
/-- An order embedding from `ℕ` to itself with a specified range -/
def order_embedding_of_set : ℕ ↪o ℕ :=
(rel_embedding.order_embedding_of_lt_embedding
  (rel_embedding.nat_lt (nat.subtype.of_nat s) (λ n, nat.subtype.lt_succ_self _))).trans
  (order_embedding.subtype s)

/-- `nat.subtype.of_nat` as an order isomorphism between `ℕ` and an infinite decidable subset. -/
noncomputable def subtype.order_iso_of_nat  :
  ℕ ≃o s :=
rel_iso.of_surjective (rel_embedding.order_embedding_of_lt_embedding
  (rel_embedding.nat_lt (nat.subtype.of_nat s) (λ n, nat.subtype.lt_succ_self _)))
  nat.subtype.of_nat_surjective

variable {s}

@[simp]
lemma order_embedding_of_set_apply {n : ℕ} : order_embedding_of_set s n = subtype.of_nat s n :=
rfl

@[simp]
lemma subtype.order_iso_of_nat_apply {n : ℕ} :
  subtype.order_iso_of_nat s n = subtype.of_nat s n :=
by { simp [subtype.order_iso_of_nat] }

variable (s)

@[simp]
lemma order_embedding_of_set_range : set.range (nat.order_embedding_of_set s) = s :=
begin
  ext x,
  rw [set.mem_range, nat.order_embedding_of_set],
  split; intro h,
  { rcases h with ⟨y, rfl⟩,
    simp },
  { refine ⟨(nat.subtype.order_iso_of_nat s).symm ⟨x, h⟩, _⟩,
    simp only [rel_embedding.coe_trans, rel_embedding.order_embedding_of_lt_embedding_apply,
      rel_embedding.nat_lt_apply, function.comp_app, order_embedding.subtype_apply],
    rw [← subtype.order_iso_of_nat_apply, order_iso.apply_symm_apply, subtype.coe_mk] }
end

end nat

theorem exists_increasing_or_nonincreasing_subseq' {α : Type*} (r : α → α → Prop) (f : ℕ → α) :
  ∃ (g : ℕ ↪o ℕ), (∀ n : ℕ, r (f (g n)) (f (g (n + 1)))) ∨
    (∀ m n : ℕ, m < n → ¬ r (f (g m)) (f (g n))) :=
begin
  classical,
  let bad : set ℕ := { m | ∀ n, m < n → ¬ r (f m) (f n) },
  by_cases hbad : infinite bad,
  { haveI := hbad,
    refine ⟨nat.order_embedding_of_set bad, or.intro_right _ (λ m n mn, _)⟩,
    have h := set.mem_range_self m,
    rw nat.order_embedding_of_set_range bad at h,
    exact h _ ((order_embedding.lt_iff_lt _).2 mn) },
  { rw [set.infinite_coe_iff, set.infinite, not_not] at hbad,
    obtain ⟨m, hm⟩ : ∃ m, ∀ n, m ≤ n → ¬ n ∈ bad,
    { by_cases he : hbad.to_finset.nonempty,
      { refine ⟨(hbad.to_finset.max' he).succ, λ n hn nbad, nat.not_succ_le_self _
        (hn.trans (hbad.to_finset.le_max' n (hbad.mem_to_finset.2 nbad)))⟩ },
      { exact ⟨0, λ n hn nbad, he ⟨n, hbad.mem_to_finset.2 nbad⟩⟩ } },
    have h : ∀ (n : ℕ), ∃ (n' : ℕ), n < n' ∧ r (f (n + m)) (f (n' + m)),
    { intro n,
      have h := hm _ (le_add_of_nonneg_left n.zero_le),
      simp only [exists_prop, not_not, set.mem_set_of_eq, not_forall] at h,
      obtain ⟨n', hn1, hn2⟩ := h,
      obtain ⟨x, hpos, rfl⟩ := exists_pos_add_of_lt hn1,
      refine ⟨n + x, add_lt_add_left hpos n, _⟩,
      rw [add_assoc, add_comm x m, ← add_assoc],
      exact hn2 },
    let g' : ℕ → ℕ := @nat.rec (λ _, ℕ) m (λ n gn, nat.find (h gn)),
    exact ⟨(rel_embedding.nat_lt (λ n, g' n + m)
      (λ n, nat.add_lt_add_right (nat.find_spec (h (g' n))).1 m)).order_embedding_of_lt_embedding,
      or.intro_left _ (λ n, (nat.find_spec (h (g' n))).2)⟩ }
end

theorem exists_increasing_or_nonincreasing_subseq
  {α : Type*} (r : α → α → Prop) [is_trans α r] (f : ℕ → α) :
  ∃ (g : ℕ ↪o ℕ), (∀ m n : ℕ, m < n → r (f (g m)) (f (g n))) ∨
    (∀ m n : ℕ, m < n → ¬ r (f (g m)) (f (g n))) :=
begin
  obtain ⟨g, hr | hnr⟩ := exists_increasing_or_nonincreasing_subseq' r f,
  { refine ⟨g, or.intro_left _ (λ m n mn, _)⟩,
    obtain ⟨x, rfl⟩ := le_iff_exists_add.1 (nat.succ_le_iff.2 mn),
    induction x with x ih,
    { apply hr },
    { apply is_trans.trans _ _ _ _ (hr _),
      exact ih (lt_of_lt_of_le m.lt_succ_self (nat.le_add_right _ _)) } },
  { exact ⟨g, or.intro_right _ hnr⟩ }
end

/-- The "monotone chain condition" below is sometimes a convenient form of well foundedness. -/
lemma well_founded.monotone_chain_condition (α : Type*) [partial_order α] :
  well_founded ((>) : α → α → Prop) ↔ ∀ (a : ℕ →ₘ α), ∃ n, ∀ m, n ≤ m → a n = a m :=
begin
  split; intros h,
  { rw well_founded.well_founded_iff_has_max' at h,
    intros a, have hne : (set.range a).nonempty, { use a 0, simp, },
    obtain ⟨x, ⟨n, hn⟩, range_bounded⟩ := h _ hne,
    use n, intros m hm, rw ← hn at range_bounded, symmetry,
    apply range_bounded (a m) (set.mem_range_self _) (a.monotone hm), },
  { rw rel_embedding.well_founded_iff_no_descending_seq, rintros ⟨a⟩,
    obtain ⟨n, hn⟩ := h (a.swap : ((<) : ℕ → ℕ → Prop) →r ((<) : α → α → Prop)).to_preorder_hom,
    exact n.succ_ne_self.symm (rel_embedding.to_preorder_hom_injective _ (hn _ n.le_succ)), },
end

/-- Given an eventually-constant monotonic sequence `a₀ ≤ a₁ ≤ a₂ ≤ ...` in a partially-ordered
type, `monotonic_sequence_limit_index a` is the least natural number `n` for which `aₙ` reaches the
constant value. For sequences that are not eventually constant, `monotonic_sequence_limit_index a`
is defined, but is a junk value. -/
noncomputable def monotonic_sequence_limit_index {α : Type*} [partial_order α] (a : ℕ →ₘ α) : ℕ :=
Inf { n | ∀ m, n ≤ m → a n = a m }

/-- The constant value of an eventually-constant monotonic sequence `a₀ ≤ a₁ ≤ a₂ ≤ ...` in a
partially-ordered type. -/
noncomputable def monotonic_sequence_limit {α : Type*} [partial_order α] (a : ℕ →ₘ α) :=
a (monotonic_sequence_limit_index a)

lemma well_founded.supr_eq_monotonic_sequence_limit {α : Type*} [complete_lattice α]
  (h : well_founded ((>) : α → α → Prop)) (a : ℕ →ₘ α) :
  (⨆ m, a m) = monotonic_sequence_limit a :=
begin
  suffices : (⨆ (m : ℕ), a m) ≤ monotonic_sequence_limit a,
  { exact le_antisymm this (le_supr a _), },
  apply supr_le,
  intros m,
  by_cases hm : m ≤ monotonic_sequence_limit_index a,
  { exact a.monotone hm, },
  { replace hm := le_of_not_le hm,
    let S := { n | ∀ m, n ≤ m → a n = a m },
    have hInf : Inf S ∈ S,
    { refine nat.Inf_mem _, rw well_founded.monotone_chain_condition at h, exact h a, },
    change Inf S ≤ m at hm,
    change a m ≤ a (Inf S),
    rw hInf m hm, },
end


lemma mul_one (m : mynat) : m * 1 = m :=
begin
rw one_eq_succ_zero,
rw mul_succ,
rw mul_zero,
simp,
end


variables A B C : Prop

premise P : A /\ (B -> C)

example : ((A->B)->C) :=
have H2: A, from and.left P,
have H3: (B->C), from and.right P,
assume H1 : (A->B),
show C, from H3 (H1 H2).


/-
Copyright (c) 2018 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Kenny Lau, Johan Commelin, Mario Carneiro, Kevin Buzzard,
Amelia Livingston, Yury Kudryashov
-/
import group_theory.subsemigroup.basic

/-!
# Submonoids: definition and `complete_lattice` structure

This file defines bundled multiplicative and additive submonoids. We also define
a `complete_lattice` structure on `submonoid`s, define the closure of a set as the minimal submonoid
that includes this set, and prove a few results about extending properties from a dense set (i.e.
a set with `closure s = ⊤`) to the whole monoid, see `submonoid.dense_induction` and
`monoid_hom.of_mdense`.

## Main definitions

* `submonoid M`: the type of bundled submonoids of a monoid `M`; the underlying set is given in
  the `carrier` field of the structure, and should be accessed through coercion as in `(S : set M)`.
* `add_submonoid M` : the type of bundled submonoids of an additive monoid `M`.

For each of the following definitions in the `submonoid` namespace, there is a corresponding
definition in the `add_submonoid` namespace.

* `submonoid.copy` : copy of a submonoid with `carrier` replaced by a set that is equal but possibly
  not definitionally equal to the carrier of the original `submonoid`.
* `submonoid.closure` :  monoid closure of a set, i.e., the least submonoid that includes the set.
* `submonoid.gi` : `closure : set M → submonoid M` and coercion `coe : submonoid M → set M`
  form a `galois_insertion`;
* `monoid_hom.eq_mlocus`: the submonoid of elements `x : M` such that `f x = g x`;
* `monoid_hom.of_mdense`:  if a map `f : M → N` between two monoids satisfies `f 1 = 1` and
  `f (x * y) = f x * f y` for `y` from some dense set `s`, then `f` is a monoid homomorphism.
  E.g., if `f : ℕ → M` satisfies `f 0 = 0` and `f (x + 1) = f x + f 1`, then `f` is an additive
  monoid homomorphism.

## Implementation notes

Submonoid inclusion is denoted `≤` rather than `⊆`, although `∈` is defined as
membership of a submonoid's underlying set.

Note that `submonoid M` does not actually require `monoid M`, instead requiring only the weaker
`mul_one_class M`.

This file is designed to have very few dependencies. In particular, it should not use natural
numbers. `submonoid` is implemented by extending `subsemigroup` requiring `one_mem'`.

## Tags
submonoid, submonoids
-/

variables {M : Type*} {N : Type*}
variables {A : Type*}

section non_assoc
variables [mul_one_class M] {s : set M}
variables [add_zero_class A] {t : set A}

/-- `one_mem_class S M` says `S` is a type of subsets `s ≤ M`, such that `1 ∈ s` for all `s`. -/
class one_mem_class (S : Type*) (M : out_param $ Type*) [has_one M] [set_like S M] :=
(one_mem : ∀ (s : S), (1 : M) ∈ s)

/-- `zero_mem_class S M` says `S` is a type of subsets `s ≤ M`, such that `0 ∈ s` for all `s`. -/
class zero_mem_class (S : Type*) (M : out_param $ Type*) [has_zero M] [set_like S M] :=
(zero_mem : ∀ (s : S), (0 : M) ∈ s)

/-- `mul_mem_class S M` says `S` is a type of subsets `s ≤ M` that are closed under `(*)` -/
class mul_mem_class (S : Type*) (M : out_param $ Type*) [has_mul M] [set_like S M] :=
(mul_mem : ∀ {s : S} {a b : M}, a ∈ s → b ∈ s → a * b ∈ s)

/-- `add_mem_class S M` says `S` is a type of subsets `s ≤ M` that are closed under `(+)` -/
class add_mem_class (S : Type*) (M : out_param $ Type*) [has_add M] [set_like S M] :=
(add_mem : ∀ {s : S} {a b : M}, a ∈ s → b ∈ s → a + b ∈ s)

export add_mem_class (add_mem)

attribute [to_additive] one_mem_class mul_mem_class

section

set_option old_structure_cmd true

/-- A submonoid of a monoid `M` is a subset containing 1 and closed under multiplication. -/
structure submonoid (M : Type*) [mul_one_class M] extends subsemigroup M :=
(one_mem' : (1 : M) ∈ carrier)

end

/-- A submonoid of a monoid `M` can be considered as a subsemigroup of that monoid. -/
add_decl_doc submonoid.to_subsemigroup

/-- `submonoid_class S M` says `S` is a type of subsets `s ≤ M` that contain `1`
and are closed under `(*)` -/
class submonoid_class (S : Type*) (M : out_param $ Type*) [mul_one_class M] [set_like S M]
  extends mul_mem_class S M :=
(one_mem : ∀ (s : S), (1 : M) ∈ s)

section

set_option old_structure_cmd true

/-- An additive submonoid of an additive monoid `M` is a subset containing 0 and
  closed under addition. -/
structure add_submonoid (M : Type*) [add_zero_class M] extends add_subsemigroup M :=
(zero_mem' : (0 : M) ∈ carrier)

end

/-- An additive submonoid of an additive monoid `M` can be considered as an
additive subsemigroup of that additive monoid. -/
add_decl_doc add_submonoid.to_add_subsemigroup

/-- `add_submonoid_class S M` says `S` is a type of subsets `s ≤ M` that contain `0`
and are closed under `(+)` -/
class add_submonoid_class (S : Type*) (M : out_param $ Type*) [add_zero_class M] [set_like S M]
  extends add_mem_class S M :=
(zero_mem : ∀ (s : S), (0 : M) ∈ s)

attribute [to_additive] submonoid submonoid_class

@[to_additive, priority 100] -- See note [lower instance priority]
instance submonoid_class.to_one_mem_class (S : Type*) (M : out_param $ Type*) [mul_one_class M]
  [set_like S M] [h : submonoid_class S M] : one_mem_class S M :=
{ ..h }

@[to_additive]
lemma pow_mem {M} [monoid M] {A : Type*} [set_like A M] [submonoid_class A M] {S : A} {x : M}
  (hx : x ∈ S) : ∀ (n : ℕ), x ^ n ∈ S
| 0 := by { rw pow_zero, exact one_mem_class.one_mem S }
| (n + 1) := by { rw pow_succ, exact mul_mem_class.mul_mem hx (pow_mem n) }

namespace submonoid

@[to_additive]
instance : set_like (submonoid M) M :=
{ coe := submonoid.carrier,
  coe_injective' := λ p q h, by cases p; cases q; congr' }

@[to_additive]
instance : submonoid_class (submonoid M) M :=
{ one_mem := submonoid.one_mem',
  mul_mem := submonoid.mul_mem' }

/-- See Note [custom simps projection] -/
@[to_additive " See Note [custom simps projection]"]
def simps.coe (S : submonoid M) : set M := S

initialize_simps_projections submonoid (carrier → coe)
initialize_simps_projections add_submonoid (carrier → coe)

@[simp, to_additive]
lemma mem_carrier {s : submonoid M} {x : M} : x ∈ s.carrier ↔ x ∈ s := iff.rfl

@[simp, to_additive]
lemma mem_mk {s : set M} {x : M} (h_one) (h_mul) : x ∈ mk s h_one h_mul ↔ x ∈ s := iff.rfl

@[simp, to_additive]
lemma coe_set_mk {s : set M} (h_one) (h_mul) : (mk s h_one h_mul : set M) = s := rfl

@[simp, to_additive]
lemma mk_le_mk {s t : set M} (h_one) (h_mul) (h_one') (h_mul') :
  mk s h_one h_mul ≤ mk t h_one' h_mul' ↔ s ⊆ t := iff.rfl

/-- Two submonoids are equal if they have the same elements. -/
@[ext, to_additive "Two `add_submonoid`s are equal if they have the same elements."]

/-- Copy a submonoid replacing `carrier` with a set that is equal to it. -/
@[to_additive "Copy an additive submonoid replacing `carrier` with a set that is equal to it."]
protected def copy (S : submonoid M) (s : set M) (hs : s = S) : submonoid M :=
{ carrier := s,
  one_mem' := hs.symm ▸ S.one_mem',
  mul_mem' := hs.symm ▸ S.mul_mem' }

variable {S : submonoid M}

@[simp, to_additive] lemma coe_copy {s : set M} (hs : s = S) :
  (S.copy s hs : set M) = s := rfl

@[to_additive] lemma copy_eq {s : set M} (hs : s = S) : S.copy s hs = S :=
set_like.coe_injective hs

variable (S)

/-- A submonoid contains the monoid's 1. -/
@[to_additive "An `add_submonoid` contains the monoid's 0."]
theorem one_mem : (1 : M) ∈ S := S.one_mem'

/-- A submonoid is closed under multiplication. -/
@[to_additive "An `add_submonoid` is closed under addition."]
theorem mul_mem {x y : M} : x ∈ S → y ∈ S → x * y ∈ S := submonoid.mul_mem' S

/-- The submonoid `M` of the monoid `M`. -/
@[to_additive "The additive submonoid `M` of the `add_monoid M`."]
instance : has_top (submonoid M) :=
⟨{ carrier := set.univ,
   one_mem' := set.mem_univ 1,
   mul_mem' := λ _ _ _ _, set.mem_univ _ }⟩

/-- The trivial submonoid `{1}` of an monoid `M`. -/
@[to_additive "The trivial `add_submonoid` `{0}` of an `add_monoid` `M`."]
instance : has_bot (submonoid M) :=
⟨{ carrier := {1},
   one_mem' := set.mem_singleton 1,
   mul_mem' := λ a b ha hb, by { simp only [set.mem_singleton_iff] at *, rw [ha, hb, mul_one] }}⟩

@[to_additive]
instance : inhabited (submonoid M) := ⟨⊥⟩

@[simp, to_additive] lemma mem_bot {x : M} : x ∈ (⊥ : submonoid M) ↔ x = 1 := set.mem_singleton_iff

@[simp, to_additive] lemma mem_top (x : M) : x ∈ (⊤ : submonoid M) := set.mem_univ x

@[simp, to_additive] lemma coe_top : ((⊤ : submonoid M) : set M) = set.univ := rfl

@[simp, to_additive] lemma coe_bot : ((⊥ : submonoid M) : set M) = {1} := rfl

/-- The inf of two submonoids is their intersection. -/
@[to_additive "The inf of two `add_submonoid`s is their intersection."]
instance : has_inf (submonoid M) :=
⟨λ S₁ S₂,
  { carrier := S₁ ∩ S₂,
    one_mem' := ⟨S₁.one_mem, S₂.one_mem⟩,
    mul_mem' := λ _ _ ⟨hx, hx'⟩ ⟨hy, hy'⟩,
      ⟨S₁.mul_mem hx hy, S₂.mul_mem hx' hy'⟩ }⟩

@[simp, to_additive]
lemma coe_inf (p p' : submonoid M) : ((p ⊓ p' : submonoid M) : set M) = p ∩ p' := rfl

@[simp, to_additive]
lemma mem_inf {p p' : submonoid M} {x : M} : x ∈ p ⊓ p' ↔ x ∈ p ∧ x ∈ p' := iff.rfl

@[to_additive]
instance : has_Inf (submonoid M) :=
⟨λ s,
{ carrier := ⋂ t ∈ s, ↑t,
  one_mem' := set.mem_bInter $ λ i h, i.one_mem,
  mul_mem' := λ x y hx hy, set.mem_bInter $ λ i h,
    i.mul_mem (by apply set.mem_Inter₂.1 hx i h) (by apply set.mem_Inter₂.1 hy i h) }⟩

@[simp, norm_cast, to_additive]
lemma coe_Inf (S : set (submonoid M)) : ((Inf S : submonoid M) : set M) = ⋂ s ∈ S, ↑s := rfl

@[to_additive]
lemma mem_Inf {S : set (submonoid M)} {x : M} : x ∈ Inf S ↔ ∀ p ∈ S, x ∈ p := set.mem_Inter₂

@[to_additive]
lemma mem_infi {ι : Sort*} {S : ι → submonoid M} {x : M} : (x ∈ ⨅ i, S i) ↔ ∀ i, x ∈ S i :=
by simp only [infi, mem_Inf, set.forall_range_iff]

@[simp, norm_cast, to_additive]
lemma coe_infi {ι : Sort*} {S : ι → submonoid M} : (↑(⨅ i, S i) : set M) = ⋂ i, S i :=
by simp only [infi, coe_Inf, set.bInter_range]

/-- Submonoids of a monoid form a complete lattice. -/
@[to_additive "The `add_submonoid`s of an `add_monoid` form a complete lattice."]
instance : complete_lattice (submonoid M) :=
{ le           := (≤),
  lt           := (<),
  bot          := (⊥),
  bot_le       := λ S x hx, (mem_bot.1 hx).symm ▸ S.one_mem,
  top          := (⊤),
  le_top       := λ S x hx, mem_top x,
  inf          := (⊓),
  Inf          := has_Inf.Inf,
  le_inf       := λ a b c ha hb x hx, ⟨ha hx, hb hx⟩,
  inf_le_left  := λ a b x, and.left,
  inf_le_right := λ a b x, and.right,
  .. complete_lattice_of_Inf (submonoid M) $ λ s,
    is_glb.of_image (λ S T,
      show (S : set M) ≤ T ↔ S ≤ T, from set_like.coe_subset_coe) is_glb_binfi }

@[simp, to_additive]
lemma subsingleton_iff : subsingleton (submonoid M) ↔ subsingleton M :=
⟨ λ h, by exactI ⟨λ x y,
    have ∀ i : M, i = 1 := λ i, mem_bot.mp $ subsingleton.elim (⊤ : submonoid M) ⊥ ▸ mem_top i,
    (this x).trans (this y).symm⟩,
  λ h, by exactI ⟨λ x y, submonoid.ext $ λ i, subsingleton.elim 1 i ▸ by simp [submonoid.one_mem]⟩⟩

@[simp, to_additive]
lemma nontrivial_iff : nontrivial (submonoid M) ↔ nontrivial M :=
not_iff_not.mp (
  (not_nontrivial_iff_subsingleton.trans subsingleton_iff).trans
  not_nontrivial_iff_subsingleton.symm)

@[to_additive]
instance [subsingleton M] : unique (submonoid M) :=
⟨⟨⊥⟩, λ a, @subsingleton.elim _ (subsingleton_iff.mpr ‹_›) a _⟩

@[to_additive]
instance [nontrivial M] : nontrivial (submonoid M) := nontrivial_iff.mpr ‹_›

/-- The `submonoid` generated by a set. -/
@[to_additive "The `add_submonoid` generated by a set"]
def closure (s : set M) : submonoid M := Inf {S | s ⊆ S}

@[to_additive]
lemma mem_closure {x : M} : x ∈ closure s ↔ ∀ S : submonoid M, s ⊆ S → x ∈ S :=
mem_Inf

/-- The submonoid generated by a set includes the set. -/
@[simp, to_additive "The `add_submonoid` generated by a set includes the set."]
lemma subset_closure : s ⊆ closure s := λ x hx, mem_closure.2 $ λ S hS, hS hx

@[to_additive]
lemma not_mem_of_not_mem_closure {P : M} (hP : P ∉ closure s) : P ∉ s := λ h, hP (subset_closure h)

variable {S}
open set

/-- A submonoid `S` includes `closure s` if and only if it includes `s`. -/
@[simp, to_additive "An additive submonoid `S` includes `closure s` if and only if it includes `s`"]
lemma closure_le : closure s ≤ S ↔ s ⊆ S :=
⟨subset.trans subset_closure, λ h, Inf_le h⟩

/-- Submonoid closure of a set is monotone in its argument: if `s ⊆ t`,
then `closure s ≤ closure t`. -/
@[to_additive "Additive submonoid closure of a set is monotone in its argument: if `s ⊆ t`,
then `closure s ≤ closure t`"]
lemma closure_mono ⦃s t : set M⦄ (h : s ⊆ t) : closure s ≤ closure t :=
closure_le.2 $ subset.trans h subset_closure

@[to_additive]
lemma closure_eq_of_le (h₁ : s ⊆ S) (h₂ : S ≤ closure s) : closure s = S :=
le_antisymm (closure_le.2 h₁) h₂

variable (S)

/-- An induction principle for closure membership. If `p` holds for `1` and all elements of `s`, and
is preserved under multiplication, then `p` holds for all elements of the closure of `s`. -/
@[elab_as_eliminator, to_additive "An induction principle for additive closure membership. If `p`
holds for `0` and all elements of `s`, and is preserved under addition, then `p` holds for all
elements of the additive closure of `s`."]
lemma closure_induction {p : M → Prop} {x} (h : x ∈ closure s)
  (Hs : ∀ x ∈ s, p x) (H1 : p 1)
  (Hmul : ∀ x y, p x → p y → p (x * y)) : p x :=
(@closure_le _ _ _ ⟨p, Hmul, H1⟩).2 Hs h

/-- A dependent version of `submonoid.closure_induction`.  -/
@[elab_as_eliminator, to_additive "A dependent version of `add_submonoid.closure_induction`. "]
lemma closure_induction' (s : set M) {p : Π x, x ∈ closure s → Prop}
  (Hs : ∀ x (h : x ∈ s), p x (subset_closure h))
  (H1 : p 1 (one_mem _))
  (Hmul : ∀ x hx y hy, p x hx → p y hy → p (x * y) (mul_mem _ hx hy))
  {x} (hx : x ∈ closure s) :
  p x hx :=
begin
  refine exists.elim _ (λ (hx : x ∈ closure s) (hc : p x hx), hc),
  exact closure_induction hx
    (λ x hx, ⟨_, Hs x hx⟩) ⟨_, H1⟩ (λ x y ⟨hx', hx⟩ ⟨hy', hy⟩, ⟨_, Hmul _ _ _ _ hx hy⟩),
end

/-- An induction principle for closure membership for predicates with two arguments.  -/
@[elab_as_eliminator, to_additive "An induction principle for additive closure membership for
predicates with two arguments."]
lemma closure_induction₂ {p : M → M → Prop} {x} {y : M} (hx : x ∈ closure s) (hy : y ∈ closure s)
  (Hs : ∀ (x ∈ s) (y ∈ s), p x y)
  (H1_left : ∀ x, p 1 x)
  (H1_right : ∀ x, p x 1)
  (Hmul_left : ∀ x y z, p x z → p y z → p (x * y) z)
  (Hmul_right : ∀ x y z, p z x → p z y → p z (x * y)) : p x y :=
closure_induction hx
  (λ x xs, closure_induction hy (Hs x xs) (H1_right x) (λ z y h₁ h₂, Hmul_right z _ _ h₁ h₂))
  (H1_left y) (λ x z h₁ h₂, Hmul_left _ _ _ h₁ h₂)

/-- If `s` is a dense set in a monoid `M`, `submonoid.closure s = ⊤`, then in order to prove that
some predicate `p` holds for all `x : M` it suffices to verify `p x` for `x ∈ s`, verify `p 1`,
and verify that `p x` and `p y` imply `p (x * y)`. -/
@[elab_as_eliminator, to_additive "If `s` is a dense set in an additive monoid `M`,
`add_submonoid.closure s = ⊤`, then in order to prove that some predicate `p` holds for all `x : M`
it suffices to verify `p x` for `x ∈ s`, verify `p 0`, and verify that `p x` and `p y` imply
`p (x + y)`."]
lemma dense_induction {p : M → Prop} (x : M) {s : set M} (hs : closure s = ⊤)
  (Hs : ∀ x ∈ s, p x) (H1 : p 1)
  (Hmul : ∀ x y, p x → p y → p (x * y)) : p x :=
have ∀ x ∈ closure s, p x, from λ x hx, closure_induction hx Hs H1 Hmul,
by simpa [hs] using this x

variable (M)

/-- `closure` forms a Galois insertion with the coercion to set. -/
@[to_additive "`closure` forms a Galois insertion with the coercion to set."]
protected def gi : galois_insertion (@closure M _) coe :=
{ choice := λ s _, closure s,
  gc := λ s t, closure_le,
  le_l_u := λ s, subset_closure,
  choice_eq := λ s h, rfl }

variable {M}

/-- Closure of a submonoid `S` equals `S`. -/
@[simp, to_additive "Additive closure of an additive submonoid `S` equals `S`"]
lemma closure_eq : closure (S : set M) = S := (submonoid.gi M).l_u_eq S

@[simp, to_additive] lemma closure_empty : closure (∅ : set M) = ⊥ :=
(submonoid.gi M).gc.l_bot

@[simp, to_additive] lemma closure_univ : closure (univ : set M) = ⊤ :=
@coe_top M _ ▸ closure_eq ⊤

@[to_additive]
lemma closure_union (s t : set M) : closure (s ∪ t) = closure s ⊔ closure t :=
(submonoid.gi M).gc.l_sup

@[to_additive]
lemma closure_Union {ι} (s : ι → set M) : closure (⋃ i, s i) = ⨆ i, closure (s i) :=
(submonoid.gi M).gc.l_supr

@[simp, to_additive]
lemma closure_singleton_le_iff_mem (m : M) (p : submonoid M) :
  closure {m} ≤ p ↔ m ∈ p :=
by rw [closure_le, singleton_subset_iff, set_like.mem_coe]

@[to_additive]
lemma mem_supr {ι : Sort*} (p : ι → submonoid M) {m : M} :
  (m ∈ ⨆ i, p i) ↔ (∀ N, (∀ i, p i ≤ N) → m ∈ N) :=
begin
  rw [← closure_singleton_le_iff_mem, le_supr_iff],
  simp only [closure_singleton_le_iff_mem],
end

@[to_additive]
lemma supr_eq_closure {ι : Sort*} (p : ι → submonoid M) :
  (⨆ i, p i) = submonoid.closure (⋃ i, (p i : set M)) :=
by simp_rw [submonoid.closure_Union, submonoid.closure_eq]

@[to_additive]
lemma disjoint_def {p₁ p₂ : submonoid M} :
  disjoint p₁ p₂ ↔ ∀ {x : M}, x ∈ p₁ → x ∈ p₂ → x = 1 :=
show (∀ x, x ∈ p₁ ∧ x ∈ p₂ → x ∈ ({1} : set M)) ↔ _, by simp

@[to_additive]
lemma disjoint_def' {p₁ p₂ : submonoid M} :
  disjoint p₁ p₂ ↔ ∀ {x y : M}, x ∈ p₁ → y ∈ p₂ → x = y → x = 1 :=
disjoint_def.trans ⟨λ h x y hx hy hxy, h hx $ hxy.symm ▸ hy,
  λ h x hx hx', h hx hx' rfl⟩

end submonoid

namespace monoid_hom

variables [mul_one_class N]

open submonoid

/-- The submonoid of elements `x : M` such that `f x = g x` -/
@[to_additive "The additive submonoid of elements `x : M` such that `f x = g x`"]
def eq_mlocus (f g : M →* N) : submonoid M :=
{ carrier := {x | f x = g x},
  one_mem' := by rw [set.mem_set_of_eq, f.map_one, g.map_one],
  mul_mem' := λ x y (hx : _ = _) (hy : _ = _), by simp [*] }

/-- If two monoid homomorphisms are equal on a set, then they are equal on its submonoid closure. -/
@[to_additive]
lemma eq_on_mclosure {f g : M →* N} {s : set M} (h : set.eq_on f g s) :
  set.eq_on f g (closure s) :=
show closure s ≤ f.eq_mlocus g, from closure_le.2 h

@[to_additive]
lemma eq_of_eq_on_mtop {f g : M →* N} (h : set.eq_on f g (⊤ : submonoid M)) :
  f = g :=
ext $ λ x, h trivial

@[to_additive]
lemma eq_of_eq_on_mdense {s : set M} (hs : closure s = ⊤) {f g : M →* N} (h : s.eq_on f g) :
  f = g :=
eq_of_eq_on_mtop $ hs ▸ eq_on_mclosure h

end monoid_hom

end non_assoc

section assoc

variables [monoid M] [monoid N] {s : set M}

section is_unit

/-- The submonoid consisting of the units of a monoid -/
@[to_additive "The additive submonoid consisting of the additive units of an additive monoid"]
def is_unit.submonoid (M : Type*) [monoid M] : submonoid M :=
{ carrier := set_of is_unit,
  one_mem' := by simp only [is_unit_one, set.mem_set_of_eq],
  mul_mem' := by { intros a b ha hb, rw set.mem_set_of_eq at *, exact is_unit.mul ha hb } }

@[to_additive]
lemma is_unit.mem_submonoid_iff {M : Type*} [monoid M] (a : M) :
  a ∈ is_unit.submonoid M ↔ is_unit a :=
begin
  change a ∈ set_of is_unit ↔ is_unit a,
  rw set.mem_set_of_eq
end

end is_unit

namespace monoid_hom

open submonoid

/-- Let `s` be a subset of a monoid `M` such that the closure of `s` is the whole monoid.
Then `monoid_hom.of_mdense` defines a monoid homomorphism from `M` asking for a proof
of `f (x * y) = f x * f y` only for `y ∈ s`. -/
@[to_additive]
def of_mdense {M N} [monoid M] [monoid N] {s : set M} (f : M → N) (hs : closure s = ⊤)
  (h1 : f 1 = 1) (hmul : ∀ x (y ∈ s), f (x * y) = f x * f y) :
  M →* N :=
{ to_fun := f,
  map_one' := h1,
  map_mul' := λ x y, dense_induction y hs (λ y hy x, hmul x y hy) (by simp [h1])
    (λ y₁ y₂ h₁ h₂ x, by simp only [← mul_assoc, h₁, h₂]) x }

/-- Let `s` be a subset of an additive monoid `M` such that the closure of `s` is the whole monoid.
Then `add_monoid_hom.of_mdense` defines an additive monoid homomorphism from `M` asking for a proof
of `f (x + y) = f x + f y` only for `y ∈ s`. -/
add_decl_doc add_monoid_hom.of_mdense

@[simp, norm_cast, to_additive] lemma coe_of_mdense (f : M → N) (hs : closure s = ⊤) (h1 hmul) :
  ⇑(of_mdense f hs h1 hmul) = f := rfl

end monoid_hom

end assoc


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

-/

import data.nat.choose data.fintype.basic
import data.fin_extra
import tactic.squeeze tactic.linarith

namespace simplicial

namespace infinite

def δ (i j : ℕ) : ℕ := if j < i then j else j + 1

def σ (i j : ℕ) : ℕ := if j ≤ i then j else j - 1

lemma δ_zero (j : ℕ) : δ 0 j = j + 1 := if_neg (nat.not_lt_zero j)

lemma σ_zero (j : ℕ) : σ 0 j = j - 1 :=
by { cases j, refl, exact if_neg (nat.not_succ_le_zero j) }

lemma δ_ge (i j : ℕ) : j ≤ δ i j :=
by { dsimp[δ], split_ifs with h, exact le_refl j, exact le_of_lt j.lt_succ_self }

lemma σ_le (i j : ℕ) : σ i j ≤ j :=
by { dsimp[σ], split_ifs with h, exact le_refl j, exact j.pred_le }

lemma δδ (i j : ℕ) (hji : j ≤ i) : (δ j) ∘ (δ i) = δ (i + 1) ∘ (δ j) :=
begin
  ext k,
  simp only [function.comp_app, δ],
  { by_cases hkj : k < j,
    { have hki : k < i := lt_of_lt_of_le hkj hji,
      rw [if_pos hki, if_pos hkj, if_pos (lt_trans hki i.lt_succ_self)] },
    { by_cases hki : k < i,
      { rw [if_pos hki, if_neg hkj, if_pos (nat.succ_lt_succ hki)] },
      { rw [if_neg hki, if_neg hkj, if_neg (λ h, hki (nat.lt_of_succ_lt_succ h))],
        rw [if_neg (λ h, hkj (lt_trans k.lt_succ_self h))] } } }
end

lemma σσ (i j : ℕ) (hij : i ≤ j) : (σ j) ∘ (σ i) = (σ  i) ∘ (σ (j + 1)) :=
begin
  ext k,
  simp only [function.comp_app, σ],
  { by_cases hki : k ≤ i,
    { have hkj : k ≤ j := le_trans hki hij,
      rw [if_pos hki, if_pos hkj, if_pos (le_trans hkj (le_of_lt j.lt_succ_self)), if_pos hki] },
    { rw [if_neg hki],
      have hki' := lt_of_not_ge hki,
      cases k with k₀, {exfalso, exact nat.not_lt_zero i hki'},
      have hk : k₀.succ - 1 = k₀ := nat.pred_succ k₀, rw [hk],
      by_cases hkj : k₀ ≤ j,
      { rw [if_pos hkj, if_pos (nat.succ_le_succ hkj), if_neg hki, hk] },
      { rw [if_neg hkj, if_neg (λ h, hkj (nat.le_of_succ_le_succ h))],
        rw [if_neg (not_le_of_gt (lt_of_le_of_lt hij (lt_of_not_ge hkj)))] } } }
end

lemma σδ₀ (i j : ℕ) (hij : i + 1 < j) : (σ i) ∘ (δ j) = (δ (j - 1)) ∘ (σ i) :=
begin
  ext k,
  simp only [function.comp_app, σ, δ],
  by_cases hki : k ≤ i,
  { rw [if_pos hki, if_pos (lt_trans (lt_of_le_of_lt hki i.lt_succ_self) hij), if_pos hki],
    rw [if_pos (lt_of_le_of_lt hki (nat.lt_pred_iff.mpr hij) : k < j - 1)] },
  { rw [if_neg hki],
    have hk : k ≠ 0 := λ h, (h ▸ hki) (nat.zero_le i),
    have hj : j ≠ 0 := λ h, nat.not_lt_zero (i + 1) (h ▸ hij),
    have hj' : (j - 1).succ = j := nat.succ_pred_eq_of_pos (nat.pos_of_ne_zero hj),
    have hk' : (k - 1).succ = k := nat.succ_pred_eq_of_pos (nat.pos_of_ne_zero hk),
    by_cases hkj : k < j,
    { have hkj' : k - 1 < j - 1 := nat.pred_lt_pred hk hkj,
      rw [if_pos hkj, if_neg hki, if_pos hkj'] },
    { rw [if_neg hkj, if_neg (λ h, hki (le_trans (le_of_lt k.lt_succ_self) h))],
      have : ¬ (k - 1 < j - 1) := λ h,
      begin
       replace h := nat.succ_lt_succ h,
       rw [hj', hk'] at h, exact hkj h,
      end,
      rw [if_neg this, nat.add_sub_cancel],
      have : k - 1 + 1 = k := hk', rw [this] } }
end

lemma σδ₁ (i : ℕ) : (σ i) ∘ (δ i) = id :=
begin
  ext k,
  simp only [function.comp_app, σ, δ, id],
  by_cases hk : k < i,
  { rw [if_pos hk, if_pos (le_of_lt hk)] },
  { rw [if_neg hk],
    rw [if_neg (λ h, hk (lt_of_lt_of_le k.lt_succ_self h)), nat.add_sub_cancel] }
end

lemma σδ₂ (i : ℕ) : (σ i) ∘ (δ (i + 1)) = id :=
begin
  ext k,
  simp only [function.comp_app, σ, δ, id],
  by_cases hk : k < i + 1,
  { rw [if_pos hk, if_pos (nat.le_of_lt_succ hk)] },
  { rw [if_neg hk],
    have : ¬ (k + 1 ≤ i) := λ h,
      hk (lt_trans (lt_of_lt_of_le k.lt_succ_self h) i.lt_succ_self),
    rw [if_neg this, nat.add_sub_cancel] }
end

lemma σδ₃ (i j : ℕ) (hji : j < i) : (σ i) ∘ (δ j) = (δ j) ∘ (σ (i - 1)) :=
begin
  cases i with i₀, { cases hji },
  replace hji := nat.le_of_lt_succ hji,
  ext k,
  simp only [function.comp_app, σ, δ, nat.succ_eq_add_one, nat.add_sub_cancel],
  by_cases hkj : k < j,
  { have hki : k < i₀ := lt_of_lt_of_le hkj hji,
    rw [if_pos hkj, if_pos (le_of_lt (lt_trans hki i₀.lt_succ_self)),
        if_pos (le_of_lt hki), if_pos hkj] },
  { rw [if_neg hkj, nat.add_sub_cancel],
    by_cases hki : k ≤ i₀,
    { rw [if_pos hki, if_pos (nat.succ_le_succ hki), if_neg hkj], },
    { rw [if_neg hki, if_neg (λ h, hki (nat.le_of_succ_le_succ h))],
      cases k with k₀, {exfalso, exact hki (nat.zero_le i₀)},
      have : k₀.succ - 1 = k₀ := nat.pred_succ k₀, rw [this],
      have : ¬ (k₀ < j) := λ h, hki (lt_of_lt_of_le h hji),
      rw [if_neg this] } }
end

lemma σδ (i j : ℕ) : (σ i) ∘ (δ j) =
  if (j < i) then (δ j) ∘ (σ (i - 1))
  else ( if j ≤ i + 1 then id
  else δ (j - 1) ∘ (σ i)) :=
begin
  split_ifs with h₀ h₁,
  { exact σδ₃ i j h₀ },
  { by_cases h₂ : j ≤ i,
    { rw [le_antisymm h₂ (le_of_not_gt h₀), σδ₁] },
    { rw [le_antisymm h₁ (lt_of_not_ge h₂), σδ₂] } },
  { exact σδ₀ i j (lt_of_not_ge h₁) }
end

lemma σδ_pred (i : ℕ) : (σ i.pred) ∘ (δ i) = id :=
begin
  cases i with i₀,
  { simp[σδ, lt_irrefl], },
  { have : ¬ (1 < 0) := dec_trivial,
    simp[σδ, nat.succ_eq_add_one, le_refl i₀, this] }
end

lemma δσ_pred {i k : ℕ} (h : k ≠ i) : δ i (σ i.pred k) = k :=
begin
  cases i with i₀,
  { cases k with k₀, { exfalso, exact h rfl },
    rw [nat.pred_zero,
        simplicial.infinite.δ_zero, simplicial.infinite.σ_zero,
        nat.succ_eq_add_one, nat.add_sub_cancel] },
  { rw [nat.pred_succ, simplicial.infinite.σ, simplicial.infinite.δ],
    by_cases h' : k ≤ i₀,
    { rw [if_pos h', if_pos (nat.lt_succ_of_le h')] },
    { rw [if_neg h'],
      rw [if_neg (not_lt_of_ge (nat.le_pred_of_lt (lt_of_le_of_ne
             (nat.succ_le_of_lt (lt_of_not_ge h')) h.symm)))],
      cases k with k₀,
      { exfalso, exact h' (nat.zero_le i₀) },
      { rw [nat.succ_eq_add_one, nat.add_sub_cancel] } } }
end

lemma δ_bound {n i k : ℕ} (hi : i < n + 1) (hk : k < n) : δ i k < n + 1 :=
begin
  rw [δ], split_ifs,
  { exact lt_trans hk n.lt_succ_self },
  { exact nat.succ_lt_succ hk }
end

lemma δ_bound' (i k : ℕ) : k ≤ δ i k ∧ δ i k ≤ k + 1 :=
begin
  dsimp [δ],
  by_cases h : k < i,
  { rw [if_pos h], exact ⟨le_refl k,le_of_lt k.lt_succ_self⟩  },
  { rw [if_neg h], exact ⟨le_of_lt k.lt_succ_self, le_refl _⟩ }
end

lemma σ_bound {n i k : ℕ} (hi : i < n) (hk : k < n + 1) : σ i k < n :=
begin
  rw [σ], split_ifs,
  { exact lt_of_le_of_lt h hi },
  { have : k ≠ 0 := λ hz, (hz ▸ h) (nat.zero_le i),
    exact nat.pred_lt_pred this hk }
end

lemma σ_bound' (i k : ℕ) : k - 1 ≤ σ i k ∧ σ i k ≤ k :=
begin
  dsimp [σ],
  by_cases h : k ≤ i,
  { rw [if_pos h], exact ⟨nat.pred_le k,le_refl k⟩ },
  { rw [if_neg h], exact ⟨le_refl _, nat.pred_le k⟩ }
end

lemma δ_inj (i : ℕ) : function.injective (δ i) := λ j₀ j₁ e,
begin
  replace e := congr_arg (σ i) e,
  have := function.comp_app (σ i) (δ i),
  rw [← this, ← this, σδ₁, id] at e, exact e
end

lemma σ_surj (i : ℕ) : function.surjective (σ i) := λ j,
begin
  use δ i j, rw [← function.comp_app (σ i) (δ i), σδ₁, id]
end

lemma δ_ne (i k : ℕ) : δ i k ≠ i :=
begin
  rw [δ], split_ifs with h; intro e; rw [← e] at h,
  { exact lt_irrefl k h }, { exact h k.lt_succ_self }
end

lemma δ_image (i j : ℕ) : (∃ k, δ i k = j) ↔ j ≠ i :=
begin
  split,
  { rintro ⟨k,e⟩, rw [← e], intro e', exact δ_ne i k e' },
  { intro hne,
    by_cases hle : j ≤ i,
    { use j, rw [δ, if_pos (lt_of_le_of_ne hle hne)] },
    { have hlt := lt_of_not_ge hle,
      cases j with j₀, { exfalso, exact nat.not_lt_zero i hlt },
      replace hlt := nat.le_of_lt_succ hlt,
      use j₀,
      rw [δ, if_neg (not_lt_of_ge hlt)] } }
end

lemma σ_ker_aux (i j k : ℕ) : j < k ∧ (σ i j = σ i k) → j = i ∧ k = i + 1 :=
begin
 rintro ⟨hlt,he⟩,
 dsimp [σ] at he, split_ifs at he with h₀ h₁ h₃,
 { exfalso, rw[he] at hlt, exact lt_irrefl k hlt },
 { rw [he] at *,
   rw [le_antisymm (nat.le_pred_of_lt (lt_of_not_ge h₁)) h₀] at *,
   cases k with k₀, {cases hlt},
   have : k₀.succ - 1 = k₀ := nat.add_sub_cancel k₀ 1,
   rw [this] at *, split; refl },
 { exfalso, rw[← he] at hlt, exact (not_le_of_gt hlt) (nat.sub_le j 1) },
 { exfalso,
   cases j with j₀, { exfalso, exact h₀ i.zero_le },
   cases k with k₀, { exfalso, exact h₃ i.zero_le },
   simp only [nat.succ_eq_add_one, nat.add_sub_cancel] at he,
   rw [he] at hlt, exact lt_irrefl _ hlt }
end

lemma σ_ker {i j k : ℕ} : (σ i j = σ i k) ↔
  (j = k ∨ (j = i ∧ k = i + 1) ∨ (j = i + 1 ∧ k = i)) :=
begin
  split,
  { intro he,
    by_cases h₀ : j = k,
    { left, exact h₀ },
    { by_cases h₁ : j < k,
      { right, left, exact σ_ker_aux i j k ⟨h₁,he⟩, },
      { change j ≠ k at h₀,
        have h₂ : k < j := lt_of_le_of_ne (le_of_not_gt h₁) h₀.symm,
        right, right, exact (σ_ker_aux i k j ⟨h₂,he.symm⟩).symm } } },
  { rintro (h₀ | ⟨h₁,h₂⟩ | ⟨h₃,h₄⟩),
    { rw [h₀] },
    { rw [h₁, h₂, σ, σ, if_pos (le_refl i),
          if_neg (not_le_of_gt i.lt_succ_self), nat.add_sub_cancel] },
    { rw [h₃, h₄, σ, σ, if_pos (le_refl i),
          if_neg (not_le_of_gt i.lt_succ_self), nat.add_sub_cancel] } }
end

lemma σ_pred_inj {i j k : ℕ} (hj : j ≠ i) (hk : k ≠ i)
  (he : σ i.pred j = σ i.pred k) : j = k :=
begin
  rcases σ_ker.mp he with ⟨⟨h₀⟩⟩ | ⟨⟨h₁⟩,⟨h₂⟩⟩ | ⟨⟨h₃⟩,⟨h₄⟩⟩;
  try { refl }; exfalso; cases i with i₀;
  try { exact hj rfl }; try { exact hk rfl }
end

example (p q : Prop) (h : ¬ (p ∨ q)) : ¬ p ∧ ¬ q := by library_search

lemma σ_pred_nodup {i : ℕ} {l : list ℕ} (hl : l.nodup) (hm : i ∉ l) :
  (l.map (σ i.pred)).nodup :=
begin
  induction l with j l ih,
  { exact list.nodup_nil },
  { rw [list.map_cons],
    rw [list.nodup_cons] at hl ⊢,
    rw [list.mem_cons_iff] at hm,
    replace hm : i ≠ j ∧ i ∉ l := or_imp_distrib.mp hm,
    split,
    { intro h,
      exfalso,
      rcases list.mem_map.mp h with ⟨k,⟨hkm,hke⟩⟩,
      have hki : k ≠ i := λ e, hm.right (e ▸ hkm),
      have hjk : j ≠ k := λ e, hl.left (e.symm ▸ hkm),
      exact hjk (σ_pred_inj hm.left.symm hki hke.symm) },
    { exact ih hl.right hm.right } }
end

end infinite

def δ {n : ℕ} (i : fin n.succ) : fin n → fin n.succ :=
  λ j, if (j : ℕ) < (i : ℕ) then j.inc else j.succ

lemma δ_infinite {n : ℕ} (i : fin n.succ) (k : fin n) :
  (δ i k : ℕ) = infinite.δ i k :=
begin
  simp only [δ, infinite.δ],
  split_ifs, { rw [fin.coe_inc] }, { exact fin.coe_succ k }
end

@[simp] lemma δ_val {n : ℕ} (i : fin n.succ) (j : fin n) : (δ i j : ℕ) =
  if (j : ℕ) < (i : ℕ) then (j : ℕ) else (j : ℕ).succ :=
by { rw [δ]; split_ifs, { rw [fin.coe_inc] }, { exact fin.coe_succ j } }

lemma δ_val_lt {n : ℕ} {i : fin n.succ} {j : fin n} (h : (j : ℕ) < (i : ℕ)) :
  (δ i j : ℕ) = j := by { rw [δ_val, if_pos h] }

lemma δ_val_ge {n : ℕ} {i : fin n.succ} {j : fin n} (h : (i : ℕ) ≤ (j : ℕ)) :
  (δ i j : ℕ) = (j : ℕ).succ := by { rw [δ_val, if_neg (not_lt_of_ge h)] }

def σ {n : ℕ} (i : fin n) : fin n.succ → fin n :=
  λ j, dite ((j : ℕ) ≤ (i : ℕ))
         (λ h, fin.res h)
         (λ h, j.pred (λ e, by { cases e, exact h (nat.zero_le _)}))

lemma σ_infinite {n : ℕ} (i : fin n) (k : fin n.succ) :
  (σ i k : ℕ) = infinite.σ i k :=
begin
  simp only [σ, infinite.σ],
  split_ifs,
  { rw [fin.coe_res] },
  { exact fin.coe_pred k _ }
end

@[simp] lemma σ_val {n : ℕ} (i : fin n) (j : fin n.succ) : (σ i j : ℕ) =
  if (j : ℕ) ≤ (i : ℕ) then (j : ℕ) else (j : ℕ).pred :=
begin
 rw [σ]; split_ifs,
 { rw [fin.coe_res] },
 { exact fin.coe_pred j _ }
end

lemma ite.map {α β : Type} (f : α → β) (a a' : α) (h : Prop) [decidable h] :
  f (ite h a a') = ite h (f a) (f a') := by { split_ifs; refl }

lemma ite.fin_val {n : ℕ} (a a' : fin n) (h : Prop) [decidable h] :
  (ite h a a' : ℕ) = ite h (a : ℕ) (a' : ℕ)  := by { split_ifs; refl }

lemma le_iff_not_gt {α : Type*} [linear_order α] (x y : α) : x ≤ y ↔ ¬ x > y :=
⟨not_lt_of_ge, le_of_not_gt⟩

lemma δδ {n : ℕ} (i : fin (n + 1)) (j : fin (n + 2)) (hji : (j : ℕ) ≤ (i : ℕ)) :
  (δ j) ∘ (δ i) = (δ i.succ) ∘ (δ (fin.res hji)) :=
begin
  ext k,
  let hi := congr_fun (infinite.δδ (i : ℕ) (j : ℕ) hji) k,
  simp only [function.comp_app, δ_infinite, fin.coe_succ, fin.coe_res] at hi ⊢,
  exact hi
end

lemma σσ {n : ℕ} (i : fin (n + 1)) (j : fin n) (hij : (i : ℕ) ≤ (j : ℕ)) :
  (σ j) ∘ (σ i) = (σ (fin.res hij)) ∘ (σ j.succ) :=
begin
  ext k,
  let hi := congr_fun (infinite.σσ (i : ℕ) (j : ℕ) hij) k,
  simp only [function.comp_app, σ_infinite, fin.coe_succ, fin.coe_res] at hi ⊢,
  exact hi
end

lemma σδ₀ {n : ℕ} (i : fin (n + 1)) (j : fin (n + 2)) (hij : (i : ℕ) + 1 < (j : ℕ)) :
  (σ i) ∘ (δ j) = (δ (j.pred (λ h, by { rw[h] at hij, exact nat.not_lt_zero _ hij}))) ∘
                  (σ ⟨i.val, nat.lt_of_succ_lt_succ (lt_of_lt_of_le hij (nat.le_of_lt_succ j.is_lt))⟩ ) :=
begin
  ext k,
  let hi := congr_fun (infinite.σδ₀ (i : ℕ) (j : ℕ) hij) k,
  simp only [function.comp_app, σ_infinite, δ_infinite, fin.coe_pred, fin.coe_res] at hi ⊢,
  exact hi
end

lemma σδ₁ {n : ℕ} (i : fin n) : (σ i) ∘ δ (fin.inc i) = id :=
begin
  ext k,
  let hi := congr_fun (infinite.σδ₁ (i : ℕ)) k,
  simp only [function.comp_app, σ_infinite, δ_infinite, fin.coe_inc] at hi ⊢,
  exact hi
end

lemma σδ₂ {n : ℕ} (i : fin n) : (σ i) ∘ δ (i.succ) = id :=
begin
  ext k,
  let hi := congr_fun (infinite.σδ₂ (i : ℕ)) k,
  simp only [function.comp_app, σ_infinite, δ_infinite, fin.coe_succ] at hi ⊢,
  exact hi
end

lemma σδ₃ {n : ℕ} (i : fin (n + 1)) (j : fin (n + 2)) (hij : (j : ℕ) < (i : ℕ)) :
  (σ i) ∘ (δ j) = (δ ⟨j.val, lt_trans hij i.is_lt ⟩) ∘
                  (σ (i.pred (λ h, by { rw[h] at hij, exact nat.not_lt_zero (j : ℕ) hij})) ) :=
begin
  ext k,
  let hi := congr_fun (infinite.σδ₃ (i : ℕ) (j : ℕ) hij) k.val,
  simp only [function.comp_app, σ_infinite, δ_infinite, fin.coe_pred, fin.coe_res] at hi ⊢,
  exact hi
end

lemma σδ_pred {n : ℕ} (i : fin (n + 2)) : (σ i.pred') ∘ (δ i) = id :=
begin
  ext k,
  let hi := congr_fun (infinite.σδ_pred (i : ℕ)) k,
  simp only [function.comp_app, σ_infinite, δ_infinite, fin.coe_pred'] at hi ⊢,
  exact hi
end

lemma δ_inj {n : ℕ} (i : fin (n + 1)): function.injective (δ i) := λ j₀ j₁ e,
begin
  replace e := congr_arg (coe : fin _ → ℕ) e,
  rw [δ_infinite, δ_infinite] at e,
  exact fin.eq_of_veq (infinite.δ_inj (i : ℕ) e)
end

lemma σ_surj {n : ℕ} (i : fin n) : function.surjective (σ i) :=
begin
  have : function.right_inverse (δ i.succ) (σ i) :=
   λ j, begin change ((σ i) ∘ (δ i.succ)) j = _, simp[σδ₂], end,
  exact function.right_inverse.surjective this
end

/-  ⟨δ i.succ,λ j, by { rw [← function.comp_app (σ i), σδ₂, id]}⟩ -/

lemma δ_ne {n : ℕ} (i : fin (n + 1)) (k : fin n) : δ i k ≠ i :=
begin
 intro e, replace e := congr_arg (coe : fin (n + 1) → ℕ) e,
 simp only  [δ_infinite] at e, exact infinite.δ_ne _ _ e
end

lemma δ_image {n : ℕ} (i j : fin (n + 1)) : (∃ k, δ i k = j) ↔ j ≠ i :=
begin
  split,
  { rintro ⟨k,e⟩, rw [← e], apply δ_ne },
  { intro hne,
    have hne' : (j : ℕ) ≠ (i : ℕ) := λ h, hne (fin.eq_of_veq h),
    by_cases hji : (j : ℕ) ≤ (i : ℕ),
    { replace hji := lt_of_le_of_ne hji hne',
      have hj : (j : ℕ) < n := lt_of_lt_of_le hji (nat.le_of_lt_succ i.is_lt),
      let j' : fin n := ⟨j,hj⟩,
      let hji' : (j' : ℕ) < (i : ℕ) := hji,
      use j', simp only [δ, if_pos hji'],
      apply fin.coe_inj, rw [fin.coe_inc], refl },
    { have : j ≠ 0 := λ h,
       begin
         replace h : (j : ℕ) = 0 := congr_arg coe h,
         rw [h] at hji, exact hji (nat.zero_le _)
       end,
      let j₀ := j.pred this, use j₀, apply fin.coe_inj,
      have : j = j₀.succ := (fin.succ_pred j _).symm,
      rw [this, fin.coe_succ] at hne' hji,
      rw [this, δ_infinite, fin.coe_succ, infinite.δ],
      have hlt := lt_of_not_ge hji,
      have : ¬ ((j₀ : ℕ) < (i : ℕ)) := λ h, hji (nat.succ_le_of_lt h),
      rw [if_neg this] } }
end

lemma σ_inj {n : ℕ} {i j k : fin (n + 2)} (hj : j ≠ i) (hk : k ≠ i)
 (he : σ i.pred' j = σ i.pred' k) : j = k :=
begin
  replace he := congr_arg (coe : fin _ → ℕ) he,
  replace hj : (j : ℕ) ≠ (i : ℕ) := λ e, hj (fin.coe_inj e),
  replace hk : (k : ℕ) ≠ (i : ℕ) := λ e, hk (fin.coe_inj e),
  simp only [σ_infinite, fin.coe_pred'] at he,
  exact fin.coe_inj (simplicial.infinite.σ_pred_inj hj hk he)
end

end simplicial


import .love07_metaprogramming_demo

/-! # LoVe Exercise 7: Metaprogramming -/

set_option pp.beta true
set_option pp.generalized_field_notation false

namespace LoVe

/-! ## Question 1: A Term Exploder

In this question, we develop a string format for the `expr` metatype. By
default, there is no `has_repr` instance to print a nice string. For example: -/

#eval (expr.app (expr.var 0) (expr.var 1) : expr)   -- result: `[external]`
#eval (`(λx : ℕ, x + x) : expr)                     -- result: `[external]`

/-! 1.1. Define a metafunction `expr.repr` that converts an `expr` into a
`string`. It is acceptable to leave out some fields from the `expr`
constructors, such as the level `l` of a sort, the binder information `bi` of
a `λ` or `∀` binder, and the arguments of the `macro` constructor.

Hint: Use `name.to_string` to convert a name to a string, and `repr` for other
types that belong to the `has_repr` type class. -/

meta def expr.repr : expr → string
| (expr.var n)                := "(var " ++ repr n ++ ")"
| (expr.sort l)               := "sort"
| (expr.const n ls)           := "(const " ++ n.to_string ++ ")"
| (expr.mvar n m t)           :=
  "(mvar " ++ name.to_string n ++ " " ++ name.to_string m ++ " " ++
  expr.repr t ++ ")"
| (expr.local_const n m bi t) :=
  "(local_const " ++ name.to_string n ++ " " ++ name.to_string m ++ " " ++
  expr.repr t ++ ")"
| (expr.app e f)              :=
  "(app " ++ expr.repr e ++ " " ++ expr.repr f ++ ")"
| (expr.lam n bi e t)         :=
  "(lam " ++ name.to_string n ++ " " ++ expr.repr e ++ " " ++ expr.repr t ++ ")"
| (expr.pi n bi e t)          :=
  "(pi " ++ name.to_string n ++ " " ++ expr.repr e ++ " " ++ expr.repr t ++ ")"
| (expr.elet n g e f)         :=
  "(elet " ++ name.to_string n ++ " " ++ expr.repr g ++ " " ++ expr.repr e ++
  " " ++ expr.repr f ++ ")"
| (expr.macro d args)         := "macro"

/-! We register `expr.repr` in the `has_repr` type class, so that we can use
`repr` without qualification in the future, and so that it is available to
`#eval`. We need the `meta` keyword in front of the command we enter. -/

meta instance expr.has_repr : has_repr expr :=
{ repr := expr.repr }

/-! 1.2. Test your setup. -/

#eval (expr.app (expr.var 0) (expr.var 1) : expr)
#eval (`(λx : ℕ, x + x) : expr)

/-! ## Question 2: `destruct_and` on Steroids

Recall from the lecture that `destruct_and` fails on easy goals such as -/

lemma abc_ac₂ (a b c : Prop) (h : a ∧ b ∧ c) :
  a ∧ c :=
sorry

/-! We will now address this by developing a new tactic called `destro_and`,
which applies both **des**truction and in**tro**duction rules for conjunction.
It will also go automatically through the hypotheses instead of taking an
argument. We will develop it in three steps.

2.1. Develop a tactic `intro_ands` that replaces all goals of the form
`a ∧ b` with two new goals `a` and `b` systematically, until all top-level
conjunctions are gone.

For this, we can use tactics such as `tactic.repeat` (which repeatedly applies a
tactic on all goals and subgoals until the tactic fails on each of the goal) and
`tactic.applyc` (which can be used to apply a rule, in connection with backtick
quoting). -/

#check tactic.repeat
#check tactic.applyc

meta def intro_ands : tactic unit :=
tactic.repeat (tactic.applyc `and.intro)

lemma abcd_bd (a b c d : Prop) (h : a ∧ (b ∧ c) ∧ d) :
  b ∧ d :=
begin
  intro_ands,
  /- The proof state should be as follows:

  2 goals
  a b c d : Prop,
  h : a ∧ (b ∧ c) ∧ d
  ⊢ b

  a b c d : Prop,
  h : a ∧ (b ∧ c) ∧ d
  ⊢ d -/
  repeat { sorry }
end

lemma abcd_bacb (a b c d : Prop) (h : a ∧ (b ∧ c) ∧ d) :
  b ∧ (a ∧ (c ∧ b)) :=
begin
  intro_ands,
  /- The proof state should be as follows:

  4 goals
  a b c d : Prop,
  h : a ∧ (b ∧ c) ∧ d
  ⊢ b

  a b c d : Prop,
  h : a ∧ (b ∧ c) ∧ d
  ⊢ a

  a b c d : Prop,
  h : a ∧ (b ∧ c) ∧ d
  ⊢ c

  a b c d : Prop,
  h : a ∧ (b ∧ c) ∧ d
  ⊢ b -/
  repeat { sorry }
end

/-! 2.2. Develop a tactic `destruct_ands` that replaces hypotheses of the form
`h : a ∧ b` by two new hypotheses `h_left : a` and `h_right : b` systematically,
until all top-level conjunctions are gone.

Here is some pseudocode that you can follow:

1. Retrieve the list of hypotheses from the context. This is provided by the
   metaconstant `tactic.local_context`.

2. Find the first hypothesis (= term) with a type (= proposition) of the form
   `_ ∧ _`. Here, you can use the `list.mfirst` function, in conjunction with
   pattern matching. You can use `tactic.infer_type` to query the type of a
   term.

3. Perform a case split on the first found hypothesis. This can be achieved
   using `tactic.cases`, a metaprogram that corresponds roughly to `cases'`.

4. Repeat.

The above procedure might fail if there exists no hypotheses of the required
form. Make sure to handle this failure gracefully, for example using
`tactic.try` or `<|> pure ()`. -/

meta def destruct_ands : tactic unit :=
tactic.repeat (do
  hs ← tactic.local_context,
  h ← list.mfirst (λh, do `(_ ∧ _) ← tactic.infer_type h, pure h) hs,
  tactic.cases h,
  pure ())

-- Alternative solutions:
meta def destruct_ands₂ : tactic unit :=
tactic.try
  (do
     hs ← tactic.local_context,
     h ← list.mfirst (λh, do `(_ ∧ _) ← tactic.infer_type h, pure h) hs,
     tactic.cases h,
     destruct_ands₂)

meta def destruct_ands₃ : tactic unit :=
(do
   hs ← tactic.local_context,
   h ← list.mfirst (λh, do `(_ ∧ _) ← tactic.infer_type h, pure h) hs,
   tactic.cases h,
   destruct_ands₃)
<|> pure ()

lemma abcd_bd₂ (a b c d : Prop) (h : a ∧ (b ∧ c) ∧ d) :
  b ∧ d :=
begin
  destruct_ands,
  /- The proof state should be as follows:

  a b c d : Prop,
  h_left : a,
  h_right_right : d,
  h_right_left_left : b,
  h_right_left_right : c
  ⊢ b ∧ d -/
  sorry
end

/-! 2.3. Combine the two tactics developed above and `tactic.assumption` to
implement the desired `destro_and` tactic. -/

meta def destro_and : tactic unit :=
do
  destruct_ands,
  intro_ands,
  tactic.all_goals (tactic.try tactic.assumption),
  pure ()

lemma abcd_bd₃ (a b c d : Prop) (h : a ∧ (b ∧ c) ∧ d) :
  b ∧ d :=
by destro_and

lemma abcd_bacb₂ (a b c d : Prop) (h : a ∧ (b ∧ c) ∧ d) :
  b ∧ (a ∧ (c ∧ b)) :=
by destro_and

lemma abd_bacb (a b c d : Prop) (h : a ∧ b ∧ d) :
  b ∧ (a ∧ (c ∧ b)) :=
begin
  destro_and,
  /- The proof state should be roughly as follows:

  a b c d : Prop,
  h_left : a,
  h_right_left : b,
  h_right_right : d
  ⊢ c -/
  sorry   -- unprovable
end

/-! 2.4. Provide some more examples for `destro_and` to convince yourself that
it works as expected also on more complicated examples. -/

lemma ab (a b : Prop) (h : a ∨ b) :
  a ∨ b :=
by destro_and

lemma abcdef_1 (a b c d e f : Prop) (h : a ∧ b ∧ c ∧ d ∧ e ∧ f) :
  f ∧ e ∧ f ∧ a ∧ d ∧ b ∧ c ∧ a :=
by destro_and

lemma abcdef_2 (a b c d e f : Prop) (h : a ∧ ((b ∧ ((c ∧ d) ∧ e)) ∧ f)) :
  f ∧ e ∧ f ∧ a ∧ d ∧ b ∧ c ∧ a :=
by destro_and

lemma abcdef_3 (a b c d e f : Prop) (h : a ∧ (b ∧ (c ∧ (d ∧ e ∧ f)))) :
  f ∧ (e ∧ (f ∧ (a ∧ d ∧ b ∧ c ∧ a))) :=
by destro_and

/-! ## Question 3 (**optional**): A Theorem Finder

We will implement a function that allows us to find theorems by constants
appearing in their statements. So given a list of constant names, the function
will list all theorems in which all these constants appear.

You can use the following metaconstants:

* `declaration` contains all data (name, type, value) associated with a
  declaration understood broadly (e.g., axiom, lemma, constant, etc.).

* `tactic.get_env` gives us access to the `environment`, a metatype that lists
  all `declaration`s (including all theorems).

* `environment.fold` allows us to walk through the environment and collect data.

* `expr.fold` allows us to walk through an expression and collect data.

3.1 (**optional**). Write a metafunction that checks whether an expression
contains a specific constant.

You can use `expr.fold` to walk through the expression, `||` and `ff` for
Booleans, and `expr.is_constant_of` to check whether an expression is a
constant. -/

meta def term_contains (e : expr) (nam : name) : bool :=
expr.fold e ff (λe' d c, c || expr.is_constant_of e' nam)

/-! 3.2 (**optional**). Write a metafunction that checks whether an expression
contains **all** constants in a list.

You can use `list.band` (Boolean and). -/

meta def term_contains_all (nams : list name) (e : expr) : bool :=
list.band (list.map (term_contains e) nams)

/-! 3.3 (**optional**). Produce the list of all theorems that contain all
constants `nams` in their statement.

`environment.fold` allows you to walk over the list of declarations. With
`declaration.type`, you get the type of a theorem, and with
`declaration.to_name` you get the name. -/

meta def list_constants (nams : list name) (e : environment) : list name :=
environment.fold e [] (λdecl nams',
  if term_contains_all nams decl.type then decl.to_name :: nams' else nams')

/-! Finally, we develop a tactic that uses the above metafunctions to log all
found theorems: -/

meta def find_constants (nams : list name) : tactic unit :=
do
  env ← tactic.get_env,
  list.mmap' tactic.trace (list_constants nams env)

/-! We test the solution. -/

run_cmd find_constants []   -- lists all theorems
run_cmd find_constants [`list.map, `function.comp]

end LoVe