-- Facts about the dual space unit ball in a normed_space

import topology.basic

import max
import max_log
import tactics
import topology

open complex (abs exp I log)
open filter (at_top)
open function (curry uncurry)
open metric (ball closed_ball sphere)
open set (range univ)
open topological_space (second_countable_topology)
open_locale real nnreal ennreal topological_space complex_conjugate
noncomputable theory

variables {G : Type} [normed_add_comm_group G]
variables {E : Type} [normed_add_comm_group E] [normed_space ℂ E] [second_countable_topology E]

-- A nonconstructive function which extracts a dual vector exhibiting f x = ∥x∥
def dual_vector (x : E) : E →L[ℂ] ℂ := classical.some (exists_dual_vector'' ℂ x)
lemma dual_vector_norm (x : E) : ∥dual_vector x∥ ≤ 1 := (classical.some_spec (exists_dual_vector'' ℂ x)).1
lemma dual_vector_nnnorm (x : E) : ∥dual_vector x∥₊ ≤ 1 := dual_vector_norm _
@[simp] lemma dual_vector_apply (x : E) : dual_vector x x = ∥x∥ := (classical.some_spec (exists_dual_vector'' ℂ x)).2

lemma dual_vector_le (x y : E) : abs (dual_vector x y) ≤ ∥y∥ := begin
  rw ←complex.norm_eq_abs,
  calc ∥dual_vector x y∥ ≤ ∥dual_vector x∥ * ∥y∥ : (dual_vector x).le_op_norm y
  ... ≤ 1 * ∥y∥ : by bound [dual_vector_norm x]
  ... = ∥y∥ : by simp,
end

-- Dual vectors of a dense subset of E
def duals : ℕ → E →L[ℂ] ℂ := λ n, dual_vector (topological_space.dense_seq E n)

-- Lipschitz 0 functions are constant
lemma lipschitz_with.is_const {g : ℝ → ℝ} (g0 : lipschitz_with 0 g) : ∀ x y, g x = g y := begin
  intros x y, have h := g0 x y, simp at h, exact h,
end

lemma duals_bdd_above {g : ℝ → ℝ} (gm : monotone g) (x : E)
    : bdd_above (range (λ n, g ∥duals n x∥)) := begin
  rw bdd_above_def, use [g ∥x∥], simp, intro n, apply gm, apply dual_vector_le,
end

-- One-sided Lipschitz bounds on the reals
lemma lipschitz_with.le {f : G → ℝ} {k : ℝ≥0} (fk : lipschitz_with k f) (x y : G) : f x ≤ f y + k * dist x y := begin
  calc f x = f y + (f x - f y) : by ring_nf
  ... ≤ f y + |f x - f y| : by bound
  ... = f y + dist (f x) (f y) : by rw real.dist_eq
  ... ≤ f y + k * dist x y : by bound [fk.dist_le_mul x y],
end

-- Norms are suprs over duals (version with an arbitrary monotone + Lipschitz function)
lemma norm_eq_duals_supr' {g : ℝ → ℝ} {k : nnreal} (gm : monotone g) (gk : lipschitz_with k g) (x : E)
    : g ∥x∥ = ⨆ n, g ∥duals n x∥ := begin
  by_cases k0 : k = 0, { rw k0 at gk, have g0 := gk.is_const 0, simp [←g0 _] },
  have kp : (k : ℝ) > 0, { simp at ⊢, exact ne.bot_lt k0, },
  apply le_antisymm, {
    apply le_of_forall_pos_le_add, intros e ep,
    rcases metric.dense_range_iff.mp (topological_space.dense_range_dense_seq E) x (e/2/k) (by bound) with ⟨n,nx⟩,
    generalize hy : topological_space.dense_seq E n = y, rw hy at nx,
    have hn : duals n = dual_vector y := by rw [←hy,duals],
    have h := le_csupr (duals_bdd_above gm x) n,
    generalize hs : (⨆ n, g ∥duals n x∥) = s,
    simp_rw [hs,hn] at h, clear hs hn hy, simp at h,
    have gk' : lipschitz_with k (λ x, g (abs (dual_vector y x))), {
      have k11 : (k : ℝ≥0) = k * 1 * 1 := by norm_num, rw k11,
      simp_rw ←complex.norm_eq_abs, apply (gk.comp lipschitz_with_one_norm).comp,
      exact (dual_vector y).lipschitz.weaken (dual_vector_nnnorm y),
    },
    calc g ∥x∥ ≤ g (∥y∥) + (k * 1) * dist x y : (gk.comp lipschitz_with_one_norm).le x y
    ... ≤ g (∥y∥) + (k * 1) * (e/2 / k) : by bound
    ... = g (∥y∥) + k / k * e/2 : by ring
    ... ≤ g (∥y∥) + 1 * e/2 : by bound
    ... = g (∥y∥) + e/2 : by simp
    ... = g (abs (dual_vector y y)) + e/2 : by simp
    ... ≤ g (abs (dual_vector y x)) + k * dist y x + e/2 : by bound [gk'.le]
    ... ≤ s + k * dist y x + e/2 : by bound
    ... = s + k * dist x y + e/2 : by rw dist_comm
    ... ≤ s + k * (e/2 / k) + e/2 : by bound
    ... = s + k / k * e/2 + e/2 : by ring_nf
    ... ≤ s + 1 * e/2 + e/2 : by bound
    ... = s + e : by ring_nf,
  }, {
    apply csupr_le, intro n, apply gm, simp, apply dual_vector_le,
  },
end

lemma norm_eq_duals_supr (x : E) : ∥x∥ = ⨆ n, ∥duals n x∥ := begin
  have h := norm_eq_duals_supr' (@monotone_id ℝ _) lipschitz_with.id x, simp at h ⊢, exact h,
end

lemma max_log_norm_eq_duals_supr (b : ℝ) (x : E)
    : max_log b ∥x∥ = ⨆ n, max_log b ∥duals n x∥ :=
  norm_eq_duals_supr' (monotone_max_log b) (lipschitz_with.max_log b) x

-- Rewrite a ℕ supr into a monotonic limit
lemma csupr.has_lim (s : ℕ → ℝ) (ba : bdd_above (range s))
    : filter.tendsto (λ n, range_max s n) at_top (𝓝 (⨆ n, s n)) := begin
  rw metric.tendsto_at_top, intros e ep,
  generalize hb : (⨆ n, s n) - e = b,
  have bs : b < (⨆ n, s n), { rw ←hb, exact sub_lt_self _ (by bound) },
  rcases exists_lt_of_lt_csupr bs with ⟨N,sN⟩, simp at sN,
  use N, intros n nN, rw real.dist_eq, rw abs_lt, constructor, {
    simp, simp [←hb] at sN,
    calc supr s = supr s - e + e : by ring
    ... < s N + e : by bound
    ... ≤ range_max s n + e : by bound [le_range_max s nN]
    ... = e + range_max s n : by ring,
  }, {
    simp,
    have rs : range_max s n ≤ supr s, {
      rw range_max_le_iff, intros a an,
      exact le_csupr ba a,
    },
    calc range_max s n - supr s ≤ supr s - supr s : by bound
    ... = 0 : by ring
    ... < e : ep,
  },
end

lemma duals_lim_tendsto_max_log_norm (b : ℝ) (x : E)
    : filter.tendsto (range_max (λ k, max_log b ∥duals k x∥)) at_top (𝓝 (max_log b ∥x∥)) := begin
  rw max_log_norm_eq_duals_supr, exact csupr.has_lim _ (duals_bdd_above (monotone_max_log _) _),
end

lemma max_log_norm_eq_duals_lim (b : ℝ) (x : E)
    : max_log b ∥x∥ = lim at_top (range_max (λ k, max_log b ∥duals k x∥)) := begin
  have a := duals_lim_tendsto_max_log_norm b x,
  exact tendsto_nhds_unique a (tendsto_nhds_lim ⟨_,a⟩),
end


import Mathlib.Data.PNat.Basic
import Mathlib.Data.Nat.Parity
import Mathlib.Algebra.BigOperators.Basic
import Mathlib.Tactic.Positivity
import Mathlib.Tactic.Ring

/-!
# IMO 2013 Q1

Prove that for any pair of positive integers k and n, there exist k positive integers
m₁, m₂, ..., mₖ (not necessarily different) such that

  1 + (2ᵏ - 1)/ n = (1 + 1/m₁) * (1 + 1/m₂) * ... * (1 + 1/mₖ).

# Solution

Adaptation of the solution found in https://www.imo-official.org/problems/IMO2013SL.pdf

We prove a slightly more general version where k does not need to be strictly positive.
-/

open BigOperators

lemma prod_lemma (m : ℕ → ℕ+) (k : ℕ) (nm : ℕ+):
      ∏ i in Finset.range k, ((1 : ℚ) + 1 / ((if i < k then m i else nm)):ℚ) =
      ∏ i in Finset.range k, (1 + 1 / ((m i):ℕ)) := by
  have : ∀ i, i ∈ Finset.range k →
      (1 : ℚ) + 1 / ↑(if i < k then m i else nm) = 1 + 1 / m i := by
    intros i hi
    simp [Finset.mem_range.mp hi]
  sorry
  --exact Finset.prod_congr rfl this

theorem imo2013_q1 (n : ℕ+) (k : ℕ) :
    (∃ m : ℕ → ℕ+, (1 : ℚ) + (2^k - 1) / (n:ℚ) =
    (∏ i in Finset.range k, (1 + 1 / ((m i):ℕ)))) := by
  revert n
  induction k with
  | zero => intro n; use (fun _ ↦ 1); simp -- For the base case, any m works.
  | succ pk hpk =>
    intro n
    obtain ⟨t, ht : ↑n = t + t⟩ | ⟨t, ht : ↑n = 2 * t + 1⟩ := (n : ℕ).even_or_odd
    · -- even case
      rw [←two_mul] at ht
      cases t with -- Eliminate the zero case to simplify later calculations.
      | zero => exfalso; rw [Nat.mul_zero] at ht; exact PNat.ne_zero n ht
      | succ t =>
        -- Now we have ht : ↑n = 2 * (t + 1).
        let t_succ : ℕ+ := ⟨t + 1, t.succ_pos⟩
        obtain ⟨pm, hpm⟩ := hpk t_succ
        let m := λi => if i < pk then pm i else ⟨2 * t + 2^pk.succ, by positivity⟩
        use m
        have hmpk : (m pk : ℚ) = 2 * t + 2^pk.succ := by
          have : m pk = ⟨2 * t + 2^pk.succ, _⟩ := if_neg (irrefl pk)
          rw [this]
          norm_cast

        have denom_ne_zero : (2 * (t:ℚ) + 2^pk.succ) ≠ 0 := sorry --by positivity

--        have := calc (1 : ℚ) + (2 ^ pk.succ - 1) / ↑↑n
--            = 1 + (2 * 2 ^ pk - 1) / (2 * (t + 1) : ℕ) := by rw [ht, pow_succ]; sorry
--         _  = (1 + 1 / (2 * t + 2 * 2^pk)) *
--           (1 + (2 ^ pk - 1) / (↑t + 1))              := by sorry
/-

