/-
Copyright (c) 2021 Hunter Monroe. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Hunter Monroe, Kyle Miller, Alena Gusakov
-/
import combinatorics.simple_graph.basic

/-!
# Subgraphs of a simple graph

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

A subgraph of a simple graph consists of subsets of the graph's vertices and edges such that the
endpoints of each edge are present in the vertex subset. The edge subset is formalized as a
sub-relation of the adjacency relation of the simple graph.

## Main definitions

* `subgraph G` is the type of subgraphs of a `G : simple_graph`

* `subgraph.neighbor_set`, `subgraph.incidence_set`, and `subgraph.degree` are like their
  `simple_graph` counterparts, but they refer to vertices from `G` to avoid subtype coercions.

* `subgraph.coe` is the coercion from a `G' : subgraph G` to a `simple_graph G'.verts`.
  (This cannot be a `has_coe` instance since the destination type depends on `G'`.)

* `subgraph.is_spanning` for whether a subgraph is a spanning subgraph and
  `subgraph.is_induced` for whether a subgraph is an induced subgraph.

* Instances for `lattice (subgraph G)` and `bounded_order (subgraph G)`.

* `simple_graph.to_subgraph`: If a `simple_graph` is a subgraph of another, then you can turn it
  into a member of the larger graph's `simple_graph.subgraph` type.

* Graph homomorphisms from a subgraph to a graph (`subgraph.map_top`) and between subgraphs
  (`subgraph.map`).

## Implementation notes

* Recall that subgraphs are not determined by their vertex sets, so `set_like` does not apply to
  this kind of subobject.

## Todo

* Images of graph homomorphisms as subgraphs.

-/

universes u v

namespace simple_graph

/-- A subgraph of a `simple_graph` is a subset of vertices along with a restriction of the adjacency
relation that is symmetric and is supported by the vertex subset.  They also form a bounded lattice.

Thinking of `V → V → Prop` as `set (V × V)`, a set of darts (i.e., half-edges), then
`subgraph.adj_sub` is that the darts of a subgraph are a subset of the darts of `G`. -/
@[ext]
structure subgraph {V : Type u} (G : simple_graph V) :=
(verts : set V)
(adj : V → V → Prop)
(adj_sub : ∀ {v w : V}, adj v w → G.adj v w)
(edge_vert : ∀ {v w : V}, adj v w → v ∈ verts)
(symm : symmetric adj . obviously)

variables {ι : Sort*} {V : Type u} {W : Type v}

/-- The one-vertex subgraph. -/
@[simps]
protected def singleton_subgraph (G : simple_graph V) (v : V) : G.subgraph :=
{ verts := {v},
  adj := ⊥,
  adj_sub := by simp [-set.bot_eq_empty],
  edge_vert := by simp [-set.bot_eq_empty] }

/-- The one-edge subgraph. -/
@[simps]
def subgraph_of_adj (G : simple_graph V) {v w : V} (hvw : G.adj v w) : G.subgraph :=
{ verts := {v, w},
  adj := λ a b, ⟦(v, w)⟧ = ⟦(a, b)⟧,
  adj_sub := λ a b h, by { rw [← G.mem_edge_set, ← h], exact hvw },
  edge_vert := λ a b h, by { apply_fun (λ e, a ∈ e) at h, simpa using h } }

namespace subgraph

variables {G : simple_graph V} {G₁ G₂ : G.subgraph} {a b : V}

