/-
Copyright (c) 2020 Fox Thomson. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Fox Thomson

! This file was ported from Lean 3 source module computability.DFA
! leanprover-community/mathlib commit 32253a1a1071173b33dc7d6a218cf722c6feb514
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Data.Fintype.Card
import Mathlib.Computability.Language
import Mathlib.Tactic.NormNum
import Mathlib.Tactic.WLOG

/-!
# Deterministic Finite Automata

This file contains the definition of a Deterministic Finite Automaton (DFA), a state machine which
determines whether a string (implemented as a list over an arbitrary alphabet) is in a regular set
in linear time.
Note that this definition allows for Automaton with infinite states, a `Fintype` instance must be
supplied for true DFA's.
-/

open Computability

universe u v

-- Porting note: Required as `DFA` is used in mathlib3
set_option linter.uppercaseLean3 false

/-- A DFA is a set of states (`σ`), a transition function from state to state labelled by the
  alphabet (`step`), a starting state (`start`) and a set of acceptance states (`accept`). -/
structure DFA (α : Type u) (σ : Type v) where
  /-- A transition function from state to state labelled by the alphabet. -/
  step : σ → α → σ
  /-- Starting state. -/
  start : σ
  /-- Set of acceptance states. -/
  accept : Set σ
#align DFA DFA

namespace DFA

variable {α : Type u} {σ : Type v} (M : DFA α σ)

instance [Inhabited σ] : Inhabited (DFA α σ) :=
  ⟨DFA.mk (fun _ _ => default) default ∅⟩

/-- `M.evalFrom s x` evaluates `M` with input `x` starting from the state `s`. -/
def evalFrom (start : σ) : List α → σ :=
  List.foldl M.step start
#align DFA.eval_from DFA.evalFrom

@[simp]
theorem evalFrom_nil (s : σ) : M.evalFrom s [] = s :=
  rfl
#align DFA.eval_from_nil DFA.evalFrom_nil

@[simp]
theorem evalFrom_singleton (s : σ) (a : α) : M.evalFrom s [a] = M.step s a :=
  rfl
#align DFA.eval_from_singleton DFA.evalFrom_singleton

@[simp]
theorem evalFrom_append_singleton (s : σ) (x : List α) (a : α) :
    M.evalFrom s (x ++ [a]) = M.step (M.evalFrom s x) a := by
  simp only [evalFrom, List.foldl_append, List.foldl_cons, List.foldl_nil]
#align DFA.eval_from_append_singleton DFA.evalFrom_append_singleton

/-- `M.eval x` evaluates `M` with input `x` starting from the state `M.start`. -/
def eval : List α → σ :=
  M.evalFrom M.start
#align DFA.eval DFA.eval

@[simp]
theorem eval_nil : M.eval [] = M.start :=
  rfl
#align DFA.eval_nil DFA.eval_nil

@[simp]
theorem eval_singleton (a : α) : M.eval [a] = M.step M.start a :=
  rfl
#align DFA.eval_singleton DFA.eval_singleton

@[simp]
theorem eval_append_singleton (x : List α) (a : α) : M.eval (x ++ [a]) = M.step (M.eval x) a :=
  evalFrom_append_singleton _ _ _ _
#align DFA.eval_append_singleton DFA.eval_append_singleton

theorem evalFrom_of_append (start : σ) (x y : List α) :
    M.evalFrom start (x ++ y) = M.evalFrom (M.evalFrom start x) y :=
  x.foldl_append _ _ y
#align DFA.eval_from_of_append DFA.evalFrom_of_append

/-- `M.accepts` is the language of `x` such that `M.eval x` is an accept state. -/
def accepts : Language α := fun x => M.eval x ∈ M.accept
#align DFA.accepts DFA.accepts

theorem mem_accepts (x : List α) : x ∈ M.accepts ↔ M.evalFrom M.start x ∈ M.accept := by rfl
#align DFA.mem_accepts DFA.mem_accepts

theorem evalFrom_split [Fintype σ] {x : List α} {s t : σ} (hlen : Fintype.card σ ≤ x.length)
    (hx : M.evalFrom s x = t) :
    ∃ q a b c,
      x = a ++ b ++ c ∧
        a.length + b.length ≤ Fintype.card σ ∧
          b ≠ [] ∧ M.evalFrom s a = q ∧ M.evalFrom q b = q ∧ M.evalFrom q c = t := by
  obtain ⟨n, m, hneq, heq⟩ :=
    Fintype.exists_ne_map_eq_of_card_lt
      (fun n : Fin (Fintype.card σ + 1) => M.evalFrom s (x.take n)) (by norm_num)
  wlog hle : (n : ℕ) ≤ m
  · exact this _ hlen hx _ _ hneq.symm heq.symm (le_of_not_le hle)
  have hm : (m : ℕ) ≤ Fintype.card σ := Fin.is_le m
  dsimp at heq
  refine'
    ⟨M.evalFrom s ((x.take m).take n), (x.take m).take n, (x.take m).drop n, x.drop m, _, _, _, by
      rfl, _⟩
  · rw [List.take_append_drop, List.take_append_drop]
  · simp only [List.length_drop, List.length_take]
    rw [min_eq_left (hm.trans hlen), min_eq_left hle, add_tsub_cancel_of_le hle]
    exact hm
  · intro h
    have hlen' := congr_arg List.length h
    simp only [List.length_drop, List.length, List.length_take] at hlen'
    rw [min_eq_left, tsub_eq_zero_iff_le] at hlen'
    · apply hneq
      apply le_antisymm
      assumption'
    exact hm.trans hlen
  have hq :
    M.evalFrom (M.evalFrom s ((x.take m).take n)) ((x.take m).drop n) =
      M.evalFrom s ((x.take m).take n) :=
    by
    rw [List.take_take, min_eq_left hle, ← evalFrom_of_append, heq, ← min_eq_left hle, ←
      List.take_take, min_eq_left hle, List.take_append_drop]
  use hq
  rwa [← hq, ← evalFrom_of_append, ← evalFrom_of_append, ← List.append_assoc,
    List.take_append_drop, List.take_append_drop]
#align DFA.eval_from_split DFA.evalFrom_split

theorem evalFrom_of_pow {x y : List α} {s : σ} (hx : M.evalFrom s x = s)
    (hy : y ∈ ({x} : Language α)∗) : M.evalFrom s y = s := by
  rw [Language.mem_kstar] at hy
  rcases hy with ⟨S, rfl, hS⟩
  induction' S with a S ih
  · rfl
  · have ha := hS a (List.mem_cons_self _ _)
    rw [Set.mem_singleton_iff] at ha
    rw [List.join, evalFrom_of_append, ha, hx]
    apply ih
    intro z hz
    exact hS z (List.mem_cons_of_mem a hz)
#align DFA.eval_from_of_pow DFA.evalFrom_of_pow

end DFA


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

! This file was ported from Lean 3 source module analysis.convex.strict
! leanprover-community/mathlib commit 84dc0bd6619acaea625086d6f53cb35cdd554219
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Analysis.Convex.Basic
import Mathlib.Topology.Algebra.Order.Group

/-!
# Strictly convex sets

This file defines strictly convex sets.

A set is strictly convex if the open segment between any two distinct points lies in its interior.
-/

open Set

open Convex Pointwise

variable {𝕜 𝕝 E F β : Type _}

open Function Set

open Convex

section OrderedSemiring

variable [OrderedSemiring 𝕜] [TopologicalSpace E] [TopologicalSpace F]

section AddCommMonoid

variable [AddCommMonoid E] [AddCommMonoid F]

section SMul

variable (𝕜)
variable [SMul 𝕜 E] [SMul 𝕜 F] (s : Set E)

/-- A set is strictly convex if the open segment between any two distinct points lies is in its
interior. This basically means "convex and not flat on the boundary". -/
def StrictConvex : Prop :=
  s.Pairwise fun x y => ∀ ⦃a b : 𝕜⦄, 0 < a → 0 < b → a + b = 1 → a • x + b • y ∈ interior s
#align strict_convex StrictConvex

variable {𝕜 s}
variable {x y : E} {a b : 𝕜}