{ field_simp [t.cast_add_one_ne_zero],
                                                             ring }

    ... = (1 + 1 / (2 * t + 2^pk.succ)) *
          (1 + (2 ^ pk - 1) / t_succ)                 : by norm_cast
    ... = (1 + 1 / ↑(m pk)) *
          ∏ (i : ℕ) in finset.range pk, (1 + 1 / m i) : by rw [hpm, prod_lemma, ←hmpk]
    ... = ∏ (i : ℕ) in finset.range pk.succ,
                                        (1 + 1 / m i) : (finset.prod_range_succ_comm _ pk).symm
-/
        sorry
    · sorry
/-

 },
  { -- odd case
    let t_succ : ℕ+ := ⟨t + 1, t.succ_pos⟩,
    obtain ⟨pm, hpm⟩ := hpk t_succ,
    let m := λi, if i < pk then pm i else ⟨2 * t + 1, nat.succ_pos _⟩,
    use m,

    have hmpk : (m pk : ℚ) = 2 * t + 1,
    { have : m pk = ⟨2 * t + 1, _⟩ := if_neg (irrefl pk), simp [this] },

    have denom_ne_zero : (2 * (t : ℚ) + 1) ≠ 0 := by positivity,

    calc (1 : ℚ) + (2 ^ pk.succ - 1) / ↑n
        = 1 + (2 * 2^pk - 1) / (2 * t + 1 : ℕ)        : by rw [coe_coe n, ht, pow_succ]
    ... = (1 + 1 / (2 * t + 1)) *
          (1 + (2^pk - 1) / (t + 1))                  : by { field_simp [t.cast_add_one_ne_zero],
                                                             ring }
    ... = (1 + 1 / (2 * t + 1)) *
          (1 + (2^pk - 1) / t_succ)                   : by norm_cast
    ... = (1 + 1 / ↑(m pk)) *
          ∏ (i : ℕ) in finset.range pk, (1 + 1 / m i) : by rw [hpm, prod_lemma, ←hmpk]
    ... = ∏ (i : ℕ) in finset.range pk.succ,
                                        (1 + 1 / m i) : (finset.prod_range_succ_comm _ pk).symm }
end
-/


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

/-!
# N-ary images of finsets

This file defines `finset.image₂`, the binary image of finsets. This is the finset version of
`set.image2`. This is mostly useful to define pointwise operations.

## Notes

This file is very similar to the n-ary section of `data.set.basic` and to `order.filter.n_ary`.
Please keep them in sync.

We do not define `finset.image₃` as its only purpose would be to prove properties of `finset.image₂`
and `set.image2` already fulfills this task.
-/

open function set

namespace finset