protected lemma loopless (G' : subgraph G) : irreflexive G'.adj :=
λ v h, G.loopless v (G'.adj_sub h)

lemma adj_comm (G' : subgraph G) (v w : V) : G'.adj v w ↔ G'.adj w v :=
⟨λ x, G'.symm x, λ x, G'.symm x⟩

@[symm] lemma adj_symm (G' : subgraph G) {u v : V} (h : G'.adj u v) : G'.adj v u := G'.symm h

protected lemma adj.symm {G' : subgraph G} {u v : V} (h : G'.adj u v) : G'.adj v u := G'.symm h

protected lemma adj.adj_sub {H : G.subgraph} {u v : V} (h : H.adj u v) : G.adj u v := H.adj_sub h

protected lemma adj.fst_mem {H : G.subgraph} {u v : V} (h : H.adj u v) : u ∈ H.verts :=
H.edge_vert h

protected lemma adj.snd_mem {H : G.subgraph} {u v : V} (h : H.adj u v) : v ∈ H.verts :=
h.symm.fst_mem

protected lemma adj.ne {H : G.subgraph} {u v : V} (h : H.adj u v) : u ≠ v := h.adj_sub.ne

/-- Coercion from `G' : subgraph G` to a `simple_graph ↥G'.verts`. -/
@[simps] protected def coe (G' : subgraph G) : simple_graph G'.verts :=
{ adj := λ v w, G'.adj v w,
  symm := λ v w h, G'.symm h,
  loopless := λ v h, loopless G v (G'.adj_sub h) }

@[simp] lemma coe_adj_sub (G' : subgraph G) (u v : G'.verts) (h : G'.coe.adj u v) : G.adj u v :=
G'.adj_sub h

/- Given `h : H.adj u v`, then `h.coe : H.coe.adj ⟨u, _⟩ ⟨v, _⟩`. -/
protected lemma adj.coe {H : G.subgraph} {u v : V} (h : H.adj u v) :
  H.coe.adj ⟨u, H.edge_vert h⟩ ⟨v, H.edge_vert h.symm⟩ := h

/-- A subgraph is called a *spanning subgraph* if it contains all the vertices of `G`. -/
def is_spanning (G' : subgraph G) : Prop := ∀ (v : V), v ∈ G'.verts

lemma is_spanning_iff {G' : subgraph G} : G'.is_spanning ↔ G'.verts = set.univ :=
set.eq_univ_iff_forall.symm

/-- Coercion from `subgraph G` to `simple_graph V`.  If `G'` is a spanning
subgraph, then `G'.spanning_coe` yields an isomorphic graph.
In general, this adds in all vertices from `V` as isolated vertices. -/
@[simps] protected def spanning_coe (G' : subgraph G) : simple_graph V :=
{ adj := G'.adj,
  symm := G'.symm,
  loopless := λ v hv, G.loopless v (G'.adj_sub hv) }

@[simp] lemma adj.of_spanning_coe {G' : subgraph G} {u v : G'.verts}
  (h : G'.spanning_coe.adj u v) : G.adj u v := G'.adj_sub h

@[simp] lemma spanning_coe_inj : G₁.spanning_coe = G₂.spanning_coe ↔ G₁.adj = G₂.adj :=
by simp [subgraph.spanning_coe]

/-- `spanning_coe` is equivalent to `coe` for a subgraph that `is_spanning`.  -/
@[simps] def spanning_coe_equiv_coe_of_spanning (G' : subgraph G) (h : G'.is_spanning) :
  G'.spanning_coe ≃g G'.coe :=
{ to_fun := λ v, ⟨v, h v⟩,
  inv_fun := λ v, v,
  left_inv := λ v, rfl,
  right_inv := λ ⟨v, hv⟩, rfl,
  map_rel_iff' := λ v w, iff.rfl }

/-- A subgraph is called an *induced subgraph* if vertices of `G'` are adjacent if
they are adjacent in `G`. -/
def is_induced (G' : subgraph G) : Prop :=
∀ {v w : V}, v ∈ G'.verts → w ∈ G'.verts → G.adj v w → G'.adj v w

/-- `H.support` is the set of vertices that form edges in the subgraph `H`. -/
def support (H : subgraph G) : set V := rel.dom H.adj

lemma mem_support (H : subgraph G) {v : V} : v ∈ H.support ↔ ∃ w, H.adj v w := iff.rfl

lemma support_subset_verts (H : subgraph G) : H.support ⊆ H.verts := λ v ⟨w, h⟩, H.edge_vert h

/-- `G'.neighbor_set v` is the set of vertices adjacent to `v` in `G'`. -/
def neighbor_set (G' : subgraph G) (v : V) : set V := set_of (G'.adj v)

lemma neighbor_set_subset (G' : subgraph G) (v : V) : G'.neighbor_set v ⊆ G.neighbor_set v :=
λ w h, G'.adj_sub h

lemma neighbor_set_subset_verts (G' : subgraph G) (v : V) : G'.neighbor_set v ⊆ G'.verts :=
λ _ h, G'.edge_vert (adj_symm G' h)

@[simp] lemma mem_neighbor_set (G' : subgraph G) (v w : V) : w ∈ G'.neighbor_set v ↔ G'.adj v w :=
iff.rfl

/-- A subgraph as a graph has equivalent neighbor sets. -/
def coe_neighbor_set_equiv {G' : subgraph G} (v : G'.verts) :
  G'.coe.neighbor_set v ≃ G'.neighbor_set v :=
{ to_fun := λ w, ⟨w, by { obtain ⟨w', hw'⟩ := w, simpa using hw' }⟩,
  inv_fun := λ w, ⟨⟨w, G'.edge_vert (G'.adj_symm w.2)⟩, by simpa using w.2⟩,
  left_inv := λ w, by simp,
  right_inv := λ w, by simp }

/-- The edge set of `G'` consists of a subset of edges of `G`. -/
def edge_set (G' : subgraph G) : set (sym2 V) := sym2.from_rel G'.symm

lemma edge_set_subset (G' : subgraph G) : G'.edge_set ⊆ G.edge_set :=
λ e, quotient.ind (λ e h, G'.adj_sub h) e

@[simp]
lemma mem_edge_set {G' : subgraph G} {v w : V} : ⟦(v, w)⟧ ∈ G'.edge_set ↔ G'.adj v w := iff.rfl

lemma mem_verts_if_mem_edge {G' : subgraph G} {e : sym2 V} {v : V}
  (he : e ∈ G'.edge_set) (hv : v ∈ e) : v ∈ G'.verts :=
begin
  refine quotient.ind (λ e he hv, _) e he hv,
  cases e with v w,
  simp only [mem_edge_set] at he,
  cases sym2.mem_iff.mp hv with h h; subst h,
  { exact G'.edge_vert he, },
  { exact G'.edge_vert (G'.symm he), },
end

/-- The `incidence_set` is the set of edges incident to a given vertex. -/
def incidence_set (G' : subgraph G) (v : V) : set (sym2 V) := {e ∈ G'.edge_set | v ∈ e}

lemma incidence_set_subset_incidence_set (G' : subgraph G) (v : V) :
  G'.incidence_set v ⊆ G.incidence_set v :=
λ e h, ⟨G'.edge_set_subset h.1, h.2⟩

lemma incidence_set_subset (G' : subgraph G) (v : V) : G'.incidence_set v ⊆ G'.edge_set :=
λ _ h, h.1

/-- Give a vertex as an element of the subgraph's vertex type. -/
@[reducible]
def vert (G' : subgraph G) (v : V) (h : v ∈ G'.verts) : G'.verts := ⟨v, h⟩

/--
Create an equal copy of a subgraph (see `copy_eq`) with possibly different definitional equalities.
See Note [range copy pattern].
-/
def copy (G' : subgraph G)
  (V'' : set V) (hV : V'' = G'.verts)
  (adj' : V → V → Prop) (hadj : adj' = G'.adj) :
  subgraph G :=
{ verts := V'',
  adj := adj',
  adj_sub := λ _ _, hadj.symm ▸ G'.adj_sub,
  edge_vert := λ _ _, hV.symm ▸ hadj.symm ▸ G'.edge_vert,
  symm := hadj.symm ▸ G'.symm }

lemma copy_eq (G' : subgraph G)
  (V'' : set V) (hV : V'' = G'.verts)
  (adj' : V → V → Prop) (hadj : adj' = G'.adj) :
  G'.copy V'' hV adj' hadj = G' :=
subgraph.ext _ _ hV hadj

/-- The union of two subgraphs. -/
instance : has_sup G.subgraph :=
⟨λ G₁ G₂,
  { verts := G₁.verts ∪ G₂.verts,
    adj := G₁.adj ⊔ G₂.adj,
    adj_sub := λ a b hab, or.elim hab (λ h, G₁.adj_sub h) (λ h, G₂.adj_sub h),
    edge_vert := λ a b, or.imp (λ h, G₁.edge_vert h) (λ h, G₂.edge_vert h),
    symm := λ a b, or.imp G₁.adj_symm G₂.adj_symm }⟩

/-- The intersection of two subgraphs. -/
instance : has_inf G.subgraph :=
⟨λ G₁ G₂,
  { verts := G₁.verts ∩ G₂.verts,
    adj := G₁.adj ⊓ G₂.adj,
    adj_sub := λ a b hab, G₁.adj_sub hab.1,
    edge_vert := λ a b, and.imp (λ h, G₁.edge_vert h) (λ h, G₂.edge_vert h),
    symm := λ a b, and.imp G₁.adj_symm G₂.adj_symm }⟩

/-- The `top` subgraph is `G` as a subgraph of itself. -/
instance : has_top G.subgraph :=
⟨{ verts := set.univ,
  adj := G.adj,
  adj_sub := λ v w h, h,
  edge_vert := λ v w h, set.mem_univ v,
  symm := G.symm }⟩

/-- The `bot` subgraph is the subgraph with no vertices or edges. -/
instance : has_bot G.subgraph :=
⟨{ verts := ∅,
  adj := ⊥,
  adj_sub := λ v w h, false.rec _ h,
  edge_vert := λ v w h, false.rec _ h,
  symm := λ u v h, h }⟩

instance : has_Sup G.subgraph :=
⟨λ s, { verts := ⋃ G' ∈ s, verts G',
        adj := λ a b, ∃ G' ∈ s, adj G' a b,
        adj_sub := by { rintro a b ⟨G', -, hab⟩, exact G'.adj_sub hab },
        edge_vert :=
          by { rintro a b ⟨G', hG', hab⟩, exact set.mem_Union₂_of_mem hG' (G'.edge_vert hab) },
        symm := λ a b, Exists₂.imp $ λ _ _, adj.symm }⟩

instance : has_Inf G.subgraph :=
⟨λ s, { verts := ⋂ G' ∈ s, verts G',
        adj := λ a b, (∀ ⦃G'⦄, G' ∈ s → adj G' a b) ∧ G.adj a b,
        adj_sub := λ a b, and.right,
        edge_vert := λ a b hab, set.mem_Inter₂_of_mem $ λ G' hG', G'.edge_vert $ hab.1 hG',
        symm := λ _ _, and.imp (forall₂_imp $ λ _ _, adj.symm) G.adj_symm }⟩

@[simp] lemma sup_adj : (G₁ ⊔ G₂).adj a b ↔ G₁.adj a b ∨ G₂.adj a b := iff.rfl
@[simp] lemma inf_adj : (G₁ ⊓ G₂).adj a b ↔ G₁.adj a b ∧ G₂.adj a b := iff.rfl
@[simp] lemma top_adj : (⊤ : subgraph G).adj a b ↔ G.adj a b := iff.rfl
@[simp] lemma not_bot_adj : ¬ (⊥ : subgraph G).adj a b := not_false

@[simp] lemma verts_sup (G₁ G₂ : G.subgraph) : (G₁ ⊔ G₂).verts = G₁.verts ∪ G₂.verts := rfl
@[simp] lemma verts_inf (G₁ G₂ : G.subgraph) : (G₁ ⊓ G₂).verts = G₁.verts ∩ G₂.verts := rfl
@[simp] lemma verts_top : (⊤ : G.subgraph).verts = set.univ := rfl
@[simp] lemma verts_bot : (⊥ : G.subgraph).verts = ∅ := rfl

@[simp] lemma Sup_adj {s : set G.subgraph} : (Sup s).adj a b ↔ ∃ G ∈ s, adj G a b := iff.rfl

@[simp] lemma Inf_adj {s : set G.subgraph} : (Inf s).adj a b ↔ (∀ G' ∈ s, adj G' a b) ∧ G.adj a b :=
iff.rfl

@[simp] lemma supr_adj {f : ι → G.subgraph} : (⨆ i, f i).adj a b ↔ ∃ i, (f i).adj a b :=
by simp [supr]

@[simp] lemma infi_adj {f : ι → G.subgraph} :
  (⨅ i, f i).adj a b ↔ (∀ i, (f i).adj a b) ∧ G.adj a b :=
by simp [infi]

lemma Inf_adj_of_nonempty {s : set G.subgraph} (hs : s.nonempty) :
  (Inf s).adj a b ↔ ∀ G' ∈ s, adj G' a b :=
Inf_adj.trans $ and_iff_left_of_imp $ by { obtain ⟨G', hG'⟩ := hs, exact λ h, G'.adj_sub (h _ hG') }

lemma infi_adj_of_nonempty [nonempty ι] {f : ι → G.subgraph} :
  (⨅ i, f i).adj a b ↔ ∀ i, (f i).adj a b :=
by simp [infi, Inf_adj_of_nonempty (set.range_nonempty _)]

@[simp]

@[simp] lemma verts_supr {f : ι → G.subgraph} : (⨆ i, f i).verts = ⋃ i, (f i).verts :=
by simp [supr]

@[simp] lemma verts_infi {f : ι → G.subgraph} : (⨅ i, f i).verts = ⋂ i, (f i).verts :=
by simp [infi]

/-- For subgraphs `G₁`, `G₂`, `G₁ ≤ G₂` iff `G₁.verts ⊆ G₂.verts` and
`∀ a b, G₁.adj a b → G₂.adj a b`. -/
instance : distrib_lattice G.subgraph :=
{ le := λ x y, x.verts ⊆ y.verts ∧ ∀ ⦃v w : V⦄, x.adj v w → y.adj v w,
  ..show distrib_lattice G.subgraph, from function.injective.distrib_lattice
    (λ G', (G'.verts, G'.spanning_coe))
    (λ G₁ G₂ h, by { rw prod.ext_iff at h, exact ext _ _ h.1 (spanning_coe_inj.1 h.2) })
    (λ _ _, rfl) (λ _ _, rfl) }

instance : bounded_order (subgraph G) :=
{ top := ⊤,
  bot := ⊥,
  le_top := λ x, ⟨set.subset_univ _, (λ v w h, x.adj_sub h)⟩,
  bot_le := λ x, ⟨set.empty_subset _, (λ v w h, false.rec _ h)⟩ }

-- Note that subgraphs do not form a Boolean algebra, because of `verts`.
instance : complete_distrib_lattice G.subgraph :=
{ le := (≤),
  sup := (⊔),
  inf := (⊓),
  top := ⊤,
  bot := ⊥,
  le_top := λ G', ⟨set.subset_univ _, λ a b, G'.adj_sub⟩,
  bot_le := λ G', ⟨set.empty_subset _, λ a b, false.elim⟩,
  Sup := Sup,
  le_Sup := λ s G' hG', ⟨set.subset_Union₂ G' hG', λ a b hab, ⟨G', hG', hab⟩⟩,
  Sup_le := λ s G' hG', ⟨set.Union₂_subset $ λ H hH, (hG' _ hH).1,
    by { rintro a b ⟨H, hH, hab⟩, exact (hG' _ hH).2 hab }⟩,
  Inf := Inf,
  Inf_le := λ s G' hG', ⟨set.Inter₂_subset G' hG', λ a b hab, hab.1 hG'⟩,
  le_Inf := λ s G' hG', ⟨set.subset_Inter₂ $ λ H hH, (hG' _ hH).1,
    λ a b hab, ⟨λ H hH, (hG' _ hH).2 hab, G'.adj_sub hab⟩⟩,
  inf_Sup_le_supr_inf := λ G' s, begin
    refine ⟨_, λ a b hab, _⟩,
    { simp only [verts_inf, verts_Sup, verts_supr, set.le_eq_subset],
      exact (set.inter_Union₂ _ _).subset },
    { simpa only [spanning_coe_adj, exists_prop, Sup_adj, and_imp, forall_exists_index, supr_adj,
        inf_adj, ←exists_and_distrib_right, exists_and_distrib_left, and_assoc, and_self_right]
        using hab }
  end,
  infi_sup_le_sup_Inf := λ G' s, begin
    refine ⟨_, λ a b hab, _⟩,
    { simp only [set.le_eq_subset, verts_infi, verts_sup, verts_Inf],
      exact (set.union_Inter₂ _ _).superset },
    simp only [spanning_coe_adj, sup_adj, Inf_adj, sup_adj, Inf_adj, infi_adj] at ⊢ hab,
    have : (∀ G'' ∈ s, adj G' a b ∨ adj G'' a b) ∧ G.adj a b :=
      (and_congr_left $ λ h, forall_congr $ λ H, _).1 hab,
    simpa [forall_or_distrib_left, or_and_distrib_right, and_iff_left_of_imp G'.adj_sub] using this,
    exact and_iff_left h,
  end,
  ..subgraph.distrib_lattice }

@[simps] instance subgraph_inhabited : inhabited (subgraph G) := ⟨⊥⟩

@[simp] lemma neighbor_set_sup {H H' : G.subgraph} (v : V) :
  (H ⊔ H').neighbor_set v = H.neighbor_set v ∪ H'.neighbor_set v := rfl

@[simp] lemma neighbor_set_inf {H H' : G.subgraph} (v : V) :
  (H ⊓ H').neighbor_set v = H.neighbor_set v ∩ H'.neighbor_set v := rfl

@[simp] lemma neighbor_set_top (v : V) : (⊤ : G.subgraph).neighbor_set v = G.neighbor_set v := rfl
@[simp] lemma neighbor_set_bot (v : V) : (⊥ : G.subgraph).neighbor_set v = ∅ := rfl

@[simp] lemma neighbor_set_Sup (s : set G.subgraph) (v : V) :
  (Sup s).neighbor_set v = ⋃ G' ∈ s, neighbor_set G' v :=
by { ext, simp }

@[simp] lemma neighbor_set_Inf (s : set G.subgraph) (v : V) :
  (Inf s).neighbor_set v = (⋂ G' ∈ s, neighbor_set G' v) ∩ G.neighbor_set v :=
by { ext, simp }

@[simp] lemma neighbor_set_supr (f : ι → G.subgraph) (v : V) :
  (⨆ i, f i).neighbor_set v = ⋃ i, (f i).neighbor_set v :=
by simp [supr]

@[simp] lemma neighbor_set_infi (f : ι → G.subgraph) (v : V) :
  (⨅ i, f i).neighbor_set v = (⋂ i, (f i).neighbor_set v) ∩ G.neighbor_set v :=
by simp [infi]

@[simp] lemma edge_set_top : (⊤ : subgraph G).edge_set = G.edge_set := rfl

@[simp] lemma edge_set_bot : (⊥ : subgraph G).edge_set = ∅ :=
set.ext $ sym2.ind (by simp)

@[simp] lemma edge_set_inf {H₁ H₂ : subgraph G} : (H₁ ⊓ H₂).edge_set = H₁.edge_set ∩ H₂.edge_set :=
set.ext $ sym2.ind (by simp)

@[simp] lemma edge_set_sup {H₁ H₂ : subgraph G} : (H₁ ⊔ H₂).edge_set = H₁.edge_set ∪ H₂.edge_set :=
set.ext $ sym2.ind (by simp)

@[simp] lemma edge_set_Sup (s : set G.subgraph) : (Sup s).edge_set = ⋃ G' ∈ s, edge_set G' :=
by { ext e, induction e using sym2.ind, simp }

@[simp] lemma edge_set_Inf (s : set G.subgraph) :
  (Inf s).edge_set = (⋂ G' ∈ s, edge_set G') ∩ G.edge_set :=
by { ext e, induction e using sym2.ind, simp }

@[simp] lemma edge_set_supr (f : ι → G.subgraph) : (⨆ i, f i).edge_set = ⋃ i, (f i).edge_set :=
by simp [supr]

@[simp] lemma edge_set_infi (f : ι → G.subgraph) :
  (⨅ i, f i).edge_set = (⋂ i, (f i).edge_set) ∩ G.edge_set :=
by simp [infi]

@[simp] lemma spanning_coe_top : (⊤ : subgraph G).spanning_coe = G :=
by { ext, refl }

@[simp] lemma spanning_coe_bot : (⊥ : subgraph G).spanning_coe = ⊥ := rfl

/-- Turn a subgraph of a `simple_graph` into a member of its subgraph type. -/
@[simps] def _root_.simple_graph.to_subgraph (H : simple_graph V) (h : H ≤ G) : G.subgraph :=
{ verts := set.univ,
  adj := H.adj,
  adj_sub := h,
  edge_vert := λ v w h, set.mem_univ v,
  symm := H.symm }

lemma support_mono {H H' : subgraph G} (h : H ≤ H') : H.support ⊆ H'.support :=
rel.dom_mono h.2

lemma _root_.simple_graph.to_subgraph.is_spanning (H : simple_graph V) (h : H ≤ G) :
  (H.to_subgraph h).is_spanning := set.mem_univ

lemma spanning_coe_le_of_le {H H' : subgraph G} (h : H ≤ H') :
  H.spanning_coe ≤ H'.spanning_coe := h.2

/-- The top of the `subgraph G` lattice is equivalent to the graph itself. -/
def top_equiv : (⊤ : subgraph G).coe ≃g G :=
{ to_fun := λ v, ↑v,
  inv_fun := λ v, ⟨v, trivial⟩,
  left_inv := λ ⟨v, _⟩, rfl,
  right_inv := λ v, rfl,
  map_rel_iff' := λ a b, iff.rfl }

/-- The bottom of the `subgraph G` lattice is equivalent to the empty graph on the empty
vertex type. -/
def bot_equiv : (⊥ : subgraph G).coe ≃g (⊥ : simple_graph empty) :=
{ to_fun := λ v, v.property.elim,
  inv_fun := λ v, v.elim,
  left_inv := λ ⟨_, h⟩, h.elim,
  right_inv := λ v, v.elim,
  map_rel_iff' := λ a b, iff.rfl }

lemma edge_set_mono {H₁ H₂ : subgraph G} (h : H₁ ≤ H₂) : H₁.edge_set ≤ H₂.edge_set :=
λ e, sym2.ind h.2 e

lemma _root_.disjoint.edge_set {H₁ H₂ : subgraph G}
  (h : disjoint H₁ H₂) : disjoint H₁.edge_set H₂.edge_set :=
disjoint_iff_inf_le.mpr $ by simpa using edge_set_mono h.le_bot

/-- Graph homomorphisms induce a covariant function on subgraphs. -/
@[simps]
protected def map {G' : simple_graph W} (f : G →g G') (H : G.subgraph) : G'.subgraph :=
{ verts := f '' H.verts,
  adj := relation.map H.adj f f,
  adj_sub := by { rintro _ _ ⟨u, v, h, rfl, rfl⟩, exact f.map_rel (H.adj_sub h) },
  edge_vert := by { rintro _ _ ⟨u, v, h, rfl, rfl⟩, exact set.mem_image_of_mem _ (H.edge_vert h) },
  symm := by { rintro _ _ ⟨u, v, h, rfl, rfl⟩, exact ⟨v, u, H.symm h, rfl, rfl⟩ } }

lemma map_monotone {G' : simple_graph W} (f : G →g G') : monotone (subgraph.map f) :=
begin
  intros H H' h,
  split,
  { intro,
    simp only [map_verts, set.mem_image, forall_exists_index, and_imp],
    rintro v hv rfl,
    exact ⟨_, h.1 hv, rfl⟩ },
  { rintros _ _ ⟨u, v, ha, rfl, rfl⟩,
    exact ⟨_, _, h.2 ha, rfl, rfl⟩ }
end

lemma map_sup {G : simple_graph V} {G' : simple_graph W} (f : G →g G')
  {H H' : G.subgraph} :
  (H ⊔ H').map f = H.map f ⊔ H'.map f :=
begin
  ext1,
  { simp only [set.image_union, map_verts, verts_sup]},
  { ext,
    simp only [relation.map, map_adj, sup_adj],
    split,
    { rintro ⟨a, b, h|h, rfl, rfl⟩,
      { exact or.inl ⟨_, _, h, rfl, rfl⟩ },
      { exact or.inr ⟨_, _, h, rfl, rfl⟩ } },
    { rintro (⟨a, b, h, rfl, rfl⟩|⟨a, b, h, rfl, rfl⟩),
      { exact ⟨_, _, or.inl h, rfl, rfl⟩ },
      { exact ⟨_, _, or.inr h, rfl, rfl⟩ } } },
end

/-- Graph homomorphisms induce a contravariant function on subgraphs. -/
@[simps]
protected def comap {G' : simple_graph W} (f : G →g G') (H : G'.subgraph) : G.subgraph :=
{ verts := f ⁻¹' H.verts,
  adj := λ u v, G.adj u v ∧ H.adj (f u) (f v),
  adj_sub := by { rintros v w ⟨ga, ha⟩, exact ga },
  edge_vert := by { rintros v w ⟨ga, ha⟩, simp [H.edge_vert ha] } }

lemma comap_monotone {G' : simple_graph W} (f : G →g G') : monotone (subgraph.comap f) :=
begin
  intros H H' h,
  split,
  { intro,
    simp only [comap_verts, set.mem_preimage],
    apply h.1, },
  { intros v w,
    simp only [comap_adj, and_imp, true_and] { contextual := tt },
    intro,
    apply h.2, }
end

lemma map_le_iff_le_comap {G' : simple_graph W} (f : G →g G') (H : G.subgraph) (H' : G'.subgraph) :
  H.map f ≤ H' ↔ H ≤ H'.comap f :=
begin
  refine ⟨λ h, ⟨λ v hv, _, λ v w hvw, _⟩, λ h, ⟨λ v, _, λ v w, _⟩⟩,
  { simp only [comap_verts, set.mem_preimage],
    exact h.1 ⟨v, hv, rfl⟩, },
  { simp only [H.adj_sub hvw, comap_adj, true_and],
    exact h.2 ⟨v, w, hvw, rfl, rfl⟩, },
  { simp only [map_verts, set.mem_image, forall_exists_index, and_imp],
    rintro w hw rfl,
    exact h.1 hw, },
  { simp only [relation.map, map_adj, forall_exists_index, and_imp],
    rintros u u' hu rfl rfl,
    have := h.2 hu,
    simp only [comap_adj] at this,
    exact this.2, }
end

/-- Given two subgraphs, one a subgraph of the other, there is an induced injective homomorphism of
the subgraphs as graphs. -/
@[simps]
def inclusion {x y : subgraph G} (h : x ≤ y) : x.coe →g y.coe :=
{ to_fun := λ v, ⟨↑v, and.left h v.property⟩,
  map_rel' := λ v w hvw, h.2 hvw }

lemma inclusion.injective {x y : subgraph G} (h : x ≤ y) : function.injective (inclusion h) :=
λ v w h, by { simp only [inclusion, rel_hom.coe_fn_mk, subtype.mk_eq_mk] at h, exact subtype.ext h }

/-- There is an induced injective homomorphism of a subgraph of `G` into `G`. -/
@[simps]
protected def hom (x : subgraph G) : x.coe →g G :=
{ to_fun := λ v, v,
  map_rel' := λ v w hvw, x.adj_sub hvw }

lemma hom.injective {x : subgraph G} : function.injective x.hom :=
λ v w h, subtype.ext h

/-- There is an induced injective homomorphism of a subgraph of `G` as
a spanning subgraph into `G`. -/
@[simps] def spanning_hom (x : subgraph G) : x.spanning_coe →g G :=
{ to_fun := id,
  map_rel' := λ v w hvw, x.adj_sub hvw }

lemma spanning_hom.injective {x : subgraph G} : function.injective x.spanning_hom :=
λ v w h, h

lemma neighbor_set_subset_of_subgraph {x y : subgraph G} (h : x ≤ y) (v : V) :
  x.neighbor_set v ⊆ y.neighbor_set v :=
λ w h', h.2 h'

instance neighbor_set.decidable_pred (G' : subgraph G) [h : decidable_rel G'.adj] (v : V) :
  decidable_pred (∈ G'.neighbor_set v) := h v

/-- If a graph is locally finite at a vertex, then so is a subgraph of that graph. -/
instance finite_at {G' : subgraph G} (v : G'.verts) [decidable_rel G'.adj]
   [fintype (G.neighbor_set v)] : fintype (G'.neighbor_set v) :=
set.fintype_subset (G.neighbor_set v) (G'.neighbor_set_subset v)

/-- If a subgraph is locally finite at a vertex, then so are subgraphs of that subgraph.

This is not an instance because `G''` cannot be inferred. -/
def finite_at_of_subgraph {G' G'' : subgraph G} [decidable_rel G'.adj]
   (h : G' ≤ G'') (v : G'.verts) [hf : fintype (G''.neighbor_set v)] :
   fintype (G'.neighbor_set v) :=
set.fintype_subset (G''.neighbor_set v) (neighbor_set_subset_of_subgraph h v)

instance (G' : subgraph G) [fintype G'.verts]
  (v : V) [decidable_pred (∈ G'.neighbor_set v)] : fintype (G'.neighbor_set v) :=
set.fintype_subset G'.verts (neighbor_set_subset_verts G' v)

instance coe_finite_at {G' : subgraph G} (v : G'.verts) [fintype (G'.neighbor_set v)] :
  fintype (G'.coe.neighbor_set v) :=
fintype.of_equiv _ (coe_neighbor_set_equiv v).symm

lemma is_spanning.card_verts [fintype V] {G' : subgraph G} [fintype G'.verts]
  (h : G'.is_spanning) : G'.verts.to_finset.card = fintype.card V :=
by { rw is_spanning_iff at h, simpa [h] }

/-- The degree of a vertex in a subgraph. It's zero for vertices outside the subgraph. -/
def degree (G' : subgraph G) (v : V) [fintype (G'.neighbor_set v)] : ℕ :=
fintype.card (G'.neighbor_set v)

lemma finset_card_neighbor_set_eq_degree {G' : subgraph G} {v : V} [fintype (G'.neighbor_set v)] :
  (G'.neighbor_set v).to_finset.card = G'.degree v := by rw [degree, set.to_finset_card]

lemma degree_le (G' : subgraph G) (v : V)
  [fintype (G'.neighbor_set v)] [fintype (G.neighbor_set v)] :
  G'.degree v ≤ G.degree v :=
begin
  rw ←card_neighbor_set_eq_degree,
  exact set.card_le_of_subset (G'.neighbor_set_subset v),
end

lemma degree_le' (G' G'' : subgraph G) (h : G' ≤ G'') (v : V)
  [fintype (G'.neighbor_set v)] [fintype (G''.neighbor_set v)] :
  G'.degree v ≤ G''.degree v :=
set.card_le_of_subset (neighbor_set_subset_of_subgraph h v)

@[simp] lemma coe_degree (G' : subgraph G) (v : G'.verts)
  [fintype (G'.coe.neighbor_set v)] [fintype (G'.neighbor_set v)] :
  G'.coe.degree v = G'.degree v :=
begin
  rw ←card_neighbor_set_eq_degree,
  exact fintype.card_congr (coe_neighbor_set_equiv v),
end

@[simp] lemma degree_spanning_coe {G' : G.subgraph} (v : V) [fintype (G'.neighbor_set v)]
  [fintype (G'.spanning_coe.neighbor_set v)] :
  G'.spanning_coe.degree v = G'.degree v :=
by { rw [← card_neighbor_set_eq_degree, subgraph.degree], congr }

lemma degree_eq_one_iff_unique_adj {G' : subgraph G} {v : V} [fintype (G'.neighbor_set v)] :
  G'.degree v = 1 ↔ ∃! (w : V), G'.adj v w :=
begin
  rw [← finset_card_neighbor_set_eq_degree, finset.card_eq_one, finset.singleton_iff_unique_mem],
  simp only [set.mem_to_finset, mem_neighbor_set],
end

end subgraph

section mk_properties
/-! ### Properties of `singleton_subgraph` and `subgraph_of_adj` -/

variables {G : simple_graph V} {G' : simple_graph W}

instance nonempty_singleton_subgraph_verts (v : V) : nonempty (G.singleton_subgraph v).verts :=
⟨⟨v, set.mem_singleton v⟩⟩

@[simp] lemma singleton_subgraph_le_iff (v : V) (H : G.subgraph) :
  G.singleton_subgraph v ≤ H ↔ v ∈ H.verts :=
begin
  refine ⟨λ h, h.1 (set.mem_singleton v), _⟩,
  intro h,
  split,
  { simp [h] },
  { simp [-set.bot_eq_empty] }
end

@[simp] lemma map_singleton_subgraph (f : G →g G') {v : V} :
  subgraph.map f (G.singleton_subgraph v) = G'.singleton_subgraph (f v) :=
by ext; simp only [relation.map, subgraph.map_adj, singleton_subgraph_adj, pi.bot_apply,
  exists_and_distrib_left, and_iff_left_iff_imp, is_empty.forall_iff, subgraph.map_verts,
  singleton_subgraph_verts, set.image_singleton]

@[simp] lemma neighbor_set_singleton_subgraph (v w : V) :
  (G.singleton_subgraph v).neighbor_set w = ∅ :=
by { ext u, refl }

@[simp] lemma edge_set_singleton_subgraph (v : V) :
  (G.singleton_subgraph v).edge_set = ∅ :=
sym2.from_rel_bot

lemma eq_singleton_subgraph_iff_verts_eq (H : G.subgraph) {v : V} :
  H = G.singleton_subgraph v ↔ H.verts = {v} :=
begin
  refine ⟨λ h, by simp [h], λ h, _⟩,
  ext,
  { rw [h, singleton_subgraph_verts] },
  { simp only [Prop.bot_eq_false, singleton_subgraph_adj, pi.bot_apply, iff_false],
    intro ha,
    have ha1 := ha.fst_mem,
    have ha2 := ha.snd_mem,
    rw [h, set.mem_singleton_iff] at ha1 ha2,
    subst_vars,
    exact ha.ne rfl },
end

instance nonempty_subgraph_of_adj_verts {v w : V} (hvw : G.adj v w) :
  nonempty (G.subgraph_of_adj hvw).verts := ⟨⟨v, by simp⟩⟩

@[simp] lemma edge_set_subgraph_of_adj {v w : V} (hvw : G.adj v w) :
  (G.subgraph_of_adj hvw).edge_set = {⟦(v, w)⟧} :=
begin
  ext e,
  refine e.ind _,
  simp only [eq_comm, set.mem_singleton_iff, subgraph.mem_edge_set, subgraph_of_adj_adj,
    iff_self, forall_2_true_iff],
end

lemma subgraph_of_adj_symm {v w : V} (hvw : G.adj v w) :
  G.subgraph_of_adj hvw.symm = G.subgraph_of_adj hvw :=
by ext; simp [or_comm, and_comm]

@[simp] lemma map_subgraph_of_adj (f : G →g G')
  {v w : V} (hvw : G.adj v w) :
  subgraph.map f (G.subgraph_of_adj hvw) = G'.subgraph_of_adj (f.map_adj hvw) :=
begin
  ext,
  { simp only [subgraph.map_verts, subgraph_of_adj_verts, set.mem_image,
      set.mem_insert_iff, set.mem_singleton_iff],
    split,
    { rintro ⟨u, rfl|rfl, rfl⟩; simp },
    { rintro (rfl|rfl),
      { use v, simp },
      { use w, simp } } },
  { simp only [relation.map, subgraph.map_adj, subgraph_of_adj_adj, quotient.eq, sym2.rel_iff],
    split,
    { rintro ⟨a, b, (⟨rfl,rfl⟩|⟨rfl,rfl⟩), rfl, rfl⟩; simp },
    { rintro (⟨rfl,rfl⟩|⟨rfl,rfl⟩),
      { use [v, w], simp },
      { use [w, v], simp } } }
end

lemma neighbor_set_subgraph_of_adj_subset {u v w : V} (hvw : G.adj v w) :
  (G.subgraph_of_adj hvw).neighbor_set u ⊆ {v, w} :=
(G.subgraph_of_adj hvw).neighbor_set_subset_verts _

@[simp] lemma neighbor_set_fst_subgraph_of_adj {v w : V} (hvw : G.adj v w) :
  (G.subgraph_of_adj hvw).neighbor_set v = {w} :=
begin
  ext u,
  suffices : w = u ↔ u = w, by simpa [hvw.ne.symm] using this,
  rw eq_comm,
end

@[simp] lemma neighbor_set_snd_subgraph_of_adj {v w : V} (hvw : G.adj v w) :
  (G.subgraph_of_adj hvw).neighbor_set w = {v} :=
begin
  rw subgraph_of_adj_symm hvw.symm,
  exact neighbor_set_fst_subgraph_of_adj hvw.symm,
end

@[simp] lemma neighbor_set_subgraph_of_adj_of_ne_of_ne {u v w : V} (hvw : G.adj v w)
  (hv : u ≠ v) (hw : u ≠ w) :
  (G.subgraph_of_adj hvw).neighbor_set u = ∅ :=
by { ext, simp [hv.symm, hw.symm] }

lemma neighbor_set_subgraph_of_adj [decidable_eq V] {u v w : V} (hvw : G.adj v w) :
  (G.subgraph_of_adj hvw).neighbor_set u =
  (if u = v then {w} else ∅) ∪ (if u = w then {v} else ∅) :=
by split_ifs; subst_vars; simp [*]

lemma singleton_subgraph_fst_le_subgraph_of_adj {u v : V} {h : G.adj u v} :
  G.singleton_subgraph u ≤ G.subgraph_of_adj h :=
by split; simp [-set.bot_eq_empty]

lemma singleton_subgraph_snd_le_subgraph_of_adj {u v : V} {h : G.adj u v} :
  G.singleton_subgraph v ≤ G.subgraph_of_adj h :=
by split; simp [-set.bot_eq_empty]

end mk_properties

namespace subgraph

variables {G : simple_graph V}

/-! ### Subgraphs of subgraphs -/

/-- Given a subgraph of a subgraph of `G`, construct a subgraph of `G`. -/
@[reducible]
protected def coe_subgraph {G' : G.subgraph} : G'.coe.subgraph → G.subgraph := subgraph.map G'.hom

/-- Given a subgraph of `G`, restrict it to being a subgraph of another subgraph `G'` by
taking the portion of `G` that intersects `G'`. -/
@[reducible]
protected def restrict {G' : G.subgraph} : G.subgraph → G'.coe.subgraph := subgraph.comap G'.hom

lemma restrict_coe_subgraph {G' : G.subgraph} (G'' : G'.coe.subgraph) :
  G''.coe_subgraph.restrict = G'' :=
begin
  ext,
  { simp },
  { simp only [relation.map, comap_adj, coe_adj, subtype.coe_prop, hom_apply, map_adj,
      set_coe.exists, subtype.coe_mk, exists_and_distrib_right, exists_eq_right_right,
      subtype.coe_eta, exists_true_left, exists_eq_right, and_iff_right_iff_imp],
    apply G''.adj_sub, }
end

lemma coe_subgraph_injective (G' : G.subgraph) :
  function.injective (subgraph.coe_subgraph : G'.coe.subgraph → G.subgraph) :=
function.left_inverse.injective restrict_coe_subgraph

/-! ### Edge deletion -/

/-- Given a subgraph `G'` and a set of vertex pairs, remove all of the corresponding edges
from its edge set, if present.

See also: `simple_graph.delete_edges`. -/
def delete_edges (G' : G.subgraph) (s : set (sym2 V)) : G.subgraph :=
{ verts := G'.verts,
  adj := G'.adj \ sym2.to_rel s,
  adj_sub := λ a b h', G'.adj_sub h'.1,
  edge_vert := λ a b h', G'.edge_vert h'.1,
  symm := λ a b, by simp [G'.adj_comm, sym2.eq_swap] }

section delete_edges
variables {G' : G.subgraph} (s : set (sym2 V))

@[simp] lemma delete_edges_verts : (G'.delete_edges s).verts = G'.verts := rfl

@[simp] lemma delete_edges_adj (v w : V) :
  (G'.delete_edges s).adj v w ↔ G'.adj v w ∧ ¬ ⟦(v, w)⟧ ∈ s := iff.rfl

@[simp] lemma delete_edges_delete_edges (s s' : set (sym2 V)) :
  (G'.delete_edges s).delete_edges s' = G'.delete_edges (s ∪ s') :=
by ext; simp [and_assoc, not_or_distrib]

@[simp] lemma delete_edges_empty_eq : G'.delete_edges ∅ = G' :=
by ext; simp

@[simp] lemma delete_edges_spanning_coe_eq :
  G'.spanning_coe.delete_edges s = (G'.delete_edges s).spanning_coe :=
by { ext, simp }

lemma delete_edges_coe_eq (s : set (sym2 G'.verts)) :
  G'.coe.delete_edges s = (G'.delete_edges (sym2.map coe '' s)).coe :=
begin
  ext ⟨v, hv⟩ ⟨w, hw⟩,
  simp only [simple_graph.delete_edges_adj, coe_adj, subtype.coe_mk, delete_edges_adj,
    set.mem_image, not_exists, not_and, and.congr_right_iff],
  intro h,
  split,
  { intros hs,
    refine sym2.ind _,
    rintro ⟨v', hv'⟩ ⟨w', hw'⟩,
    simp only [sym2.map_pair_eq, subtype.coe_mk, quotient.eq],
    contrapose!,
    rintro (_ | _); simpa [sym2.eq_swap], },
  { intros h' hs,
    exact h' _ hs rfl, },
end

lemma coe_delete_edges_eq (s : set (sym2 V)) :
  (G'.delete_edges s).coe = G'.coe.delete_edges (sym2.map coe ⁻¹' s) :=
by { ext ⟨v, hv⟩ ⟨w, hw⟩, simp }

lemma delete_edges_le : G'.delete_edges s ≤ G' :=
by split; simp { contextual := tt }

lemma delete_edges_le_of_le {s s' : set (sym2 V)} (h : s ⊆ s') :
  G'.delete_edges s' ≤ G'.delete_edges s :=
begin
  split;
  simp only [delete_edges_verts, delete_edges_adj, true_and, and_imp] {contextual := tt},
  exact λ v w hvw hs' hs, hs' (h hs),
end

@[simp] lemma delete_edges_inter_edge_set_left_eq :
  G'.delete_edges (G'.edge_set ∩ s) = G'.delete_edges s :=
by ext; simp [imp_false] { contextual := tt }

@[simp] lemma delete_edges_inter_edge_set_right_eq :
  G'.delete_edges (s ∩ G'.edge_set) = G'.delete_edges s :=
by ext; simp [imp_false] { contextual := tt }

lemma coe_delete_edges_le :
  (G'.delete_edges s).coe ≤ (G'.coe : simple_graph G'.verts) :=
λ v w, by simp { contextual := tt }

lemma spanning_coe_delete_edges_le (G' : G.subgraph) (s : set (sym2 V)) :
  (G'.delete_edges s).spanning_coe ≤ G'.spanning_coe :=
spanning_coe_le_of_le (delete_edges_le s)

end delete_edges

/-! ### Induced subgraphs -/

/- Given a subgraph, we can change its vertex set while removing any invalid edges, which
gives induced subgraphs. See also `simple_graph.induce` for the `simple_graph` version, which,
unlike for subgraphs, results in a graph with a different vertex type. -/

/-- The induced subgraph of a subgraph. The expectation is that `s ⊆ G'.verts` for the usual
notion of an induced subgraph, but, in general, `s` is taken to be the new vertex set and edges
are induced from the subgraph `G'`. -/
@[simps]
def induce (G' : G.subgraph) (s : set V) : G.subgraph :=
{ verts := s,
  adj := λ u v, u ∈ s ∧ v ∈ s ∧ G'.adj u v,
  adj_sub := λ u v, by { rintro ⟨-, -, ha⟩, exact G'.adj_sub ha },
  edge_vert := λ u v, by { rintro ⟨h, -, -⟩, exact h } }

lemma _root_.simple_graph.induce_eq_coe_induce_top (s : set V) :
  G.induce s = ((⊤ : G.subgraph).induce s).coe :=
by { ext v w, simp }

section induce
variables {G' G'' : G.subgraph} {s s' : set V}

lemma induce_mono (hg : G' ≤ G'') (hs : s ⊆ s') : G'.induce s ≤ G''.induce s' :=
begin
  split,
  { simp [hs], },
  { simp only [induce_adj, true_and, and_imp] { contextual := tt },
    intros v w hv hw ha,
    exact ⟨hs hv, hs hw, hg.2 ha⟩, },
end

@[mono]
lemma induce_mono_left (hg : G' ≤ G'') : G'.induce s ≤ G''.induce s := induce_mono hg (by refl)

@[mono]
lemma induce_mono_right (hs : s ⊆ s') : G'.induce s ≤ G'.induce s' := induce_mono (by refl) hs

@[simp] lemma induce_empty : G'.induce ∅ = ⊥ :=
by ext; simp

@[simp] lemma induce_self_verts : G'.induce G'.verts = G' :=
begin
  ext,
  { simp },
  { split;
    simp only [induce_adj, implies_true_iff, and_true] {contextual := tt},
    exact λ ha, ⟨G'.edge_vert ha, G'.edge_vert ha.symm⟩ }
end

lemma singleton_subgraph_eq_induce {v : V} :
  G.singleton_subgraph v = (⊤ : G.subgraph).induce {v} :=
by ext; simp [-set.bot_eq_empty, Prop.bot_eq_false] { contextual := tt }

lemma subgraph_of_adj_eq_induce {v w : V} (hvw : G.adj v w) :
  G.subgraph_of_adj hvw = (⊤ : G.subgraph).induce {v, w} :=
begin
  ext,
  { simp },
  { split,
    { intro h,
      simp only [subgraph_of_adj_adj, quotient.eq, sym2.rel_iff] at h,
      obtain ⟨rfl, rfl⟩|⟨rfl, rfl⟩ := h; simp [hvw, hvw.symm], },
    { intro h,
      simp only [induce_adj, set.mem_insert_iff, set.mem_singleton_iff, top_adj] at h,
      obtain ⟨rfl|rfl, rfl|rfl, ha⟩ := h;
        exact (ha.ne rfl).elim <|> simp } }
end

end induce

/-- Given a subgraph and a set of vertices, delete all the vertices from the subgraph,
if present. Any edges indicent to the deleted vertices are deleted as well. -/
@[reducible] def delete_verts (G' : G.subgraph) (s : set V) : G.subgraph := G'.induce (G'.verts \ s)

section delete_verts
variables {G' : G.subgraph} {s : set V}

lemma delete_verts_verts : (G'.delete_verts s).verts = G'.verts \ s := rfl

lemma delete_verts_adj {u v : V} :
  (G'.delete_verts s).adj u v ↔
  u ∈ G'.verts ∧ ¬ u ∈ s ∧ v ∈ G'.verts ∧ ¬ v ∈ s ∧ G'.adj u v :=
by simp [and_assoc]

@[simp] lemma delete_verts_delete_verts (s s' : set V) :
  (G'.delete_verts s).delete_verts s' = G'.delete_verts (s ∪ s') :=
by ext; simp [not_or_distrib, and_assoc] { contextual := tt }

@[simp] lemma delete_verts_empty : G'.delete_verts ∅ = G' :=
by simp [delete_verts]

lemma delete_verts_le : G'.delete_verts s ≤ G' :=
by split; simp [set.diff_subset]

@[mono]
lemma delete_verts_mono {G' G'' : G.subgraph} (h : G' ≤ G'') :
  G'.delete_verts s ≤ G''.delete_verts s :=
induce_mono h (set.diff_subset_diff_left h.1)

@[mono]
lemma delete_verts_anti {s s' : set V} (h : s ⊆ s') :
  G'.delete_verts s' ≤ G'.delete_verts s :=
induce_mono (le_refl _) (set.diff_subset_diff_right h)

@[simp] lemma delete_verts_inter_verts_left_eq :
  G'.delete_verts (G'.verts ∩ s) = G'.delete_verts s :=
by ext; simp [imp_false] { contextual := tt }

@[simp] lemma delete_verts_inter_verts_set_right_eq :
  G'.delete_verts (s ∩ G'.verts) = G'.delete_verts s :=
by ext; simp [imp_false] { contextual := tt }

end delete_verts

end subgraph

end simple_graph


import galois.nat.simplify_eq

universe variable u

namespace list

variable { α : Type u}

theorem tail_repeat (x : α) (n : ℕ) : tail (repeat x n) = repeat x (n - 1) :=
begin
  cases n,
  all_goals { simp },
end

theorem tail_append (x y : list α) : tail (x ++ y) = (if length x = 0 then tail y else tail x ++ y) :=
begin
  cases x,
  { simp },
  { simp [nat.succ_add], }
end

end list


import set_theory.surreal
open pgame
namespace pgame
universe u

/-- An explicit description of the moves for Left in `x * y`. -/
def left_moves_mul (x y : pgame) : (x * y).left_moves
  ≃ x.left_moves × y.left_moves ⊕ x.right_moves × y.right_moves :=
by { cases x, cases y, refl, }

/-- An explicit description of the moves for Right in `x * y`. -/
def right_moves_mul (x y : pgame) : (x * y).right_moves
  ≃ x.left_moves × y.right_moves ⊕ x.right_moves × y.left_moves :=
by { cases x, cases y, refl, }

@[simp] lemma mk_mul_move_left_inl {xl xr yl yr} {xL xR yL yR} {i j} :
  (mk xl xr xL xR * mk yl yr yL yR).move_left (sum.inl (i, j))
  = xL i * (mk yl yr yL yR) + (mk xl xr xL xR) * yL j - xL i * yL j :=
 rfl

@[simp] lemma mul_move_left_inl {x y : pgame} {i j} :
   (x * y).move_left ((left_moves_mul x y).symm (sum.inl (i, j)))
   = x.move_left i * y + x * y.move_left j - x.move_left i * y.move_left j :=
by {cases x, cases y, refl}

@[simp] lemma mk_mul_move_left_inr {xl xr yl yr} {xL xR yL yR} {i j} :
  (mk xl xr xL xR * mk yl yr yL yR).move_left (sum.inr (i, j))
  = xR i * (mk yl yr yL yR) + (mk xl xr xL xR) * yR j - xR i * yR j :=
rfl

@[simp] lemma mul_move_left_inr {x y : pgame} {i j} :
   (x * y).move_left ((left_moves_mul x y).symm (sum.inr (i, j)))
   = x.move_right i * y + x * y.move_right j - x.move_right i * y.move_right j :=
by {cases x, cases y, refl}

@[simp] lemma mk_mul_move_right_inl {xl xr yl yr} {xL xR yL yR} {i j} :
  (mk xl xr xL xR * mk yl yr yL yR).move_right (sum.inl (i, j))
  = xL i * (mk yl yr yL yR) + (mk xl xr xL xR) * yR j - xL i * yR j :=
rfl

@[simp] lemma mul_move_right_inl {x y : pgame} {i j} :
   (x * y).move_right ((right_moves_mul x y).symm (sum.inl (i, j)))
   = x.move_left i * y + x * y.move_right j - x.move_left i * y.move_right j :=
by {cases x, cases y, refl}

@[simp] lemma mk_mul_move_right_inr {xl xr yl yr} {xL xR yL yR} {i j} :
  (mk xl xr xL xR * mk yl yr yL yR).move_right (sum.inr (i,j))
  = xR i * (mk yl yr yL yR) + (mk xl xr xL xR) * yL j - xR i * yL j :=
rfl

@[simp] lemma mul_move_right_inr {x y : pgame} {i j} :
   (x * y).move_right ((right_moves_mul x y).symm (sum.inr (i, j)))
   = x.move_right i * y + x * y.move_left j - x.move_right i * y.move_left j :=
by {cases x, cases y, refl}

/-- If `w` has the same moves as `x` and `y` has the same moves as `z`,
then `w + y` has the same moves as `x + z`. -/
def add_congr_relabelling : ∀ {w x y z : pgame.{u}},
w.relabelling x → y.relabelling z → (w + y).relabelling (x + z)
| (mk wl wr wL wR) (mk xl xr xL xR) (mk yl yr yL yR) (mk zl zr zL zR)
  ⟨L_equiv₁, R_equiv₁, L_relabelling₁, R_relabelling₁⟩
  ⟨L_equiv₂, R_equiv₂, L_relabelling₂, R_relabelling₂⟩ :=
begin
  refine ⟨equiv.sum_congr L_equiv₁ L_equiv₂, equiv.sum_congr R_equiv₁ R_equiv₂,_,_⟩,
  { rintro (i|j),
    { exact add_congr_relabelling
        (L_relabelling₁ i)
        (⟨L_equiv₂, R_equiv₂, L_relabelling₂, R_relabelling₂⟩) },
    { exact add_congr_relabelling
        (⟨L_equiv₁, R_equiv₁, L_relabelling₁, R_relabelling₁⟩)
        (L_relabelling₂ j) }},
  { rintro (i|j),
    { exact add_congr_relabelling
        (R_relabelling₁ i)
        (⟨L_equiv₂, R_equiv₂, L_relabelling₂, R_relabelling₂⟩) },
    { exact add_congr_relabelling
        (⟨L_equiv₁, R_equiv₁, L_relabelling₁, R_relabelling₁⟩)
        (R_relabelling₂ j) }},
end
using_well_founded { dec_tac := pgame_wf_tac }

/-- If `x` has the same moves as `y`, then `-x` has the sames moves as `-y`. -/
def neg_congr_relabelling : ∀ {x y : pgame}, x.relabelling y → (-x).relabelling (-y)
| (mk xl xr xL xR) (mk yl yr yL yR) ⟨L_equiv, R_equiv, L_relabelling, R_relabelling⟩ :=
  ⟨R_equiv, L_equiv,
    λ i, neg_congr_relabelling (by simpa using R_relabelling (R_equiv i)),
    λ i, neg_congr_relabelling (by simpa using L_relabelling (L_equiv.symm i))⟩

/-- If `w` has the same moves as `x` and `y` has the same moves as `z`,
then `w - y` has the same moves as `x - z`. -/
def sub_congr_relabelling {w x y z : pgame}
  (h₁ : w.relabelling x) (h₂ : y.relabelling z) : (w - y).relabelling (x - z) :=
add_congr_relabelling h₁ (neg_congr_relabelling h₂)

/-- If `a` has the same moves as `x`, `b` has the same moves as `y`,
and `c` has the same moves as `z`, then `a + b - c` has the same moves as `x + y - z`.
This lemma is repeatedly used for simplifying multiplication of surreal numbers. -/
def add_sub_relabelling {a b c x y z : pgame}
  (h₁ : a.relabelling x) (h₂ : b.relabelling y) (h₃ : c.relabelling z) :
  (a + b - c).relabelling (x + y - z) :=
sub_congr_relabelling (add_congr_relabelling h₁ h₂) h₃

/-- If `a` has the same moves as `x`, `b` has the same moves as `y`,
and `c` has the same moves as `z`, then `a + b - c` has the same moves as `y + x - z`.
This lemma is repeatedly used for simplifying multiplication of surreal numbers. -/
def add_comm_sub_relabelling {a b c x y z : pgame}
  (h₁ : a.relabelling x) (h₂ : b.relabelling y) (h₃ : c.relabelling z) :
  (a + b - c).relabelling (y + x - z) :=
sub_congr_relabelling
  ((add_comm_relabelling a b).trans (add_congr_relabelling h₂ h₁)) h₃

def add_sub_congr {a b c x y z : pgame}
  (h₁ : a.equiv x) (h₂ : b.equiv y) (h₃ : c.equiv z) :
  (a + b - c).relabelling (x + y - z) :=
sorry
end pgame

#lint


/-
Copyright (c) 2018 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
import data.list.nodup

/-!
# Erasure of duplicates in a list

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

This file proves basic results about `list.dedup` (definition in `data.list.defs`).
`dedup l` returns `l` without its duplicates. It keeps the earliest (that is, rightmost)
occurrence of each.

## Tags

duplicate, multiplicity, nodup, `nub`
-/

universes u

namespace list

variables {α : Type u} [decidable_eq α]

@[simp] theorem dedup_nil : dedup [] = ([] : list α) := rfl

theorem dedup_cons_of_mem' {a : α} {l : list α} (h : a ∈ dedup l) :
  dedup (a :: l) = dedup l :=
pw_filter_cons_of_neg $ by simpa only [forall_mem_ne] using h

theorem dedup_cons_of_not_mem' {a : α} {l : list α} (h : a ∉ dedup l) :
  dedup (a :: l) = a :: dedup l :=
pw_filter_cons_of_pos $ by simpa only [forall_mem_ne] using h

@[simp] theorem mem_dedup {a : α} {l : list α} : a ∈ dedup l ↔ a ∈ l :=
by simpa only [dedup, forall_mem_ne, not_not] using not_congr (@forall_mem_pw_filter α (≠) _
  (λ x y z xz, not_and_distrib.1 $ mt (λ h, eq.trans h.1 h.2) xz) a l)

@[simp] theorem dedup_cons_of_mem {a : α} {l : list α} (h : a ∈ l) :
  dedup (a :: l) = dedup l :=
dedup_cons_of_mem' $ mem_dedup.2 h

@[simp] theorem dedup_cons_of_not_mem {a : α} {l : list α} (h : a ∉ l) :
  dedup (a :: l) = a :: dedup l :=
dedup_cons_of_not_mem' $ mt mem_dedup.1 h

theorem dedup_sublist : ∀ (l : list α), dedup l <+ l := pw_filter_sublist

theorem dedup_subset : ∀ (l : list α), dedup l ⊆ l := pw_filter_subset

theorem subset_dedup (l : list α) : l ⊆ dedup l :=
λ a, mem_dedup.2

theorem nodup_dedup : ∀ l : list α, nodup (dedup l) := pairwise_pw_filter

theorem dedup_eq_self {l : list α} : dedup l = l ↔ nodup l := pw_filter_eq_self

protected lemma nodup.dedup {l : list α} (h : l.nodup) : l.dedup = l :=
list.dedup_eq_self.2 h

@[simp] theorem dedup_idempotent {l : list α} : dedup (dedup l) = dedup l :=
pw_filter_idempotent

theorem dedup_append (l₁ l₂ : list α) : dedup (l₁ ++ l₂) = l₁ ∪ dedup l₂ :=
begin
  induction l₁ with a l₁ IH, {refl}, rw [cons_union, ← IH],
  show dedup (a :: (l₁ ++ l₂)) = insert a (dedup (l₁ ++ l₂)),
  by_cases a ∈ dedup (l₁ ++ l₂);
  [ rw [dedup_cons_of_mem' h, insert_of_mem h],
    rw [dedup_cons_of_not_mem' h, insert_of_not_mem h]]
end

lemma replicate_dedup {x : α} : ∀ {k}, k ≠ 0 → (replicate k x).dedup = [x]
| 0 h := (h rfl).elim
| 1 _ := rfl
| (n+2) _ := by rw [replicate_succ, dedup_cons_of_mem (mem_replicate.2 ⟨n.succ_ne_zero, rfl⟩),
    replicate_dedup n.succ_ne_zero]

lemma count_dedup (l : list α) (a : α) :
  l.dedup.count a = if a ∈ l then 1 else 0 :=
by simp_rw [count_eq_of_nodup $ nodup_dedup l, mem_dedup]

/-- Summing the count of `x` over a list filtered by some `p` is just `countp` applied to `p` -/
lemma sum_map_count_dedup_filter_eq_countp (p : α → Prop) [decidable_pred p]
  (l : list α) : ((l.dedup.filter p).map $ λ x, l.count x).sum = l.countp p :=
begin
  induction l with a as h,
  { simp },
  { simp_rw [list.countp_cons, list.count_cons', list.sum_map_add],
    congr' 1,
    { refine trans _ h,
      by_cases ha : a ∈ as,
      { simp [dedup_cons_of_mem ha] },
      { simp only [dedup_cons_of_not_mem ha, list.filter],
        split_ifs with hp; simp [list.map_cons, list.sum_cons,
          list.count_eq_zero.2 ha, zero_add] } },
    { by_cases hp : p a,
      { refine trans (sum_map_eq_nsmul_single a _ (λ _ h _, by simp [h])) _,
        simp [hp, count_dedup] },
      { refine trans (list.sum_eq_zero $ λ n hn, _) (by simp [hp]),
        obtain ⟨a', ha'⟩ := list.mem_map.1 hn,
        simp only [(λ h, hp (h ▸ (list.mem_filter.1 ha'.1).2) : a' ≠ a), if_false] at ha',
        exact ha'.2.symm } } },
end

lemma sum_map_count_dedup_eq_length (l : list α) :
  (l.dedup.map $ λ x, l.count x).sum = l.length :=
by simpa using sum_map_count_dedup_filter_eq_countp (λ _, true) l

end list


/- Copyright (c) 2022 Sina Hazratpour. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
----------------

# Surjective Injective Factorization
Sina Hazratpour
Introduction to Proof
MATH 301, Johns Hopkins University, Fall 2022
-/

import ..prooflab
import .lec9_structure_unbundled

namespace PROOFS

namespace STR

variables {X Y : Type} {f : X → Y}

/-! ### Prelim 1: Extending Structures
We can use the `extend` command to define a structure that adds fields to one or more existing structures.

In example `H2plus` we are extending the structure `R2` (of a previous lecture) by adding new properties, i.e. equations indicating the points belong to the upper half plane.
-/

@[ext]
structure H2plus_alt_alt :=
(x : ℝ)
(y : ℝ)
(y_pos : 0 < y )

section
variable a : H2plus_alt_alt
#check a.x
#check a.y
#check a.y_pos
end

@[ext]
structure H2plus_alt :=
( a : R2 )
( y_pos : 0 < a.y )

section
variable b : H2plus_alt
#check b.a
#check b.a.x
#check b.a.y
#check b.y_pos
end

@[ext]
structure H2plus extends R2 :=
(y_pos : 0 < y ) -- data satisfying certian constraint

def Pt_p1p2 : H2plus :=
{
  x := 1,
  y := 2,
  y_pos := by {simp},
}

#print H2plus
#check H2plus.to_R2 -- this is an embedding which forgets the positivity property
#check H2plus.to_R2 Pt_p1p2

-- the way to prove two points of `H2plus` are the same is essentially the same way as proving equality of points of `R2`.
example (a b : H2plus) (hx : a.x = b.x) (hy : a.y = b.y) :
  a = b :=
begin
  ext,
  repeat {assumption},
end

/-! ### Prelim 2: Comprehension Types
If we have a predicate `P : X → Prop` we can make `P` into a type `{ x : X // P x }` which consists of pairs whose first component is a term of `x : X` and the second component is a proof `hx : P x`.
-/

#check is_even

lemma ten_is_even :
  is_even 10 :=
begin
  unfold is_even,
  use 5,
  refl,
end

def Even_Num := { n : ℕ // is_even n } -- This type consists of pairs of a natural number and a proof that the natural number is even. -/

#check Even_Num
#reduce Even_Num -- this unfolds the predicate `is_even`

-- to construct a term of `{ x : X // P x }` we need to provide a __value__ `x` (a term `x : X`) and a __proof of property__ `Px`.

def my_even_num : Even_Num := ⟨10, ten_is_even⟩ -- generic pairing different than product type
-- value `10` and a proof `ten_is_even` of the property `is_even 10`.

def your_even_num : Even_Num := ⟨8, by {use 4, refl} ⟩

def our_even_num : Even_Num := ⟨8, ⟨4, rfl ⟩⟩

-- for projecting out of a comprehension, we use `.val`
example (e : Even_Num) : ℕ := e.val -- here `e.val` is just a natural number, it has forgotten the evenness of `e`.

#check my_even_num.val
#eval my_even_num.val
#reduce my_even_num.prop

example (e : Even_Num) :
  is_even e.val :=
begin
  exact e.prop,
end

example (e e': Even_Num) (h : e = e') :
  e.val = e'.val :=
begin
  rw h,
end

-- two terms of `{ x : X // P x }` are equal if their corresponding values are equal.
example (e e': Even_Num) (h : e.val = e'.val) :
  e = e' :=
begin
  ext, -- now we only need to prove e and e' are equal simply __as natual numbers__ (coercion to ℕ indicated by an arrow in the displayed goal. `↑e` is the same as `e.val`)
  exact h,
end

def fun_image (f : X → Y) : Type := { y : Y // ∃ x : X, y = f x}

#check @fun_image

#check fun_image nat_of_bool

def my_nat_of_bool : fun_image nat_of_bool := ⟨0, by {use ff, refl} ⟩
def your_nat_of_bool : fun_image nat_of_bool := ⟨0, ff, rfl ⟩ -- unbiased pairing (it is not left nor right binding) -- `rfl` is the proof that `ff` is mapped to `0`.

-- factorization
structure fun_fact {X Y : Type} (f : X → Y) :=
(node : Type) -- the node through which `f` factors
(left_fun : X → node) -- the left factor
(right_fun : node → Y) -- the right factor
(fun_eq : right_fun ∘ left_fun = f)

#print fun_fact
#check @fun_fact.node
#check @fun_fact.left_fun
#check @fun_fact.right_fun

@[simp]
def fun_image.embedding (f : X → Y) (z : fun_image f) : Y := z.val

#check @fun_image.embedding

#check fun_image.embedding nat_of_bool

lemma inj_of_fun_image  (f : X → Y) :
  is_injective (fun_image.embedding f) :=
begin
  simp,
  intros y₁ y₂,
  intro h₁,
  ext,
  exact h₁,
end

def fun_image.cover (f : X → Y) (x : X) : fun_image f := ⟨f x, x , rfl⟩

/-
Recall that in order to extract a witness `x` and proof `hx : P x` from a hypothesis `h : ∃ x, P x`, we use the tactic `cases h with x hx`.
-/

lemma surj_of_fun_image  (f : X → Y) :
  is_surjective (fun_image.cover f) :=
begin
  unfold is_surjective, -- our goal is to prove that the function `fun_image.cover f` is surjective. We unfold the definition of surjectivity.
  intro y, -- We have to show for every `y` in  `fun_image.cover f` there is some `x` in `X` such that `cover f x = y`
  cases y, -- an element `y` in  `fun_image.cover f` is some `y_val` in `Y` and a proof  `y_prop` of the fact that `∃ (x : X), y_val = f x`.
  cases y_property with x h, -- from `y_prop`, by existentional elimination, we can find some `x : X` and a proof `h : y_val = f x`.
  unfold fun_image.cover, -- simplifying definition of fun_image.cover.
  use x, -- we find our desired `x`, from one before last step.
  simp, -- simplifying the goal
  rw h,  --
end

structure surj_inj_fact {X Y : Type} (f : X → Y) extends fun_fact f :=
(surj : is_surjective left_fun)
(inj : is_injective right_fun)

def canonical_surj_inj_fact {X Y : Type} (f : X → Y) : surj_inj_fact f :=
{
  node := fun_image f,
  left_fun := fun_image.cover f,
  right_fun := fun_image.embedding f,
  fun_eq := by {funext x, simp, refl},
  surj := by {exact surj_of_fun_image f,},
  inj := by {exact inj_of_fun_image f,},
}

#check @canonical_surj_inj_fact

end STR
end PROOFS


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

import measure_theory.measure.ae_measurable

/-!
# Typeclasses for measurability of lattice operations

In this file we define classes `has_measurable_sup` and `has_measurable_inf` and prove dot-style
lemmas (`measurable.sup`, `ae_measurable.sup` etc). For binary operations we define two typeclasses:

- `has_measurable_sup` says that both left and right sup are measurable;
- `has_measurable_sup₂` says that `λ p : α × α, p.1 ⊔ p.2` is measurable,

and similarly for other binary operations. The reason for introducing these classes is that in case
of topological space `α` equipped with the Borel `σ`-algebra, instances for `has_measurable_sup₂`
etc require `α` to have a second countable topology.

For instances relating, e.g., `has_continuous_sup` to `has_measurable_sup` see file
`measure_theory.borel_space`.

## Tags

measurable function, lattice operation

-/

open measure_theory

/-- We say that a type `has_measurable_sup` if `((⊔) c)` and `(⊔ c)` are measurable functions.
For a typeclass assuming measurability of `uncurry (⊔)` see `has_measurable_sup₂`. -/
class has_measurable_sup (M : Type*) [measurable_space M] [has_sup M] : Prop :=
(measurable_const_sup : ∀ c : M, measurable ((⊔) c))
(measurable_sup_const : ∀ c : M, measurable (⊔ c))

/-- We say that a type `has_measurable_sup₂` if `uncurry (⊔)` is a measurable functions.
For a typeclass assuming measurability of `((⊔) c)` and `(⊔ c)` see `has_measurable_sup`. -/
class has_measurable_sup₂ (M : Type*) [measurable_space M] [has_sup M] : Prop :=
(measurable_sup : measurable (λ p : M × M, p.1 ⊔ p.2))

export has_measurable_sup₂ (measurable_sup)
  has_measurable_sup (measurable_const_sup measurable_sup_const)

/-- We say that a type `has_measurable_inf` if `((⊓) c)` and `(⊓ c)` are measurable functions.
For a typeclass assuming measurability of `uncurry (⊓)` see `has_measurable_inf₂`. -/
class has_measurable_inf (M : Type*) [measurable_space M] [has_inf M] : Prop :=
(measurable_const_inf : ∀ c : M, measurable ((⊓) c))
(measurable_inf_const : ∀ c : M, measurable (⊓ c))

/-- We say that a type `has_measurable_inf₂` if `uncurry (⊔)` is a measurable functions.
For a typeclass assuming measurability of `((⊔) c)` and `(⊔ c)` see `has_measurable_inf`. -/
class has_measurable_inf₂ (M : Type*) [measurable_space M] [has_inf M] : Prop :=
(measurable_inf : measurable (λ p : M × M, p.1 ⊓ p.2))

export has_measurable_inf₂ (measurable_inf)
  has_measurable_inf (measurable_const_inf measurable_inf_const)

variables {M : Type*} [measurable_space M]

section order_dual

@[priority 100]
instance [has_inf M] [has_measurable_inf M] : has_measurable_sup Mᵒᵈ :=
⟨@measurable_const_inf M _ _ _, @measurable_inf_const M _ _ _⟩

@[priority 100]
instance [has_sup M] [has_measurable_sup M] : has_measurable_inf Mᵒᵈ :=
⟨@measurable_const_sup M _ _ _, @measurable_sup_const M _ _ _⟩

@[priority 100]
instance [has_inf M] [has_measurable_inf₂ M] : has_measurable_sup₂ Mᵒᵈ :=
⟨@measurable_inf M _ _ _⟩

@[priority 100]
instance [has_sup M] [has_measurable_sup₂ M] : has_measurable_inf₂ Mᵒᵈ :=
⟨@measurable_sup M _ _ _⟩

end order_dual

variables {α : Type*} {m : measurable_space α} {μ : measure α} {f g : α → M}
include m

section sup
variables [has_sup M]

section measurable_sup
variables [has_measurable_sup M]

@[measurability]
lemma measurable.const_sup (hf : measurable f) (c : M) : measurable (λ x, c ⊔ f x) :=
(measurable_const_sup c).comp hf

@[measurability]
lemma ae_measurable.const_sup (hf : ae_measurable f μ) (c : M) : ae_measurable (λ x, c ⊔ f x) μ :=
(has_measurable_sup.measurable_const_sup c).comp_ae_measurable hf

@[measurability]
lemma measurable.sup_const (hf : measurable f) (c : M) : measurable (λ x, f x ⊔ c) :=
(measurable_sup_const c).comp hf

@[measurability]
lemma ae_measurable.sup_const (hf : ae_measurable f μ) (c : M) :
  ae_measurable (λ x, f x ⊔ c) μ :=
(measurable_sup_const c).comp_ae_measurable hf

end measurable_sup

section measurable_sup₂
variables [has_measurable_sup₂ M]

@[measurability]
lemma measurable.sup' (hf : measurable f) (hg : measurable g) : measurable (f ⊔ g) :=
measurable_sup.comp (hf.prod_mk hg)

@[measurability]
lemma measurable.sup (hf : measurable f) (hg : measurable g) : measurable (λ a, f a ⊔ g a) :=
measurable_sup.comp (hf.prod_mk hg)

@[measurability]
lemma ae_measurable.sup' (hf : ae_measurable f μ) (hg : ae_measurable g μ) :
  ae_measurable (f ⊔ g) μ :=
measurable_sup.comp_ae_measurable (hf.prod_mk hg)

@[measurability]
lemma ae_measurable.sup (hf : ae_measurable f μ) (hg : ae_measurable g μ) :
  ae_measurable (λ a, f a ⊔ g a) μ :=
measurable_sup.comp_ae_measurable (hf.prod_mk hg)

omit m
@[priority 100]
instance has_measurable_sup₂.to_has_measurable_sup : has_measurable_sup M :=
⟨λ c, measurable_const.sup measurable_id, λ c, measurable_id.sup measurable_const⟩
include m

end measurable_sup₂

end sup

section inf
variables [has_inf M]

section measurable_inf
variables [has_measurable_inf M]

@[measurability]
lemma measurable.const_inf (hf : measurable f) (c : M) :
  measurable (λ x, c ⊓ f x) :=
(measurable_const_inf c).comp hf

@[measurability]
lemma ae_measurable.const_inf (hf : ae_measurable f μ) (c : M) :
  ae_measurable (λ x, c ⊓ f x) μ :=
(has_measurable_inf.measurable_const_inf c).comp_ae_measurable hf

@[measurability]
lemma measurable.inf_const (hf : measurable f) (c : M) :
  measurable (λ x, f x ⊓ c) :=
(measurable_inf_const c).comp hf

@[measurability]
lemma ae_measurable.inf_const (hf : ae_measurable f μ) (c : M) :
  ae_measurable (λ x, f x ⊓ c) μ :=
(measurable_inf_const c).comp_ae_measurable hf

end measurable_inf

section measurable_inf₂
variables [has_measurable_inf₂ M]

@[measurability]
lemma measurable.inf' (hf : measurable f) (hg : measurable g) : measurable (f ⊓ g) :=
measurable_inf.comp (hf.prod_mk hg)

@[measurability]
lemma measurable.inf (hf : measurable f) (hg : measurable g) : measurable (λ a, f a ⊓ g a) :=
measurable_inf.comp (hf.prod_mk hg)

@[measurability]
lemma ae_measurable.inf' (hf : ae_measurable f μ) (hg : ae_measurable g μ) :
  ae_measurable (f ⊓ g) μ :=
measurable_inf.comp_ae_measurable (hf.prod_mk hg)

@[measurability]
lemma ae_measurable.inf (hf : ae_measurable f μ) (hg : ae_measurable g μ) :
  ae_measurable (λ a, f a ⊓ g a) μ :=
measurable_inf.comp_ae_measurable (hf.prod_mk hg)

omit m
@[priority 100]
instance has_measurable_inf₂.to_has_measurable_inf : has_measurable_inf M :=
⟨λ c, measurable_const.inf measurable_id, λ c, measurable_id.inf measurable_const⟩
include m

end measurable_inf₂

end inf

section semilattice_sup

open finset

variables {δ : Type*} [measurable_space δ] [semilattice_sup α] [has_measurable_sup₂ α]

@[measurability] lemma finset.measurable_sup' {ι : Type*} {s : finset ι} (hs : s.nonempty)
  {f : ι → δ → α} (hf : ∀ n ∈ s, measurable (f n)) :
  measurable (s.sup' hs f) :=
finset.sup'_induction hs _ (λ f hf g hg, hf.sup hg) (λ n hn, hf n hn)

@[measurability] lemma finset.measurable_range_sup'
  {f : ℕ → δ → α} {n : ℕ} (hf : ∀ k ≤ n, measurable (f k)) :
  measurable ((range (n + 1)).sup' nonempty_range_succ f) :=
begin
  simp_rw ← nat.lt_succ_iff at hf,
  refine finset.measurable_sup' _ _,
  simpa [finset.mem_range],
end

@[measurability] lemma finset.measurable_range_sup''
  {f : ℕ → δ → α} {n : ℕ} (hf : ∀ k ≤ n, measurable (f k)) :
  measurable (λ x, (range (n + 1)).sup' nonempty_range_succ (λ k, f k x)) :=
begin
  convert finset.measurable_range_sup' hf,
  ext x,
  simp,
end

end semilattice_sup


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

! This file was ported from Lean 3 source module model_theory.definability
! leanprover-community/mathlib commit 70fd9563a21e7b963887c9360bd29b2393e6225a
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Data.SetLike.Basic
import Mathbin.ModelTheory.Semantics

/-!
# Definable Sets
This file defines what it means for a set over a first-order structure to be definable.

## Main Definitions
* `set.definable` is defined so that `A.definable L s` indicates that the
set `s` of a finite cartesian power of `M` is definable with parameters in `A`.
* `set.definable₁` is defined so that `A.definable₁ L s` indicates that
`(s : set M)` is definable with parameters in `A`.
* `set.definable₂` is defined so that `A.definable₂ L s` indicates that
`(s : set (M × M))` is definable with parameters in `A`.
* A `first_order.language.definable_set` is defined so that `L.definable_set A α` is the boolean
  algebra of subsets of `α → M` defined by formulas with parameters in `A`.

## Main Results
* `L.definable_set A α` forms a `boolean_algebra`
* `set.definable.image_comp` shows that definability is closed under projections in finite
  dimensions.

-/

universe u v w

namespace Set

variable {M : Type w} (A : Set M) (L : FirstOrder.Language.{u, v}) [L.Structure M]

open FirstOrder

open FirstOrder.Language FirstOrder.Language.Structure

variable {α : Type _} {β : Type _}

/-- A subset of a finite Cartesian product of a structure is definable over a set `A` when
  membership in the set is given by a first-order formula with parameters from `A`. -/
def Definable (s : Set (α → M)) : Prop :=
  ∃ φ : L[[A]].Formula α, s = setOf φ.realize
#align set.definable Set.Definable

variable {L} {A} {B : Set M} {s : Set (α → M)}

theorem Definable.map_expansion {L' : FirstOrder.Language} [L'.Structure M] (h : A.Definable L s)
    (φ : L →ᴸ L') [φ.IsExpansionOn M] : A.Definable L' s :=
  by
  obtain ⟨ψ, rfl⟩ := h
  refine' ⟨(φ.add_constants A).onFormula ψ, _⟩
  ext x
  simp only [mem_set_of_eq, Lhom.realize_on_formula]
#align set.definable.map_expansion Set.Definable.map_expansion

theorem empty_definable_iff : (∅ : Set M).Definable L s ↔ ∃ φ : L.Formula α, s = setOf φ.realize :=
  by
  rw [definable, Equiv.exists_congr_left (Lequiv.add_empty_constants L (∅ : Set M)).onFormula]
  simp
#align set.empty_definable_iff Set.empty_definable_iff

theorem definable_iff_empty_definable_with_params :
    A.Definable L s ↔ (∅ : Set M).Definable (L[[A]]) s :=
  empty_definable_iff.symm
#align set.definable_iff_empty_definable_with_params Set.definable_iff_empty_definable_with_params

theorem Definable.mono (hAs : A.Definable L s) (hAB : A ⊆ B) : B.Definable L s :=
  by
  rw [definable_iff_empty_definable_with_params] at *
  exact hAs.map_expansion (L.Lhom_with_constants_map (Set.inclusion hAB))
#align set.definable.mono Set.Definable.mono

@[simp]
theorem definable_empty : A.Definable L (∅ : Set (α → M)) :=
  ⟨⊥, by
    ext
    simp⟩
#align set.definable_empty Set.definable_empty

@[simp]
theorem definable_univ : A.Definable L (univ : Set (α → M)) :=
  ⟨⊤, by
    ext
    simp⟩
#align set.definable_univ Set.definable_univ

@[simp]
theorem Definable.inter {f g : Set (α → M)} (hf : A.Definable L f) (hg : A.Definable L g) :
    A.Definable L (f ∩ g) := by
  rcases hf with ⟨φ, rfl⟩
  rcases hg with ⟨θ, rfl⟩
  refine' ⟨φ ⊓ θ, _⟩
  ext
  simp
#align set.definable.inter Set.Definable.inter

@[simp]
theorem Definable.union {f g : Set (α → M)} (hf : A.Definable L f) (hg : A.Definable L g) :
    A.Definable L (f ∪ g) := by
  rcases hf with ⟨φ, hφ⟩
  rcases hg with ⟨θ, hθ⟩
  refine' ⟨φ ⊔ θ, _⟩
  ext
  rw [hφ, hθ, mem_set_of_eq, formula.realize_sup, mem_union, mem_set_of_eq, mem_set_of_eq]
#align set.definable.union Set.Definable.union

theorem definable_finset_inf {ι : Type _} {f : ∀ i : ι, Set (α → M)} (hf : ∀ i, A.Definable L (f i))
    (s : Finset ι) : A.Definable L (s.inf f) := by
  classical
    refine' Finset.induction definable_univ (fun i s is h => _) s
    rw [Finset.inf_insert]
    exact (hf i).inter h
#align set.definable_finset_inf Set.definable_finset_inf

theorem definable_finset_sup {ι : Type _} {f : ∀ i : ι, Set (α → M)} (hf : ∀ i, A.Definable L (f i))
    (s : Finset ι) : A.Definable L (s.sup f) := by
  classical
    refine' Finset.induction definable_empty (fun i s is h => _) s
    rw [Finset.sup_insert]
    exact (hf i).union h
#align set.definable_finset_sup Set.definable_finset_sup

theorem definable_finset_bInter {ι : Type _} {f : ∀ i : ι, Set (α → M)}
    (hf : ∀ i, A.Definable L (f i)) (s : Finset ι) : A.Definable L (⋂ i ∈ s, f i) :=
  by
  rw [← Finset.inf_set_eq_interᵢ]
  exact definable_finset_inf hf s
#align set.definable_finset_bInter Set.definable_finset_bInter

theorem definable_finset_bUnion {ι : Type _} {f : ∀ i : ι, Set (α → M)}
    (hf : ∀ i, A.Definable L (f i)) (s : Finset ι) : A.Definable L (⋃ i ∈ s, f i) :=
  by
  rw [← Finset.sup_set_eq_bunionᵢ]
  exact definable_finset_sup hf s
#align set.definable_finset_bUnion Set.definable_finset_bUnion

@[simp]
theorem Definable.compl {s : Set (α → M)} (hf : A.Definable L s) : A.Definable L (sᶜ) :=
  by
  rcases hf with ⟨φ, hφ⟩
  refine' ⟨φ.not, _⟩
  rw [hφ]
  rfl
#align set.definable.compl Set.Definable.compl

@[simp]
theorem Definable.sdiff {s t : Set (α → M)} (hs : A.Definable L s) (ht : A.Definable L t) :
    A.Definable L (s \ t) :=
  hs.inter ht.compl
#align set.definable.sdiff Set.Definable.sdiff

theorem Definable.preimage_comp (f : α → β) {s : Set (α → M)} (h : A.Definable L s) :
    A.Definable L ((fun g : β → M => g ∘ f) ⁻¹' s) :=
  by
  obtain ⟨φ, rfl⟩ := h
  refine' ⟨φ.relabel f, _⟩
  ext
  simp only [Set.preimage_setOf_eq, mem_set_of_eq, formula.realize_relabel]
#align set.definable.preimage_comp Set.Definable.preimage_comp

theorem Definable.image_comp_equiv {s : Set (β → M)} (h : A.Definable L s) (f : α ≃ β) :
    A.Definable L ((fun g : β → M => g ∘ f) '' s) :=
  by
  refine' (congr rfl _).mp (h.preimage_comp f.symm)
  rw [image_eq_preimage_of_inverse]
  · intro i
    ext b
    simp only [Function.comp_apply, Equiv.apply_symm_apply]
  · intro i
    ext a
    simp
#align set.definable.image_comp_equiv Set.Definable.image_comp_equiv

/-- This lemma is only intended as a helper for `definable.image_comp. -/
theorem Definable.image_comp_sum_inl_fin (m : ℕ) {s : Set (Sum α (Fin m) → M)}
    (h : A.Definable L s) : A.Definable L ((fun g : Sum α (Fin m) → M => g ∘ Sum.inl) '' s) :=
  by
  obtain ⟨φ, rfl⟩ := h
  refine' ⟨(bounded_formula.relabel id φ).exs, _⟩
  ext x
  simp only [Set.mem_image, mem_set_of_eq, bounded_formula.realize_exs,
    bounded_formula.realize_relabel, Function.comp.right_id, Fin.castAdd_zero, Fin.cast_refl]
  constructor
  · rintro ⟨y, hy, rfl⟩
    exact
      ⟨y ∘ Sum.inr, (congr (congr rfl (Sum.elim_comp_inl_inr y).symm) (funext finZeroElim)).mp hy⟩
  · rintro ⟨y, hy⟩
    exact ⟨Sum.elim x y, (congr rfl (funext finZeroElim)).mp hy, Sum.elim_comp_inl _ _⟩
#align set.definable.image_comp_sum_inl_fin Set.Definable.image_comp_sum_inl_fin

/-- Shows that definability is closed under finite projections. -/
theorem Definable.image_comp_embedding {s : Set (β → M)} (h : A.Definable L s) (f : α ↪ β)
    [Finite β] : A.Definable L ((fun g : β → M => g ∘ f) '' s) := by
  classical
    cases nonempty_fintype β
    refine'
      (congr rfl (ext fun x => _)).mp
        (((h.image_comp_equiv (Equiv.Set.sumCompl (range f))).image_comp_equiv
              (Equiv.sumCongr (Equiv.ofInjective f f.injective)
                (Fintype.equivFin _).symm)).image_comp_sum_inl_fin
          _)
    simp only [mem_preimage, mem_image, exists_exists_and_eq_and]
    refine' exists_congr fun y => and_congr_right fun ys => Eq.congr_left (funext fun a => _)
    simp
#align set.definable.image_comp_embedding Set.Definable.image_comp_embedding

/-- Shows that definability is closed under finite projections. -/
theorem Definable.image_comp {s : Set (β → M)} (h : A.Definable L s) (f : α → β) [Finite α]
    [Finite β] : A.Definable L ((fun g : β → M => g ∘ f) '' s) := by
  classical
    cases nonempty_fintype α
    cases nonempty_fintype β
    have h :=
      (((h.image_comp_equiv (Equiv.Set.sumCompl (range f))).image_comp_equiv
                (Equiv.sumCongr (_root_.equiv.refl _)
                  (Fintype.equivFin _).symm)).image_comp_sum_inl_fin
            _).preimage_comp
        (range_splitting f)
    have h' :
      A.definable L { x : α → M | ∀ a, x a = x (range_splitting f (range_factorization f a)) } :=
      by
      have h' :
        ∀ a, A.definable L { x : α → M | x a = x (range_splitting f (range_factorization f a)) } :=
        by
        refine' fun a => ⟨(var a).equal (var (range_splitting f (range_factorization f a))), ext _⟩
        simp
      refine' (congr rfl (ext _)).mp (definable_finset_bInter h' Finset.univ)
      simp
    refine' (congr rfl (ext fun x => _)).mp (h.inter h')
    simp only [Equiv.coe_trans, mem_inter_iff, mem_preimage, mem_image, exists_exists_and_eq_and,
      mem_set_of_eq]
    constructor
    · rintro ⟨⟨y, ys, hy⟩, hx⟩
      refine' ⟨y, ys, _⟩
      ext a
      rw [hx a, ← Function.comp_apply x, ← hy]
      simp
    · rintro ⟨y, ys, rfl⟩
      refine' ⟨⟨y, ys, _⟩, fun a => _⟩
      · ext
        simp [Set.apply_rangeSplitting f]
      ·
        rw [Function.comp_apply, Function.comp_apply, apply_range_splitting f,
          range_factorization_coe]
#align set.definable.image_comp Set.Definable.image_comp

variable (L) {M} (A)

/-- A 1-dimensional version of `definable`, for `set M`. -/
def Definable₁ (s : Set M) : Prop :=
  A.Definable L { x : Fin 1 → M | x 0 ∈ s }
#align set.definable₁ Set.Definable₁

/-- A 2-dimensional version of `definable`, for `set (M × M)`. -/
def Definable₂ (s : Set (M × M)) : Prop :=
  A.Definable L { x : Fin 2 → M | (x 0, x 1) ∈ s }
#align set.definable₂ Set.Definable₂

end Set

namespace FirstOrder

namespace Language

open Set

variable (L : FirstOrder.Language.{u, v}) {M : Type w} [L.Structure M] (A : Set M) (α : Type _)

/-- Definable sets are subsets of finite Cartesian products of a structure such that membership is
  given by a first-order formula. -/
def DefinableSet :=
  { s : Set (α → M) // A.Definable L s }
#align first_order.language.definable_set FirstOrder.Language.DefinableSet

namespace DefinableSet

variable {L A α} {s t : L.DefinableSet A α} {x : α → M}

instance : SetLike (L.DefinableSet A α) (α → M)
    where
  coe := Subtype.val
  coe_injective' := Subtype.val_injective

instance : Top (L.DefinableSet A α) :=
  ⟨⟨⊤, definable_univ⟩⟩

instance : Bot (L.DefinableSet A α) :=
  ⟨⟨⊥, definable_empty⟩⟩

instance : Sup (L.DefinableSet A α) :=
  ⟨fun s t => ⟨s ∪ t, s.2.union t.2⟩⟩

instance : Inf (L.DefinableSet A α) :=
  ⟨fun s t => ⟨s ∩ t, s.2.inter t.2⟩⟩

instance : HasCompl (L.DefinableSet A α) :=
  ⟨fun s => ⟨sᶜ, s.2.compl⟩⟩

instance : SDiff (L.DefinableSet A α) :=
  ⟨fun s t => ⟨s \ t, s.2.sdiff t.2⟩⟩

instance : Inhabited (L.DefinableSet A α) :=
  ⟨⊥⟩

theorem le_iff : s ≤ t ↔ (s : Set (α → M)) ≤ (t : Set (α → M)) :=
  Iff.rfl
#align first_order.language.definable_set.le_iff FirstOrder.Language.DefinableSet.le_iff

@[simp]
theorem mem_top : x ∈ (⊤ : L.DefinableSet A α) :=
  mem_univ x
#align first_order.language.definable_set.mem_top FirstOrder.Language.DefinableSet.mem_top

@[simp]
theorem not_mem_bot {x : α → M} : ¬x ∈ (⊥ : L.DefinableSet A α) :=
  not_mem_empty x
#align first_order.language.definable_set.not_mem_bot FirstOrder.Language.DefinableSet.not_mem_bot

@[simp]
theorem mem_sup : x ∈ s ⊔ t ↔ x ∈ s ∨ x ∈ t :=
  Iff.rfl
#align first_order.language.definable_set.mem_sup FirstOrder.Language.DefinableSet.mem_sup

@[simp]
theorem mem_inf : x ∈ s ⊓ t ↔ x ∈ s ∧ x ∈ t :=
  Iff.rfl
#align first_order.language.definable_set.mem_inf FirstOrder.Language.DefinableSet.mem_inf

@[simp]
theorem mem_compl : x ∈ sᶜ ↔ ¬x ∈ s :=
  Iff.rfl
#align first_order.language.definable_set.mem_compl FirstOrder.Language.DefinableSet.mem_compl

@[simp]
theorem mem_sdiff : x ∈ s \ t ↔ x ∈ s ∧ ¬x ∈ t :=
  Iff.rfl
#align first_order.language.definable_set.mem_sdiff FirstOrder.Language.DefinableSet.mem_sdiff

@[simp, norm_cast]
theorem coe_top : ((⊤ : L.DefinableSet A α) : Set (α → M)) = univ :=
  rfl
#align first_order.language.definable_set.coe_top FirstOrder.Language.DefinableSet.coe_top

@[simp, norm_cast]
theorem coe_bot : ((⊥ : L.DefinableSet A α) : Set (α → M)) = ∅ :=
  rfl
#align first_order.language.definable_set.coe_bot FirstOrder.Language.DefinableSet.coe_bot

@[simp, norm_cast]
theorem coe_sup (s t : L.DefinableSet A α) : (↑(s ⊔ t) : Set (α → M)) = s ∪ t :=
  rfl
#align first_order.language.definable_set.coe_sup FirstOrder.Language.DefinableSet.coe_sup

@[simp, norm_cast]
theorem coe_inf (s t : L.DefinableSet A α) : (↑(s ⊓ t) : Set (α → M)) = s ∩ t :=
  rfl
#align first_order.language.definable_set.coe_inf FirstOrder.Language.DefinableSet.coe_inf

@[simp, norm_cast]
theorem coe_compl (s : L.DefinableSet A α) : (↑(sᶜ) : Set (α → M)) = sᶜ :=
  rfl
#align first_order.language.definable_set.coe_compl FirstOrder.Language.DefinableSet.coe_compl

@[simp, norm_cast]
theorem coe_sdiff (s t : L.DefinableSet A α) : (↑(s \ t) : Set (α → M)) = s \ t :=
  rfl
#align first_order.language.definable_set.coe_sdiff FirstOrder.Language.DefinableSet.coe_sdiff

instance : BooleanAlgebra (L.DefinableSet A α) :=
  Subtype.coe_injective.BooleanAlgebra _ coe_sup coe_inf coe_top coe_bot coe_compl coe_sdiff

end DefinableSet

end Language

end FirstOrder


universes u

inductive mytree (A : Type u) : Type u
| leaf : A → mytree
| branch : A → mytree → mytree → mytree

def flip_mytree {A : Type u} : mytree A → mytree A
| t@(mytree.leaf _)     := t
| (mytree.branch a l r) := mytree.branch a (flip_mytree r) (flip_mytree l)

theorem flip_flip {A : Type u} {t : mytree A} : flip_mytree (flip_mytree t) = t :=
begin
    induction t with t a l r hl hr,
    {
        rw [flip_mytree, flip_mytree],
    },
    {
        rw [flip_mytree, flip_mytree, hr, hl],
    },
end


variables p q : Prop

example (hp : p) (hq : q) : p ∧ q := and.intro hp hq

#check assume (hp : p) (hq : q), and.intro hp hq


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

import group_theory.perm group_theory.order_of_element group_theory.quotient_group

universes u v
open finset is_subgroup equiv equiv.perm quotient_group

instance {α β : Type*} [group α] [group β] [decidable_eq β] (f : α → β) [is_group_hom f] :
  decidable_pred (is_group_hom.ker f) :=
λ _, decidable_of_iff _ (is_group_hom.mem_ker f).symm

def alternating (α : Type*) [decidable_eq α] [fintype α] : Type* :=
is_group_hom.ker (sign : perm α → units ℤ)

/- not definitionally equal to `subtype.decidable_eq`, since `subtype.decidable_eq` does
  not reduce in the kernel -/
instance (α : Type*) [decidable_eq α] [fintype α] : decidable_eq (alternating α) :=
λ a b, decidable_of_iff (a.1 = b.1) (by cases a; cases b; simp [subtype.mk.inj_eq])

instance (α : Type*) [decidable_eq α] [fintype α] : fintype (alternating α) :=
set_fintype _

instance (α : Type*) [decidable_eq α] [fintype α] : group (alternating α) :=
by unfold alternating; apply_instance

section classical

local attribute [instance] classical.prop_decidable

lemma card_alternating (α : Type*) [decidable_eq α] [fintype α] (h : 2 ≤ fintype.card α):
  fintype.card (alternating α) * 2 = (fintype.card α).fact :=
have (quotient_group.quotient (is_group_hom.ker (sign : perm α → units ℤ))) ≃ units ℤ,
  from quotient_ker_equiv_of_surjective _ (sign_surjective h),
calc fintype.card (alternating α) * 2 = fintype.card (units ℤ × alternating α) :
  by rw [mul_comm, fintype.card_prod, fintype.card_units_int]
... = fintype.card (perm α) : fintype.card_congr
  (calc (units ℤ × alternating α) ≃
    (quotient_group.quotient (is_group_hom.ker (sign : perm α → units ℤ)) × alternating α)  :
      equiv.prod_congr this.symm (by refl)
  ... ≃ perm α : (group_equiv_quotient_times_subgroup _).symm)
... = (fintype.card α).fact : fintype.card_perm

end classical

local notation `A5` := alternating (fin 5)
variables {α : Type*} [fintype α] [decidable_eq α]

section
local attribute [semireducible] reflected

meta instance fin_reflect (n : ℕ) : has_reflect (fin n) :=
λ a, `(@fin.mk %%`(n) %%(nat.reflect a.1) (of_as_true %%`(_root_.trivial)))

meta instance fin_fun.has_reflect : has_reflect (fin 5 → fin 5) :=
list.rec_on (quot.unquot (@univ (fin 5) _).1)
  (λ f, `(λ y : fin 5, y))
  (λ x l ih f, let e := ih f in
    if f x = x then e
    else let ex := fin_reflect 5 x in
      let efx := fin_reflect 5 (f x) in
      if e = `(λ y : fin 5, y)
      then `(λ y : fin 5, ite.{1} (y = %%ex) (%%efx) y)
      else `(λ y : fin 5, ite.{1} (y = %%ex) (%%efx) ((%%e : fin 5 → fin 5) y)))

meta instance : has_reflect (perm (fin 5)) :=
λ f, `(@equiv.mk.{1 1} (fin 5) (fin 5)
    %%(fin_fun.has_reflect f.to_fun)
  %%(fin_fun.has_reflect f.inv_fun)
  (of_as_true %%`(_root_.trivial)) (of_as_true %%`(_root_.trivial)))

meta instance I1 : has_reflect (alternating (fin 5)) :=
λ f, `(@subtype.mk (perm (fin 5)) (is_group_hom.ker (sign : perm (fin 5) → units ℤ))
   %%(@reflect (perm (fin 5)) f.1 (equiv.perm.has_reflect f.1))
  ((is_group_hom.mem_ker sign).2 %%`(@eq.refl (units ℤ) 1)))

meta instance multiset.has_reflect {α : Type} [reflected α] [has_reflect α] :
  has_reflect (multiset α) :=
λ s, let l : list α := quot.unquot s in `(@quotient.mk.{1} (list %%`(α)) _ %%`(l))

meta instance I2 (a : alternating (fin 5)) :
  has_reflect {b : alternating (fin 5) × alternating (fin 5) // b.2 * a * b.2⁻¹ = b.1} :=
λ b, `(@subtype.mk (alternating (fin 5) × alternating (fin 5))
  (λ b, b.2 * %%`(a) * b.2⁻¹ = b.1)
  %%(prod.has_reflect _ _ b.1) (of_as_true %%`(_root_.trivial)))

meta instance I3 (a : alternating (fin 5)) (m : reflected a) :
  reflected {b : alternating (fin 5) × alternating (fin 5) // b.2 * a * b.2⁻¹ = b.1} :=
`({b : alternating (fin 5) × alternating (fin 5) // b.2 * %%m * b.2⁻¹ = b.1})

meta instance I4 : has_reflect
  (Σ a : alternating (fin 5), multiset
  {b : alternating (fin 5) × alternating (fin 5) // b.2 * a * b.2⁻¹ = b.1}) :=
λ s, let ra : reflected s.1 := (I1 s.1) in
`(let a : alternating (fin 5) := %%ra in
  @sigma.mk (alternating (fin 5))
    (λ a, multiset {b : alternating (fin 5) × alternating (fin 5) // b.2 * a * b.2⁻¹ = b.1})
    a %%(@multiset.has_reflect _ (I3 s.1 ra) (I2 s.1) s.2))

end

def conjugacy_classes_A5_meta_aux : list (alternating (fin 5)) → multiset
  (Σ a : alternating (fin 5), multiset
  {b : alternating (fin 5) × alternating (fin 5) // b.2 * a * b.2⁻¹ = b.1})
| [] := 0
| (a :: l) := let m : Σ a : alternating (fin 5), multiset
    {b : alternating (fin 5) × alternating (fin 5) // b.2 * a * b.2⁻¹ = b.1} :=
  ⟨a, quotient.lift_on (@univ (alternating (fin 5)) _).1
  (λ l, (l.map
  (λ x, show {b : alternating (fin 5) × alternating (fin 5) // b.2 * a * b.2⁻¹ = b.1},
    from ⟨(x * a * x⁻¹, x), rfl⟩)).pw_filter (λ x y, x.1.1 ≠ y.1.1)) sorry⟩ in
have wf : (l.filter (λ x, x ∉ m.2.map (prod.fst ∘ subtype.val))).length <
    (a :: l : list _).length,
  from  sorry,
m :: conjugacy_classes_A5_meta_aux (l.filter (λ x, x ∉ m.2.map (prod.fst ∘ subtype.val)))
using_well_founded {rel_tac := λ _ _, `[exact ⟨_, measure_wf list.length⟩],
  dec_tac := tactic.assumption}

def conjugacy_classes_A52 : list A5 →
  multiset {s : finset A5 //  ∀ (x∈s) (y∈s), is_conj x y}
| []     := ∅
| (a::l) :=
  let s : {s : finset A5 // ∀ (x∈s) (y∈s), is_conj x y} :=
  ⟨(@univ A5 _).image (λ x, x * a * x⁻¹),
    λ x hx y hy, let ⟨m, _, hm⟩ := mem_image.1 hx in
      let ⟨n, _, hn⟩ := mem_image.1 hy in
      ⟨n * m⁻¹, by simp [hm.symm, mul_assoc, hn.symm]⟩⟩ in
  have wf : false, from sorry,
  s :: conjugacy_classes_A52 (l.filter (λ x, x ∉ s.1))
using_well_founded {rel_tac := λ _ _, `[exact ⟨_, empty_wf⟩],
  dec_tac := tactic.assumption}

-- def conjugacy_classes_A5_meta : multiset (Σ a : alternating (fin 5), multiset
--   {b : alternating (fin 5) × alternating (fin 5) // b.2 * a * b.2⁻¹ = b.1}) :=
-- (quotient.mk ((conjugacy_classes_A5_meta_aux (quot.unquot univ.1)).map
--     (λ a, ⟨a.1, (quotient.mk a.2)⟩)))

#print nat.gcd

open nat
def gcd' : nat → nat → nat
| 0        y := y
| (succ x) y := have false, from sorry,
                gcd (y % succ x) (succ x)
using_well_founded {rel_tac := λ _ _, `[exact ⟨_, empty_wf⟩],
  dec_tac := tactic.assumption}

example : gcd' 1 2 = 1 := rfl

meta def exact_reflect {α : Sort*} [has_reflect α] (a : α) : tactic unit :=
tactic.exact `(a)

@[irreducible] def conjugacy_classes_A5_aux : multiset (Σ a : alternating (fin 5), multiset
  {b : alternating (fin 5) × alternating (fin 5) // b.2 * a * b.2⁻¹ = b.1}) :=
by exact_reflect (conjugacy_classes_A5_meta_aux (quot.unquot univ.1))

example : conjugacy_classes_A5_aux = conjugacy_classes_A5_aux := dec_trivial

def conjugacy_classes_A5_aux2 : multiset (multiset (alternating (fin 5))) :=
conjugacy_classes_A5_aux.map (λ s, s.2.map (λ b, b.1.1))

example : (quotient.lift_on (@univ A5 _).1 conjugacy_classes_A52 sorry).map (finset.card ∘ subtype.val) =
  {1,12,12,15,20} := dec_trivial

lemma nodup_conjugacy_classes_A5_aux2_bind : (conjugacy_classes_A5_aux2.bind id).nodup :=
dec_trivial

lemma nodup_conjugacy_classes_A5_aux2 : ∀ s : multiset (alternating (fin 5)),
  s ∈ conjugacy_classes_A5_aux2 → s.nodup :=
(multiset.nodup_bind.1 nodup_conjugacy_classes_A5_aux2_bind).1

def conjugacy_classes_A5 : finset (finset (alternating (fin 5))) :=
⟨conjugacy_classes_A5_aux2.pmap finset.mk nodup_conjugacy_classes_A5_aux2, dec_trivial⟩

lemma nodup_conjugacy_classes_A5_bind : (conjugacy_classes_A5.1.bind finset.val).nodup :=
have conjugacy_classes_A5.1.bind finset.val =
  conjugacy_classes_A5_aux2.bind id,
from multiset.ext.2 $ λ a,
  by rw [conjugacy_classes_A5, @multiset.count_bind A5, @multiset.count_bind A5,
    multiset.map_pmap, multiset.pmap_eq_map]; refl,
by rw this; exact nodup_conjugacy_classes_A5_aux2_bind

lemma is_conj_conjugacy_classes_A5 (s : finset A5) (h : s ∈ conjugacy_classes_A5) :
  ∀ x y ∈ s, is_conj x y :=
assume x y hx hy,
begin
  simp only [conjugacy_classes_A5, finset.mem_def, multiset.mem_pmap,
    conjugacy_classes_A5_aux2] at h,
  rcases h with ⟨t, ht₁, ht₂⟩,
  rw [multiset.mem_map] at ht₁,
  rcases ht₁ with ⟨u, hu₁, hu₂⟩,
  have hx' : x ∈ multiset.map (λ (b : {b : A5 × A5 // b.2 * u.1 * b.2⁻¹ = b.1}), b.1.1) u.2,
  { simpa [ht₂.symm, hu₂] using hx },
  have hy' : y ∈ multiset.map (λ (b : {b : A5 × A5 // b.2 * u.1 * b.2⁻¹ = b.1}), b.1.1) u.2,
  { simpa [ht₂.symm, hu₂] using hy },
  cases multiset.mem_map.1 hx' with xc hxc,
  cases multiset.mem_map.1 hy' with yc hyc,
  exact is_conj_trans
    (is_conj_symm (show is_conj u.1 x, from hxc.2 ▸ ⟨_, xc.2⟩))
    (hyc.2 ▸ ⟨_, yc.2⟩)
end

variables {G : Type u} [group G] [decidable_eq G]

lemma normal_subgroup_eq_bind_conjugacy_classes (s : finset (finset G)) (h₁ : ∀ x, ∃ t ∈ s, x ∈ t)
  (h₂ : ∀ t ∈ s, ∀ x y ∈ t, is_conj x y) (I : finset G) [nI : normal_subgroup (↑I : set G)] :
  ∃ u ⊆ s, I = u.bind id :=
⟨(s.powerset.filter (λ u : finset (finset G), u.bind id ⊆ I)).bind id,
    (λ x, by simp only [finset.subset_iff, mem_bind, mem_filter, exists_imp_distrib, mem_powerset,
      and_imp, id.def] {contextual := tt}; tauto),
  le_antisymm
    (λ x hxI, let ⟨t, ht₁, ht₂⟩ := h₁ x in
      mem_bind.2 ⟨t, mem_bind.2 ⟨(s.powerset.filter (λ u : finset (finset G), u.bind id ⊆ I)).bind id,
          mem_filter.2 ⟨mem_powerset.2
            (λ u hu, let ⟨v, hv₁, hv₂⟩ := mem_bind.1 hu in
              mem_powerset.1 (mem_filter.1 hv₁).1 hv₂),
          λ y hy, let ⟨u, hu₁, hu₂⟩ := mem_bind.1 hy in
            let ⟨v, hv₁, hv₂⟩ := mem_bind.1 hu₁ in
            (mem_filter.1 hv₁).2 (mem_bind.2 ⟨u, hv₂, hu₂⟩)⟩,
        mem_bind.2 ⟨{t}, mem_filter.2 ⟨by simp [ht₁, finset.subset_iff],
            λ y hy, let ⟨u, hu₁, hu₂⟩ := mem_bind.1 hy in
              let ⟨z, hz⟩ := h₂ t ht₁ x y ht₂ (by simp * at *) in
              hz ▸ @normal_subgroup.normal G _ I.to_set nI _ hxI _⟩,
          by simp⟩⟩,
        ht₂⟩)
    (λ x, by simp only [finset.subset_iff, mem_bind, exists_imp_distrib, mem_filter, mem_powerset]; tauto)⟩

lemma simple_of_card_conjugacy_classes [fintype G] (s : finset (finset G))
  (h₁ : ∀ x, ∃ t ∈ s, x ∈ t) (h₂ : ∀ t ∈ s, ∀ x y ∈ t, is_conj x y)
  (hs : (s.1.bind finset.val).nodup)
  (h₃ : ∀ t ≤ s.1.map finset.card, 1 ∈ t → t.sum ∣ fintype.card G → t.sum = 1 ∨ t.sum = fintype.card G) :
  simple_group G :=
by haveI := classical.dec; exact
⟨λ H iH,
  let I := (set.to_finset H) in
  have Ii : normal_subgroup (↑I : set G), by simpa using iH,
  let ⟨u, hu₁, hu₂⟩ :=
    @normal_subgroup_eq_bind_conjugacy_classes G _ _ s h₁ h₂ I Ii in
  have hInd : ∀ (x : finset G), x ∈ u → ∀ (y : finset G), y ∈ u → x ≠ y → id x ∩ id y = ∅,
    from λ x hxu y hyu hxy,
      begin
        rw multiset.nodup_bind at hs,
        rw [← finset.disjoint_iff_inter_eq_empty, finset.disjoint_left],
        exact multiset.forall_of_pairwise
          (λ (a b : finset G) (h : multiset.disjoint a.1 b.1),
          multiset.disjoint.symm h) hs.2 x (hu₁ hxu) y (hu₁ hyu) hxy
      end,
  have hci : card I = u.sum finset.card,
    by rw [hu₂, card_bind hInd]; refl,
  have hu1 : (1 : G) ∈ u.bind id, by exactI hu₂ ▸ is_submonoid.one_mem (↑I : set G),
  let ⟨v, hv₁, hv₂⟩ := mem_bind.1 hu1 in
  have hv : v = finset.singleton (1 : G),
    from finset.ext.2 $ λ a, ⟨λ hav, mem_singleton.2 $
        is_conj_one_right.1 (h₂ v (hu₁ hv₁) _ _ hv₂ hav),
      by simp [show (1 : G) ∈ v, from hv₂] {contextual := tt}⟩,
  have hci' : card I = 1 ∨ card I = fintype.card G,
    begin
      rw [hci],
      exact h₃ _ (multiset.map_le_map (show u.1 ≤ s.1,
        from (multiset.le_iff_subset u.2).2 hu₁))
          (multiset.mem_map.2 ⟨finset.singleton 1, hv ▸ hv₁, rfl⟩)
          (calc u.sum finset.card = card I : hci.symm
            ... = fintype.card (↑I : set G) : (set.card_fintype_of_finset' I (by simp)).symm
            ... ∣ fintype.card G : by exactI card_subgroup_dvd_card _)
    end,
    hci'.elim
      (λ hci', or.inl (set.ext (λ x,
        let ⟨y, hy⟩ := finset.card_eq_one.1 hci' in
        by resetI;
          simp only [I, finset.ext, set.mem_to_finset, finset.mem_singleton] at hy;
          simp [is_subgroup.mem_trivial, hy, (hy 1).1 (is_submonoid.one_mem H)])))
      (λ hci', or.inr $
        suffices I = finset.univ,
          by simpa [I, set.ext_iff, finset.ext] using this,
        finset.eq_of_subset_of_card_le (λ _, by simp) (by rw hci'; refl))⟩

lemma card_A5 : fintype.card A5 = 60 :=
(nat.mul_right_inj (show 2 > 0, from dec_trivial)).1 $
have 2 ≤ fintype.card (fin 5), from dec_trivial,
  by rw [card_alternating _ this]; simp; refl

lemma conjugacy_classes_A5_bind_eq_univ :
  conjugacy_classes_A5.bind (λ t, t) = univ :=
eq_of_subset_of_card_le (λ _, by simp)
  (calc card univ = 60 : card_A5
    ... ≤ (conjugacy_classes_A5.1.bind finset.val).card : dec_trivial
    ... = (conjugacy_classes_A5.bind id).card :
      begin
        rw [finset.card_bind, multiset.card_bind], refl,
        { exact multiset.forall_of_pairwise (λ a b, by simp [finset.inter_comm])
            (by simp only [finset.disjoint_iff_inter_eq_empty.symm, finset.disjoint_left];
              exact (multiset.nodup_bind.1 nodup_conjugacy_classes_A5_bind).2) }
      end)

lemma A5_simple : simple_group A5 :=
simple_of_card_conjugacy_classes conjugacy_classes_A5
  (λ x, mem_bind.1 $ by rw [conjugacy_classes_A5_bind_eq_univ]; simp)
  is_conj_conjugacy_classes_A5
  nodup_conjugacy_classes_A5_bind
  (by simp only [multiset.mem_powerset.symm, card_A5];
    exact dec_trivial)


import Meta.Boolean
import Meta.Resolution

theorem mpCvc5 (P Q : Prop) : ¬ (P → (P → Q) → Q) → False :=
  λ lean_a0 =>
    have lean_s0     := notImplies2 lean_a0
    have lean_s1     := notImplies1 lean_s0
    have lean_s2     := impliesElim lean_s1
    have lean_s4     := notImplies1 lean_a0
    have lean_s6     := by R1 lean_s4, lean_s2, P
    have lean_s9     := notImplies2 lean_s0
    contradiction lean_s6 lean_s9

theorem mp : ∀ (P Q : Prop), P → (P → Q) → Q := λ P Q => doubleNeg (mpCvc5 P Q)


import Mathlib

open Classical

/- TEMP BEGIN -/
macro "obtain " t:term " := " h:term : tactic =>
  `(match $h:term with | $t:term => ?_)

@[simp] theorem Set.mem_set_of_eq {a : α} {p : α → Prop} : (a ∈ {a | p a}) = p a := sorry
theorem Set.ext_iff {s t : Set α} : s = t ↔ ∀ x, x ∈ s ↔ x ∈ t := sorry

def Trace (AP) := Nat → Set AP
def Trace.suffix {AP} (σ : Trace AP) (m : Nat) : Trace AP := λ n => σ (n + m)
notation:max σ:max "[" m "+]" => Trace.suffix σ m

@[simp]
theorem Trace.suffix_zero {AP} (σ : Trace AP) : σ[0+] = σ := by
  simp [suffix]

theorem Trace.suffix_split {AP} (σ : Trace AP) {m n : Nat} : σ[m+][n+] = σ[(m + n)+] := by
  sorry

theorem Trace.suffix_shuffle {AP} (σ : Trace AP) {m n : Nat} : σ[m+][n+] = σ[n+][m+] := by
  sorry

-- TODO: Macros for ∃∞ and ∀∞

/- TEMP END -/

-- Definition 5.1
inductive LTLFormula (AP) where
  | «true» : LTLFormula AP
  | atomic : AP → LTLFormula AP
  | not :    LTLFormula AP → LTLFormula AP
  | and :    LTLFormula AP → LTLFormula AP → LTLFormula AP
  | next :   LTLFormula AP → LTLFormula AP
  | until :  LTLFormula AP → LTLFormula AP → LTLFormula AP

variable {AP}

namespace LTLFormula

instance : Coe AP (LTLFormula AP) := ⟨LTLFormula.atomic⟩

notation "⊤" => LTLFormula.true
notation:max "¬" f:40 => LTLFormula.not f
notation:max "◯" f:40 => LTLFormula.next f
infixr:35 " ∧ " => LTLFormula.and
infixr:35 " U " => LTLFormula.until

def or (φ₁ φ₂ : LTLFormula AP) : LTLFormula AP := ¬(¬φ₁ ∧ ¬φ₂)
infixr:30 " ∨ " => or

def implication (φ₁ φ₂ : LTLFormula AP) : LTLFormula AP := ¬φ₁ ∨ φ₂
infixr:25 " → " => implication

def equivalence (φ₁ φ₂ : LTLFormula AP) : LTLFormula AP := (φ₁ → φ₂) ∧ (φ₂ → φ₁)
infixr:20 " ↔ " => equivalence

def eventually (φ : LTLFormula AP) : LTLFormula AP := ⊤ U φ
notation:max "◇" φ:40 => eventually φ

def always (φ : LTLFormula AP) : LTLFormula AP := ¬◇¬φ
notation:max "□" φ:40 => always φ

-- Definition 5.6
def satisfies {AP} (σ : Trace AP) : LTLFormula AP → Prop
  | ⊤         => True
  | (a : AP)  => a ∈ (σ 0)
  | not φ     => ¬(satisfies σ φ)
  | and φ₁ φ₂ => (satisfies σ φ₁) ∧ (satisfies σ φ₂)
  | ◯φ        => satisfies σ[1+] φ
  | φ₁ U φ₂   => ∃ j, (satisfies σ[j+] φ₂) ∧ ∀ i, i < j → (satisfies σ[i+] φ₁)

infix:15 " ⊨ " => satisfies

def words (φ : LTLFormula AP) := {σ | σ ⊨ φ}

variable {φ φ₁ φ₂ : LTLFormula AP} {σ : Trace AP}

theorem or_sat : (σ ⊨ φ₁ ∨ φ₂) ↔ (σ ⊨ φ₁) ∨ (σ ⊨ φ₂) := by
  simp [or, satisfies]
  constructor
  case mp =>
    intro h
    byCases hc : σ ⊨ φ₁
    case inl => exact Or.inl hc
    case inr => exact Or.inr (h hc)
  case mpr =>
    intro h h'
    exact h.resolve_left h'

theorem implication_sat : (σ ⊨ φ₁ → φ₂) ↔ (σ ⊨ φ₁) → (σ ⊨ φ₂) := by
  simp [satisfies]

theorem equivalence_sat : (σ ⊨ φ₁ ↔ φ₂) ↔ ((σ ⊨ φ₁) ↔ (σ ⊨ φ₂)) := by
  simp [equivalence]
  constructor
  case mp =>
    intro h
    simp [satisfies] at h
    exact ⟨h.left, h.right⟩
  case mpr =>
    intro h
    simp [satisfies]
    exact ⟨h.mp, h.mpr⟩

theorem eventually_sat : (σ ⊨ ◇φ) ↔ (∃ j, σ[j+] ⊨ φ) := by
  simp [satisfies]

theorem always_sat : (σ ⊨ □φ) ↔ (∀ j, σ[j+] ⊨ φ) := by
  simp [satisfies]

-- Definition 5.17
def equivalent (φ₁ φ₂ : LTLFormula AP) : Prop :=
  φ₁.words = φ₂.words

infix:15 " ≡ " => equivalent

theorem equivalent_ext : (φ₁ ≡ φ₂) ↔ ∀ σ, (σ ⊨ φ₂) ↔ (σ ⊨ φ₁) := by
  constructor <;> (
    simp [equivalent, Set.ext_iff, words, Set.mem_set_of_eq]
    intro h σ
    exact Iff.symm $ h σ
  )

@[simp]
theorem equivalent_refl : φ ≡ φ := by
  simp [equivalent]

@[simp]
theorem equivalent_from_eq : (φ₁ = φ₂) → (φ₁ ≡ φ₂) :=
  λ h => by simp [h]

@[simp]
theorem equivalent_trans : (φ ≡ φ₁) → (φ₁ ≡ φ₂) → (φ ≡ φ₂) := by
  simp [equivalent]
  exact Eq.trans

-- Subsitute ψ₁ with ψ₂ in φ.
noncomputable def substitute (φ ψ₁ ψ₂ : LTLFormula AP) : LTLFormula AP :=
  if φ = ψ₁ then ψ₂ else
  match φ with
  | ⊤           => ⊤
  | (a : AP)    => a
  | not φ'      => ¬(substitute φ' ψ₁ ψ₂)
  | and φ'₁ φ'₂ => (substitute φ'₁ ψ₁ ψ₂) ∧ (substitute φ'₂ ψ₁ ψ₂)
  | ◯φ'         => ◯(substitute φ' ψ₁ ψ₂)
  | φ'₁ U φ'₂   => (substitute φ'₁ ψ₁ ψ₂) U (substitute φ'₂ ψ₁ ψ₂)

theorem substitute_equiv (h : φ₁ ≡ φ₂) : φ ≡ φ.substitute φ₁ φ₂ := by
  induction φ
  case true =>
    simp only [substitute]
    split
    case inl h' => simp [h', h]
    case inr => simp
  case atomic =>
    simp only [substitute]
    split
    case inl h' => simp [h', h]
    case inr => simp
  case not φ' hi =>
    simp only [substitute]
    split
    case inl h' => simp [h', h]
    case inr =>
      simp [equivalent_ext] at hi ⊢
      intro σ
      simp only [satisfies]
      exact ⟨mt (hi σ).mpr, mt (hi σ).mp⟩
  case and φ'₁ φ'₂ hi₁ hi₂ =>
    simp only [substitute]
    split
    case inl h' => simp [h', h]
    case inr =>
      simp [equivalent_ext] at hi₁ hi₂ ⊢
      intro σ
      simp only [satisfies]
      constructor
      case mp =>
        intro h
        exact ⟨(hi₁ σ).mp h.left, (hi₂ σ).mp h.right⟩
      case mpr =>
        intro h
        exact ⟨(hi₁ σ).mpr h.left, (hi₂ σ).mpr h.right⟩
  case next φ' hi =>
    simp only [substitute]
    split
    case inl h' => simp [h', h]
    case inr =>
      simp [equivalent_ext] at hi ⊢
      intro σ
      simp only [satisfies]
      exact hi σ[1+]
  case until φ'₁ φ'₂ hi₁ hi₂ =>
    simp only [substitute]
    split
    case inl h' => simp [h', h]
    case inr =>
      simp [equivalent_ext] at hi₁ hi₂ ⊢
      intro σ
      simp only [satisfies]
      constructor
      case mp =>
        intro ⟨j, hj, hij⟩
        exists j
        apply And.intro $ (hi₂ σ[j+]).mp hj
        intro i hi
        exact (hi₁ σ[i+]).mp (hij i hi)
      case mpr =>
        intro ⟨j, hj, hij⟩
        exists j
        apply And.intro $ (hi₂ σ[j+]).mpr hj
        intro i hi
        exact (hi₁ σ[i+]).mpr (hij i hi)

@[simp]
theorem double_negation : ¬¬φ ≡ φ := by
  rw [equivalent_ext]
  intro σ
  simp [satisfies]

@[simp]
theorem next_duality : ¬◯φ ≡ ◯¬φ := by
  rw [equivalent_ext]
  intro σ
  constructor <;> (intro h; exact h)

@[simp]
theorem eventually_duality : ¬◇φ ≡ □¬φ := by
  rw [equivalent_ext]
  intro σ
  constructor <;> (
    intro h
    simp [satisfies] at *
    exact h
  )

@[simp]
theorem always_duality : ¬□φ ≡ ◇¬φ := by
  rw [equivalent_ext]
  intro σ
  constructor <;> (
    intro h
    simp [satisfies] at *
    exact h
  )

@[simp]
theorem eventually_idem : ◇◇φ ≡ ◇φ := by
  rw [equivalent_ext]
  intro σ
  simp [eventually]
  constructor
  case mp =>
    intro ⟨j, h⟩
    simp [satisfies] at *
    exact ⟨j, 0, h⟩
  case mpr =>
    simp [satisfies]
    intro j j' h
    simp [Trace.suffix_split] at h
    exact ⟨j + j', h⟩

@[simp]
theorem always_idem : □□φ ≡ □φ := by
  rw [equivalent_ext]
  intro σ
  simp [always]
  constructor
  case mp =>
    simp [satisfies]
    intro h j j'
    simp [Trace.suffix_split, h (j + j')]
  case mpr =>
    simp [satisfies]
    intro h j
    exact h j 0

@[simp]
theorem until_idem_left : φ₁ U (φ₁ U φ₂) ≡ φ₁ U φ₂ := by
  rw [equivalent_ext]
  intro σ
  constructor
  case mp =>
    simp [satisfies]
    intro j h₁ h₂
    exists j
    constructor
    case left =>
      exists (0 : Nat)
      apply And.intro h₁
      intro i hi
      contradiction
    case right =>
      exact h₂
  case mpr =>
    intro h
    simp [satisfies] at h ⊢
    obtain ⟨j, ⟨⟨j', ⟨h₁, h₂⟩⟩, h₃⟩⟩ := h
    clear h
    exists j + j'
    simp [Trace.suffix_split] at h₁
    apply And.intro h₁
    clear h₁
    intro i hi
    have h₂':= h₂ i
    have h₃' := h₃ i
    clear h₂ h₃
    sorry -- unprovable from here

@[simp]
theorem until_idem_right : (φ₁ U φ₂) U φ₂ ≡ φ₁ U φ₂ := by
  sorry

set_option maxHeartbeats 100000

@[simp]
theorem eventually_absorption : ◇□◇φ ≡ □◇φ := by
  rw [equivalent_ext]
  intro σ
  constructor
  case mp =>
    intro h
    simp [satisfies] at h ⊢
    exists (0 : Nat)
    simp [h]
  case mpr =>
    intro h
    simp [satisfies] at *
    intro x
    obtain ⟨j, h⟩ := h
    obtain ⟨j', h⟩ := h x
    exists (j + j')
    simp [Trace.suffix_shuffle σ, Trace.suffix_split σ[x+]] at h
    exact h

end LTLFormula