theorem strictConvex_iff_openSegment_subset :
    StrictConvex 𝕜 s ↔ s.Pairwise fun x y => openSegment 𝕜 x y ⊆ interior s :=
  forall₅_congr fun _ _ _ _ _ => (openSegment_subset_iff 𝕜).symm
#align strict_convex_iff_open_segment_subset strictConvex_iff_openSegment_subset

theorem StrictConvex.openSegment_subset (hs : StrictConvex 𝕜 s) (hx : x ∈ s) (hy : y ∈ s)
    (h : x ≠ y) : openSegment 𝕜 x y ⊆ interior s :=
  strictConvex_iff_openSegment_subset.1 hs hx hy h
#align strict_convex.open_segment_subset StrictConvex.openSegment_subset

theorem strictConvex_empty : StrictConvex 𝕜 (∅ : Set E) :=
  pairwise_empty _
#align strict_convex_empty strictConvex_empty

theorem strictConvex_univ : StrictConvex 𝕜 (univ : Set E) := by
  intro x _ y _ _ a b _ _ _
  rw [interior_univ]
  exact mem_univ _
#align strict_convex_univ strictConvex_univ

protected nonrec theorem StrictConvex.eq (hs : StrictConvex 𝕜 s) (hx : x ∈ s) (hy : y ∈ s)
    (ha : 0 < a) (hb : 0 < b) (hab : a + b = 1) (h : a • x + b • y ∉ interior s) : x = y :=
  hs.eq hx hy fun H => h <| H ha hb hab
#align strict_convex.eq StrictConvex.eq

protected theorem StrictConvex.inter {t : Set E} (hs : StrictConvex 𝕜 s) (ht : StrictConvex 𝕜 t) :
    StrictConvex 𝕜 (s ∩ t) := by
  intro x hx y hy hxy a b ha hb hab
  rw [interior_inter]
  exact ⟨hs hx.1 hy.1 hxy ha hb hab, ht hx.2 hy.2 hxy ha hb hab⟩
#align strict_convex.inter StrictConvex.inter

theorem Directed.strictConvex_unionᵢ {ι : Sort _} {s : ι → Set E} (hdir : Directed (· ⊆ ·) s)
    (hs : ∀ ⦃i : ι⦄, StrictConvex 𝕜 (s i)) : StrictConvex 𝕜 (⋃ i, s i) := by
  rintro x hx y hy hxy a b ha hb hab
  rw [mem_unionᵢ] at hx hy
  obtain ⟨i, hx⟩ := hx
  obtain ⟨j, hy⟩ := hy
  obtain ⟨k, hik, hjk⟩ := hdir i j
  exact interior_mono (subset_unionᵢ s k) (hs (hik hx) (hjk hy) hxy ha hb hab)
#align directed.strict_convex_Union Directed.strictConvex_unionᵢ

theorem DirectedOn.strictConvex_unionₛ {S : Set (Set E)} (hdir : DirectedOn (· ⊆ ·) S)
    (hS : ∀ s ∈ S, StrictConvex 𝕜 s) : StrictConvex 𝕜 (⋃₀ S) := by
  rw [unionₛ_eq_unionᵢ]
  exact (directedOn_iff_directed.1 hdir).strictConvex_unionᵢ fun s => hS _ s.2
#align directed_on.strict_convex_sUnion DirectedOn.strictConvex_unionₛ

end SMul

section Module

variable [Module 𝕜 E] [Module 𝕜 F] {s : Set E}

protected theorem StrictConvex.convex (hs : StrictConvex 𝕜 s) : Convex 𝕜 s :=
  convex_iff_pairwise_pos.2 fun _ hx _ hy hxy _ _ ha hb hab =>
    interior_subset <| hs hx hy hxy ha hb hab
#align strict_convex.convex StrictConvex.convex

/-- An open convex set is strictly convex. -/
protected theorem Convex.strictConvex_of_open (h : IsOpen s) (hs : Convex 𝕜 s) : StrictConvex 𝕜 s :=
  fun _ hx _ hy _ _ _ ha hb hab => h.interior_eq.symm ▸ hs hx hy ha.le hb.le hab
#align convex.strict_convex_of_open Convex.strictConvex_of_open

theorem IsOpen.strictConvex_iff (h : IsOpen s) : StrictConvex 𝕜 s ↔ Convex 𝕜 s :=
  ⟨StrictConvex.convex, Convex.strictConvex_of_open h⟩
#align is_open.strict_convex_iff IsOpen.strictConvex_iff

theorem strictConvex_singleton (c : E) : StrictConvex 𝕜 ({c} : Set E) :=
  pairwise_singleton _ _
#align strict_convex_singleton strictConvex_singleton

theorem Set.Subsingleton.strictConvex (hs : s.Subsingleton) : StrictConvex 𝕜 s :=
  hs.pairwise _
#align set.subsingleton.strict_convex Set.Subsingleton.strictConvex

theorem StrictConvex.linear_image [Semiring 𝕝] [Module 𝕝 E] [Module 𝕝 F]
    [LinearMap.CompatibleSMul E F 𝕜 𝕝] (hs : StrictConvex 𝕜 s) (f : E →ₗ[𝕝] F) (hf : IsOpenMap f) :
    StrictConvex 𝕜 (f '' s) := by
  rintro _ ⟨x, hx, rfl⟩ _ ⟨y, hy, rfl⟩ hxy a b ha hb hab
  refine' hf.image_interior_subset _ ⟨a • x + b • y, hs hx hy (ne_of_apply_ne _ hxy) ha hb hab, _⟩
  rw [map_add, f.map_smul_of_tower a, f.map_smul_of_tower b]
#align strict_convex.linear_image StrictConvex.linear_image