variables {α α' β β' γ γ' δ δ' ε ε' : Type*}
  [decidable_eq α'] [decidable_eq β'] [decidable_eq γ] [decidable_eq γ'] [decidable_eq δ]
  [decidable_eq δ'] [decidable_eq ε] [decidable_eq ε']
  {f f' : α → β → γ} {g g' : α → β → γ → δ} {s s' : finset α} {t t' : finset β} {u u' : finset γ}
  {a a' : α} {b b' : β} {c : γ}

/-- The image of a binary function `f : α → β → γ` as a function `finset α → finset β → finset γ`.
Mathematically this should be thought of as the image of the corresponding function `α × β → γ`. -/
def image₂ (f : α → β → γ) (s : finset α) (t : finset β) : finset γ :=
(s.product t).image $ uncurry f

@[simp] lemma mem_image₂ : c ∈ image₂ f s t ↔ ∃ a b, a ∈ s ∧ b ∈ t ∧ f a b = c :=
by simp [image₂, and_assoc]

@[simp, norm_cast] lemma coe_image₂ (f : α → β → γ) (s : finset α) (t : finset β) :
  (image₂ f s t : set γ) = set.image2 f s t :=
set.ext $ λ _, mem_image₂

lemma card_image₂_le (f : α → β → γ) (s : finset α) (t : finset β) :
  (image₂ f s t).card ≤ s.card * t.card :=
card_image_le.trans_eq $ card_product _ _

lemma card_image₂_iff :
  (image₂ f s t).card = s.card * t.card ↔
    ((s : set α) ×ˢ (t : set β) : set (α × β)).inj_on (λ x, f x.1 x.2) :=
by { rw [←card_product, ←coe_product], exact card_image_iff }

lemma card_image₂ (hf : injective2 f) (s : finset α) (t : finset β) :
  (image₂ f s t).card = s.card * t.card :=
(card_image_of_injective _ hf.uncurry).trans $ card_product _ _

lemma mem_image₂_of_mem (ha : a ∈ s) (hb : b ∈ t) : f a b ∈ image₂ f s t :=
mem_image₂.2 ⟨a, b, ha, hb, rfl⟩

lemma mem_image₂_iff (hf : injective2 f) : f a b ∈ image₂ f s t ↔ a ∈ s ∧ b ∈ t :=
by rw [←mem_coe, coe_image₂, mem_image2_iff hf, mem_coe, mem_coe]

lemma image₂_subset (hs : s ⊆ s') (ht : t ⊆ t') : image₂ f s t ⊆ image₂ f s' t' :=
by { rw [←coe_subset, coe_image₂, coe_image₂], exact image2_subset hs ht }

lemma image₂_subset_left (ht : t ⊆ t') : image₂ f s t ⊆ image₂ f s t' := image₂_subset subset.rfl ht

lemma image₂_subset_right (hs : s ⊆ s') : image₂ f s t ⊆ image₂ f s' t :=
image₂_subset hs subset.rfl

lemma image_subset_image₂_left (hb : b ∈ t) : (λ a, f a b) '' s ⊆ image₂ f s t :=
ball_image_of_ball $ λ a ha, mem_image₂_of_mem ha hb

lemma image_subset_image₂_right (ha : a ∈ s) : f a '' t ⊆ image₂ f s t :=
ball_image_of_ball $ λ b, mem_image₂_of_mem ha

lemma forall_image₂_iff {p : γ → Prop} : (∀ z ∈ image₂ f s t, p z) ↔ ∀ (x ∈ s) (y ∈ t), p (f x y) :=
by simp_rw [←mem_coe, coe_image₂, forall_image2_iff]

@[simp] lemma image₂_subset_iff : image₂ f s t ⊆ u ↔ ∀ (x ∈ s) (y ∈ t), f x y ∈ u :=
forall_image₂_iff

@[simp] lemma image₂_nonempty_iff : (image₂ f s t).nonempty ↔ s.nonempty ∧ t.nonempty :=
by { rw [←coe_nonempty, coe_image₂], exact image2_nonempty_iff }

lemma nonempty.image₂ (hs : s.nonempty) (ht : t.nonempty) : (image₂ f s t).nonempty :=
image₂_nonempty_iff.2 ⟨hs, ht⟩

lemma nonempty.of_image₂_left (h : (image₂ f s t).nonempty) : s.nonempty :=
(image₂_nonempty_iff.1 h).1

lemma nonempty.of_image₂_right (h : (image₂ f s t).nonempty) : t.nonempty :=
(image₂_nonempty_iff.1 h).2

@[simp] lemma image₂_empty_left : image₂ f ∅ t = ∅ := coe_injective $ by simp
@[simp] lemma image₂_empty_right : image₂ f s ∅ = ∅ := coe_injective $ by simp
@[simp] lemma image₂_eq_empty_iff : image₂ f s t = ∅ ↔ s = ∅ ∨ t = ∅ :=
by simp_rw [←not_nonempty_iff_eq_empty, image₂_nonempty_iff, not_and_distrib]

@[simp] lemma image₂_singleton_left : image₂ f {a} t = t.image (λ b, f a b) := ext $ λ x, by simp
@[simp] lemma image₂_singleton_right : image₂ f s {b} = s.image (λ a, f a b) := ext $ λ x, by simp
lemma image₂_singleton_left' : image₂ f {a} t = t.image (f a) := image₂_singleton_left

lemma image₂_singleton : image₂ f {a} {b} = {f a b} := by simp

lemma image₂_union_left [decidable_eq α] : image₂ f (s ∪ s') t = image₂ f s t ∪ image₂ f s' t :=
coe_injective $ by { push_cast, exact image2_union_left }

lemma image₂_union_right [decidable_eq β] : image₂ f s (t ∪ t') = image₂ f s t ∪ image₂ f s t' :=
coe_injective $ by { push_cast, exact image2_union_right }

lemma image₂_inter_subset_left [decidable_eq α] :
  image₂ f (s ∩ s') t ⊆ image₂ f s t ∩ image₂ f s' t :=
coe_subset.1 $ by { push_cast, exact image2_inter_subset_left }

lemma image₂_inter_subset_right [decidable_eq β] :
  image₂ f s (t ∩ t') ⊆ image₂ f s t ∩ image₂ f s t' :=
coe_subset.1 $ by { push_cast, exact image2_inter_subset_right }

lemma image₂_congr (h : ∀ (a ∈ s) (b ∈ t), f a b = f' a b) : image₂ f s t = image₂ f' s t :=
coe_injective $ by { push_cast, exact image2_congr h }

/-- A common special case of `image₂_congr` -/
lemma image₂_congr' (h : ∀ a b, f a b = f' a b) : image₂ f s t = image₂ f' s t :=
image₂_congr $ λ a _ b _, h a b

lemma subset_image₂ {s : set α} {t : set β} (hu : ↑u ⊆ image2 f s t) :
  ∃ (s' : finset α) (t' : finset β), ↑s' ⊆ s ∧ ↑t' ⊆ t ∧ u ⊆ image₂ f s' t' :=
begin
  apply finset.induction_on' u,
  { exact ⟨∅, ∅, set.empty_subset _, set.empty_subset _, empty_subset _⟩ },
  rintro a u ha _ _ ⟨s', t', hs, hs', h⟩,
  obtain ⟨x, y, hx, hy, ha⟩ := hu ha,
  haveI := classical.dec_eq α,
  haveI := classical.dec_eq β,
  refine ⟨insert x s', insert y t', _⟩,
  simp_rw [coe_insert, set.insert_subset],
  exact ⟨⟨hx, hs⟩, ⟨hy, hs'⟩, insert_subset.2 ⟨mem_image₂.2 ⟨x, y, mem_insert_self _ _,
    mem_insert_self _ _, ha⟩, h.trans $ image₂_subset (subset_insert _ _) $ subset_insert _ _⟩⟩,
end

lemma bUnion_image_left : s.bUnion (λ a, t.image $ f a) = image₂ f s t :=
coe_injective $ by { push_cast, exact set.Union_image_left _ }

lemma bUnion_image_right : t.bUnion (λ b, s.image $ λ a, f a b) = image₂ f s t :=
coe_injective $ by { push_cast, exact set.Union_image_right _ }

/-!
### Algebraic replacement rules

A collection of lemmas to transfer associativity, commutativity, distributivity, ... of operations
to the associativity, commutativity, distributivity, ... of `finset.image₂` of those operations.

The proof pattern is `image₂_lemma operation_lemma`. For example, `image₂_comm mul_comm` proves that
`image₂ (*) f g = image₂ (*) g f` in a `comm_semigroup`.
-/

lemma image_image₂ (f : α → β → γ) (g : γ → δ) :
  (image₂ f s t).image g = image₂ (λ a b, g (f a b)) s t :=
coe_injective $ by { push_cast, exact image_image2 _ _ }

lemma image₂_image_left (f : γ → β → δ) (g : α → γ) :
  image₂ f (s.image g) t = image₂ (λ a b, f (g a) b) s t :=
coe_injective $ by { push_cast, exact image2_image_left _ _ }

lemma image₂_image_right (f : α → γ → δ) (g : β → γ) :
  image₂ f s (t.image g) = image₂ (λ a b, f a (g b)) s t :=
coe_injective $ by { push_cast, exact image2_image_right _ _ }

lemma image₂_swap (f : α → β → γ) (s : finset α) (t : finset β) :
  image₂ f s t = image₂ (λ a b, f b a) t s :=
coe_injective $ by { push_cast, exact image2_swap _ _ _ }

@[simp] lemma image₂_left [decidable_eq α] (h : t.nonempty) : image₂ (λ x y, x) s t = s :=
coe_injective $ by { push_cast, exact image2_left h }

@[simp] lemma image₂_right [decidable_eq β] (h : s.nonempty) : image₂ (λ x y, y) s t = t :=
coe_injective $ by { push_cast, exact image2_right h }

lemma image₂_assoc {γ : Type*} {u : finset γ} {f : δ → γ → ε} {g : α → β → δ} {f' : α → ε' → ε}
  {g' : β → γ → ε'} (h_assoc : ∀ a b c, f (g a b) c = f' a (g' b c)) :
  image₂ f (image₂ g s t) u = image₂ f' s (image₂ g' t u) :=
coe_injective $ by { push_cast, exact image2_assoc h_assoc }

lemma image₂_left_comm {γ : Type*} {u : finset γ} {f : α → δ → ε} {g : β → γ → δ} {f' : α → γ → δ'}
  {g' : β → δ' → ε} (h_left_comm : ∀ a b c, f a (g b c) = g' b (f' a c)) :
  image₂ f s (image₂ g t u) = image₂ g' t (image₂ f' s u) :=
coe_injective $ by { push_cast, exact image2_left_comm h_left_comm }

lemma image₂_right_comm {γ : Type*} {u : finset γ} {f : δ → γ → ε} {g : α → β → δ} {f' : α → γ → δ'}
  {g' : δ' → β → ε} (h_right_comm : ∀ a b c, f (g a b) c = g' (f' a c) b) :
  image₂ f (image₂ g s t) u = image₂ g' (image₂ f' s u) t :=
coe_injective $ by { push_cast, exact image2_right_comm h_right_comm }

lemma image_image₂_distrib {g : γ → δ} {f' : α' → β' → δ} {g₁ : α → α'} {g₂ : β → β'}
  (h_distrib : ∀ a b, g (f a b) = f' (g₁ a) (g₂ b)) :
  (image₂ f s t).image g = image₂ f' (s.image g₁) (t.image g₂) :=
coe_injective $ by { push_cast, exact image_image2_distrib h_distrib }

/-- Symmetric of `finset.image₂_image_left_comm`. -/
lemma image_image₂_distrib_left {g : γ → δ} {f' : α' → β → δ} {g' : α → α'}
  (h_distrib : ∀ a b, g (f a b) = f' (g' a) b) :
  (image₂ f s t).image g = image₂ f' (s.image g') t :=
coe_injective $ by { push_cast, exact image_image2_distrib_left h_distrib }

/-- Symmetric of `finset.image_image₂_right_comm`. -/
lemma image_image₂_distrib_right {g : γ → δ} {f' : α → β' → δ} {g' : β → β'}
  (h_distrib : ∀ a b, g (f a b) = f' a (g' b)) :
  (image₂ f s t).image g = image₂ f' s (t.image g') :=
coe_injective $ by { push_cast, exact image_image2_distrib_right h_distrib }

/-- Symmetric of `finset.image_image₂_distrib_left`. -/
lemma image₂_image_left_comm {f : α' → β → γ} {g : α → α'} {f' : α → β → δ} {g' : δ → γ}
  (h_left_comm : ∀ a b, f (g a) b = g' (f' a b)) :
  image₂ f (s.image g) t = (image₂ f' s t).image g' :=
(image_image₂_distrib_left $ λ a b, (h_left_comm a b).symm).symm

/-- Symmetric of `finset.image_image₂_distrib_right`. -/
lemma image_image₂_right_comm {f : α → β' → γ} {g : β → β'} {f' : α → β → δ} {g' : δ → γ}
  (h_right_comm : ∀ a b, f a (g b) = g' (f' a b)) :
  image₂ f s (t.image g) = (image₂ f' s t).image g' :=
(image_image₂_distrib_right $ λ a b, (h_right_comm a b).symm).symm

/-- The other direction does not hold because of the `s`-`s` cross terms on the RHS. -/
lemma image₂_distrib_subset_left {γ : Type*} {u : finset γ} {f : α → δ → ε} {g : β → γ → δ}
  {f₁ : α → β → β'} {f₂ : α → γ → γ'} {g' : β' → γ' → ε}
  (h_distrib : ∀ a b c, f a (g b c) = g' (f₁ a b) (f₂ a c)) :
  image₂ f s (image₂ g t u) ⊆ image₂ g' (image₂ f₁ s t) (image₂ f₂ s u) :=
coe_subset.1 $ by { push_cast, exact set.image2_distrib_subset_left h_distrib }

/-- The other direction does not hold because of the `u`-`u` cross terms on the RHS. -/
lemma image₂_distrib_subset_right {γ : Type*} {u : finset γ} {f : δ → γ → ε} {g : α → β → δ}
  {f₁ : α → γ → α'} {f₂ : β → γ → β'} {g' : α' → β' → ε}
  (h_distrib : ∀ a b c, f (g a b) c = g' (f₁ a c) (f₂ b c)) :
  image₂ f (image₂ g s t) u ⊆ image₂ g' (image₂ f₁ s u) (image₂ f₂ t u) :=
coe_subset.1 $ by { push_cast, exact set.image2_distrib_subset_right h_distrib }

lemma image_image₂_antidistrib {g : γ → δ} {f' : β' → α' → δ} {g₁ : β → β'} {g₂ : α → α'}
  (h_antidistrib : ∀ a b, g (f a b) = f' (g₁ b) (g₂ a)) :
  (image₂ f s t).image g = image₂ f' (t.image g₁) (s.image g₂) :=
by { rw image₂_swap f, exact image_image₂_distrib (λ _ _, h_antidistrib _ _) }

/-- Symmetric of `finset.image₂_image_left_anticomm`. -/
lemma image_image₂_antidistrib_left {g : γ → δ} {f' : β' → α → δ} {g' : β → β'}
  (h_antidistrib : ∀ a b, g (f a b) = f' (g' b) a) :
  (image₂ f s t).image g = image₂ f' (t.image g') s :=
coe_injective $ by { push_cast, exact image_image2_antidistrib_left h_antidistrib }

/-- Symmetric of `finset.image_image₂_right_anticomm`. -/
lemma image_image₂_antidistrib_right {g : γ → δ} {f' : β → α' → δ} {g' : α → α'}
  (h_antidistrib : ∀ a b, g (f a b) = f' b (g' a)) :
  (image₂ f s t).image g = image₂ f' t (s.image g') :=
coe_injective $ by { push_cast, exact image_image2_antidistrib_right h_antidistrib }

/-- Symmetric of `finset.image_image₂_antidistrib_left`. -/
lemma image₂_image_left_anticomm {f : α' → β → γ} {g : α → α'} {f' : β → α → δ} {g' : δ → γ}
  (h_left_anticomm : ∀ a b, f (g a) b = g' (f' b a)) :
  image₂ f (s.image g) t = (image₂ f' t s).image g' :=
(image_image₂_antidistrib_left $ λ a b, (h_left_anticomm b a).symm).symm

/-- Symmetric of `finset.image_image₂_antidistrib_right`. -/
lemma image_image₂_right_anticomm {f : α → β' → γ} {g : β → β'} {f' : β → α → δ} {g' : δ → γ}
  (h_right_anticomm : ∀ a b, f a (g b) = g' (f' b a)) :
  image₂ f s (t.image g) = (image₂ f' t s).image g' :=
(image_image₂_antidistrib_right $ λ a b, (h_right_anticomm b a).symm).symm

end finset


/-
Copyright (c) 2018 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro, Kenny Lau
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.finset.basic
import Mathlib.PostPort

universes u u_1

namespace Mathlib

/-!
# Finsets of ordered types
-/

theorem directed.finset_le {α : Type u} {r : α → α → Prop} [is_trans α r] {ι : Type u_1} [hι : Nonempty ι] {f : ι → α} (D : directed r f) (s : finset ι) : ∃ (z : ι), ∀ (i : ι), i ∈ s → r (f i) (f z) := sorry

theorem finset.exists_le {α : Type u} [Nonempty α] [directed_order α] (s : finset α) : ∃ (M : α), ∀ (i : α), i ∈ s → i ≤ M :=
  directed.finset_le directed_order.directed s


/-
Copyright (c) 2018 Kenny Lau. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenny Lau
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.opposite
import Mathlib.algebra.field
import Mathlib.group_theory.group_action.defs
import Mathlib.data.equiv.mul_add
import Mathlib.PostPort

universes u u_1 u_2

namespace Mathlib

/-!
# Algebraic operations on `αᵒᵖ`
-/

namespace opposite

protected instance has_add (α : Type u) [Add α] : Add (αᵒᵖ) :=
  { add := fun (x y : αᵒᵖ) => op (unop x + unop y) }

protected instance has_sub (α : Type u) [Sub α] : Sub (αᵒᵖ) :=
  { sub := fun (x y : αᵒᵖ) => op (unop x - unop y) }

protected instance add_semigroup (α : Type u) [add_semigroup α] : add_semigroup (αᵒᵖ) :=
  add_semigroup.mk Add.add sorry

protected instance add_left_cancel_semigroup (α : Type u) [add_left_cancel_semigroup α] : add_left_cancel_semigroup (αᵒᵖ) :=
  add_left_cancel_semigroup.mk add_semigroup.add sorry sorry

protected instance add_right_cancel_semigroup (α : Type u) [add_right_cancel_semigroup α] : add_right_cancel_semigroup (αᵒᵖ) :=
  add_right_cancel_semigroup.mk add_semigroup.add sorry sorry

protected instance add_comm_semigroup (α : Type u) [add_comm_semigroup α] : add_comm_semigroup (αᵒᵖ) :=
  add_comm_semigroup.mk add_semigroup.add sorry sorry

protected instance has_zero (α : Type u) [HasZero α] : HasZero (αᵒᵖ) :=
  { zero := op 0 }

protected instance nontrivial (α : Type u) [nontrivial α] : nontrivial (αᵒᵖ) :=
  sorry

@[simp] theorem unop_eq_zero_iff (α : Type u) [HasZero α] (a : αᵒᵖ) : unop a = 0 ↔ a = 0 :=
  iff.refl (unop a = 0)

@[simp] theorem op_eq_zero_iff (α : Type u) [HasZero α] (a : α) : op a = 0 ↔ a = 0 :=
  iff.refl (op a = 0)

protected instance add_monoid (α : Type u) [add_monoid α] : add_monoid (αᵒᵖ) :=
  add_monoid.mk add_semigroup.add sorry 0 sorry sorry

protected instance add_comm_monoid (α : Type u) [add_comm_monoid α] : add_comm_monoid (αᵒᵖ) :=
  add_comm_monoid.mk add_monoid.add sorry add_monoid.zero sorry sorry sorry

protected instance has_neg (α : Type u) [Neg α] : Neg (αᵒᵖ) :=
  { neg := fun (x : αᵒᵖ) => op (-unop x) }

protected instance add_group (α : Type u) [add_group α] : add_group (αᵒᵖ) :=
  add_group.mk add_monoid.add sorry add_monoid.zero sorry sorry Neg.neg Sub.sub sorry

protected instance add_comm_group (α : Type u) [add_comm_group α] : add_comm_group (αᵒᵖ) :=
  add_comm_group.mk add_group.add sorry add_group.zero sorry sorry add_group.neg add_group.sub sorry sorry

protected instance has_mul (α : Type u) [Mul α] : Mul (αᵒᵖ) :=
  { mul := fun (x y : αᵒᵖ) => op (unop y * unop x) }

protected instance semigroup (α : Type u) [semigroup α] : semigroup (αᵒᵖ) :=
  semigroup.mk Mul.mul sorry

protected instance left_cancel_semigroup (α : Type u) [right_cancel_semigroup α] : left_cancel_semigroup (αᵒᵖ) :=
  left_cancel_semigroup.mk semigroup.mul sorry sorry

protected instance right_cancel_semigroup (α : Type u) [left_cancel_semigroup α] : right_cancel_semigroup (αᵒᵖ) :=
  right_cancel_semigroup.mk semigroup.mul sorry sorry

protected instance comm_semigroup (α : Type u) [comm_semigroup α] : comm_semigroup (αᵒᵖ) :=
  comm_semigroup.mk semigroup.mul sorry sorry

protected instance has_one (α : Type u) [HasOne α] : HasOne (αᵒᵖ) :=
  { one := op 1 }

@[simp] theorem unop_eq_one_iff (α : Type u) [HasOne α] (a : αᵒᵖ) : unop a = 1 ↔ a = 1 :=
  iff.refl (unop a = 1)

@[simp] theorem op_eq_one_iff (α : Type u) [HasOne α] (a : α) : op a = 1 ↔ a = 1 :=
  iff.refl (op a = 1)

protected instance monoid (α : Type u) [monoid α] : monoid (αᵒᵖ) :=
  monoid.mk semigroup.mul sorry 1 sorry sorry

protected instance comm_monoid (α : Type u) [comm_monoid α] : comm_monoid (αᵒᵖ) :=
  comm_monoid.mk monoid.mul sorry monoid.one sorry sorry sorry

protected instance has_inv (α : Type u) [has_inv α] : has_inv (αᵒᵖ) :=
  has_inv.mk fun (x : αᵒᵖ) => op (unop x⁻¹)

protected instance group (α : Type u) [group α] : group (αᵒᵖ) :=
  group.mk monoid.mul sorry monoid.one sorry sorry has_inv.inv
    (div_inv_monoid.div._default monoid.mul sorry monoid.one sorry sorry has_inv.inv) sorry

protected instance comm_group (α : Type u) [comm_group α] : comm_group (αᵒᵖ) :=
  comm_group.mk group.mul sorry group.one sorry sorry group.inv group.div sorry sorry

protected instance distrib (α : Type u) [distrib α] : distrib (αᵒᵖ) :=
  distrib.mk Mul.mul Add.add sorry sorry

protected instance semiring (α : Type u) [semiring α] : semiring (αᵒᵖ) :=
  semiring.mk add_comm_monoid.add sorry add_comm_monoid.zero sorry sorry sorry monoid.mul sorry monoid.one sorry sorry
    sorry sorry sorry sorry

protected instance ring (α : Type u) [ring α] : ring (αᵒᵖ) :=
  ring.mk add_comm_group.add sorry add_comm_group.zero sorry sorry add_comm_group.neg add_comm_group.sub sorry sorry
    monoid.mul sorry monoid.one sorry sorry sorry sorry

protected instance comm_ring (α : Type u) [comm_ring α] : comm_ring (αᵒᵖ) :=
  comm_ring.mk ring.add sorry ring.zero sorry sorry ring.neg ring.sub sorry sorry ring.mul sorry ring.one sorry sorry
    sorry sorry sorry

protected instance no_zero_divisors (α : Type u) [HasZero α] [Mul α] [no_zero_divisors α] : no_zero_divisors (αᵒᵖ) :=
  no_zero_divisors.mk
    fun (x y : αᵒᵖ) (H : op (unop y * unop x) = op 0) =>
      or.cases_on (eq_zero_or_eq_zero_of_mul_eq_zero (op_injective H))
        (fun (hy : unop y = 0) => Or.inr (unop_injective hy)) fun (hx : unop x = 0) => Or.inl (unop_injective hx)

protected instance integral_domain (α : Type u) [integral_domain α] : integral_domain (αᵒᵖ) :=
  integral_domain.mk comm_ring.add sorry comm_ring.zero sorry sorry comm_ring.neg comm_ring.sub sorry sorry comm_ring.mul
    sorry comm_ring.one sorry sorry sorry sorry sorry sorry sorry

protected instance field (α : Type u) [field α] : field (αᵒᵖ) :=
  field.mk comm_ring.add sorry comm_ring.zero sorry sorry comm_ring.neg comm_ring.sub sorry sorry comm_ring.mul sorry
    comm_ring.one sorry sorry sorry sorry sorry has_inv.inv sorry sorry sorry

protected instance has_scalar (α : Type u) (R : Type u_1) [has_scalar R α] : has_scalar R (αᵒᵖ) :=
  has_scalar.mk fun (c : R) (x : αᵒᵖ) => op (c • unop x)

protected instance mul_action (α : Type u) (R : Type u_1) [monoid R] [mul_action R α] : mul_action R (αᵒᵖ) :=
  mul_action.mk sorry sorry

protected instance distrib_mul_action (α : Type u) (R : Type u_1) [monoid R] [add_monoid α] [distrib_mul_action R α] : distrib_mul_action R (αᵒᵖ) :=
  distrib_mul_action.mk sorry sorry

@[simp] theorem op_zero (α : Type u) [HasZero α] : op 0 = 0 :=
  rfl

@[simp] theorem unop_zero (α : Type u) [HasZero α] : unop 0 = 0 :=
  rfl

@[simp] theorem op_one (α : Type u) [HasOne α] : op 1 = 1 :=
  rfl

@[simp] theorem unop_one (α : Type u) [HasOne α] : unop 1 = 1 :=
  rfl

@[simp] theorem op_add {α : Type u} [Add α] (x : α) (y : α) : op (x + y) = op x + op y :=
  rfl

@[simp] theorem unop_add {α : Type u} [Add α] (x : αᵒᵖ) (y : αᵒᵖ) : unop (x + y) = unop x + unop y :=
  rfl

@[simp] theorem op_neg {α : Type u} [Neg α] (x : α) : op (-x) = -op x :=
  rfl

@[simp] theorem unop_neg {α : Type u} [Neg α] (x : αᵒᵖ) : unop (-x) = -unop x :=
  rfl

@[simp] theorem op_mul {α : Type u} [Mul α] (x : α) (y : α) : op (x * y) = op y * op x :=
  rfl

@[simp] theorem unop_mul {α : Type u} [Mul α] (x : αᵒᵖ) (y : αᵒᵖ) : unop (x * y) = unop y * unop x :=
  rfl

@[simp] theorem op_inv {α : Type u} [has_inv α] (x : α) : op (x⁻¹) = (op x⁻¹) :=
  rfl

@[simp] theorem unop_inv {α : Type u} [has_inv α] (x : αᵒᵖ) : unop (x⁻¹) = (unop x⁻¹) :=
  rfl

@[simp] theorem op_sub {α : Type u} [add_group α] (x : α) (y : α) : op (x - y) = op x - op y :=
  rfl

@[simp] theorem unop_sub {α : Type u} [add_group α] (x : αᵒᵖ) (y : αᵒᵖ) : unop (x - y) = unop x - unop y :=
  rfl

@[simp] theorem op_smul {α : Type u} {R : Type u_1} [has_scalar R α] (c : R) (a : α) : op (c • a) = c • op a :=
  rfl

@[simp] theorem unop_smul {α : Type u} {R : Type u_1} [has_scalar R α] (c : R) (a : αᵒᵖ) : unop (c • a) = c • unop a :=
  rfl

/-- The function `op` is an additive equivalence. -/
def op_add_equiv {α : Type u} [Add α] : α ≃+ (αᵒᵖ) :=
  add_equiv.mk (equiv.to_fun equiv_to_opposite) (equiv.inv_fun equiv_to_opposite) sorry sorry sorry

@[simp] theorem coe_op_add_equiv {α : Type u} [Add α] : ⇑op_add_equiv = op :=
  rfl

@[simp] theorem coe_op_add_equiv_symm {α : Type u} [Add α] : ⇑(add_equiv.symm op_add_equiv) = unop :=
  rfl

@[simp] theorem op_add_equiv_to_equiv {α : Type u} [Add α] : add_equiv.to_equiv op_add_equiv = equiv_to_opposite :=
  rfl

end opposite

/-- A ring homomorphism `f : R →+* S` such that `f x` commutes with `f y` for all `x, y` defines
a ring homomorphism to `Sᵒᵖ`. -/
def ring_hom.to_opposite {R : Type u_1} {S : Type u_2} [semiring R] [semiring S] (f : R →+* S) (hf : ∀ (x y : R), commute (coe_fn f x) (coe_fn f y)) : R →+* (Sᵒᵖ) :=
  ring_hom.mk (add_monoid_hom.to_fun (add_monoid_hom.comp (add_equiv.to_add_monoid_hom opposite.op_add_equiv) ↑f)) sorry
    sorry sorry sorry

@[simp] theorem ring_hom.coe_to_opposite {R : Type u_1} {S : Type u_2} [semiring R] [semiring S] (f : R →+* S) (hf : ∀ (x y : R), commute (coe_fn f x) (coe_fn f y)) : ⇑(ring_hom.to_opposite f hf) = opposite.op ∘ ⇑f :=
  rfl


import algebra.group.basic
import data.fintype.basic
import computability.language
import group_theory.submonoid.operations
import group_theory.finiteness
import data.list.basic
import computability.epsilon_NFA

open list
open prod

universes u v w u'

structure bRMA (M: Type u) (α : Type w) (σ : Type v) (ι : Type u') [monoid M] :=
(step : σ → option α → set (σ × ι))
(start : σ)
(accept : set σ)
(to_monoid : ι → M)

variables {M : Type u} {α : Type v} {σ : Type w} {ι : Type u'} [monoid M] [inhabited σ]
variables (A : bRMA M α σ ι)

namespace bRMA

instance : inhabited (bRMA M α σ ι) := ⟨bRMA.mk (λ _ _, ∅) default ∅ (λ x, 1)⟩

def cstep  : (σ × (list (option α)) × M) → (σ × (list (option α)) × M) → Prop
| (s,w,m) (s',w',m') := ∃ i : ι, (s', i) ∈ A.step s (head w) ∧ A.to_monoid i * m = m' ∧ w' = (tail w)

def der : (σ × (list (option α)) × M) → (σ × (list (option α)) × M) → Prop  := relation.refl_trans_gen A.cstep

def accepts : language α :=
set.image reduce_option
  {w : list (option α) | ∃ S ∈ A.accept, A.der (A.start, w, 1) (S, [], 1) }

def to_submonoid_bRMA :
bRMA (submonoid.closure {m : M | ∃ i, A.to_monoid i = m }) α σ ι  := {
  step := A.step,
  start := A.start,
  accept := A.accept,
  to_monoid := (λ i, ⟨(A.to_monoid i), by {
  rw submonoid.mem_closure,
  intros S,
  exact set.mem_of_mem_of_subset (by {dsimp, use i}),}⟩)
}

lemma exists_chain_of_submonoid {A : bRMA M α σ ι} (a b : σ × list (option α) × M) (h : A.der a b) :
a.2.2 ∈ (submonoid.closure {m : M | ∃ i, A.to_monoid i = m }) →
∃ (l : list (σ × list (option α) × (submonoid.closure {m : M | ∃ i, A.to_monoid i = m }))),
chain A.cstep a (map (map id (map id coe)) l) ∧ last (a :: (map (map id (map id coe)) l)) (cons_ne_nil _ _) = b  :=
begin
  apply relation.refl_trans_gen.head_induction_on h,
  intro ha, { use ([]), split, exact chain.nil, refl },
  { rintros ⟨s,w,m⟩ ⟨s',w',m'⟩ ⟨i,_,hi,_⟩ _ ih hswm,
    dsimp at *,
    have h_mem_submonoid : m' ∈ (submonoid.closure {m : M | ∃ i, A.to_monoid i = m }), by {
      have h_to_monoid_mem_submonoid : A.to_monoid i ∈ (submonoid.closure {m : M | ∃ i, A.to_monoid i = m }) ,by {
        rw submonoid.mem_closure,
        intros S,
        exact set.mem_of_mem_of_subset (by {dsimp, use i}) },
      rw [← hi, submonoid.mem_closure],
      intros S hS,
      apply submonoid.mul_mem, {
        rw submonoid.mem_closure at h_to_monoid_mem_submonoid,
        specialize h_to_monoid_mem_submonoid S hS,
        exact h_to_monoid_mem_submonoid },
      { rw submonoid.mem_closure at hswm,
        specialize hswm S hS,
        exact hswm } },
    specialize ih h_mem_submonoid,
    cases ih with l,
    use ((s',w', ⟨m', h_mem_submonoid⟩) :: l),
    dsimp,
    rw [chain_cons, and_assoc],
    exact ⟨⟨i, h'_h_left, hi, h'_h_right_right⟩, ⟨ih_h.1, ih_h.2⟩⟩ }
end

theorem to_submonoid_bRMA_correct : A.to_submonoid_bRMA.accepts = A.accepts :=
begin
  ext,
  split,
  intro hx,{
    rw accepts at *,
    simp only [exists_prop, set.mem_image, set.mem_set_of_eq] at *,
    rcases hx with ⟨x₁,hl, hr⟩,
    rcases hl with ⟨S, hls, hrs⟩,
    use [x₁,S],
    split,{
      rw to_submonoid_bRMA at hls,
      rw to_submonoid_bRMA at hrs,
      dsimp at *,
      exact hls },
      { have h₁ :  ∀ a b, (A.to_submonoid_bRMA.der) a b →  A.der (map id (map id coe) a) (map id (map id coe) b), by {
        intros a b h,
        have h₁: ∀ a b, A.to_submonoid_bRMA.cstep a b →
        A.cstep (map id (map id coe) a) (map id (map id coe) b), by {
              rintros ⟨s,w,m⟩ ⟨s',w',m'⟩ h',{
              rw [to_submonoid_bRMA, cstep] at *,
              dsimp at *,
              rcases h' with ⟨i, h₁, h₂, h₃⟩,
              exact ⟨i,h₁, (congr_arg coe h₂).congr_right.mp rfl, h₃⟩ } },
        exact relation.refl_trans_gen.lift (map id (map id coe)) h₁ h },
      exact h₁ (A.start, x₁, 1) (S, [], 1) hrs },
    exact hr },
    { intro hx,
      rw accepts at *,
      simp only [exists_prop, set.mem_image, set.mem_set_of_eq] at *,
      rcases hx with ⟨x₁,hl, hr⟩,
      rcases hl with ⟨S, hls, hrs⟩,
      use [x₁,S],
      split,{
        rw to_submonoid_bRMA,
        dsimp,
        exact hls },
      { have h₁ := exists_chain_of_submonoid (A.start, x₁, 1) (S,  [], 1) hrs
                   (by {dsimp; rw submonoid.mem_closure; intros S hS; exact submonoid.one_mem S}),
        rcases h₁ with ⟨l,hl,hr⟩,
        refine relation_refl_trans_gen_of_exists_chain l _ _,
        { rw to_submonoid_bRMA; dsimp;
          let f   : σ × list (option α) × (submonoid.closure {m : M | ∃ i, A.to_monoid i = m }) →
                    σ × list (option α) × M := map id (map id coe),
          have h₂ : chain A.cstep ((map id (map id coe))
            (A.start, x₁, (1 : (submonoid.closure {m : M | ∃ i, A.to_monoid i = m }))))
              (map (map id (map id coe)) l), by {rw chain_map,exact (chain_map _).mp hl},
          have h₃ : ∀ (a b : σ × list (option α) × (submonoid.closure {m : M | ∃ i, A.to_monoid i = m })),
            A.cstep (f a) (f b) → A.to_submonoid_bRMA.cstep a b , by {
              rintros ⟨s,w,m⟩ ⟨s',w',m'⟩ hab,
              rw [to_submonoid_bRMA, cstep],
              have hf_eq : f  = map id (map id coe) := rfl,
              rw hf_eq at *,
              dsimp at *,
              rw cstep at hab,
              rcases hab with ⟨i,h₁,h₂,h₃⟩,
              exact ⟨i, h₁,subtype.eq h₂, h₃⟩ },
          exact chain_of_chain_map f h₃ hl },
          { rw to_submonoid_bRMA; dsimp;
            cases l,
            { dsimp at *,
              repeat {injections_and_clear,apply prod.ext,itauto},
              refl },
            { have h  : (l_hd :: l_tl) ≠ nil := cons_ne_nil _ _,
              have h₁ : map (map id (map id coe)) (l_hd :: l_tl) ≠ nil, by {rw [ne.def, map_eq_nil], apply cons_ne_nil},
              have h₂ : (A.start, x₁, 1) :: (l_hd :: l_tl) ≠ nil := cons_ne_nil _ _,
              rw [last_cons h₁, last_map (map id (map id coe))] at hr,
              rw last_cons h,
              repeat {injections_and_clear,apply prod.ext,itauto},
              exact subtype.eq h_4 } } },
      exact hr },
end

theorem to_submonoid_bRMA_closure_fg [fintype ι] : (submonoid.closure {m : M | ∃ i, A.to_monoid i = m }).fg :=
begin
  rw submonoid.fg_iff,
  use {m : M | ∃ i, A.to_monoid i = m },
  split,
  refl,
  exact set.finite_range (λ (y : ι), A.to_monoid y),
end

end bRMA


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

/-
A tactic which constructs exprs to discharge
goals of the form `clauses.unsat cs`.
-/

import tactic.omega.find_ees
import tactic.omega.find_scalars
import tactic.omega.lin_comb

namespace omega

open tactic

/-- Return expr of proof that given int is negative -/
meta def prove_neg : int → tactic expr
| (int.of_nat _) := failed
| -[1+ m] := return `(int.neg_succ_lt_zero %%`(m))

lemma forall_mem_repeat_zero_eq_zero (m : nat) :
  (∀ x ∈ (list.repeat (0 : int) m), x = (0 : int)) :=
λ x, list.eq_of_mem_repeat

/-- Return expr of proof that elements of (repeat 0 is.length) are all 0 -/
meta def prove_forall_mem_eq_zero (is : list int) : tactic expr :=
return `(forall_mem_repeat_zero_eq_zero is.length)

/-- Return expr of proof that the combination of linear constraints
    represented by ks and ts is unsatisfiable -/
meta def prove_unsat_lin_comb (ks : list nat) (ts : list term) : tactic expr :=
let ⟨b,as⟩ := lin_comb ks ts in
do x1 ← prove_neg b,
   x2 ← prove_forall_mem_eq_zero as,
   to_expr ``(unsat_lin_comb_of %%`(ks) %%`(ts) %%x1 %%x2)

/-- Given a (([],les) : clause), return the expr of a term (t : clause.unsat ([],les)). -/
meta def prove_unsat_ef : clause → tactic expr
| ((_::_), _) := failed
| ([], les) :=
  do ks ← find_scalars les,
     x ← prove_unsat_lin_comb ks les,
     return `(unsat_of_unsat_lin_comb %%`(ks) %%`(les) %%x)

/-- Given a (c : clause), return the expr of a term (t : clause.unsat c)  -/
meta def prove_unsat (c : clause) : tactic expr :=
do ee ← find_ees c,
   x ← prove_unsat_ef (eq_elim ee c),
   return `(unsat_of_unsat_eq_elim %%`(ee) %%`(c) %%x)

/-- Given a (cs : list clause), return the expr of a term (t : clauses.unsat cs)  -/
meta def prove_unsats : list clause → tactic expr
| [] := return `(clauses.unsat_nil)
| (p::ps) :=
  do x ← prove_unsat p,
     xs ← prove_unsats ps,
     to_expr ``(clauses.unsat_cons %%`(p) %%`(ps) %%x %%xs)

end omega


/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl
-/
import logic.function.basic
import tactic.ext
import tactic.simps

/-!
# Subtypes

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

This file provides basic API for subtypes, which are defined in core.

A subtype is a type made from restricting another type, say `α`, to its elements that satisfy some
predicate, say `p : α → Prop`. Specifically, it is the type of pairs `⟨val, property⟩` where
`val : α` and `property : p val`. It is denoted `subtype p` and notation `{val : α // p val}` is
available.

A subtype has a natural coercion to the parent type, by coercing `⟨val, property⟩` to `val`. As
such, subtypes can be thought of as bundled sets, the difference being that elements of a set are
still of type `α` while elements of a subtype aren't.
-/

open function

namespace subtype
variables {α β γ : Sort*} {p q : α → Prop}

/-- See Note [custom simps projection] -/
def simps.coe (x : subtype p) : α := x

initialize_simps_projections subtype (val → coe)

/-- A version of `x.property` or `x.2` where `p` is syntactically applied to the coercion of `x`
  instead of `x.1`. A similar result is `subtype.mem` in `data.set.basic`. -/
lemma prop (x : subtype p) : p x := x.2

@[simp] lemma val_eq_coe {x : subtype p} : x.1 = ↑x := rfl

@[simp] protected theorem «forall» {q : {a // p a} → Prop} :
  (∀ x, q x) ↔ (∀ a b, q ⟨a, b⟩) :=
⟨assume h a b, h ⟨a, b⟩, assume h ⟨a, b⟩, h a b⟩

/-- An alternative version of `subtype.forall`. This one is useful if Lean cannot figure out `q`
  when using `subtype.forall` from right to left. -/
protected theorem forall' {q : ∀ x, p x → Prop} :
  (∀ x h, q x h) ↔ (∀ x : {a // p a}, q x x.2) :=
(@subtype.forall _ _ (λ x, q x.1 x.2)).symm

@[simp] protected theorem «exists» {q : {a // p a} → Prop} :
  (∃ x, q x) ↔ (∃ a b, q ⟨a, b⟩) :=
⟨assume ⟨⟨a, b⟩, h⟩, ⟨a, b, h⟩, assume ⟨a, b, h⟩, ⟨⟨a, b⟩, h⟩⟩

/-- An alternative version of `subtype.exists`. This one is useful if Lean cannot figure out `q`
  when using `subtype.exists` from right to left. -/
protected theorem exists' {q : ∀x, p x → Prop} :
  (∃ x h, q x h) ↔ (∃ x : {a // p a}, q x x.2) :=
(@subtype.exists _ _ (λ x, q x.1 x.2)).symm

@[ext] protected lemma ext : ∀ {a1 a2 : {x // p x}}, (a1 : α) = (a2 : α) → a1 = a2
| ⟨x, h1⟩ ⟨.(x), h2⟩ rfl := rfl

lemma ext_iff {a1 a2 : {x // p x}} : a1 = a2 ↔ (a1 : α) = (a2 : α) :=
⟨congr_arg _, subtype.ext⟩

lemma heq_iff_coe_eq (h : ∀ x, p x ↔ q x) {a1 : {x // p x}} {a2 : {x // q x}} :
  a1 == a2 ↔ (a1 : α) = (a2 : α) :=
eq.rec (λ a2', heq_iff_eq.trans ext_iff) (funext $ λ x, propext (h x)) a2

lemma heq_iff_coe_heq {α β : Sort*} {p : α → Prop} {q : β → Prop} {a : {x // p x}}
  {b : {y // q y}} (h : α = β) (h' : p == q) :
  a == b ↔ (a : α) == (b : β) :=
by { subst h, subst h', rw [heq_iff_eq, heq_iff_eq, ext_iff] }

lemma ext_val {a1 a2 : {x // p x}} : a1.1 = a2.1 → a1 = a2 :=
subtype.ext

lemma ext_iff_val {a1 a2 : {x // p x}} : a1 = a2 ↔ a1.1 = a2.1 :=
ext_iff

@[simp] theorem coe_eta (a : {a // p a}) (h : p a) : mk ↑a h = a := subtype.ext rfl

@[simp] theorem coe_mk (a h) : (@mk α p a h : α) = a := rfl

@[simp, nolint simp_nf] -- built-in reduction doesn't always work
theorem mk_eq_mk {a h a' h'} : @mk α p a h = @mk α p a' h' ↔ a = a' :=
ext_iff

lemma coe_eq_of_eq_mk {a : {a // p a}} {b : α} (h : ↑a = b) :
  a = ⟨b, h ▸ a.2⟩ := subtype.ext h

theorem coe_eq_iff {a : {a // p a}} {b : α} : ↑a = b ↔ ∃ h, a = ⟨b, h⟩ :=
⟨λ h, h ▸ ⟨a.2, (coe_eta _ _).symm⟩, λ ⟨hb, ha⟩, ha.symm ▸ rfl⟩

lemma coe_injective : injective (coe : subtype p → α) := λ a b, subtype.ext
lemma val_injective : injective (@val _ p) := coe_injective
lemma coe_inj {a b : subtype p} : (a : α) = b ↔ a = b := coe_injective.eq_iff
lemma val_inj {a b : subtype p} : a.val = b.val ↔ a = b := coe_inj

@[simp] lemma _root_.exists_eq_subtype_mk_iff {a : subtype p} {b : α} :
  (∃ h : p b, a = subtype.mk b h) ↔ ↑a = b :=
coe_eq_iff.symm

@[simp] lemma _root_.exists_subtype_mk_eq_iff {a : subtype p} {b : α} :
  (∃ h : p b, subtype.mk b h = a) ↔ b = a :=
by simp only [@eq_comm _ b, exists_eq_subtype_mk_iff, @eq_comm _ _ a]

/-- Restrict a (dependent) function to a subtype -/
def restrict {α} {β : α → Type*} (p : α → Prop) (f : Π x, β x) (x : subtype p) : β x.1 :=
f x

lemma restrict_apply {α} {β : α → Type*} (f : Π x, β x) (p : α → Prop) (x : subtype p) :
  restrict p f x = f x.1 :=
by refl

lemma restrict_def {α β} (f : α → β) (p : α → Prop) : restrict p f = f ∘ coe :=
by refl

lemma restrict_injective {α β} {f : α → β} (p : α → Prop) (h : injective f) :
  injective (restrict p f) :=
h.comp coe_injective

lemma surjective_restrict {α} {β : α → Type*} [ne : Π a, nonempty (β a)] (p : α → Prop) :
  surjective (λ f : Π x, β x, restrict p f) :=
begin
  letI := classical.dec_pred p,
  refine λ f, ⟨λ x, if h : p x then f ⟨x, h⟩ else nonempty.some (ne x), funext $ _⟩,
  rintro ⟨x, hx⟩,
  exact dif_pos hx
end

/-- Defining a map into a subtype, this can be seen as an "coinduction principle" of `subtype`-/
@[simps] def coind {α β} (f : α → β) {p : β → Prop} (h : ∀ a, p (f a)) : α → subtype p :=
λ a, ⟨f a, h a⟩

theorem coind_injective {α β} {f : α → β} {p : β → Prop} (h : ∀ a, p (f a))
  (hf : injective f) : injective (coind f h) :=
λ x y hxy, hf $ by apply congr_arg subtype.val hxy

theorem coind_surjective {α β} {f : α → β} {p : β → Prop} (h : ∀ a, p (f a))
  (hf : surjective f) : surjective (coind f h) :=
λ x, let ⟨a, ha⟩ := hf x in ⟨a, coe_injective ha⟩

theorem coind_bijective {α β} {f : α → β} {p : β → Prop} (h : ∀ a, p (f a))
  (hf : bijective f) : bijective (coind f h) :=
⟨coind_injective h hf.1, coind_surjective h hf.2⟩

/-- Restriction of a function to a function on subtypes. -/
@[simps] def map {p : α → Prop} {q : β → Prop} (f : α → β) (h : ∀ a, p a → q (f a)) :
  subtype p → subtype q :=
λ x, ⟨f x, h x x.prop⟩

theorem map_comp {p : α → Prop} {q : β → Prop} {r : γ → Prop} {x : subtype p}
  (f : α → β) (h : ∀ a, p a → q (f a)) (g : β → γ) (l : ∀ a, q a → r (g a)) :
  map g l (map f h x) = map (g ∘ f) (assume a ha, l (f a) $ h a ha) x :=
rfl

theorem map_id {p : α → Prop} {h : ∀ a, p a → p (id a)} : map (@id α) h = id :=
funext $ assume ⟨v, h⟩, rfl

lemma map_injective {p : α → Prop} {q : β → Prop} {f : α → β} (h : ∀ a, p a → q (f a))
  (hf : injective f) : injective (map f h) :=
coind_injective _ $ hf.comp coe_injective

lemma map_involutive {p : α → Prop} {f : α → α} (h : ∀ a, p a → p (f a))
  (hf : involutive f) : involutive (map f h) :=
λ x, subtype.ext (hf x)

instance [has_equiv α] (p : α → Prop) : has_equiv (subtype p) :=
⟨λ s t, (s : α) ≈ (t : α)⟩

theorem equiv_iff [has_equiv α] {p : α → Prop} {s t : subtype p} :
  s ≈ t ↔ (s : α) ≈ (t : α) :=
iff.rfl

variables [setoid α]

protected theorem refl (s : subtype p) : s ≈ s :=
setoid.refl ↑s

protected theorem symm {s t : subtype p} (h : s ≈ t) : t ≈ s :=
setoid.symm h

protected theorem trans {s t u : subtype p} (h₁ : s ≈ t) (h₂ : t ≈ u) : s ≈ u :=
setoid.trans h₁ h₂

theorem equivalence (p : α → Prop) : equivalence (@has_equiv.equiv (subtype p) _) :=
mk_equivalence _ subtype.refl (@subtype.symm _ p _) (@subtype.trans _ p _)

instance (p : α → Prop) : setoid (subtype p) :=
setoid.mk (≈) (equivalence p)

end subtype

namespace subtype
/-! Some facts about sets, which require that `α` is a type. -/
variables {α β γ : Type*} {p : α → Prop}

@[simp] lemma coe_prop {S : set α} (a : {a // a ∈ S}) : ↑a ∈ S := a.prop

lemma val_prop {S : set α} (a : {a // a ∈ S}) : a.val ∈ S := a.property

end subtype


-- TABLEAU-EXAMPLES

import syntax
import tableau

lemma noBot : provable (~ ⊥) :=
begin
  apply provable.byTableau,
  apply closedTableau.loc,
  swap 2,
  {
    apply localTableau.byLocalRule (localRule.neg (finset.mem_singleton.mpr (refl (~~⊥)))),
    intros β inB,
    rw finset.sdiff_self at inB,
    rw finset.empty_union at inB,
    rw finset.mem_singleton at inB,
    rw inB,
    apply (localTableau.byLocalRule (localRule.bot (finset.mem_singleton.mpr (refl ⊥)))),
    intros Y YinEmpty,
    cases YinEmpty,
  },
  { -- show that endNodesOf is empty
    intros Y,
    intro YisEndNode,
    unfold endNodesOf at *,
    simp at *,
    exfalso,
    rcases YisEndNode with ⟨a,h,hyp⟩,
    subst h,
    simp at *,
    cases hyp,
  },
end

def emptyTableau : Π (β : finset formula), β ∈ ∅ → localTableau β :=
begin
  intros beta b_in_empty,
  exact absurd b_in_empty (finset.not_mem_empty beta),
end

-- an example:
lemma noContradiction : provable (~ (p ⋏ ~p)) :=
begin
  apply provable.byTableau,
  apply closedTableau.loc,
  swap 2,
  {
    apply localTableau.byLocalRule,
    -- neg:
    apply localRule.neg,
    simp,
    intros β β_prop,
    simp at β_prop,
    subst β_prop,
    -- con:
    apply localTableau.byLocalRule,
    apply localRule.con,
    simp,
    split,
    refl,
    refl,
    intros β2 β2_prop,
    simp at β2_prop,
    subst β2_prop,
    -- closed:
    apply localTableau.byLocalRule (@localRule.not _ p _) emptyTableau,
    exact dec_trivial,
  },
  { -- show that endNodesOf is empty
    intros Y,
    intro YisEndNode,
    simp at *,
    exfalso,
    rcases YisEndNode with ⟨a,h,hyp⟩,
    subst h,
    simp at *,
    rcases hyp with ⟨Y,Ydef,YinEndNodes⟩,
    subst Ydef,
    finish,
  },
end

-- preparing example 2
def subTabForEx2 : closedTableau {r, ~□p, □(p ⋏ q)} :=
begin
  apply @closedTableau.atm {r, ~□p, □(p ⋏ q)} p (by {simp,}),
  -- show that this set is simple:
  { unfold simple, simp at *, tauto, },
  apply closedTableau.loc,
  rotate,
  -- con:
  apply localTableau.byLocalRule (@localRule.con {p⋏q, ~p} p q (by {simp, })),
  intros child childDef,
  rw finset.mem_singleton at childDef,
  -- not:
  apply localTableau.byLocalRule (@localRule.not _ p _) emptyTableau,
  { subst childDef, exact dec_trivial, },
  { -- show that endNodesOf is empty
    intros Y,
    intro YisEndNode,
    simp at *,
    exfalso,
    assumption,
},
end

-- Example 2
example : closedTableau { r ⋏ ~□p, r ↣ □(p ⋏ q) } :=
begin
  apply closedTableau.loc,
  rotate,
  { -- con
    apply localTableau.byLocalRule,
    apply localRule.con,
    simp only [impl, finset.mem_insert, finset.mem_singleton, or_false],
    split,
    refl,
    refl,
    intros branch branch_def,
    rw finset.mem_singleton at branch_def,
    rw finset.union_insert at branch_def,
    -- nCo
    apply localTableau.byLocalRule,
    apply @localRule.nCo _ r (~□(p ⋏ q)),
    { rw branch_def, simp, },
    intros b b_in,
    simp only [finset.mem_insert, finset.mem_singleton] at b_in,
    refine if h1 : b = branch \ {~(r⋏~□(p⋏q))} ∪ {~r} then _ else _,
    { -- right branch
      -- not:
      apply localTableau.byLocalRule (@localRule.not _ r _) emptyTableau,
      finish,
    },
    { --left branch
      have h2 : b = branch \ {~(r⋏~□(p⋏q))} ∪ {~~□(p⋏q)}, { tauto, },
      -- neg:
      apply localTableau.byLocalRule (@localRule.neg _ (□(p ⋏ q)) _),
      rotate, {rw h2, simp,},
      intros child childDef,
      -- ending local tableau with a simple node:
      apply localTableau.sim,
      rw finset.mem_singleton at childDef,
      rw childDef,
      unfold simple, simp at *, split, unfold simpleForm,
      intros f f_notDef1 f_in_branch,
      cases b_in,
      tauto,
      rw b_in at f_in_branch,
      simp at f_in_branch,
      cases f_in_branch,
      tauto,
      rw branch_def at f_in_branch,
      cases f_in_branch with l r, simp at r,
      cases r,
      { subst r, unfold r, },
      cases r,
      { subst r, unfold simpleForm, },
      { exfalso, tauto, },
    },
  },
  { -- tableau for the simple end nodes:
    rw conEndNodes,
    rw nCoEndNodes,
    intros Y Yin,
    simp at *,
    split_ifs at *,
    { -- not-R branch
      exfalso, -- show that there are no endnodes!
      simp at Yin,
      exact Yin,
    },
    { -- notnotbranch
      dedup,
      have Yis : Y = {r, ~□p, □(p ⋏ q)}, {
        simp at Yin,
        subst Yin,
        ext1,
        split ; { intro hyp, finish },
      },
      subst Yis,
      exact subTabForEx2,
    },
  },
end


/-
Copyright (c) 2020 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.topology.opens
import Mathlib.category_theory.sites.grothendieck
import Mathlib.category_theory.sites.pretopology
import Mathlib.category_theory.limits.lattice
import Mathlib.PostPort

universes u

namespace Mathlib

/-!
# Grothendieck topology on a topological space

Define the Grothendieck topology and the pretopology associated to a topological space, and show
that the pretopology induces the topology.

The covering (pre)sieves on `X` are those for which the union of domains contains `X`.

## Tags

site, Grothendieck topology, space

## References

* [https://ncatlab.org/nlab/show/Grothendieck+topology][nlab]
* [S. MacLane, I. Moerdijk, *Sheaves in Geometry and Logic*][MM92]

## Implementation notes

We define the two separately, rather than defining the Grothendieck topology as that generated
by the pretopology for the purpose of having nice definitional properties for the sieves.
-/

namespace opens

/-- The Grothendieck topology associated to a topological space. -/
def grothendieck_topology (T : Type u) [topological_space T] : category_theory.grothendieck_topology (topological_space.opens T) :=
  category_theory.grothendieck_topology.mk
    (fun (X : topological_space.opens T) (S : category_theory.sieve X) =>
      ∀ (x : T), x ∈ X → ∃ (U : topological_space.opens T), ∃ (f : U ⟶ X), coe_fn S U f ∧ x ∈ U)
    sorry sorry sorry

/-- The Grothendieck pretopology associated to a topological space. -/
def pretopology (T : Type u) [topological_space T] : category_theory.pretopology (topological_space.opens T) :=
  category_theory.pretopology.mk
    (fun (X : topological_space.opens T) (R : category_theory.presieve X) =>
      ∀ (x : T), x ∈ X → ∃ (U : topological_space.opens T), ∃ (f : U ⟶ X), R f ∧ x ∈ U)
    sorry sorry sorry

/--
The pretopology associated to a space induces the Grothendieck topology associated to the space.
-/
@[simp] theorem pretopology_to_grothendieck (T : Type u) [topological_space T] : category_theory.pretopology.to_grothendieck (topological_space.opens T) (pretopology T) = grothendieck_topology T := sorry


import algebraic_topology.fundamental_groupoid.basic
import topology.category.Top.basic
import topology.path_connected

noncomputable theory

structure top_subspace (X : Type*) [topological_space X] :=
(carrier : set X)
(univ_open : is_open carrier)

variables {X : Type*} [topological_space X]

instance : has_mem X (top_subspace X) :=
begin
  split, intro s, intro S, exact s ∈ S.carrier,
end

instance : has_coe (top_subspace X) (set X) :=
begin
  split, intro S, exact S.carrier,
end

-- instance to_topspace (H : top_subspace X) : topological_space H :=
-- begin
--   exact subtype.topological_space,
-- end

variable {H : top_subspace X}

@[simp] lemma mem_carrier {x : X} : x ∈ H.carrier ↔ x ∈ H :=
begin
  refl
end

@[simp] lemma mem_coe {x : X} : x ∈ (↑H : set X) ↔ x ∈ H :=
begin
  refl
end

@[simp] lemma mem_coe_self : (H : set X) = H.carrier :=
begin
  refl,
end

@[reducible] def incl : H → X :=
begin
  intro h, cases h, exact h_val,
end

instance has_coe_to_topspace : has_coe (H : top_subspace X) X :=
begin
  split, exact incl,
end

instance derived_topspace : topological_space H :=
begin
  exact @topological_space.induced _ _ incl _inst_1,
end

instance has_coe_to_parent_set : has_coe (set H) (set X) :=
begin
  fconstructor, intro h, exact set.image incl h,
end

theorem subspace_topology_equiv {X : Type*} [top_X : topological_space X] {H : top_subspace X} (x : set H):
 is_open x ↔ (∃(y : set X), is_open y ∧ y ∩ H = ↑x) :=
begin
  split,
  {
    intro h, cases h, use h_w, cases h_h, fconstructor, assumption,
    norm_num, rw incl at *, induction h_h_right, ring_nf, ext1,
    split, intro h2, fconstructor, fconstructor, exact x_1, finish,
    finish, intro h3, cases h3, fconstructor, finish, cases h3_h, cases h3_w, finish,
  },
  {
    intro h, cases h, cases h_h, fconstructor, exact h_w, fconstructor, assumption,
    rw set.preimage, ext1, rw incl, simp only [set.mem_set_of_eq], split,
    {
      intro hhh,
    cases x_1, simp at *, unfold_coes at *, rw incl at *, simp at *, dsimp at *,
    have s: x_1_val ∈ h_w ∩ H.carrier, fconstructor, exact hhh, exact x_1_property,
    rw h_h_right at s, finish,
    },
    intro h, have p: ↑x ⊆ h_w, rw ←h_h_right, intro s, intro hs, cases hs, assumption,
    apply p, fconstructor,exact x_1, split,exact h, rw incl,

  },
end

@[continuity] lemma incl_continuous : @continuous H X _ _ incl :=
begin
  exact continuous_induced_dom,
end

@[reducible] def i : C(↥H, X) := ⟨incl, incl_continuous⟩

def to_set (H : top_subspace X): set H := λh : H, true

@[simp] lemma to_set_id : set.image incl (to_set H) = H :=
begin
  unfold_coes, rw set.image, ext1, split, intro x,cases x,
  rw to_set at *, cases x_h with xh1 xh2, rw incl at xh2,simp at xh2, induction xh2, cases x_w,tauto,
  intro a, split, split,rotate 2,fconstructor,exact x,tauto, solve_by_elim, tauto,
end

-- lemma incl_intersection (x : set H) (y : set H): incl '' x ∩ incl '' y = incl '' (x ∩ y) :=
-- begin
--   sorry{rw incl, ext1, simp, split,
--   {intro s,cases s with sx sy, cases sx, cases sx_h with sxh1 sxh2, cases sy,
--   cases sy_h with syh1 syh2, cases sx_w, cases sy_w, use x_1, simp at *, finish, fconstructor, finish,
--   finish,},
--   {
--     intro s, cases s, cases s_w, cases s_h with sh1 sh2,cases sh1, simp at *, split, use x_1, rw ←sh2, assumption,
--     split, finish, finish, use x_1, finish, split, finish,finish,
--   },}

-- end

variables {a b : (H : top_subspace X)}

-- lift a path from subspace H to X --

-- theorem subspace_path_incl (p : path a b) : path (a:X) (b:X) :=
-- begin
--   fconstructor,
--   {
--     exact { to_fun := i ∘ p.to_continuous_map,
--             continuous_to_fun := continuous_induced_dom.comp (map_continuous p.to_continuous_map)}
--   },
--   {
--     simp only [path.coe_to_continuous_map, function.comp_app, path.source], unfold i, unfold incl, refl,
--   },
--   {
--     simp only [path.target, path.coe_to_continuous_map, function.comp_app], unfold i, unfold incl, refl,
--   }
-- end

-- notation `πₓ` := fundamental_groupoid.fundamental_groupoid_functor.obj
-- notation `π` := fundamental_groupoid.fundamental_groupoid_functor
-- notation `πₘ` := fundamental_groupoid.fundamental_groupoid_functor.map

-- def induced_top_morphism : Top.of H ⟶ Top.of X := i
-- def induced_groupoid_morphism : πₓ (Top.of H) ⟶ πₓ (Top.of X) := πₘ i

def to_subspace (X : Type*) [top : topological_space X]: top_subspace X :=
{ carrier := @set.univ X,
  univ_open := top.is_open_univ}

instance has_coe_to_subspace {Y : Type*} [topological_space Y] : has_coe Y (top_subspace Y) :=
begin
  fconstructor, intro h, apply to_subspace,
end

-- Partial order --

theorem ext' {H K : top_subspace X} (h : H.carrier = K.carrier) : H = K :=
begin
  cases H,
  cases K,
  simp * at *,
end

theorem ext'_iff {H K : top_subspace X} :
  H.carrier = K.carrier ↔ H = K :=
begin
  split,
  { exact ext' },
  { intro h,
    rw h, }
end

@[ext] theorem ext {H K : top_subspace X} (h : ∀ x, x ∈ H ↔ x ∈ K) : H = K :=
begin
  apply ext',
  ext,
  apply h,
end

instance : has_le (top_subspace X) := {le := λ X Y, X.carrier ⊆ Y.carrier}

variable K : (top_subspace X)

lemma le_def : H ≤ K ↔ H.carrier ⊆ K.carrier :=
begin
  refl
end

lemma le_iff : H ≤ K ↔ ∀ g, g ∈ H → g ∈ K :=
begin
  refl,
end

lemma le_space : H ≤ to_subspace X :=
begin
  rw le_def, rw to_subspace, simp only [set.subset_univ],
end

@[refl] lemma subspace_le_refl {H : top_subspace X}: H ≤ H :=
begin
  rw le_def,
end

lemma subspace_le_antisymm : H ≤ K → K ≤ H → H = K :=
begin
  rw [le_def, le_def, ← ext'_iff],
  exact set.subset.antisymm,
end

@[trans] lemma subspace_le_trans {H J K : top_subspace X}: H ≤ J → J ≤ K → H ≤ K :=
begin
  rw [le_def, le_def, le_def],
  exact set.subset.trans,
end

instance {X : Type*} [topological_space X]: partial_order (top_subspace X) :=
{ le := (≤),
  le_refl :=
  begin
    intro a, apply subspace_le_refl,
  end,
  le_antisymm :=
  begin
    intros a b, apply subspace_le_antisymm,
  end,
  le_trans :=
  begin
    intros a b c, apply subspace_le_trans,
  end}

-- open subspace
variables {A B : top_subspace X}

@[reducible] def open_incl (h: A ≤ B) : A → B :=
begin
  intro a, cases a, fconstructor, exact a_val, rw le_def at h, apply h, assumption,
end

lemma incl_open_map {X : Type*} [top_X : topological_space X] {A : top_subspace X} (x : set A) :
is_open x → is_open (set.image incl x):=
begin
  intro h, rw subspace_topology_equiv at *, cases h, cases h_h, rw is_open, rw incl,  simp,
  have p : is_open (h_w ∩ A.carrier), apply is_open.inter, assumption, exact A.univ_open, unfold_coes at *,
  rw incl at *,
  simp at h_h_right,
  rw h_h_right at p, finish,
end

@[simp] lemma incl_composition (h: A ≤ B) : (incl ∘ (open_incl h)) = incl :=
begin
  rw open_incl,rw incl, rw incl, simp, ext1, simp, cases x, simp,
end

@[simp] lemma incl_set_composition (h: A ≤ B) (x : set A): incl '' (open_incl h '' x) = incl '' x :=
begin
  rw ←set.image_comp, rw incl_composition,
  -- ext1, split, intro s, cases s, cases s_h, fconstructor,
end

@[simp] lemma incl_point_composition (h: A ≤ B) (x : A) : incl ((open_incl h) x) = incl x :=
begin
  rw open_incl, rw incl, rw incl, cases x, simp,
end

@[simp] lemma incl_self : incl '' (to_set A) = A.carrier :=
begin
  apply to_set_id,
end

lemma incl_inj {H: top_subspace X}: function.injective (@incl X _ H) :=
begin
  rw function.injective, intros a b,
  rw incl, cases a, cases b, finish,
end

-- @[simp] lemma incl_open_intersection (x : set A) (y : set A) : incl '' x ∩ incl '' y = incl '' (x ∩ y) :=
-- begin
--   apply incl_intersection,
-- end

-- @[simp] lemma incl_composition_asso (h: A ≤ B) (x : A): incl (open_incl h) = incl :=
-- begin
--   rw open_incl,rw incl, rw incl, cases x, simp,
-- end

-- @[simp] lemma set_incl_composition (h: A ≤ B) (x : set A): (incl ∘ (open_incl h))'' x = incl '' x :=
-- begin
--   ext1, split, intro hs,
-- end

theorem top_subspace_set_incl {X : Type*} [top_X : topological_space X] {A : top_subspace X} {B : top_subspace X} (x : set A)
(h: A ≤ B): is_open x → is_open (set.image (open_incl h) x):=
begin
  intro hs, have hrs : is_open (set.image incl x), apply incl_open_map, exact hs,
  rw subspace_topology_equiv, use (incl '' x), split, assumption, unfold_coes, rw incl_set_composition,
  simp, intro,intro hx, rw set.mem_preimage,rw incl, simp, cases x_1, solve_by_elim,
end

lemma range_incl {A : top_subspace X} : set.range (@incl X _ A) = A.carrier :=
begin
  rw set.range, ext1, split, intro hx, cases hx, cases hx_w, simp_rw incl at *, finish,
  intro hx, split, rotate, split, rotate, exact x, simp_rw incl, exact hx,
end

lemma incl_sub (x : A) (s : set A) : x ∈ s ↔ incl x ∈ incl '' s :=
begin
  split, intro hx, rw incl, finish,
  rw incl, intro hx, cases x, cases hx, simp at *, cases hx_h, cases hx_w, finish,
end

lemma incl_point_self (x : A) : incl x ∈ A.carrier :=
begin
  rw incl, cases x, simp, finish,
end

def top_subspace_incl {X : Type*} [top_X : topological_space X] {A : top_subspace X} {B : top_subspace X} (h : A ≤ B) : C(A,B) := {
  to_fun :=
  begin
    exact open_incl h,
  end,
  continuous_to_fun :=
  begin
    fconstructor, intro bns, intro hs, rw subspace_topology_equiv at *, cases hs with sX hsX, cases hsX with hsOpen ps,
    let ans : set X := sX ∩ A, use ans, fconstructor, apply is_open.inter, assumption, exact A.univ_open,
    rw set.subset.antisymm_iff, unfold_coes, have hp : open_incl h ⁻¹' bns = incl ⁻¹' ans,
    {
      rw set.preimage, rw set.preimage, ext1,split, intro hx, simp only [set.mem_set_of_eq] at hx,
      rw incl_sub at hx, rw incl_point_composition at hx, unfold_coes at *,rw ←ps at hx, cases hx, fconstructor,
      assumption, apply incl_point_self,
      intro hx, simp only [set.mem_set_of_eq] at hx, cases hx with hx1 hx2, simp only [set.mem_set_of_eq], rw incl_sub, rw incl_point_composition, rw le_iff at h,
      have hx3: incl x ∈ B, apply h, assumption,have hx4 : incl x ∈ sX∩↑B, split, assumption, assumption,
      have hx5: sX ∩ ↑B ⊆ incl '' bns, rotate,apply hx5, assumption, rw ps, unfold_coes,
    },
    {
        rw hp, simp only [set.inter_subset_left,
        set.image_subset_iff,
        and_true,
        set.subset_inter_iff,
        mem_coe_self,
        set.inter_subset_right,
        set.preimage_inter,
        and_self], rw ←set.preimage_inter, rw set.image_preimage_eq_of_subset,
        intro x, intro hx, cases hx, fconstructor, exact hx_left.1,
        assumption, rw range_incl, refine set.inter_subset_right sX A.carrier,
    },
  end}

instance point_lift (h : A ≤ B): has_coe A B :=
begin
  fconstructor, exact open_incl h,
end

--- intersection and union of subspace ---

def intersection (A : top_subspace X) (B : top_subspace X) : top_subspace X :=
begin
  fconstructor, exact A.carrier ∩ B.carrier, apply is_open.inter, exact A.univ_open, exact B.univ_open,
end

instance : has_inter (top_subspace X) := {inter := intersection}

@[simp] theorem inter_sub : A ∩ B ≤ A :=
begin
  rw le_def, intro, intro hx, cases hx, assumption,
end

@[simp] theorem inter_sub2 : A ∩ B ≤ B :=
begin
  rw le_def, intro, intro hx, cases hx, assumption,
end

def union (A : top_subspace X) (B : top_subspace X) : top_subspace X :=
begin
  fconstructor, exact A.carrier ∪ B.carrier, apply is_open.union, exact A.univ_open, exact B.univ_open,
end

instance : has_union (top_subspace X) := {union := union}

@[simp] theorem union_sub : A ≤ A ∪ B :=
begin
  rw le_def, intro, intro hx, fconstructor, exact hx,
end

@[simp] theorem union_sub2 : B ≤ A ∪ B :=
begin
  rw le_def, intro, intro hx, simp at *, right, exact hx,
end

-- (backward) lift of element

def elem_backward_inclusion (x : X) (hx : x ∈ H) : H :=
begin
  fconstructor, exact x, exact hx,
end

instance hascoe_top : has_coe (top_subspace X) Top :=
begin
  fconstructor, intro x, exact Top.of x,
end
-- (backward) lift of function

@[simp] lemma incl_inj_eq {x y : H}: incl x = incl y ↔ x = y :=
begin
  rw incl, cases x, cases y, simp,
end

@[simp] lemma incl_carrier (a : H) : incl a ∈ H.carrier :=
begin
  cases a, simp_rw incl, assumption,
end

lemma openincl_carrier {G : top_subspace X} (h : H ≤ G) (a : H) : incl a ∈ G.carrier :=
begin
  rw le_def at h, apply h, simp,
end

-- variables {A B : top_subspace X} {hAB : A≤ B}

-- instance subspace_has_coe (hAB : A ≤ B): has_coe (A : top_subspace X) (top_subspace B):=
-- begin
--   split, intro a, split, cases A, cases B, rw le_def at hAB, simp only [] at hAB,
--   cases a, tauto,
-- end

-- def subspace_lift {A B : top_subspace X} (hAB : A ≤ B): top_subspace B :=
-- begin
--   split, rw le_def at hAB, cases A, cases B, simp only [] at hAB, simp only [coe_sort_coe_base],
--   unfold_coes, simp only [], intro h, cases h, exact h_val ∈ A,
-- end

-- #check (@derived_topspace X _ A)
-- #check (@subspace_lift X _ A B hAB)
-- #check @derived_topspace B _ ((@subspace_lift X _ A B hAB) : top_subspace B)

-- theorem topology_equivalence (hAB : A ≤ B): (@derived_topspace X _ A).is_open = (@derived_topspace B _ (@subspace_lift X _ A B hAB)).is_open
-- def continuous_subspace_incl (A B : top_subspace X) {hAB : A ≤ B}: C(A,B) :=
-- { to_fun :=
--   begin
--     intro a, exact {val := a.val,
--     property := hAB a.property}
--   end,
--   continuous_to_fun :=
--   begin
--     fconstructor,
--   end, }