theorem StrictConvex.is_linear_image (hs : StrictConvex 𝕜 s) {f : E → F} (h : IsLinearMap 𝕜 f)
    (hf : IsOpenMap f) : StrictConvex 𝕜 (f '' s) :=
  hs.linear_image (h.mk' f) hf
#align strict_convex.is_linear_image StrictConvex.is_linear_image

theorem StrictConvex.linear_preimage {s : Set F} (hs : StrictConvex 𝕜 s) (f : E →ₗ[𝕜] F)
    (hf : Continuous f) (hfinj : Injective f) : StrictConvex 𝕜 (s.preimage f) := by
  intro x hx y hy hxy a b ha hb hab
  refine' preimage_interior_subset_interior_preimage hf _
  rw [mem_preimage, f.map_add, f.map_smul, f.map_smul]
  exact hs hx hy (hfinj.ne hxy) ha hb hab
#align strict_convex.linear_preimage StrictConvex.linear_preimage

theorem StrictConvex.is_linear_preimage {s : Set F} (hs : StrictConvex 𝕜 s) {f : E → F}
    (h : IsLinearMap 𝕜 f) (hf : Continuous f) (hfinj : Injective f) :
    StrictConvex 𝕜 (s.preimage f) :=
  hs.linear_preimage (h.mk' f) hf hfinj
#align strict_convex.is_linear_preimage StrictConvex.is_linear_preimage

section LinearOrderedCancelAddCommMonoid

variable [TopologicalSpace β] [LinearOrderedCancelAddCommMonoid β] [OrderTopology β] [Module 𝕜 β]
  [OrderedSMul 𝕜 β]

protected theorem Set.OrdConnected.strictConvex {s : Set β} (hs : OrdConnected s) :
    StrictConvex 𝕜 s := by
  refine' strictConvex_iff_openSegment_subset.2 fun x hx y hy hxy => _
  cases' hxy.lt_or_lt with hlt hlt <;> [skip, rw [openSegment_symm]] <;>
    exact
      (openSegment_subset_Ioo hlt).trans
        (isOpen_Ioo.subset_interior_iff.2 <| Ioo_subset_Icc_self.trans <| hs.out ‹_› ‹_›)
#align set.ord_connected.strict_convex Set.OrdConnected.strictConvex

theorem strictConvex_Iic (r : β) : StrictConvex 𝕜 (Iic r) :=
  ordConnected_Iic.strictConvex
#align strict_convex_Iic strictConvex_Iic

theorem strictConvex_Ici (r : β) : StrictConvex 𝕜 (Ici r) :=
  ordConnected_Ici.strictConvex
#align strict_convex_Ici strictConvex_Ici

theorem strictConvex_Iio (r : β) : StrictConvex 𝕜 (Iio r) :=
  ordConnected_Iio.strictConvex
#align strict_convex_Iio strictConvex_Iio

theorem strictConvex_Ioi (r : β) : StrictConvex 𝕜 (Ioi r) :=
  ordConnected_Ioi.strictConvex
#align strict_convex_Ioi strictConvex_Ioi

theorem strictConvex_Icc (r s : β) : StrictConvex 𝕜 (Icc r s) :=
  ordConnected_Icc.strictConvex
#align strict_convex_Icc strictConvex_Icc

theorem strictConvex_Ioo (r s : β) : StrictConvex 𝕜 (Ioo r s) :=
  ordConnected_Ioo.strictConvex
#align strict_convex_Ioo strictConvex_Ioo

theorem strictConvex_Ico (r s : β) : StrictConvex 𝕜 (Ico r s) :=
  ordConnected_Ico.strictConvex
#align strict_convex_Ico strictConvex_Ico

theorem strictConvex_Ioc (r s : β) : StrictConvex 𝕜 (Ioc r s) :=
  ordConnected_Ioc.strictConvex
#align strict_convex_Ioc strictConvex_Ioc

theorem strictConvex_uIcc (r s : β) : StrictConvex 𝕜 (uIcc r s) :=
  strictConvex_Icc _ _
#align strict_convex_uIcc strictConvex_uIcc

theorem strictConvex_uIoc (r s : β) : StrictConvex 𝕜 (uIoc r s) :=
  strictConvex_Ioc _ _
#align strict_convex_uIoc strictConvex_uIoc

end LinearOrderedCancelAddCommMonoid

end Module

end AddCommMonoid

section AddCancelCommMonoid

variable [AddCancelCommMonoid E] [ContinuousAdd E] [Module 𝕜 E] {s : Set E}

/-- The translation of a strictly convex set is also strictly convex. -/
theorem StrictConvex.preimage_add_right (hs : StrictConvex 𝕜 s) (z : E) :
    StrictConvex 𝕜 ((fun x => z + x) ⁻¹' s) := by
  intro x hx y hy hxy a b ha hb hab
  refine' preimage_interior_subset_interior_preimage (continuous_add_left _) _
  have h := hs hx hy ((add_right_injective _).ne hxy) ha hb hab
  rwa [smul_add, smul_add, add_add_add_comm, ← _root_.add_smul, hab, one_smul] at h
#align strict_convex.preimage_add_right StrictConvex.preimage_add_right

/-- The translation of a strictly convex set is also strictly convex. -/
theorem StrictConvex.preimage_add_left (hs : StrictConvex 𝕜 s) (z : E) :
    StrictConvex 𝕜 ((fun x => x + z) ⁻¹' s) := by
  simpa only [add_comm] using hs.preimage_add_right z
#align strict_convex.preimage_add_left StrictConvex.preimage_add_left

end AddCancelCommMonoid

section AddCommGroup

variable [AddCommGroup E] [AddCommGroup F] [Module 𝕜 E] [Module 𝕜 F]

section continuous_add

variable [ContinuousAdd E] {s t : Set E}

theorem StrictConvex.add (hs : StrictConvex 𝕜 s) (ht : StrictConvex 𝕜 t) : StrictConvex 𝕜 (s + t) :=
  by
  rintro _ ⟨v, w, hv, hw, rfl⟩ _ ⟨x, y, hx, hy, rfl⟩ h a b ha hb hab
  rw [smul_add, smul_add, add_add_add_comm]
  obtain rfl | hvx := eq_or_ne v x
  · refine' interior_mono (add_subset_add (singleton_subset_iff.2 hv) Subset.rfl) _
    rw [Convex.combo_self hab, singleton_add]
    exact
      (isOpenMap_add_left _).image_interior_subset _
        (mem_image_of_mem _ <| ht hw hy (ne_of_apply_ne _ h) ha hb hab)
  exact
    subset_interior_add_left
      (add_mem_add (hs hv hx hvx ha hb hab) <| ht.convex hw hy ha.le hb.le hab)
#align strict_convex.add StrictConvex.add

theorem StrictConvex.add_left (hs : StrictConvex 𝕜 s) (z : E) :
    StrictConvex 𝕜 ((fun x => z + x) '' s) := by
  simpa only [singleton_add] using (strictConvex_singleton z).add hs
#align strict_convex.add_left StrictConvex.add_left

theorem StrictConvex.add_right (hs : StrictConvex 𝕜 s) (z : E) :
    StrictConvex 𝕜 ((fun x => x + z) '' s) := by simpa only [add_comm] using hs.add_left z
#align strict_convex.add_right StrictConvex.add_right

/-- The translation of a strictly convex set is also strictly convex. -/
theorem StrictConvex.vadd (hs : StrictConvex 𝕜 s) (x : E) : StrictConvex 𝕜 (x +ᵥ s) :=
  hs.add_left x
#align strict_convex.vadd StrictConvex.vadd

end continuous_add

section ContinuousSmul

variable [LinearOrderedField 𝕝] [Module 𝕝 E] [ContinuousConstSMul 𝕝 E]
  [LinearMap.CompatibleSMul E E 𝕜 𝕝] {s : Set E} {x : E}

theorem StrictConvex.smul (hs : StrictConvex 𝕜 s) (c : 𝕝) : StrictConvex 𝕜 (c • s) := by
  obtain rfl | hc := eq_or_ne c 0
  · exact (subsingleton_zero_smul_set _).strictConvex
  · exact hs.linear_image (LinearMap.lsmul _ _ c) (isOpenMap_smul₀ hc)
#align strict_convex.smul StrictConvex.smul

theorem StrictConvex.affinity [ContinuousAdd E] (hs : StrictConvex 𝕜 s) (z : E) (c : 𝕝) :
    StrictConvex 𝕜 (z +ᵥ c • s) :=
  (hs.smul c).vadd z
#align strict_convex.affinity StrictConvex.affinity

end ContinuousSmul

end AddCommGroup

end OrderedSemiring

section OrderedCommSemiring

variable [OrderedCommSemiring 𝕜] [TopologicalSpace E]

section AddCommGroup

variable [AddCommGroup E] [Module 𝕜 E] [NoZeroSMulDivisors 𝕜 E] [ContinuousConstSMul 𝕜 E]
  {s : Set E}

theorem StrictConvex.preimage_smul (hs : StrictConvex 𝕜 s) (c : 𝕜) :
    StrictConvex 𝕜 ((fun z => c • z) ⁻¹' s) := by
  classical
    obtain rfl | hc := eq_or_ne c 0
    · simp_rw [zero_smul, preimage_const]
      split_ifs
      · exact strictConvex_univ
      · exact strictConvex_empty
    refine' hs.linear_preimage (LinearMap.lsmul _ _ c) _ (smul_right_injective E hc)
    unfold LinearMap.lsmul LinearMap.mk₂ LinearMap.mk₂' LinearMap.mk₂'ₛₗ
    exact continuous_const_smul _
#align strict_convex.preimage_smul StrictConvex.preimage_smul

end AddCommGroup

end OrderedCommSemiring

section OrderedRing

variable [OrderedRing 𝕜] [TopologicalSpace E] [TopologicalSpace F]

section AddCommGroup

variable [AddCommGroup E] [AddCommGroup F] [Module 𝕜 E] [Module 𝕜 F] {s t : Set E} {x y : E}

theorem StrictConvex.eq_of_openSegment_subset_frontier [Nontrivial 𝕜] [DenselyOrdered 𝕜]
    (hs : StrictConvex 𝕜 s) (hx : x ∈ s) (hy : y ∈ s) (h : openSegment 𝕜 x y ⊆ frontier s) :
    x = y := by
  obtain ⟨a, ha₀, ha₁⟩ := DenselyOrdered.dense (0 : 𝕜) 1 zero_lt_one
  classical
    by_contra hxy
    exact
      (h ⟨a, 1 - a, ha₀, sub_pos_of_lt ha₁, add_sub_cancel'_right _ _, rfl⟩).2
        (hs hx hy hxy ha₀ (sub_pos_of_lt ha₁) <| add_sub_cancel'_right _ _)
#align strict_convex.eq_of_open_segment_subset_frontier StrictConvex.eq_of_openSegment_subset_frontier

theorem StrictConvex.add_smul_mem (hs : StrictConvex 𝕜 s) (hx : x ∈ s) (hxy : x + y ∈ s)
    (hy : y ≠ 0) {t : 𝕜} (ht₀ : 0 < t) (ht₁ : t < 1) : x + t • y ∈ interior s := by
  have h : x + t • y = (1 - t) • x + t • (x + y) := by
    rw [smul_add, ← add_assoc, ← _root_.add_smul, sub_add_cancel, one_smul]
  rw [h]
  refine' hs hx hxy (fun h => hy <| add_left_cancel _) (sub_pos_of_lt ht₁) ht₀ (sub_add_cancel _ _)
  rw [← h, add_zero]
#align strict_convex.add_smul_mem StrictConvex.add_smul_mem

theorem StrictConvex.smul_mem_of_zero_mem (hs : StrictConvex 𝕜 s) (zero_mem : (0 : E) ∈ s)
    (hx : x ∈ s) (hx₀ : x ≠ 0) {t : 𝕜} (ht₀ : 0 < t) (ht₁ : t < 1) : t • x ∈ interior s := by
  simpa using hs.add_smul_mem zero_mem (by simpa using hx) hx₀ ht₀ ht₁
#align strict_convex.smul_mem_of_zero_mem StrictConvex.smul_mem_of_zero_mem

theorem StrictConvex.add_smul_sub_mem (h : StrictConvex 𝕜 s) (hx : x ∈ s) (hy : y ∈ s) (hxy : x ≠ y)
    {t : 𝕜} (ht₀ : 0 < t) (ht₁ : t < 1) : x + t • (y - x) ∈ interior s := by
  apply h.openSegment_subset hx hy hxy
  rw [openSegment_eq_image']
  exact mem_image_of_mem _ ⟨ht₀, ht₁⟩
#align strict_convex.add_smul_sub_mem StrictConvex.add_smul_sub_mem

/-- The preimage of a strictly convex set under an affine map is strictly convex. -/
theorem StrictConvex.affine_preimage {s : Set F} (hs : StrictConvex 𝕜 s) {f : E →ᵃ[𝕜] F}
    (hf : Continuous f) (hfinj : Injective f) : StrictConvex 𝕜 (f ⁻¹' s) := by
  intro x hx y hy hxy a b ha hb hab
  refine' preimage_interior_subset_interior_preimage hf _
  rw [mem_preimage, Convex.combo_affine_apply hab]
  exact hs hx hy (hfinj.ne hxy) ha hb hab
#align strict_convex.affine_preimage StrictConvex.affine_preimage

/-- The image of a strictly convex set under an affine map is strictly convex. -/
theorem StrictConvex.affine_image (hs : StrictConvex 𝕜 s) {f : E →ᵃ[𝕜] F} (hf : IsOpenMap f) :
    StrictConvex 𝕜 (f '' s) := by
  rintro _ ⟨x, hx, rfl⟩ _ ⟨y, hy, rfl⟩ hxy a b ha hb hab
  exact
    hf.image_interior_subset _
      ⟨a • x + b • y, ⟨hs hx hy (ne_of_apply_ne _ hxy) ha hb hab, Convex.combo_affine_apply hab⟩⟩
#align strict_convex.affine_image StrictConvex.affine_image

variable [TopologicalAddGroup E]

theorem StrictConvex.neg (hs : StrictConvex 𝕜 s) : StrictConvex 𝕜 (-s) :=
  hs.is_linear_preimage IsLinearMap.isLinearMap_neg continuous_id.neg neg_injective
#align strict_convex.neg StrictConvex.neg

theorem StrictConvex.sub (hs : StrictConvex 𝕜 s) (ht : StrictConvex 𝕜 t) : StrictConvex 𝕜 (s - t) :=
  (sub_eq_add_neg s t).symm ▸ hs.add ht.neg
#align strict_convex.sub StrictConvex.sub

end AddCommGroup

end OrderedRing

section LinearOrderedField

variable [LinearOrderedField 𝕜] [TopologicalSpace E]

section AddCommGroup

variable [AddCommGroup E] [AddCommGroup F] [Module 𝕜 E] [Module 𝕜 F] {s : Set E} {x : E}

/-- Alternative definition of set strict convexity, using division. -/
theorem strictConvex_iff_div :
    StrictConvex 𝕜 s ↔
      s.Pairwise fun x y =>
        ∀ ⦃a b : 𝕜⦄, 0 < a → 0 < b → (a / (a + b)) • x + (b / (a + b)) • y ∈ interior s :=
  ⟨fun h x hx y hy hxy a b ha hb => by
    apply h hx hy hxy (div_pos ha <| add_pos ha hb) (div_pos hb <| add_pos ha hb)
    rw [← add_div]
    exact div_self (add_pos ha hb).ne', fun h x hx y hy hxy a b ha hb hab => by
    convert h hx hy hxy ha hb <;> rw [hab, div_one]⟩
#align strict_convex_iff_div strictConvex_iff_div

theorem StrictConvex.mem_smul_of_zero_mem (hs : StrictConvex 𝕜 s) (zero_mem : (0 : E) ∈ s)
    (hx : x ∈ s) (hx₀ : x ≠ 0) {t : 𝕜} (ht : 1 < t) : x ∈ t • interior s := by
  rw [mem_smul_set_iff_inv_smul_mem₀ (zero_lt_one.trans ht).ne']
  exact hs.smul_mem_of_zero_mem zero_mem hx hx₀ (inv_pos.2 <| zero_lt_one.trans ht) (inv_lt_one ht)
#align strict_convex.mem_smul_of_zero_mem StrictConvex.mem_smul_of_zero_mem

end AddCommGroup

end LinearOrderedField

/-!
#### Convex sets in an ordered space

Relates `Convex` and `Set.OrdConnected`.
-/

section

variable [LinearOrderedField 𝕜] [TopologicalSpace 𝕜] [OrderTopology 𝕜] {s : Set 𝕜}

/-- A set in a linear ordered field is strictly convex if and only if it is convex. -/
@[simp]
theorem strictConvex_iff_convex : StrictConvex 𝕜 s ↔ Convex 𝕜 s :=
  ⟨StrictConvex.convex, fun hs => hs.ordConnected.strictConvex⟩
#align strict_convex_iff_convex strictConvex_iff_convex

theorem strictConvex_iff_ordConnected : StrictConvex 𝕜 s ↔ s.OrdConnected :=
  strictConvex_iff_convex.trans convex_iff_ordConnected
#align strict_convex_iff_ord_connected strictConvex_iff_ordConnected

alias strictConvex_iff_ordConnected ↔ StrictConvex.ordConnected _
#align strict_convex.ord_connected StrictConvex.ordConnected

end


import tactic.induction
import tactic.linarith

universes u v w

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

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

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

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

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

namespace List

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

end List

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

namespace Vec

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

end Vec

inductive Two : Type | zero | one

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

namespace ℕ₂

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

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

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

end ℕ₂

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

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

namespace rose

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

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

end rose

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

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

/- Head induction for transitive closure -/

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

namespace star

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

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

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

end star

/- Factorial -/

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

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

/- Substitution -/

namespace expressions

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

export exp

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

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

end expressions

/- Less-than -/

namespace less_than

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

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

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

end less_than

/- Sortedness -/

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

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

/- Palindromes -/

namespace palindrome

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

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

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

end palindrome

/- Transitive Closure -/

namespace transitive_closure

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

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

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

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

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

/- Another proof along the same lines. -/

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

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

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

end transitive_closure

/- Evenness -/

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

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

/- Big-Step Semantics -/

namespace semantics

def state :=
string → ℕ

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

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

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

export stmt

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

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

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

infix ` ⟹ `:110 := big_step

open big_step

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

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

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

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

end semantics

/- Small-Step Semantics -/

namespace semantics

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

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

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

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

namespace star

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

attribute [refl] star.refl

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

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

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

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

end star

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

end semantics


/-
Copyright (c) 2018 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Jens Wagemaker, Anne Baanen

! This file was ported from Lean 3 source module data.list.prime
! leanprover-community/mathlib commit ccad6d5093bd2f5c6ca621fc74674cce51355af6
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Algebra.Associated
import Mathlib.Data.List.BigOperators.Lemmas
import Mathlib.Data.List.Perm

/-!
# Products of lists of prime elements.

This file contains some theorems relating `Prime` and products of `List`s.

-/

open List

section CommMonoidWithZero

variable {M : Type _} [CommMonoidWithZero M]

/-- Prime `p` divides the product of a list `L` iff it divides some `a ∈ L` -/
theorem Prime.dvd_prod_iff {p : M} {L : List M} (pp : Prime p) : p ∣ L.prod ↔ ∃ a ∈ L, p ∣ a := by
  constructor
  · intro h
    induction' L with L_hd L_tl L_ih
    · rw [prod_nil] at h
      exact absurd h pp.not_dvd_one
    · rw [prod_cons] at h
      cases' pp.dvd_or_dvd h with hd hd
      · exact ⟨L_hd, mem_cons_self L_hd L_tl, hd⟩
      · obtain ⟨x, hx1, hx2⟩ := L_ih hd
        exact ⟨x, mem_cons_of_mem L_hd hx1, hx2⟩
  · exact fun ⟨a, ha1, ha2⟩ => dvd_trans ha2 (dvd_prod ha1)
#align prime.dvd_prod_iff Prime.dvd_prod_iff

theorem Prime.not_dvd_prod {p : M} {L : List M} (pp : Prime p) (hL : ∀ a ∈ L, ¬p ∣ a) :
    ¬p ∣ L.prod :=
  mt (Prime.dvd_prod_iff pp).1 <| not_exists.2 <| fun a => not_and.2 (hL a)
#align prime.not_dvd_prod Prime.not_dvd_prod

end CommMonoidWithZero

section CancelCommMonoidWithZero

variable {M : Type _} [CancelCommMonoidWithZero M] [Unique (Units M)]

theorem mem_list_primes_of_dvd_prod {p : M} (hp : Prime p) {L : List M} (hL : ∀ q ∈ L, Prime q)
    (hpL : p ∣ L.prod) : p ∈ L := by
  obtain ⟨x, hx1, hx2⟩ := hp.dvd_prod_iff.mp hpL
  rwa [(prime_dvd_prime_iff_eq hp (hL x hx1)).mp hx2]
#align mem_list_primes_of_dvd_prod mem_list_primes_of_dvd_prod

theorem perm_of_prod_eq_prod :
    ∀ {l₁ l₂ : List M}, l₁.prod = l₂.prod → (∀ p ∈ l₁, Prime p) → (∀ p ∈ l₂, Prime p) → Perm l₁ l₂
  | [], [], _, _, _ => Perm.nil
  | [], a :: l, h₁, _, h₃ =>
    have ha : a ∣ 1 := @prod_nil M _ ▸ h₁.symm ▸ (@prod_cons _ _ l a).symm ▸ dvd_mul_right _ _
    absurd ha (Prime.not_dvd_one (h₃ a (mem_cons_self _ _)))
  | a :: l, [], h₁, h₂, _ =>
    have ha : a ∣ 1 := @prod_nil M _ ▸ h₁ ▸ (@prod_cons _ _ l a).symm ▸ dvd_mul_right _ _
    absurd ha (Prime.not_dvd_one (h₂ a (mem_cons_self _ _)))
  | a :: l₁, b :: l₂, h, hl₁, hl₂ => by
    classical
      have hl₁' : ∀ p ∈ l₁, Prime p := fun p hp => hl₁ p (mem_cons_of_mem _ hp)
      have hl₂' : ∀ p ∈ (b :: l₂).erase a, Prime p := fun p hp => hl₂ p (mem_of_mem_erase hp)
      have ha : a ∈ b :: l₂ :=
        mem_list_primes_of_dvd_prod (hl₁ a (mem_cons_self _ _)) hl₂
          (h ▸ by rw [prod_cons] ; exact dvd_mul_right _ _)
      have hb : b :: l₂ ~ a :: (b :: l₂).erase a := perm_cons_erase ha
      have hl : prod l₁ = prod ((b :: l₂).erase a) :=
        (mul_right_inj' (hl₁ a (mem_cons_self _ _)).ne_zero).1 <| by
          rwa [← prod_cons, ← prod_cons, ← hb.prod_eq]
      exact Perm.trans ((perm_of_prod_eq_prod hl hl₁' hl₂').cons _) hb.symm
#align perm_of_prod_eq_prod perm_of_prod_eq_prod

end CancelCommMonoidWithZero


/- Exercise 2.3: Functional Programming — Monads -/

namespace exercise

/- Question 1: A state monad with failure -/

/- As usual, we start by repeating some material from the lecture. -/

class monad (M : Type → Type) extends has_bind M, has_pure M : Type 1 :=
(pure_bind {α β} (a : α) (f : α → M β) :
  pure a >>= f = f a)
(bind_pure {α} (m : M α) :
  m >>= pure = m)
(bind_assoc {α β γ} (f : α → M β) (g : β → M γ) (m : M α) :
  ((m >>= f) >>= g) = (m >>= (λa, f a >>= g)))

attribute [simp] exercise.monad.bind_pure exercise.monad.bind_assoc exercise.monad.pure_bind

open exercise.monad

instance monad_option : monad option :=
{ pure       := @option.some,
  bind       := @option.bind,
  pure_bind  := assume α β a f, by refl,
  bind_pure  := assume α m, match m with none := by refl | some a := by refl end,
  bind_assoc := assume α β γ f g m, match m with none := by refl | some a := by refl end }

/- For this exercise, we introduce a richer notion of monad that provides an `orelse` operator `<|>`
satisfying some laws, given below. `emp` denotes failure. `x <|> y` tries `x` first, falling back on
`y` on failure. -/

class monad_with_orelse (M : Type → Type) extends monad M, has_orelse M :=
(emp {} {α} : M α)
(emp_orelse {α} (a : M α) :
  (emp <|> a) = a)
(orelse_emp {α} (a : M α) :
  (a <|> emp) = a)
(orelse_assoc {α} (a b c : M α) :
  ((a <|> b) <|> c) = (a <|> (b <|> c)))
(emp_bind {α β} (f : α → M β) :
  (emp >>= f) = emp)
(bind_emp {α β} (f : M α) :
  (f >>= (λa, emp : α → M β)) = emp)

open exercise.monad_with_orelse

attribute [simp] exercise.monad_with_orelse.emp_orelse exercise.monad_with_orelse.orelse_emp
  exercise.monad_with_orelse.orelse_assoc exercise.monad_with_orelse.emp_bind
  exercise.monad_with_orelse.bind_emp

/- 1.1. We set up the `option` type constructor to be a `monad_with_orelse`. Complete the proofs
below. -/

namespace option

variables {α β γ : Type}

def orelse {α} : option α → option α → option α
| none     b := b
| (some a) _ := some a

instance : monad_with_orelse option :=
{ emp          := λα, none,
  orelse       := @option.orelse,
  emp_orelse   := assume α a, match a with some a := by refl | none := by refl end ,
  orelse_emp   := assume α a, match a with some a := by refl | none := by refl end,
  orelse_assoc := assume α a b c, match a with some a := by refl | none := by refl end,
  emp_bind     := assume α β f, by refl,
  bind_emp     := assume α β f, by ...,
  .. exercise.monad_option }

@[simp] lemma some_bind (a : α) (g : α → option β) :
  (some a >>= g) = g a := by refl

end option

/- Let us enable some convenient pattern matching syntax, by instantiating Lean's `monad_fail` type
class. -/

instance {M} [monad_with_orelse M] : monad_fail M :=
⟨λα msg, emp⟩

/- Now we can write definitions such as the following: -/

def first_of_three {M} [monad_with_orelse M] (c : M (list ℕ)) : M ℕ := do
  [n, _, _] ← c, -- look Ma, this list has three elements!
  pure n

#eval first_of_three (some [1])
#eval first_of_three (some [1, 2, 3, 4])
#eval first_of_three (some [1, 2, 3])

/- Using `monad_with_orelse` and the `monad_fail` syntax, we can give a much more consise definition
for the `sum_2_5_7` function seen in the lecture. -/

def sum_2_5_7 {M} [monad_with_orelse M] (c : M (list ℕ)) : M ℕ := do
  (_ :: n2 :: _ :: _ :: n5 :: _ :: n7 :: _) ← c,
  pure (n2 + n5 + n7)

/- 1.2. Now we are ready to define `fstate σ`: a monad with an internal state of type `σ` that can
fail (unlike `state σ`).

We start with defining `fstate σ α`, where `σ` is the type of the internal state, and `α` is the
type of the value stored in the monad. We use `option` to model failure. This means we can also use
the monadic behvior of `option` when defining the monadic opertions on `fstate`.

**Hint:** Remember that `fstate σ α` is an alias for a function type, so you can use pattern
matching and `λs, ...` to define values of type `fstate σ α`.

**Hint:** `fstate` is very similar to `state` in the lecture demonstration. You can look there for
inspiration.
-/

def fstate (σ : Type) (α : Type) := σ → option (α × σ)

/- 1.3. Define the `get` and `set` function for `fstate`, where `get` returns the state passed along
the state monad, and `set s` changes the state to `s` and returns the old state.
-/

def get {σ : Type} : fstate σ σ
| s := (s,s)

def set {σ : Type} (s : σ) : fstate σ unit
| t := ((), s)

namespace fstate

variables {σ α β γ : Type}

/- 1.4. Define the monadic operators (`bind` and `pure`) for `fstate`, in such a way that they
will satisfy the monadic laws. -/

protected def bind (f : fstate σ α) (g : α → fstate σ β) : fstate σ β
| s := function.uncurry g (f s)

-- set up the `>>=` syntax on `fstate`
instance : has_bind (fstate σ) := ⟨@fstate.bind σ⟩

@[simp] lemma bind_apply (f : fstate σ α) (g : α → fstate σ β) (s : σ) :
  (f >>= g) s = f s >>= function.uncurry g :=
by refl

protected def pure (a : α) : fstate σ α
:= sorry

-- we already setup the syntax for `pure` on `fstate`
instance : has_pure (fstate σ) := ⟨@fstate.pure σ⟩

@[simp] lemma pure_apply (a : α) (s : σ) :
  (pure a : fstate σ α) s = some (a, s) :=
by refl

/- 1.3 `fstate` is a monad:

**Hint:** `pure` and `bind` are introduced using `protected`, so their names are `fstate.pure` and
`fstate.bind`

**Hint**: `funext` is your friend when you need to prove equality between two functions.

**Hint**: Sometimes one `cases` is not enough, especially `uncurry f p` requires that `p` is a pair
of the form `(a, b)`!

**Hint**: `cases (f s)` only works when `f s` is appreaing in your goal, so you may need to unfold
some constants before you can do a `cases`.
-/

instance : monad (fstate σ) :=
{ pure_bind  :=
    sorry,
  bind_pure  :=
    sorry,
  bind_assoc :=
    sorry,
  .. fstate.has_bind, .. fstate.has_pure }

/- 1.4 `fstate` is a monad which supports failure.

**Hint**: Sometimes one `cases` is not enough, especially `uncurry f p` requires that `p` is a pair
of the form `(a, b)`!

**Hint**: `funext` is your friend when you need to prove equality between two functions.

**Hint**: parts of `fstate` are defined using the `option` monad, so parts of some proofs could
use `emp_orelse`, `orelse_emp`, `orelse_assoc`, `emp_bind`, when talking about `option`. -/

instance : monad_with_orelse (fstate σ) :=
{ emp          := λα s, none,
  orelse       := λα f g s, option.orelse (f s) (g s),
  emp_orelse   :=
    sorry,
  orelse_emp   :=
    sorry,
  orelse_assoc :=
    sorry,
  emp_bind     :=
    sorry,
  bind_emp     := assume α β f, funext $ assume s,
    sorry,
  .. exercise.fstate.exercise.monad }

@[simp] lemma orelse_apply (f g : fstate σ α) (s : σ) :
  (f <|> g) s = (f s <|> g s) :=
by refl

@[simp] lemma emp_apply (s : σ) :
  (emp : fstate σ α) s = (emp : option (α × σ)) :=
by refl

end fstate

/- Let us use `fstate`. -/

section monad

variables {M : Type → Type} [monad M] {α β : Type}

def mmap (f : α → M β) : list α → M (list β)
| []       := pure []
| (a :: l) := do
  b ← f a,
  l' ← mmap l,
  pure (b :: l')

end monad

example (l : list ℕ) : fstate ℕ (list ℕ) :=
mmap (λp : ℕ, do
  prev ← get,
  set p,
  if prev > p then
    emp
  else
    pure (p - prev)) l

/-  Question 2: Kleisli operator: pipelining monadic operations -/

section kleisli_operator

open monad

variables {M : Type → Type} [monad M] {α β γ δ : Type}
variables {f : α → M β} {g : β → M γ} {h : γ → M δ}

def kleisli (f : α → M β) (g : β → M γ) : (α → M γ) :=
λa, f a >>= g

infixr ` >=> `:90 := kleisli

/- 2.1. Prove the following equations for the Kleisli operator.

**Hint**: Remember `funext`. -/

-- `pure` is a left unit for `>=>`
lemma pure_kleisli : pure >=> f = f :=
sorry

-- `pure` is a right unit for `>=>`
lemma kleisli_pure : f >=> pure = f :=
sorry

-- `>=>` is associative
lemma kleisli_assoc : (f >=> g) >=> h = f >=> (g >=> h) :=
sorry

end kleisli_operator

end exercise


/-
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

! This file was ported from Lean 3 source module topology.algebra.infinite_sum.ring
! leanprover-community/mathlib commit 9a59dcb7a2d06bf55da57b9030169219980660cd
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Algebra.BigOperators.NatAntidiagonal
import Mathlib.Topology.Algebra.InfiniteSum.Basic
import Mathlib.Topology.Algebra.Ring.Basic

/-!
# Infinite sum in a ring

This file provides lemmas about the interaction between infinite sums and multiplication.

## Main results

* `tsum_mul_tsum_eq_tsum_sum_antidiagonal`: Cauchy product formula
-/

open Filter Finset Function

open BigOperators Classical

variable {ι κ R α : Type _}

section NonUnitalNonAssocSemiring

variable [NonUnitalNonAssocSemiring α] [TopologicalSpace α] [TopologicalSemiring α] {f g : ι → α}
  {a a₁ a₂ : α}

theorem HasSum.mul_left (a₂) (h : HasSum f a₁) : HasSum (fun i => a₂ * f i) (a₂ * a₁) := by
  simpa only using h.map (AddMonoidHom.mulLeft a₂) (continuous_const.mul continuous_id)
#align has_sum.mul_left HasSum.mul_left

theorem HasSum.mul_right (a₂) (hf : HasSum f a₁) : HasSum (fun i => f i * a₂) (a₁ * a₂) := by
  simpa only using hf.map (AddMonoidHom.mulRight a₂) (continuous_id.mul continuous_const)
#align has_sum.mul_right HasSum.mul_right

theorem Summable.mul_left (a) (hf : Summable f) : Summable fun i => a * f i :=
  (hf.hasSum.mul_left _).summable
#align summable.mul_left Summable.mul_left

theorem Summable.mul_right (a) (hf : Summable f) : Summable fun i => f i * a :=
  (hf.hasSum.mul_right _).summable
#align summable.mul_right Summable.mul_right

section tsum

variable [T2Space α]

theorem Summable.tsum_mul_left (a) (hf : Summable f) : (∑' i, a * f i) = a * ∑' i, f i :=
  (hf.hasSum.mul_left _).tsum_eq
#align summable.tsum_mul_left Summable.tsum_mul_left

theorem Summable.tsum_mul_right (a) (hf : Summable f) : (∑' i, f i * a) = (∑' i, f i) * a :=
  (hf.hasSum.mul_right _).tsum_eq
#align summable.tsum_mul_right Summable.tsum_mul_right

theorem Commute.tsum_right (a) (h : ∀ i, _root_.Commute a (f i)) : _root_.Commute a (∑' i, f i) :=
  if hf : Summable f then
    (hf.tsum_mul_left a).symm.trans ((congr_arg _ <| funext h).trans (hf.tsum_mul_right a))
  else (tsum_eq_zero_of_not_summable hf).symm ▸ Commute.zero_right _
#align commute.tsum_right Commute.tsum_right

theorem Commute.tsum_left (a) (h : ∀ i, _root_.Commute (f i) a) : _root_.Commute (∑' i, f i) a :=
  (Commute.tsum_right _ fun i => (h i).symm).symm
#align commute.tsum_left Commute.tsum_left

end tsum

end NonUnitalNonAssocSemiring

section DivisionSemiring

variable [DivisionSemiring α] [TopologicalSpace α] [TopologicalSemiring α] {f g : ι → α}
  {a a₁ a₂ : α}

theorem HasSum.div_const (h : HasSum f a) (b : α) : HasSum (fun i => f i / b) (a / b) := by
  simp only [div_eq_mul_inv, h.mul_right b⁻¹]
#align has_sum.div_const HasSum.div_const

theorem Summable.div_const (h : Summable f) (b : α) : Summable fun i => f i / b :=
  (h.hasSum.div_const _).summable
#align summable.div_const Summable.div_const

theorem hasSum_mul_left_iff (h : a₂ ≠ 0) : HasSum (fun i => a₂ * f i) (a₂ * a₁) ↔ HasSum f a₁ :=
  ⟨fun H => by simpa only [inv_mul_cancel_left₀ h] using H.mul_left a₂⁻¹, HasSum.mul_left _⟩
#align has_sum_mul_left_iff hasSum_mul_left_iff

theorem hasSum_mul_right_iff (h : a₂ ≠ 0) : HasSum (fun i => f i * a₂) (a₁ * a₂) ↔ HasSum f a₁ :=
  ⟨fun H => by simpa only [mul_inv_cancel_right₀ h] using H.mul_right a₂⁻¹, HasSum.mul_right _⟩
#align has_sum_mul_right_iff hasSum_mul_right_iff

theorem hasSum_div_const_iff (h : a₂ ≠ 0) : HasSum (fun i => f i / a₂) (a₁ / a₂) ↔ HasSum f a₁ := by
  simpa only [div_eq_mul_inv] using hasSum_mul_right_iff (inv_ne_zero h)
#align has_sum_div_const_iff hasSum_div_const_iff

theorem summable_mul_left_iff (h : a ≠ 0) : (Summable fun i => a * f i) ↔ Summable f :=
  ⟨fun H => by simpa only [inv_mul_cancel_left₀ h] using H.mul_left a⁻¹, fun H => H.mul_left _⟩
#align summable_mul_left_iff summable_mul_left_iff

theorem summable_mul_right_iff (h : a ≠ 0) : (Summable fun i => f i * a) ↔ Summable f :=
  ⟨fun H => by simpa only [mul_inv_cancel_right₀ h] using H.mul_right a⁻¹, fun H => H.mul_right _⟩
#align summable_mul_right_iff summable_mul_right_iff

theorem summable_div_const_iff (h : a ≠ 0) : (Summable fun i => f i / a) ↔ Summable f := by
  simpa only [div_eq_mul_inv] using summable_mul_right_iff (inv_ne_zero h)
#align summable_div_const_iff summable_div_const_iff

theorem tsum_mul_left [T2Space α] : (∑' x, a * f x) = a * ∑' x, f x :=
  if hf : Summable f then hf.tsum_mul_left a
  else if ha : a = 0 then by simp [ha]
  else by rw [tsum_eq_zero_of_not_summable hf,
              tsum_eq_zero_of_not_summable (mt (summable_mul_left_iff ha).mp hf), mul_zero]
#align tsum_mul_left tsum_mul_left

theorem tsum_mul_right [T2Space α] : (∑' x, f x * a) = (∑' x, f x) * a :=
  if hf : Summable f then hf.tsum_mul_right a
  else if ha : a = 0 then by simp [ha]
  else by rw [tsum_eq_zero_of_not_summable hf,
              tsum_eq_zero_of_not_summable (mt (summable_mul_right_iff ha).mp hf), zero_mul]
#align tsum_mul_right tsum_mul_right

theorem tsum_div_const [T2Space α] : (∑' x, f x / a) = (∑' x, f x) / a := by
  simpa only [div_eq_mul_inv] using tsum_mul_right
#align tsum_div_const tsum_div_const

end DivisionSemiring

/-!
### Multipliying two infinite sums

In this section, we prove various results about `(∑' x : ι, f x) * (∑' y : κ, g y)`. Note that we
always assume that the family `λ x : ι × κ, f x.1 * g x.2` is summable, since there is no way to
deduce this from the summmabilities of `f` and `g` in general, but if you are working in a normed
space, you may want to use the analogous lemmas in `Analysis/NormedSpace/Basic`
(e.g `tsum_mul_tsum_of_summable_norm`).

We first establish results about arbitrary index types, `ι` and `κ`, and then we specialize to
`ι = κ = ℕ` to prove the Cauchy product formula (see `tsum_mul_tsum_eq_tsum_sum_antidiagonal`).

#### Arbitrary index types
-/

section tsum_mul_tsum

variable [TopologicalSpace α] [T3Space α] [NonUnitalNonAssocSemiring α] [TopologicalSemiring α]
  {f : ι → α} {g : κ → α} {s t u : α}

theorem HasSum.mul_eq (hf : HasSum f s) (hg : HasSum g t)
    (hfg : HasSum (fun x : ι × κ => f x.1 * g x.2) u) : s * t = u :=
  have key₁ : HasSum (fun i => f i * t) (s * t) := hf.mul_right t
  have this : ∀ i : ι, HasSum (fun c : κ => f i * g c) (f i * t) := fun i => hg.mul_left (f i)
  have key₂ : HasSum (fun i => f i * t) u := HasSum.prod_fiberwise hfg this
  key₁.unique key₂
#align has_sum.mul_eq HasSum.mul_eq

theorem HasSum.mul (hf : HasSum f s) (hg : HasSum g t)
    (hfg : Summable fun x : ι × κ => f x.1 * g x.2) :
    HasSum (fun x : ι × κ => f x.1 * g x.2) (s * t) :=
  let ⟨_u, hu⟩ := hfg
  (hf.mul_eq hg hu).symm ▸ hu
#align has_sum.mul HasSum.mul

/-- Product of two infinites sums indexed by arbitrary types.
    See also `tsum_mul_tsum_of_summable_norm` if `f` and `g` are abolutely summable. -/
theorem tsum_mul_tsum (hf : Summable f) (hg : Summable g)
    (hfg : Summable fun x : ι × κ => f x.1 * g x.2) :
    ((∑' x, f x) * ∑' y, g y) = ∑' z : ι × κ, f z.1 * g z.2 :=
  hf.hasSum.mul_eq hg.hasSum hfg.hasSum
#align tsum_mul_tsum tsum_mul_tsum

end tsum_mul_tsum

/-!
#### `ℕ`-indexed families (Cauchy product)

We prove two versions of the Cauchy product formula. The first one is
`tsum_mul_tsum_eq_tsum_sum_range`, where the `n`-th term is a sum over `Finset.range (n+1)`
involving `Nat` subtraction.
In order to avoid `Nat` subtraction, we also provide `tsum_mul_tsum_eq_tsum_sum_antidiagonal`,
where the `n`-th term is a sum over all pairs `(k, l)` such that `k+l=n`, which corresponds to the
`Finset` `Finset.Nat.antidiagonal n`
-/

section CauchyProduct

variable [TopologicalSpace α] [NonUnitalNonAssocSemiring α] {f g : ℕ → α}

/- The family `(k, l) : ℕ × ℕ ↦ f k * g l` is summable if and only if the family
`(n, k, l) : Σ (n : ℕ), Nat.antidiagonal n ↦ f k * g l` is summable. -/
theorem summable_mul_prod_iff_summable_mul_sigma_antidiagonal :
    (Summable fun x : ℕ × ℕ => f x.1 * g x.2) ↔
      Summable fun x : Σn : ℕ, Nat.antidiagonal n => f (x.2 : ℕ × ℕ).1 * g (x.2 : ℕ × ℕ).2 :=
  Nat.sigmaAntidiagonalEquivProd.summable_iff.symm
#align summable_mul_prod_iff_summable_mul_sigma_antidiagonal summable_mul_prod_iff_summable_mul_sigma_antidiagonal

variable [T3Space α] [TopologicalSemiring α]

theorem summable_sum_mul_antidiagonal_of_summable_mul
    (h : Summable fun x : ℕ × ℕ => f x.1 * g x.2) :
    Summable fun n => ∑ kl in Nat.antidiagonal n, f kl.1 * g kl.2 := by
  rw [summable_mul_prod_iff_summable_mul_sigma_antidiagonal] at h
  conv => congr; ext; rw [← Finset.sum_finset_coe, ← tsum_fintype]
  exact h.sigma' fun n => (hasSum_fintype _).summable
#align summable_sum_mul_antidiagonal_of_summable_mul summable_sum_mul_antidiagonal_of_summable_mul

/-- The **Cauchy product formula** for the product of two infinites sums indexed by `ℕ`, expressed
by summing on `Finset.Nat.antidiagonal`.

See also `tsum_mul_tsum_eq_tsum_sum_antidiagonal_of_summable_norm` if `f` and `g` are absolutely
summable. -/
theorem tsum_mul_tsum_eq_tsum_sum_antidiagonal (hf : Summable f) (hg : Summable g)
    (hfg : Summable fun x : ℕ × ℕ => f x.1 * g x.2) :
    ((∑' n, f n) * ∑' n, g n) = ∑' n, ∑ kl in Nat.antidiagonal n, f kl.1 * g kl.2 := by
  conv_rhs => congr; ext; rw [← Finset.sum_finset_coe, ← tsum_fintype]
  rw [tsum_mul_tsum hf hg hfg, ← Nat.sigmaAntidiagonalEquivProd.tsum_eq (_ : ℕ × ℕ → α)]
  exact
    tsum_sigma' (fun n => (hasSum_fintype _).summable)
      (summable_mul_prod_iff_summable_mul_sigma_antidiagonal.mp hfg)
#align tsum_mul_tsum_eq_tsum_sum_antidiagonal tsum_mul_tsum_eq_tsum_sum_antidiagonal

theorem summable_sum_mul_range_of_summable_mul (h : Summable fun x : ℕ × ℕ => f x.1 * g x.2) :
    Summable fun n => ∑ k in range (n + 1), f k * g (n - k) := by
  simp_rw [← Nat.sum_antidiagonal_eq_sum_range_succ fun k l => f k * g l]
  exact summable_sum_mul_antidiagonal_of_summable_mul h
#align summable_sum_mul_range_of_summable_mul summable_sum_mul_range_of_summable_mul

/-- The **Cauchy product formula** for the product of two infinites sums indexed by `ℕ`, expressed
by summing on `Finset.range`.

See also `tsum_mul_tsum_eq_tsum_sum_range_of_summable_norm` if `f` and `g` are absolutely summable.
-/
theorem tsum_mul_tsum_eq_tsum_sum_range (hf : Summable f) (hg : Summable g)
    (hfg : Summable fun x : ℕ × ℕ => f x.1 * g x.2) :
    ((∑' n, f n) * ∑' n, g n) = ∑' n, ∑ k in range (n + 1), f k * g (n - k) := by
  simp_rw [← Nat.sum_antidiagonal_eq_sum_range_succ fun k l => f k * g l]
  exact tsum_mul_tsum_eq_tsum_sum_antidiagonal hf hg hfg
#align tsum_mul_tsum_eq_tsum_sum_range tsum_mul_tsum_eq_tsum_sum_range

end CauchyProduct


/-
Copyright (c) 2022 Anand Rao, Rémi Bottinelli. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Anand Rao, Rémi Bottinelli
-/
import combinatorics.simple_graph.ends.defs
import data.finite.set
import data.finset.basic
/-!
# Properties of the ends of graphs

This file is meant to contain results about the ends of
(usually locally finite and connected) graphs.
-/

variables {V : Type} (G : simple_graph V)

namespace simple_graph

lemma ends_of_finite [finite V] : is_empty G.end :=
begin
  rw is_empty_iff,
  rintro ⟨s, -⟩,
  casesI nonempty_fintype V,
  obtain ⟨v, h⟩ := (s $ opposite.op finset.univ).nonempty,
  exact set.disjoint_iff.mp (s _).disjoint_right
    ⟨by simp only [opposite.unop_op, finset.coe_univ], h⟩,
end

section TODO

def induce_univ_iso : G.induce ⊤ ≃g G := sorry
def connected_component.iso {V V' : Type*}
  {G : simple_graph V} {G' : simple_graph V'} :
  G ≃g G' → G.connected_component ≃ G'.connected_component := sorry
theorem component_compl.eq_of_not_disjoint {G : simple_graph V} {K : set V}
  (C D : G.component_compl K) :
  ¬(disjoint (C : set V) (D : set V)) → C = D := sorry

end TODO

/--!

## Ends of locally finite, connected graphs

-/

/-
For a locally finite preconnected graph, the number of components outside of any finite set
is finite.
-/
lemma component_compl_finite [locally_finite G] (Gpc : preconnected G) (K : finset V) :
  finite (G.component_compl K) :=
begin
  classical,
  rcases K.eq_empty_or_nonempty with h|h,
  -- If K is empty, then removing K doesn't change the graph, which is connected, hence has a
  -- single connected component
  { cases h, dsimp [component_compl],
    rw set.compl_empty,
    haveI := @finite.of_subsingleton _ Gpc.subsingleton_connected_component,
    exact finite.of_equiv _ (connected_component.iso (induce_univ_iso G)).symm, },
  -- Otherwise, we consider the function `touch` mapping a connected component to one of its
  -- vertices adjacent to `K`.
  { let touch : G.component_compl K → {v : V | ∃ k : V, k ∈ K ∧ G.adj k v} :=
      λ C, let p := C.exists_adj_boundary_pair Gpc h in
        ⟨p.some.1, p.some.2, p.some_spec.2.1, p.some_spec.2.2.symm⟩,
    -- `touch` is injective
    have touch_inj : touch.injective := λ C D h', component_compl.eq_of_not_disjoint C D (by
    { rw set.not_disjoint_iff,
      use touch C,
      exact ⟨ (C.exists_adj_boundary_pair Gpc h).some_spec.1,
              h'.symm ▸ (D.exists_adj_boundary_pair Gpc h).some_spec.1⟩, }),
    -- `touch` has finite range
    haveI : finite (set.range touch), by
    { apply @subtype.finite _ _ _,
      apply set.finite.to_subtype,
      have : {v : V | ∃ (k : V), k ∈ K ∧ G.adj k v} = finset.bUnion K (λ v, G.neighbor_finset v), by
      { ext v,
        simp only [set.mem_Union, exists_prop, set.mem_set_of_eq, finset.coe_bUnion,
                  finset.mem_coe, mem_neighbor_finset], },
      rw this,
      apply finset.finite_to_set, },
    apply finite.of_injective_finite_range touch_inj, },
end

/--
In an infinite graph, the set of components out of a finite set is nonempty.
-/
lemma component_compl_nonempty_of_infinite [infinite V] (K : finset V) : nonempty (G.component_compl K) :=
begin
  obtain ⟨k,kK⟩ := set.infinite.nonempty (set.finite.infinite_compl $ K.finite_to_set),
  exact ⟨component_compl_mk _ kK⟩,
end

-- TODO: Fix the definitions below using the newer inverse system implementation
#exit
/--
The `component_compl`s chosen by an end are all infinite.
-/
lemma end_component_compl_infinite (e : G.end) (K : (finset V)ᵒᵖ) : (e.val K).supp.infinite :=
begin
  apply (e.val K).inf_iff_in_all_ranges.mpr (λ L h, _),
  change opposite.unop K ⊆ opposite.unop (opposite.op L) at h,
  exact  ⟨e.val (opposite.op L), (e.prop (category_theory.op_hom_of_le h)).symm⟩,
end

/--
A locally finite preconnected infinite graph has at least one end.
-/
lemma nonempty_ends_of_infinite [Glf : locally_finite G] (Gpc : preconnected G) [Vi : infinite V] :
  G.end.nonempty :=
begin
  classical,
  exact @nonempty_sections_of_fintype_inverse_system _ _ _ G.component_compl_functor
    (λ K, @fintype.of_finite _ $ G.component_compl_finite Gpc K.unop)
    (λ K, G.component_compl_nonempty_of_infinite K.unop)
end

end simple_graph