/-
Copyright (c) 2018 Kenny Lau. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenny Lau
-/
import algebra.group.defs
import logic.equiv.basic
import logic.nontrivial

/-!
# Multiplicative opposite and algebraic operations on it

In this file we define `mul_opposite α = αᵐᵒᵖ` to be the multiplicative opposite of `α`. It inherits
all additive algebraic structures on `α` (in other files), and reverses the order of multipliers in
multiplicative structures, i.e., `op (x * y) = op y * op x`, where `mul_opposite.op` is the
canonical map from `α` to `αᵐᵒᵖ`.

We also define `add_opposite α = αᵃᵒᵖ` to be the additive opposite of `α`. It inherits all
multiplicative algebraic structures on `α` (in other files), and reverses the order of summands in
additive structures, i.e. `op (x + y) = op y + op x`, where `add_opposite.op` is the canonical map
from `α` to `αᵃᵒᵖ`.

## Notation

* `αᵐᵒᵖ = mul_opposite α`
* `αᵃᵒᵖ = add_opposite α`

## Tags

multiplicative opposite, additive opposite
-/

universes u v
open function

/-- Multiplicative opposite of a type. This type inherits all additive structures on `α` and
reverses left and right in multiplication.-/
@[to_additive "Additive opposite of a type. This type inherits all multiplicative structures on
`α` and reverses left and right in addition."]
def mul_opposite (α : Type u) : Type u := α

postfix `ᵐᵒᵖ`:std.prec.max_plus := mul_opposite
postfix `ᵃᵒᵖ`:std.prec.max_plus := add_opposite

variables {α : Type u}

namespace mul_opposite

/-- The element of `mul_opposite α` that represents `x : α`. -/
@[pp_nodot, to_additive "The element of `αᵃᵒᵖ` that represents `x : α`."]
def op : α → αᵐᵒᵖ := id

/-- The element of `α` represented by `x : αᵐᵒᵖ`. -/
@[pp_nodot, to_additive "The element of `α` represented by `x : αᵃᵒᵖ`."]
def unop : αᵐᵒᵖ → α := id

attribute [pp_nodot] add_opposite.op add_opposite.unop

@[simp, to_additive] lemma unop_op (x : α) : unop (op x) = x := rfl
@[simp, to_additive] lemma op_unop (x : αᵐᵒᵖ) : op (unop x) = x := rfl
@[simp, to_additive] lemma op_comp_unop : (op : α → αᵐᵒᵖ) ∘ unop = id := rfl
@[simp, to_additive] lemma unop_comp_op : (unop : αᵐᵒᵖ → α) ∘ op = id := rfl

attribute [irreducible] mul_opposite

/-- A recursor for `mul_opposite`. Use as `induction x using mul_opposite.rec`. -/
@[simp, to_additive "A recursor for `add_opposite`. Use as `induction x using add_opposite.rec`."]
protected def rec {F : Π (X : αᵐᵒᵖ), Sort v} (h : Π X, F (op X)) : Π X, F X :=
λ X, h (unop X)

/-- The canonical bijection between `α` and `αᵐᵒᵖ`. -/
@[to_additive "The canonical bijection between `α` and `αᵃᵒᵖ`.",
  simps apply symm_apply { fully_applied := ff }]
def op_equiv : α ≃ αᵐᵒᵖ := ⟨op, unop, unop_op, op_unop⟩

@[to_additive] lemma op_bijective : bijective (op : α → αᵐᵒᵖ) := op_equiv.bijective
@[to_additive] lemma unop_bijective : bijective (unop : αᵐᵒᵖ → α) := op_equiv.symm.bijective
@[to_additive] lemma op_injective : injective (op : α → αᵐᵒᵖ) := op_bijective.injective
@[to_additive] lemma op_surjective : surjective (op : α → αᵐᵒᵖ) := op_bijective.surjective
@[to_additive] lemma unop_injective : injective (unop : αᵐᵒᵖ → α) := unop_bijective.injective
@[to_additive] lemma unop_surjective : surjective (unop : αᵐᵒᵖ → α) := unop_bijective.surjective

@[simp, to_additive] lemma op_inj {x y : α} : op x = op y ↔ x = y := op_injective.eq_iff
@[simp, to_additive] lemma unop_inj {x y : αᵐᵒᵖ} : unop x = unop y ↔ x = y := unop_injective.eq_iff

variable (α)

@[to_additive] instance [nontrivial α] : nontrivial αᵐᵒᵖ := op_injective.nontrivial
@[to_additive] instance [inhabited α] : inhabited αᵐᵒᵖ := ⟨op default⟩
@[to_additive] instance [subsingleton α] : subsingleton αᵐᵒᵖ := unop_injective.subsingleton
@[to_additive] instance [unique α] : unique αᵐᵒᵖ := unique.mk' _
@[to_additive] instance [is_empty α] : is_empty αᵐᵒᵖ := function.is_empty unop

instance [has_zero α] : has_zero αᵐᵒᵖ := { zero := op 0 }

@[to_additive] instance [has_one α] : has_one αᵐᵒᵖ := { one := op 1 }

instance [has_add α] : has_add αᵐᵒᵖ :=
{ add := λ x y, op (unop x + unop y) }

instance [has_sub α] : has_sub αᵐᵒᵖ :=
{ sub := λ x y, op (unop x - unop y) }

instance [has_neg α] : has_neg αᵐᵒᵖ :=
{ neg := λ x, op $ -(unop x) }

instance [has_involutive_neg α] : has_involutive_neg αᵐᵒᵖ :=
{ neg_neg := λ a, unop_injective $ neg_neg _,
  ..mul_opposite.has_neg α }

@[to_additive] instance [has_mul α] : has_mul αᵐᵒᵖ :=
{ mul := λ x y, op (unop y * unop x) }

@[to_additive] instance [has_inv α] : has_inv αᵐᵒᵖ :=
{ inv := λ x, op $ (unop x)⁻¹ }

@[to_additive] instance [has_involutive_inv α] : has_involutive_inv αᵐᵒᵖ :=
{ inv_inv := λ a, unop_injective $ inv_inv _,
  ..mul_opposite.has_inv α }

@[to_additive] instance (R : Type*) [has_scalar R α] : has_scalar R αᵐᵒᵖ :=
{ smul := λ c x, op (c • unop x) }

section
variables (α)

@[simp] lemma op_zero [has_zero α] : op (0 : α) = 0 := rfl
@[simp]

@[simp, to_additive] lemma op_one [has_one α] : op (1 : α) = 1 := rfl
@[simp, to_additive] lemma unop_one [has_one α] : unop (1 : αᵐᵒᵖ) = 1 := rfl

variable {α}

@[simp] lemma op_add [has_add α] (x y : α) : op (x + y) = op x + op y := rfl
@[simp] lemma unop_add [has_add α] (x y : αᵐᵒᵖ) : unop (x + y) = unop x + unop y := rfl

@[simp] lemma op_neg [has_neg α] (x : α) : op (-x) = -op x := rfl
@[simp] lemma unop_neg [has_neg α] (x : αᵐᵒᵖ) : unop (-x) = -unop x := rfl

@[simp, to_additive] lemma op_mul [has_mul α] (x y : α) : op (x * y) = op y * op x := rfl
@[simp, to_additive] lemma unop_mul [has_mul α] (x y : αᵐᵒᵖ) : unop (x * y) = unop y * unop x := rfl

@[simp, to_additive] lemma op_inv [has_inv α] (x : α) : op (x⁻¹) = (op x)⁻¹ := rfl
@[simp, to_additive] lemma unop_inv [has_inv α] (x : αᵐᵒᵖ) : unop (x⁻¹) = (unop x)⁻¹ := rfl

@[simp] lemma op_sub [has_sub α] (x y : α) : op (x - y) = op x - op y := rfl
@[simp] lemma unop_sub [has_sub α] (x y : αᵐᵒᵖ) : unop (x - y) = unop x - unop y := rfl

@[simp, to_additive] lemma op_smul {R : Type*} [has_scalar R α] (c : R) (a : α) :
  op (c • a) = c • op a := rfl

@[simp, to_additive] lemma unop_smul {R : Type*} [has_scalar R α] (c : R) (a : αᵐᵒᵖ) :
  unop (c • a) = c • unop a := rfl

end

variable {α}

@[simp] lemma unop_eq_zero_iff [has_zero α] (a : αᵐᵒᵖ) : a.unop = (0 : α) ↔ a = (0 : αᵐᵒᵖ) :=
unop_injective.eq_iff' rfl

@[simp] lemma op_eq_zero_iff [has_zero α] (a : α) : op a = (0 : αᵐᵒᵖ) ↔ a = (0 : α) :=
op_injective.eq_iff' rfl

lemma unop_ne_zero_iff [has_zero α] (a : αᵐᵒᵖ) : a.unop ≠ (0 : α) ↔ a ≠ (0 : αᵐᵒᵖ) :=
not_congr $ unop_eq_zero_iff a

lemma op_ne_zero_iff [has_zero α] (a : α) : op a ≠ (0 : αᵐᵒᵖ) ↔ a ≠ (0 : α) :=
not_congr $ op_eq_zero_iff a

@[simp, to_additive] lemma unop_eq_one_iff [has_one α] (a : αᵐᵒᵖ) : a.unop = 1 ↔ a = 1 :=
unop_injective.eq_iff' rfl

@[simp, to_additive] lemma op_eq_one_iff [has_one α] (a : α) : op a = 1 ↔ a = 1 :=
op_injective.eq_iff' rfl

end mul_opposite

namespace add_opposite

instance [has_one α] : has_one αᵃᵒᵖ := { one := op 1 }

@[simp] lemma op_one [has_one α] : op (1 : α) = 1 := rfl
@[simp] lemma unop_one [has_one α] : unop 1 = (1 : α) := rfl

@[simp] lemma op_eq_one_iff [has_one α] {a : α} : op a = 1 ↔ a = 1 := op_injective.eq_iff' op_one

@[simp] lemma unop_eq_one_iff [has_one α] {a : αᵃᵒᵖ} : unop a = 1 ↔ a = 1 :=
unop_injective.eq_iff' unop_one

instance [has_mul α] : has_mul αᵃᵒᵖ := { mul := λ a b, op (unop a * unop b) }

@[simp] lemma op_mul [has_mul α] (a b : α) : op (a * b) = op a * op b := rfl
@[simp] lemma unop_mul [has_mul α] (a b : αᵃᵒᵖ) : unop (a * b) = unop a * unop b := rfl

instance [has_inv α] : has_inv αᵃᵒᵖ := { inv := λ a, op (unop a)⁻¹ }

instance [has_involutive_inv α] : has_involutive_inv αᵃᵒᵖ :=
{ inv_inv := λ a, unop_injective $ inv_inv _,
  ..add_opposite.has_inv }

@[simp] lemma op_inv [has_inv α] (a : α) : op a⁻¹ = (op a)⁻¹ := rfl
@[simp] lemma unop_inv [has_inv α] (a : αᵃᵒᵖ) : unop a⁻¹ = (unop a)⁻¹ := rfl

instance [has_div α] : has_div αᵃᵒᵖ := { div := λ a b, op (unop a / unop b) }

@[simp] lemma op_div [has_div α] (a b : α) : op (a / b) = op a / op b := rfl
@[simp] lemma unop_div [has_div α] (a b : α) : unop (a / b) = unop a / unop b := rfl

end add_opposite


/-
Copyright (c) 2017 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.propext
import Mathlib.Lean3Lib.init.classical

universes u

namespace Mathlib

/- Lemmas use by the congruence closure module -/

theorem iff_eq_of_eq_true_left {a : Prop} {b : Prop} (h : a = True) : (a ↔ b) = b :=
  Eq.symm h ▸ propext (true_iff b)

theorem iff_eq_of_eq_true_right {a : Prop} {b : Prop} (h : b = True) : (a ↔ b) = a :=
  Eq.symm h ▸ propext (iff_true a)

theorem iff_eq_true_of_eq {a : Prop} {b : Prop} (h : a = b) : (a ↔ b) = True :=
  h ▸ propext (iff_self a)

theorem and_eq_of_eq_true_left {a : Prop} {b : Prop} (h : a = True) : (a ∧ b) = b :=
  Eq.symm h ▸ propext (true_and b)

theorem and_eq_of_eq_true_right {a : Prop} {b : Prop} (h : b = True) : (a ∧ b) = a :=
  Eq.symm h ▸ propext (and_true a)

theorem and_eq_of_eq_false_left {a : Prop} {b : Prop} (h : a = False) : (a ∧ b) = False :=
  Eq.symm h ▸ propext (false_and b)

theorem and_eq_of_eq_false_right {a : Prop} {b : Prop} (h : b = False) : (a ∧ b) = False :=
  Eq.symm h ▸ propext (and_false a)

theorem and_eq_of_eq {a : Prop} {b : Prop} (h : a = b) : (a ∧ b) = a :=
  h ▸ propext (and_self a)

theorem or_eq_of_eq_true_left {a : Prop} {b : Prop} (h : a = True) : (a ∨ b) = True :=
  Eq.symm h ▸ propext (true_or b)

theorem or_eq_of_eq_true_right {a : Prop} {b : Prop} (h : b = True) : (a ∨ b) = True :=
  Eq.symm h ▸ propext (or_true a)

theorem or_eq_of_eq_false_left {a : Prop} {b : Prop} (h : a = False) : (a ∨ b) = b :=
  Eq.symm h ▸ propext (false_or b)

theorem or_eq_of_eq_false_right {a : Prop} {b : Prop} (h : b = False) : (a ∨ b) = a :=
  Eq.symm h ▸ propext (or_false a)

theorem or_eq_of_eq {a : Prop} {b : Prop} (h : a = b) : (a ∨ b) = a :=
  h ▸ propext (or_self a)

theorem imp_eq_of_eq_true_left {a : Prop} {b : Prop} (h : a = True) : (a → b) = b :=
  Eq.symm h ▸ propext { mp := fun (h : True → b) => h trivial, mpr := fun (h₁ : b) (h₂ : True) => h₁ }

theorem imp_eq_of_eq_true_right {a : Prop} {b : Prop} (h : b = True) : (a → b) = True :=
  Eq.symm h ▸ propext { mp := fun (h : a → True) => trivial, mpr := fun (h₁ : True) (h₂ : a) => h₁ }

theorem imp_eq_of_eq_false_left {a : Prop} {b : Prop} (h : a = False) : (a → b) = True :=
  Eq.symm h ▸ propext { mp := fun (h : False → b) => trivial, mpr := fun (h₁ : True) (h₂ : False) => false.elim h₂ }

theorem imp_eq_of_eq_false_right {a : Prop} {b : Prop} (h : b = False) : (a → b) = (¬a) :=
  Eq.symm h ▸ propext { mp := fun (h : a → False) => h, mpr := fun (hna : ¬a) (ha : a) => hna ha }

/- Remark: the congruence closure module will only use the following lemma is
   cc_config.em is tt. -/

theorem not_imp_eq_of_eq_false_right {a : Prop} {b : Prop} (h : b = False) : (¬a → b) = a := sorry

theorem imp_eq_true_of_eq {a : Prop} {b : Prop} (h : a = b) : (a → b) = True :=
  h ▸ propext { mp := fun (h : a → a) => trivial, mpr := fun (h : True) (ha : a) => ha }

theorem not_eq_of_eq_true {a : Prop} (h : a = True) : (¬a) = False :=
  Eq.symm h ▸ propext not_true_iff

theorem not_eq_of_eq_false {a : Prop} (h : a = False) : (¬a) = True :=
  Eq.symm h ▸ propext not_false_iff

theorem false_of_a_eq_not_a {a : Prop} (h : a = (¬a)) : False :=
  (fun (this : ¬a) => absurd (eq.mpr h this) this) fun (ha : a) => absurd ha (eq.mp h ha)

theorem if_eq_of_eq_true {c : Prop} [d : Decidable c] {α : Sort u} (t : α) (e : α) (h : c = True) : ite c t e = t :=
  if_pos (of_eq_true h)

theorem if_eq_of_eq_false {c : Prop} [d : Decidable c] {α : Sort u} (t : α) (e : α) (h : c = False) : ite c t e = e :=
  if_neg (not_of_eq_false h)

theorem if_eq_of_eq (c : Prop) [d : Decidable c] {α : Sort u} {t : α} {e : α} (h : t = e) : ite c t e = t := sorry

theorem eq_true_of_and_eq_true_left {a : Prop} {b : Prop} (h : (a ∧ b) = True) : a = True :=
  eq_true_intro (and.left (of_eq_true h))

theorem eq_true_of_and_eq_true_right {a : Prop} {b : Prop} (h : (a ∧ b) = True) : b = True :=
  eq_true_intro (and.right (of_eq_true h))

theorem eq_false_of_or_eq_false_left {a : Prop} {b : Prop} (h : (a ∨ b) = False) : a = False :=
  eq_false_intro fun (ha : a) => false.elim (eq.mp h (Or.inl ha))

theorem eq_false_of_or_eq_false_right {a : Prop} {b : Prop} (h : (a ∨ b) = False) : b = False :=
  eq_false_intro fun (hb : b) => false.elim (eq.mp h (Or.inr hb))

theorem eq_false_of_not_eq_true {a : Prop} (h : (¬a) = True) : a = False :=
  eq_false_intro fun (ha : a) => absurd ha (eq.mpr h trivial)

/- Remark: the congruence closure module will only use the following lemma is
   cc_config.em is tt. -/

theorem eq_true_of_not_eq_false {a : Prop} (h : (¬a) = False) : a = True :=
  eq_true_intro (classical.by_contradiction fun (hna : ¬a) => eq.mp h hna)

theorem ne_of_eq_of_ne {α : Sort u} {a : α} {b : α} {c : α} (h₁ : a = b) (h₂ : b ≠ c) : a ≠ c :=
  Eq.symm h₁ ▸ h₂

theorem ne_of_ne_of_eq {α : Sort u} {a : α} {b : α} {c : α} (h₁ : a ≠ b) (h₂ : b = c) : a ≠ c :=
  h₂ ▸ h₁


-- Copyright 2022-2023 VMware, Inc.
-- SPDX-License-Identifier: BSD-2-Clause

import tactic.omega.main
import tactic.linarith
import tactic.split_ifs

/-!

# Streams

Definition of streams and some basic properties. We don't use mathlib streams
because we hardly need any definitions from it.

A stream over a type `a` is a `ℕ → a`.

Defines agree_upto n s s', usually written with the notation s ==n== s', which
says that s and s' agree on all indices in 0..n (inclusive).

-/

universes u v.

/-- A stream is an infinite sequence of elements from `a`.

The indices usually use the metavariable `t`, meant to represent (a discrete
notion of) time.
 -/
def stream (a: Type u) : Type u := ℕ → a.

variable {a : Type u}.

/-- s₁ ==n== s₂ says that streams s₁ and s₂ are equal up to (and including) time
`n`. -/
def agree_upto (n: ℕ) (s₁ s₂: stream a) := ∀ t ≤ n, s₁ t = s₂ t.

notation s ` ==` n `== ` s':35 := agree_upto n s s'.

instance stream_po [partial_order a] : partial_order (stream a) :=
  by { unfold stream, apply_instance }.

@[ext]
lemma stream_le_ext [partial_order a] (s1 s2: stream a) :
  s1 ≤ s2 = (∀ t, s1 t ≤ s2 t) := rfl.

instance stream_zero [has_zero a] : has_zero (stream a) := ⟨λ (_: ℕ), 0⟩.

@[refl]
lemma agree_refl (n: ℕ) : ∀ (s: stream a), s ==n== s :=
begin
  unfold agree_upto,
  intros s i _,
  refl,
end

@[symm]
lemma agree_symm (n: ℕ) : ∀ (s1 s2: stream a), s1 ==n== s2 → s2 ==n== s1 :=
begin
  unfold agree_upto,
  intros s1 s2 h12 i hle,
  rw [h12]; assumption,
end

@[trans]
lemma agree_trans {n: ℕ} : ∀ (s1 s2 s3: stream a), s1 ==n== s2 → s2 ==n== s3 → s1 ==n== s3 :=
begin
  unfold agree_upto,
  intros s1 s2 s3 h12 h23 i hle,
  rw [h12, h23]; assumption,
end

-- TODO: these don't seem to do anything (don't help with rewriting)
instance agree_upto_refl (n: ℕ) : is_refl (stream a) (agree_upto n) := ⟨agree_refl n⟩.
instance agree_upto_symm (n: ℕ) : is_symm (stream a) (agree_upto n) := ⟨agree_symm n⟩.
instance agree_upto_trans (n: ℕ) : is_trans (stream a) (agree_upto n) := ⟨agree_trans⟩.
instance agree_upto_preorder (n: ℕ) : is_preorder (stream a) (agree_upto n) := ⟨⟩.
instance agree_upto_equiv (n: ℕ) : is_equiv (stream a) (agree_upto n) := ⟨⟩.

theorem agree_everywhere_eq (s s': stream a) :
  s = s' ↔ (∀ n, s ==n== s') :=
begin
  split,
  { intros h n,
    rw h, },
  { intros h,
    funext n,
    apply (h n), omega,
   }
end

lemma agree_upto_weaken {s s': stream a} (n n': ℕ) :
  s ==n== s' →
  n' ≤ n →
  s ==n'== s' :=
begin
  intros heq hle,
  intros i hle_i,
  apply heq, omega,
end

lemma agree_upto_weaken1 {s s': stream a} (n: ℕ) :
  s ==n.succ== s' →
  s ==n== s' :=
begin
  intros heq,
  apply (agree_upto_weaken n.succ), assumption, omega,
end

lemma agree_upto_0 (s s': stream a) :
  s ==0== s' ↔ s 0 = s' 0 :=
begin
  unfold agree_upto,
  split,
  { intros hagree,
    apply (hagree 0),
    omega, },
  { intros h0 t hle,
    have h: (t = 0) := by omega,
    cc, }
end

lemma agree_upto_extend (n: nat) (s s': stream a) :
  s ==n== s' → s n.succ = s' n.succ → s ==n.succ== s' :=
begin
  intros hagree heq,
  intros i hle,
  have h: (i ≤ n ∨ i = n.succ) := by omega,
  cases h,
  { apply hagree, assumption, },
  { subst i, assumption, }
end

-- We don't use this theory because everything is based on [agree_upto], but
-- formalize a little bit from the paper.
namespace cutting.

variables [has_zero a].

/-- Construct a stream that matches `s` up to time `t` and is 0 afterward. -/
def cut (s: stream a) (t: ℕ) : stream a :=
  λ i, if (i < t) then s i else 0.

lemma cut_at_0 (s: stream a) : cut s 0 = 0 :=
begin
  ext n,
  unfold cut, rw if_neg, simp,
  omega,
end

lemma cut_0 : cut (0 : stream a) = 0 :=
begin
  ext n,
  unfold cut, split_ifs; refl,
end

theorem cut_cut (s: stream a) (t1 t2: ℕ) :
  cut (cut s t1) t2 = cut s (min t1 t2) :=
begin
  funext i, simp [cut],
  split_ifs; try { simp },
  tauto,
  { exfalso, linarith, },
  { exfalso, linarith, },
end

theorem cut_comm (s: stream a) (t1 t2: ℕ) :
  cut (cut s t1) t2 = cut (cut s t2) t1 :=
begin
  rw [cut_cut, cut_cut],
  rw min_comm,
end

theorem cut_idem (s: stream a) (t: ℕ) :
  cut (cut s t) t = cut s t :=
begin
  rw cut_cut, simp,
end

/-- Relate [agree_upto] to equality on [cut]. -/
theorem agree_upto_cut (s1 s2: stream a) (n: ℕ) :
  s1 ==n== s2 ↔ cut s1 n.succ = cut s2 n.succ :=
begin
  split,
  { intros heq,
    funext t, simp [cut],
    split_ifs; try { refl },
    apply heq, omega, },
  { intros heq,
    intros t hle, simp [cut] at heq,
    have h := congr_fun heq t, simp at h,
    split_ifs at *,
    { assumption, },
    { exfalso, apply h_1, omega, },
  },
end

lemma cut_agree_succ (s1 s2: stream a) (t: ℕ) :
  cut s1 t = cut s2 t →
  s1 t = s2 t →
  cut s1 t.succ = cut s2 t.succ :=
begin
  cases t,
  { intros _hcut heq,
    ext n,
    unfold cut, split_ifs, swap, refl,
    have heq : n = 0 := by omega,
    subst n, assumption,
  },
  repeat { rw<- agree_upto_cut },
  apply agree_upto_extend,
end

theorem agree_with_cut (s: stream a) (n: ℕ) :
  s ==n== cut s n.succ :=
begin
  rw [agree_upto_cut, cut_idem],
end

end cutting.

-- #lint only doc_blame simp_nf


import data.set.lattice
import tidy.tidy

example (X : Type) (R : Type) (D : R → set X) (γ : Type) (f : γ → R) :
  ⋃₀(D '' set.range f) = ⋃ (i : γ), D (f i) := by tidy


import algebra.field
import gtm106.weierstrass_equation.basic
import gtm106.weierstrass_equation.point
import gtm106.weierstrass_equation.group_law.basic
import tactic

namespace weierstrass_equation

namespace affine_point

-- copied from [Fri17] An elementary proof of the group law for elliptic curves

lemma add.assoc.lemma_2_3
{K : Type*} [field K] {E : weierstrass_equation K}
(P : affine_plane_point K)
(h : E.affine_point_on_curve P)
(hnot2tors : neg_of_double_of_affine_plane_point.C E P ≠ 0)
(h2not2tors : neg_of_double_of_affine_plane_point.C E (E.double_of_affine_plane_point P) ≠ 0)
(hx31 : (E.add_of_affine_plane_point (E.double_of_affine_plane_point P) P).x - P.x ≠ 0)
(hx21 : (E.double_of_affine_plane_point P).x - P.x ≠ 0)
: (E.double_of_affine_plane_point (E.double_of_affine_plane_point P))
= E.add_of_affine_plane_point P (E.add_of_affine_plane_point P (E.double_of_affine_plane_point P)) :=
begin
  sorry,
end

end affine_point

end weierstrass_equation


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

Relator for functions, pairs, sums, and lists.
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.tactic.reserved_notation
import Mathlib.PostPort

universes u₁ u₂ v₁ v₂ u_1 u_2

namespace Mathlib

namespace relator

/- TODO(johoelzl):
 * should we introduce relators of datatypes as recursive function or as inductive
predicate? For now we stick to the recursor approach.
 * relation lift for datatypes, Π, Σ, set, and subtype types
 * proof composition and identity laws
 * implement method to derive relators from datatype
-/

def lift_fun {α : Sort u₁} {β : Sort u₂} {γ : Sort v₁} {δ : Sort v₂} (R : α → β → Prop) (S : γ → δ → Prop) (f : α → γ) (g : β → δ) :=
  ∀ {a : α} {b : β}, R a b → S (f a) (g b)

infixr:40 " ⇒ " => Mathlib.relator.lift_fun

def right_total {α : Type u₁} {β : outParam (Type u₂)} (R : outParam (α → β → Prop)) :=
  ∀ (b : β), ∃ (a : α), R a b

def left_total {α : Type u₁} {β : outParam (Type u₂)} (R : outParam (α → β → Prop)) :=
  ∀ (a : α), ∃ (b : β), R a b

def bi_total {α : Type u₁} {β : outParam (Type u₂)} (R : outParam (α → β → Prop)) :=
  left_total R ∧ right_total R

def left_unique {α : Type u₁} {β : Type u₂} (R : α → β → Prop) :=
  ∀ {a : α} {b : β} {c : α}, R a b → R c b → a = c

def right_unique {α : Type u₁} {β : Type u₂} (R : α → β → Prop) :=
  ∀ {a : α} {b c : β}, R a b → R a c → b = c

theorem rel_forall_of_right_total {α : Type u₁} {β : Type u₂} (R : α → β → Prop) [t : right_total R] : lift_fun (R ⇒ implies) implies (fun (p : α → Prop) => ∀ (i : α), p i) fun (q : β → Prop) => ∀ (i : β), q i :=
  fun (p : α → Prop) (q : β → Prop) (Hrel : lift_fun R implies p q) (H : ∀ (i : α), p i) (b : β) =>
    exists.elim (t b) fun (a : α) (Rab : R a b) => Hrel Rab (H a)

theorem rel_exists_of_left_total {α : Type u₁} {β : Type u₂} (R : α → β → Prop) [t : left_total R] : lift_fun (R ⇒ implies) implies (fun (p : α → Prop) => ∃ (i : α), p i) fun (q : β → Prop) => ∃ (i : β), q i := sorry

theorem rel_forall_of_total {α : Type u₁} {β : Type u₂} (R : α → β → Prop) [t : bi_total R] : lift_fun (R ⇒ Iff) Iff (fun (p : α → Prop) => ∀ (i : α), p i) fun (q : β → Prop) => ∀ (i : β), q i := sorry

theorem rel_exists_of_total {α : Type u₁} {β : Type u₂} (R : α → β → Prop) [t : bi_total R] : lift_fun (R ⇒ Iff) Iff (fun (p : α → Prop) => ∃ (i : α), p i) fun (q : β → Prop) => ∃ (i : β), q i := sorry

theorem left_unique_of_rel_eq {α : Type u₁} {β : Type u₂} (R : α → β → Prop) {eq' : β → β → Prop} (he : lift_fun R (R ⇒ Iff) Eq eq') : left_unique R :=
  fun {a : α} {b : β} {c : α} (ᾰ : R a b) (ᾰ_1 : R c b) =>
    idRhs (a = c) ((fun (this : eq' b b) => iff.mpr (he ᾰ ᾰ_1) this) (iff.mp (he ᾰ ᾰ) rfl))

theorem rel_imp : lift_fun Iff (Iff ⇒ Iff) implies implies :=
  fun (p q : Prop) (h : p ↔ q) (r s : Prop) (l : r ↔ s) => imp_congr h l

theorem rel_not : lift_fun Iff Iff Not Not :=
  fun (p q : Prop) (h : p ↔ q) => not_congr h

-- (this is an instance is always applies, since the relation is an out-param)

protected instance bi_total_eq {α : Type u₁} : bi_total Eq :=
  { left := fun (a : α) => Exists.intro a rfl, right := fun (a : α) => Exists.intro a rfl }

def bi_unique {α : Type u_1} {β : Type u_2} (r : α → β → Prop) :=
  left_unique r ∧ right_unique r

theorem left_unique_flip {α : Type u_1} {β : Type u_2} {r : α → β → Prop} (h : left_unique r) : right_unique (flip r) :=
  fun {a : β} {b c : α} (ᾰ : flip r a b) (ᾰ_1 : flip r a c) => idRhs (b = c) (h ᾰ ᾰ_1)

theorem rel_and : lift_fun Iff (Iff ⇒ Iff) And And :=
  fun (a b : Prop) (h₁ : a ↔ b) (c d : Prop) (h₂ : c ↔ d) => and_congr h₁ h₂

theorem rel_or : lift_fun Iff (Iff ⇒ Iff) Or Or :=
  fun (a b : Prop) (h₁ : a ↔ b) (c d : Prop) (h₂ : c ↔ d) => or_congr h₁ h₂

theorem rel_iff : lift_fun Iff (Iff ⇒ Iff) Iff Iff :=
  fun (a b : Prop) (h₁ : a ↔ b) (c d : Prop) (h₂ : c ↔ d) => iff_congr h₁ h₂

theorem rel_eq {α : Type u_1} {β : Type u_2} {r : α → β → Prop} (hr : bi_unique r) : lift_fun r (r ⇒ Iff) Eq Eq :=
  fun (a : α) (b : β) (h₁ : r a b) (c : α) (d : β) (h₂ : r c d) =>
    { mp := fun (h : a = c) => Eq._oldrec (fun (h₂ : r a d) => and.right hr a b d h₁ h₂) h h₂,
      mpr := fun (h : b = d) => Eq._oldrec (fun (h₂ : r c b) => and.left hr a b c h₁ h₂) h h₂ }


/-
Copyright (c) 2021 Devon Tuma. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Devon Tuma
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.ring_theory.jacobson
import Mathlib.field_theory.algebraic_closure
import Mathlib.field_theory.mv_polynomial
import Mathlib.algebraic_geometry.prime_spectrum
import Mathlib.PostPort

universes u_1 u_2

namespace Mathlib

/-!
# Nullstellensatz
This file establishes a version of Hilbert's classical Nullstellensatz for `mv_polynomial`s.
The main statement of the theorem is `vanishing_ideal_zero_locus_eq_radical`.

The statement is in terms of new definitions `vanishing_ideal` and `zero_locus`.
Mathlib already has versions of these in terms of the prime spectrum of a ring,
  but those are not well-suited for expressing this result.
Suggestions for better ways to state this theorem or organize things are welcome.

The machinery around `vanishing_ideal` and `zero_locus` is also minimal, I only added lemmas
  directly needed in this proof, since I'm not sure if they are the right approach.
-/

namespace mv_polynomial

/-- Set of points that are zeroes of all polynomials in an ideal -/
def zero_locus {k : Type u_1} [field k] {σ : Type u_2} (I : ideal (mv_polynomial σ k)) : set (σ → k) :=
  set_of fun (x : σ → k) => ∀ (p : mv_polynomial σ k), p ∈ I → coe_fn (eval x) p = 0

@[simp] theorem mem_zero_locus_iff {k : Type u_1} [field k] {σ : Type u_2} {I : ideal (mv_polynomial σ k)} {x : σ → k} : x ∈ zero_locus I ↔ ∀ (p : mv_polynomial σ k), p ∈ I → coe_fn (eval x) p = 0 :=
  iff.rfl

theorem zero_locus_anti_mono {k : Type u_1} [field k] {σ : Type u_2} {I : ideal (mv_polynomial σ k)} {J : ideal (mv_polynomial σ k)} (h : I ≤ J) : zero_locus J ≤ zero_locus I :=
  fun (x : σ → k) (hx : x ∈ zero_locus J) (p : mv_polynomial σ k) (hp : p ∈ I) => hx p (h hp)

theorem zero_locus_bot {k : Type u_1} [field k] {σ : Type u_2} : zero_locus ⊥ = ⊤ :=
  iff.mpr eq_top_iff
    fun (x : σ → k) (hx : x ∈ ⊤) (p : mv_polynomial σ k) (hp : p ∈ ⊥) =>
      trans (congr_arg (⇑(eval x)) (iff.mp ideal.mem_bot hp)) (ring_hom.map_zero (eval x))

theorem zero_locus_top {k : Type u_1} [field k] {σ : Type u_2} : zero_locus ⊤ = ⊥ :=
  iff.mpr eq_bot_iff
    fun (x : σ → k) (hx : x ∈ zero_locus ⊤) => one_ne_zero (ring_hom.map_one (eval x) ▸ hx 1 submodule.mem_top)

/-- Ideal of polynomials with common zeroes at all elements of a set -/
def vanishing_ideal {k : Type u_1} [field k] {σ : Type u_2} (V : set (σ → k)) : ideal (mv_polynomial σ k) :=
  submodule.mk (set_of fun (p : mv_polynomial σ k) => ∀ (x : σ → k), x ∈ V → coe_fn (eval x) p = 0) sorry sorry sorry

@[simp] theorem mem_vanishing_ideal_iff {k : Type u_1} [field k] {σ : Type u_2} {V : set (σ → k)} {p : mv_polynomial σ k} : p ∈ vanishing_ideal V ↔ ∀ (x : σ → k), x ∈ V → coe_fn (eval x) p = 0 :=
  iff.rfl

theorem vanishing_ideal_anti_mono {k : Type u_1} [field k] {σ : Type u_2} {A : set (σ → k)} {B : set (σ → k)} (h : A ≤ B) : vanishing_ideal B ≤ vanishing_ideal A :=
  fun (p : mv_polynomial σ k) (hp : p ∈ vanishing_ideal B) (x : σ → k) (hx : x ∈ A) => hp x (h hx)

theorem vanishing_ideal_empty {k : Type u_1} [field k] {σ : Type u_2} : vanishing_ideal ∅ = ⊤ :=
  le_antisymm le_top fun (p : mv_polynomial σ k) (hp : p ∈ ⊤) (x : σ → k) (hx : x ∈ ∅) => absurd hx (set.not_mem_empty x)

theorem le_vanishing_ideal_zero_locus {k : Type u_1} [field k] {σ : Type u_2} (I : ideal (mv_polynomial σ k)) : I ≤ vanishing_ideal (zero_locus I) :=
  fun (p : mv_polynomial σ k) (hp : p ∈ I) (x : σ → k) (hx : x ∈ zero_locus I) => hx p hp

theorem zero_locus_vanishing_ideal_le {k : Type u_1} [field k] {σ : Type u_2} (V : set (σ → k)) : V ≤ zero_locus (vanishing_ideal V) :=
  fun (V_1 : σ → k) (hV : V_1 ∈ V) (p : mv_polynomial σ k) (hp : p ∈ vanishing_ideal V) => hp V_1 hV

theorem zero_locus_vanishing_ideal_galois_connection {k : Type u_1} [field k] {σ : Type u_2} : galois_connection zero_locus vanishing_ideal :=
  fun (I : ideal (mv_polynomial σ k)) (V : order_dual (set (σ → k))) =>
    { mp := fun (h : zero_locus I ≤ V) => le_trans (le_vanishing_ideal_zero_locus I) (vanishing_ideal_anti_mono h),
      mpr := fun (h : I ≤ vanishing_ideal V) => le_trans (zero_locus_anti_mono h) (zero_locus_vanishing_ideal_le V) }

theorem mem_vanishing_ideal_singleton_iff {k : Type u_1} [field k] {σ : Type u_2} (x : σ → k) (p : mv_polynomial σ k) : p ∈ vanishing_ideal (singleton x) ↔ coe_fn (eval x) p = 0 :=
  { mp := fun (h : p ∈ vanishing_ideal (singleton x)) => h x rfl,
    mpr := fun (hpx : coe_fn (eval x) p = 0) (y : σ → k) (hy : y ∈ singleton x) => Eq.symm hy ▸ hpx }

protected instance vanishing_ideal_singleton_is_maximal {k : Type u_1} [field k] {σ : Type u_2} {x : σ → k} : ideal.is_maximal (vanishing_ideal (singleton x)) := sorry

theorem radical_le_vanishing_ideal_zero_locus {k : Type u_1} [field k] {σ : Type u_2} (I : ideal (mv_polynomial σ k)) : ideal.radical I ≤ vanishing_ideal (zero_locus I) := sorry

/-- The point in the prime spectrum assosiated to a given point -/
def point_to_point {k : Type u_1} [field k] {σ : Type u_2} (x : σ → k) : prime_spectrum (mv_polynomial σ k) :=
  { val := vanishing_ideal (singleton x), property := sorry }

@[simp] theorem vanishing_ideal_point_to_point {k : Type u_1} [field k] {σ : Type u_2} (V : set (σ → k)) : prime_spectrum.vanishing_ideal (point_to_point '' V) = vanishing_ideal V := sorry

theorem point_to_point_zero_locus_le {k : Type u_1} [field k] {σ : Type u_2} (I : ideal (mv_polynomial σ k)) : point_to_point '' zero_locus I ≤ prime_spectrum.zero_locus ↑I := sorry

theorem is_maximal_iff_eq_vanishing_ideal_singleton {k : Type u_1} [field k] {σ : Type u_2} [is_alg_closed k] [fintype σ] (I : ideal (mv_polynomial σ k)) : ideal.is_maximal I ↔ ∃ (x : σ → k), I = vanishing_ideal (singleton x) := sorry

/-- Main statement of the Nullstellensatz -/
@[simp] theorem vanishing_ideal_zero_locus_eq_radical {k : Type u_1} [field k] {σ : Type u_2} [is_alg_closed k] [fintype σ] (I : ideal (mv_polynomial σ k)) : vanishing_ideal (zero_locus I) = ideal.radical I := sorry

@[simp] theorem is_prime.vanishing_ideal_zero_locus {k : Type u_1} [field k] {σ : Type u_2} [is_alg_closed k] [fintype σ] (P : ideal (mv_polynomial σ k)) [h : ideal.is_prime P] : vanishing_ideal (zero_locus P) = P :=
  trans (vanishing_ideal_zero_locus_eq_radical P) (ideal.is_prime.radical h)


import tactic.norm_cast

constant cardinal : Type
@[instance] constant cardinal.has_zero : has_zero cardinal
@[instance] constant cardinal.has_one : has_one cardinal
@[instance] constant cardinal.has_add : has_add cardinal
constant cardinal.succ : cardinal → cardinal

@[instance] constant cardinal.has_coe_from_nat : has_coe ℕ cardinal

@[norm_cast] axiom coe_zero : ((0 : ℕ) : cardinal) = 0
@[norm_cast] axiom coe_one : ((1 : ℕ) : cardinal) = 1
@[norm_cast] axiom coe_add {a b : ℕ} : ((a + b : ℕ) : cardinal) = a + b
@[norm_cast] lemma coe_bit0 {a : ℕ} : ((bit0 a : ℕ) : cardinal) = bit0 a := coe_add
@[norm_cast] lemma coe_bit1 {a : ℕ} : ((bit1 a : ℕ) : cardinal) = bit1 a :=
by unfold bit1; norm_cast
@[norm_cast, priority 900] axiom coe_succ {n : ℕ} : (n.succ : cardinal) = cardinal.succ n

example : cardinal.succ 0 = 1 := by norm_cast
example : cardinal.succ 1 = 2 := by norm_cast
example : cardinal.succ 2 = 3 := by norm_cast
example : cardinal.succ 3 = 4 := by norm_cast


/-
Copyright (c) 2017 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro, Yaël Dillies, Bhavik Mehta

! This file was ported from Lean 3 source module data.finset.sigma
! leanprover-community/mathlib commit 9003f28797c0664a49e4179487267c494477d853
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Data.Finset.Lattice
import Mathlib.Data.Set.Sigma

/-!
# Finite sets in a sigma type

This file defines a few `Finset` constructions on `Σ i, α i`.

## Main declarations

* `Finset.sigma`: Given a finset `s` in `ι` and finsets `t i` in each `α i`, `s.sigma t` is the
  finset of the dependent sum `Σ i, α i`
* `Finset.sigmaLift`: Lifts maps `α i → β i → Finset (γ i)` to a map
  `Σ i, α i → Σ i, β i → Finset (Σ i, γ i)`.

## TODO

`Finset.sigmaLift` can be generalized to any alternative functor. But to make the generalization
worth it, we must first refactor the functor library so that the `alternative` instance for `Finset`
is computable and universe-polymorphic.
-/

open Function Multiset

variable {ι : Type _}

namespace Finset

section Sigma

variable {α : ι → Type _} {β : Type _} (s s₁ s₂ : Finset ι) (t t₁ t₂ : ∀ i, Finset (α i))

/-- `s.sigma t` is the finset of dependent pairs `⟨i, a⟩` such that `i ∈ s` and `a ∈ t i`. -/
protected def sigma : Finset (Σi, α i) :=
  ⟨_, s.nodup.sigma fun i => (t i).nodup⟩
#align finset.sigma Finset.sigma

variable {s s₁ s₂ t t₁ t₂}

@[simp]
theorem mem_sigma {a : Σi, α i} : a ∈ s.sigma t ↔ a.1 ∈ s ∧ a.2 ∈ t a.1 :=
  Multiset.mem_sigma
#align finset.mem_sigma Finset.mem_sigma

@[simp, norm_cast]
theorem coe_sigma (s : Finset ι) (t : ∀ i, Finset (α i)) :
    (s.sigma t : Set (Σi, α i)) = (s : Set ι).Sigma fun i => (t i : Set (α i)) :=
  Set.ext fun _ => mem_sigma
#align finset.coe_sigma Finset.coe_sigma

@[simp]
theorem sigma_nonempty : (s.sigma t).Nonempty ↔ ∃ i ∈ s, (t i).Nonempty := by simp [Finset.Nonempty]
#align finset.sigma_nonempty Finset.sigma_nonempty

@[simp]
theorem sigma_eq_empty : s.sigma t = ∅ ↔ ∀ i ∈ s, t i = ∅ := by
  simp only [← not_nonempty_iff_eq_empty, sigma_nonempty, not_exists, not_and]
#align finset.sigma_eq_empty Finset.sigma_eq_empty

@[mono]
theorem sigma_mono (hs : s₁ ⊆ s₂) (ht : ∀ i, t₁ i ⊆ t₂ i) : s₁.sigma t₁ ⊆ s₂.sigma t₂ :=
  fun ⟨i, _⟩ h =>
  let ⟨hi, ha⟩ := mem_sigma.1 h
  mem_sigma.2 ⟨hs hi, ht i ha⟩
#align finset.sigma_mono Finset.sigma_mono

theorem pairwiseDisjoint_map_sigmaMk :
    (s : Set ι).PairwiseDisjoint fun i => (t i).map (Embedding.sigmaMk i) := by
  intro i _ j _ hij
  rw [Function.onFun, disjoint_left]
  simp_rw [mem_map, Function.Embedding.sigmaMk_apply]
  rintro _ ⟨y, _, rfl⟩ ⟨z, _, hz'⟩
  exact hij (congr_arg Sigma.fst hz'.symm)
#align finset.pairwise_disjoint_map_sigma_mk Finset.pairwiseDisjoint_map_sigmaMk

@[simp]
theorem disjUnionᵢ_map_sigma_mk :
    s.disjUnionᵢ (fun i => (t i).map (Embedding.sigmaMk i)) pairwiseDisjoint_map_sigmaMk =
      s.sigma t :=
  rfl
#align finset.disj_Union_map_sigma_mk Finset.disjUnionᵢ_map_sigma_mk

theorem sigma_eq_bunionᵢ [DecidableEq (Σi, α i)] (s : Finset ι) (t : ∀ i, Finset (α i)) :
    s.sigma t = s.bunionᵢ fun i => (t i).map <| Embedding.sigmaMk i := by
  ext ⟨x, y⟩
  simp [and_left_comm]
#align finset.sigma_eq_bUnion Finset.sigma_eq_bunionᵢ

variable (s t) (f : (Σi, α i) → β)

theorem sup_sigma [SemilatticeSup β] [OrderBot β] :
    (s.sigma t).sup f = s.sup fun i => (t i).sup fun b => f ⟨i, b⟩ :=
  by
  simp only [le_antisymm_iff, Finset.sup_le_iff, mem_sigma, and_imp, Sigma.forall]
  exact
    ⟨fun i a hi ha => (le_sup hi).trans' <| le_sup (f := fun a => f ⟨i, a⟩) ha, fun i hi a ha =>
      le_sup <| mem_sigma.2 ⟨hi, ha⟩⟩
#align finset.sup_sigma Finset.sup_sigma

theorem inf_sigma [SemilatticeInf β] [OrderTop β] :
    (s.sigma t).inf f = s.inf fun i => (t i).inf fun b => f ⟨i, b⟩ :=
  @sup_sigma _ _ βᵒᵈ _ _ _ _ _
#align finset.inf_sigma Finset.inf_sigma

end Sigma

section SigmaLift

variable {α β γ : ι → Type _} [DecidableEq ι]

/-- Lifts maps `α i → β i → Finset (γ i)` to a map `Σ i, α i → Σ i, β i → Finset (Σ i, γ i)`. -/
def sigmaLift (f : ∀ ⦃i⦄, α i → β i → Finset (γ i)) (a : Sigma α) (b : Sigma β) :
    Finset (Sigma γ) :=
  dite (a.1 = b.1) (fun h => (f (h ▸ a.2) b.2).map <| Embedding.sigmaMk _) fun _ => ∅
#align finset.sigma_lift Finset.sigmaLift

theorem mem_sigmaLift (f : ∀ ⦃i⦄, α i → β i → Finset (γ i)) (a : Sigma α) (b : Sigma β)
    (x : Sigma γ) :
    x ∈ sigmaLift f a b ↔ ∃ (ha : a.1 = x.1)(hb : b.1 = x.1), x.2 ∈ f (ha ▸ a.2) (hb ▸ b.2) :=
  by
  obtain ⟨⟨i, a⟩, j, b⟩ := a, b
  obtain rfl | h := Decidable.eq_or_ne i j
  · constructor
    · simp_rw [sigmaLift, dif_pos rfl, mem_map, Embedding.sigmaMk_apply]
      simp only [dite_eq_ite, ite_true, mem_map, Embedding.sigmaMk_apply, forall_exists_index,
        and_imp]
      rintro x hx rfl
      exact ⟨rfl, rfl, hx⟩
    · rintro ⟨⟨⟩, ⟨⟩, hx⟩
      rw [sigmaLift, dif_pos rfl, mem_map]
      exact ⟨_, hx, by simp [Sigma.ext_iff]⟩
  · rw [sigmaLift, dif_neg h]
    refine' iff_of_false (not_mem_empty _) _
    rintro ⟨⟨⟩, ⟨⟩, _⟩
    exact h rfl
#align finset.mem_sigma_lift Finset.mem_sigmaLift

theorem mk_mem_sigmaLift (f : ∀ ⦃i⦄, α i → β i → Finset (γ i)) (i : ι) (a : α i) (b : β i)
    (x : γ i) : (⟨i, x⟩ : Sigma γ) ∈ sigmaLift f ⟨i, a⟩ ⟨i, b⟩ ↔ x ∈ f a b :=
  by
  rw [sigmaLift, dif_pos rfl, mem_map]
  refine' ⟨_, fun hx => ⟨_, hx, rfl⟩⟩
  rintro ⟨x, hx, _, rfl⟩
  exact hx
#align finset.mk_mem_sigma_lift Finset.mk_mem_sigmaLift

theorem not_mem_sigmaLift_of_ne_left (f : ∀ ⦃i⦄, α i → β i → Finset (γ i)) (a : Sigma α)
    (b : Sigma β) (x : Sigma γ) (h : a.1 ≠ x.1) : x ∉ sigmaLift f a b := by
  rw [mem_sigmaLift]
  exact fun H => h H.fst
#align finset.not_mem_sigma_lift_of_ne_left Finset.not_mem_sigmaLift_of_ne_left

theorem not_mem_sigmaLift_of_ne_right (f : ∀ ⦃i⦄, α i → β i → Finset (γ i)) {a : Sigma α}
    (b : Sigma β) {x : Sigma γ} (h : b.1 ≠ x.1) : x ∉ sigmaLift f a b := by
  rw [mem_sigmaLift]
  exact fun H => h H.snd.fst
#align finset.not_mem_sigma_lift_of_ne_right Finset.not_mem_sigmaLift_of_ne_right

variable {f g : ∀ ⦃i⦄, α i → β i → Finset (γ i)} {a : Σi, α i} {b : Σi, β i}

theorem sigmaLift_nonempty :
    (sigmaLift f a b).Nonempty ↔ ∃ h : a.1 = b.1, (f (h ▸ a.2) b.2).Nonempty := by
  simp_rw [nonempty_iff_ne_empty, sigmaLift]
  split_ifs with h <;> simp [h]
#align finset.sigma_lift_nonempty Finset.sigmaLift_nonempty

theorem sigmaLift_eq_empty : sigmaLift f a b = ∅ ↔ ∀ h : a.1 = b.1, f (h ▸ a.2) b.2 = ∅ := by
  simp_rw [nonempty_iff_ne_empty, sigmaLift]
  split_ifs with h
  . simp [h, forall_prop_of_true h]
  . simp [h, forall_prop_of_false h]
#align finset.sigma_lift_eq_empty Finset.sigmaLift_eq_empty

theorem sigmaLift_mono (h : ∀ ⦃i⦄ ⦃a : α i⦄ ⦃b : β i⦄, f a b ⊆ g a b) (a : Σi, α i) (b : Σi, β i) :
    sigmaLift f a b ⊆ sigmaLift g a b := by
  rintro x hx
  rw [mem_sigmaLift] at hx⊢
  obtain ⟨ha, hb, hx⟩ := hx
  exact ⟨ha, hb, h hx⟩
#align finset.sigma_lift_mono Finset.sigmaLift_mono

variable (f a b)

theorem card_sigmaLift :
    (sigmaLift f a b).card = dite (a.1 = b.1) (fun h => (f (h ▸ a.2) b.2).card) fun _ => 0 := by
  simp_rw [nonempty_iff_ne_empty, sigmaLift]
  split_ifs with h <;> simp [h]
#align finset.card_sigma_lift Finset.card_sigmaLift

end SigmaLift

end Finset


/-
Copyright (c) 2019 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin, Floris van Doorn
-/
import algebra.module.basic
import data.set.pairwise.lattice
import data.set.pointwise.basic
import tactic.by_contra

/-!
# Pointwise operations of sets

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

This file defines pointwise algebraic operations on sets.

## Main declarations

For sets `s` and `t` and scalar `a`:
* `s • t`: Scalar multiplication, set of all `x • y` where `x ∈ s` and `y ∈ t`.
* `s +ᵥ t`: Scalar addition, set of all `x +ᵥ y` where `x ∈ s` and `y ∈ t`.
* `s -ᵥ t`: Scalar subtraction, set of all `x -ᵥ y` where `x ∈ s` and `y ∈ t`.
* `a • s`: Scaling, set of all `a • x` where `x ∈ s`.
* `a +ᵥ s`: Translation, set of all `a +ᵥ x` where `x ∈ s`.

For `α` a semigroup/monoid, `set α` is a semigroup/monoid.

Appropriate definitions and results are also transported to the additive theory via `to_additive`.

## Implementation notes

* We put all instances in the locale `pointwise`, so that these instances are not available by
  default. Note that we do not mark them as reducible (as argued by note [reducible non-instances])
  since we expect the locale to be open whenever the instances are actually used (and making the
  instances reducible changes the behavior of `simp`.

-/

open function mul_opposite

variables {F α β γ : Type*}

namespace set

open_locale pointwise

/-! ### Translation/scaling of sets -/

section smul

/-- The dilation of set `x • s` is defined as `{x • y | y ∈ s}` in locale `pointwise`. -/
@[to_additive "The translation of set `x +ᵥ s` is defined as `{x +ᵥ y | y ∈ s}` in
locale `pointwise`."]
protected def has_smul_set [has_smul α β] : has_smul α (set β) :=
⟨λ a, image (has_smul.smul a)⟩

/-- The pointwise scalar multiplication of sets `s • t` is defined as `{x • y | x ∈ s, y ∈ t}` in
locale `pointwise`. -/
@[to_additive "The pointwise scalar addition of sets `s +ᵥ t` is defined as
`{x +ᵥ y | x ∈ s, y ∈ t}` in locale `pointwise`."]
protected def has_smul [has_smul α β] : has_smul (set α) (set β) :=
⟨image2 has_smul.smul⟩

localized "attribute [instance] set.has_smul_set set.has_smul" in pointwise
localized "attribute [instance] set.has_vadd_set set.has_vadd" in pointwise

section has_smul
variables {ι : Sort*} {κ : ι → Sort*} [has_smul α β] {s s₁ s₂ : set α} {t t₁ t₂ u : set β} {a : α}
  {b : β}

@[simp, to_additive]
lemma image2_smul : image2 has_smul.smul s t = s • t := rfl

@[to_additive add_image_prod]
lemma image_smul_prod : (λ x : α × β, x.fst • x.snd) '' s ×ˢ t = s • t := image_prod _

@[to_additive]
lemma mem_smul : b ∈ s • t ↔ ∃ x y, x ∈ s ∧ y ∈ t ∧ x • y = b := iff.rfl

@[to_additive] lemma smul_mem_smul : a ∈ s → b ∈ t → a • b ∈ s • t := mem_image2_of_mem

@[simp, to_additive] lemma empty_smul : (∅ : set α) • t = ∅ := image2_empty_left
@[simp, to_additive] lemma smul_empty : s • (∅ : set β) = ∅ := image2_empty_right
@[simp, to_additive] lemma smul_eq_empty : s • t = ∅ ↔ s = ∅ ∨ t = ∅ := image2_eq_empty_iff
@[simp, to_additive] lemma smul_nonempty : (s • t).nonempty ↔ s.nonempty ∧ t.nonempty :=
image2_nonempty_iff
@[to_additive] lemma nonempty.smul : s.nonempty → t.nonempty → (s • t).nonempty := nonempty.image2
@[to_additive] lemma nonempty.of_smul_left : (s • t).nonempty → s.nonempty :=
nonempty.of_image2_left
@[to_additive] lemma nonempty.of_smul_right : (s • t).nonempty → t.nonempty :=
nonempty.of_image2_right
@[simp, to_additive] lemma smul_singleton : s • {b} = (• b) '' s := image2_singleton_right
@[simp, to_additive] lemma singleton_smul : ({a} : set α) • t = a • t := image2_singleton_left
@[simp, to_additive] lemma singleton_smul_singleton : ({a} : set α) • ({b} : set β) = {a • b} :=
image2_singleton

@[to_additive, mono] lemma smul_subset_smul : s₁ ⊆ s₂ → t₁ ⊆ t₂ → s₁ • t₁ ⊆ s₂ • t₂ := image2_subset
@[to_additive] lemma smul_subset_smul_left : t₁ ⊆ t₂ → s • t₁ ⊆ s • t₂ := image2_subset_left
@[to_additive] lemma smul_subset_smul_right : s₁ ⊆ s₂ → s₁ • t ⊆ s₂ • t := image2_subset_right
@[to_additive] lemma smul_subset_iff : s • t ⊆ u ↔ ∀ (a ∈ s) (b ∈ t), a • b ∈ u := image2_subset_iff

attribute [mono] vadd_subset_vadd

@[to_additive] lemma union_smul : (s₁ ∪ s₂) • t = s₁ • t ∪ s₂ • t := image2_union_left
@[to_additive] lemma smul_union : s • (t₁ ∪ t₂) = s • t₁ ∪ s • t₂ := image2_union_right
@[to_additive] lemma inter_smul_subset : (s₁ ∩ s₂) • t ⊆ s₁ • t ∩ s₂ • t := image2_inter_subset_left
@[to_additive] lemma smul_inter_subset : s • (t₁ ∩ t₂) ⊆ s • t₁ ∩ s • t₂ :=
image2_inter_subset_right
@[to_additive] lemma inter_smul_union_subset_union :
  (s₁ ∩ s₂) • (t₁ ∪ t₂) ⊆ (s₁ • t₁) ∪ (s₂ • t₂) :=
image2_inter_union_subset_union
@[to_additive] lemma union_smul_inter_subset_union :
  (s₁ ∪ s₂) • (t₁ ∩ t₂) ⊆ (s₁ • t₁) ∪ (s₂ • t₂) :=
image2_union_inter_subset_union

@[to_additive] lemma Union_smul_left_image : (⋃ a ∈ s, a • t) = s • t := Union_image_left _
@[to_additive] lemma Union_smul_right_image : (⋃ a ∈ t, (• a) '' s) = s • t := Union_image_right _

@[to_additive] lemma Union_smul (s : ι → set α) (t : set β) : (⋃ i, s i) • t = ⋃ i, s i • t :=
image2_Union_left _ _ _
@[to_additive] lemma smul_Union (s : set α) (t : ι → set β) : s • (⋃ i, t i) = ⋃ i, s • t i :=
image2_Union_right _ _ _

@[to_additive]
lemma Union₂_smul (s : Π i, κ i → set α) (t : set β) : (⋃ i j, s i j) • t = ⋃ i j, s i j • t :=
image2_Union₂_left _ _ _

@[to_additive]

@[to_additive]
lemma Inter_smul_subset (s : ι → set α) (t : set β) : (⋂ i, s i) • t ⊆ ⋂ i, s i • t :=
image2_Inter_subset_left _ _ _

@[to_additive]
lemma smul_Inter_subset (s : set α) (t : ι → set β) : s • (⋂ i, t i) ⊆ ⋂ i, s • t i :=
image2_Inter_subset_right _ _ _

@[to_additive]
lemma Inter₂_smul_subset (s : Π i, κ i → set α) (t : set β) :
  (⋂ i j, s i j) • t ⊆ ⋂ i j, s i j • t :=
image2_Inter₂_subset_left _ _ _

@[to_additive]
lemma smul_Inter₂_subset (s : set α) (t : Π i, κ i → set β) :
  s • (⋂ i j, t i j) ⊆ ⋂ i j, s • t i j :=
image2_Inter₂_subset_right _ _ _

@[to_additive] lemma smul_set_subset_smul {s : set α} : a ∈ s → a • t ⊆ s • t :=
image_subset_image2_right

@[simp, to_additive] lemma bUnion_smul_set (s : set α) (t : set β) :
  (⋃ a ∈ s, a • t) = s • t :=
Union_image_left _

end has_smul

section has_smul_set
variables {ι : Sort*} {κ : ι → Sort*} [has_smul α β] {s t t₁ t₂ : set β} {a : α} {b : β} {x y : β}

@[simp, to_additive] lemma image_smul : (λ x, a • x) '' t = a • t := rfl

@[to_additive] lemma mem_smul_set : x ∈ a • t ↔ ∃ y, y ∈ t ∧ a • y = x := iff.rfl

@[to_additive] lemma smul_mem_smul_set : b ∈ s → a • b ∈ a • s := mem_image_of_mem _

@[simp, to_additive] lemma smul_set_empty : a • (∅ : set β) = ∅ := image_empty _
@[simp, to_additive] lemma smul_set_eq_empty : a • s = ∅ ↔ s = ∅ := image_eq_empty
@[simp, to_additive] lemma smul_set_nonempty : (a • s).nonempty ↔ s.nonempty := nonempty_image_iff

@[simp, to_additive] lemma smul_set_singleton : a • ({b} : set β) = {a • b} := image_singleton

@[to_additive] lemma smul_set_mono : s ⊆ t → a • s ⊆ a • t := image_subset _
@[to_additive] lemma smul_set_subset_iff : a • s ⊆ t ↔ ∀ ⦃b⦄, b ∈ s → a • b ∈ t := image_subset_iff

@[to_additive] lemma smul_set_union : a • (t₁ ∪ t₂) = a • t₁ ∪ a • t₂ := image_union _ _ _

@[to_additive]
lemma smul_set_inter_subset : a • (t₁ ∩ t₂) ⊆ a • t₁ ∩ (a • t₂) := image_inter_subset _ _ _

@[to_additive]
lemma smul_set_Union (a : α) (s : ι → set β) : a • (⋃ i, s i) = ⋃ i, a • s i := image_Union

@[to_additive]
lemma smul_set_Union₂ (a : α) (s : Π i, κ i → set β) : a • (⋃ i j, s i j) = ⋃ i j, a • s i j :=
image_Union₂ _ _

@[to_additive]
lemma smul_set_Inter_subset (a : α) (t : ι → set β) : a • (⋂ i, t i) ⊆ ⋂ i, a • t i :=
image_Inter_subset _ _

@[to_additive]
lemma smul_set_Inter₂_subset (a : α) (t : Π i, κ i → set β) :
  a • (⋂ i j, t i j) ⊆ ⋂ i j, a • t i j :=
image_Inter₂_subset _ _

@[to_additive] lemma nonempty.smul_set : s.nonempty → (a • s).nonempty := nonempty.image _

end has_smul_set

section has_mul
variables [has_mul α] {s t u : set α} {a : α}

@[to_additive] lemma op_smul_set_subset_mul : a ∈ t → op a • s ⊆ s * t := image_subset_image2_left

@[simp, to_additive] lemma bUnion_op_smul_set (s t : set α) : (⋃ a ∈ t, op a • s) = s * t :=
Union_image_right _

@[to_additive] lemma mul_subset_iff_left : s * t ⊆ u ↔ ∀ a ∈ s, a • t ⊆ u := image2_subset_iff_left
@[to_additive] lemma mul_subset_iff_right : s * t ⊆ u ↔ ∀ b ∈ t, op b • s ⊆ u :=
image2_subset_iff_right

end has_mul

variables {s s₁ s₂ : set α} {t t₁ t₂ : set β} {a : α} {b : β}

@[to_additive]
theorem range_smul_range {ι κ : Type*} [has_smul α β] (b : ι → α) (c : κ → β) :
  range b • range c = range (λ p : ι × κ, b p.1 • c p.2) :=
ext $ λ x, ⟨λ hx, let ⟨p, q, ⟨i, hi⟩, ⟨j, hj⟩, hpq⟩ := set.mem_smul.1 hx in
  ⟨(i, j), hpq ▸ hi ▸ hj ▸ rfl⟩,
λ ⟨⟨i, j⟩, h⟩, set.mem_smul.2 ⟨b i, c j, ⟨i, rfl⟩, ⟨j, rfl⟩, h⟩⟩

@[to_additive] lemma smul_set_range [has_smul α β] {ι : Sort*} {f : ι → β} :
  a • range f = range (λ i, a • f i) := (range_comp _ _).symm

@[to_additive]
instance smul_comm_class_set [has_smul α γ] [has_smul β γ] [smul_comm_class α β γ] :
  smul_comm_class α β (set γ) :=
⟨λ _ _, commute.set_image $ smul_comm _ _⟩

@[to_additive]
instance smul_comm_class_set' [has_smul α γ] [has_smul β γ] [smul_comm_class α β γ] :
  smul_comm_class α (set β) (set γ) :=
⟨λ _ _ _, image_image2_distrib_right $ smul_comm _⟩

@[to_additive]
instance smul_comm_class_set'' [has_smul α γ] [has_smul β γ] [smul_comm_class α β γ] :
  smul_comm_class (set α) β (set γ) :=
by haveI := smul_comm_class.symm α β γ; exact smul_comm_class.symm _ _ _

@[to_additive]
instance smul_comm_class [has_smul α γ] [has_smul β γ] [smul_comm_class α β γ] :
  smul_comm_class (set α) (set β) (set γ) :=
⟨λ _ _ _, image2_left_comm smul_comm⟩

@[to_additive]
instance is_scalar_tower [has_smul α β] [has_smul α γ] [has_smul β γ] [is_scalar_tower α β γ] :
  is_scalar_tower α β (set γ) :=
{ smul_assoc := λ a b T, by simp only [←image_smul, image_image, smul_assoc] }

@[to_additive]
instance is_scalar_tower' [has_smul α β] [has_smul α γ] [has_smul β γ] [is_scalar_tower α β γ] :
  is_scalar_tower α (set β) (set γ) :=
⟨λ _ _ _, image2_image_left_comm $ smul_assoc _⟩

@[to_additive]
instance is_scalar_tower'' [has_smul α β] [has_smul α γ] [has_smul β γ] [is_scalar_tower α β γ] :
  is_scalar_tower (set α) (set β) (set γ) :=
{ smul_assoc := λ T T' T'', image2_assoc smul_assoc }

@[to_additive]
instance is_central_scalar [has_smul α β] [has_smul αᵐᵒᵖ β] [is_central_scalar α β] :
  is_central_scalar α (set β) :=
⟨λ a S, congr_arg (λ f, f '' S) $ by exact funext (λ _, op_smul_eq_smul _ _)⟩

/-- A multiplicative action of a monoid `α` on a type `β` gives a multiplicative action of `set α`
on `set β`. -/
@[to_additive "An additive action of an additive monoid `α` on a type `β` gives an additive action
of `set α` on `set β`"]
protected def mul_action [monoid α] [mul_action α β] : mul_action (set α) (set β) :=
{ mul_smul := λ _ _ _, image2_assoc mul_smul,
  one_smul := λ s, image2_singleton_left.trans $ by simp_rw [one_smul, image_id'] }

/-- A multiplicative action of a monoid on a type `β` gives a multiplicative action on `set β`. -/
@[to_additive "An additive action of an additive monoid on a type `β` gives an additive action
on `set β`."]
protected def mul_action_set [monoid α] [mul_action α β] : mul_action α (set β) :=
{ mul_smul := by { intros, simp only [← image_smul, image_image, ← mul_smul] },
  one_smul := by { intros, simp only [← image_smul, one_smul, image_id'] } }

localized "attribute [instance] set.mul_action_set set.add_action_set
  set.mul_action set.add_action" in pointwise

/-- A distributive multiplicative action of a monoid on an additive monoid `β` gives a distributive
multiplicative action on `set β`. -/
protected def distrib_mul_action_set [monoid α] [add_monoid β] [distrib_mul_action α β] :
  distrib_mul_action α (set β) :=
{ smul_add := λ _ _ _, image_image2_distrib $ smul_add _,
  smul_zero := λ _, image_singleton.trans $ by rw [smul_zero, singleton_zero] }

/-- A multiplicative action of a monoid on a monoid `β` gives a multiplicative action on `set β`. -/
protected def mul_distrib_mul_action_set [monoid α] [monoid β] [mul_distrib_mul_action α β] :
  mul_distrib_mul_action α (set β) :=
{ smul_mul := λ _ _ _, image_image2_distrib $ smul_mul' _,
  smul_one := λ _, image_singleton.trans $ by rw [smul_one, singleton_one] }

localized "attribute [instance] set.distrib_mul_action_set set.mul_distrib_mul_action_set"
  in pointwise

instance [has_zero α] [has_zero β] [has_smul α β] [no_zero_smul_divisors α β] :
  no_zero_smul_divisors (set α) (set β) :=
⟨λ s t h, begin
  by_contra' H,
  have hst : (s • t).nonempty := h.symm.subst zero_nonempty,
  simp_rw [←hst.of_smul_left.subset_zero_iff, ←hst.of_smul_right.subset_zero_iff, not_subset,
    mem_zero] at H,
  obtain ⟨⟨a, hs, ha⟩, b, ht, hb⟩ := H,
  exact (eq_zero_or_eq_zero_of_smul_eq_zero $ h.subset $ smul_mem_smul hs ht).elim ha hb,
end⟩

instance no_zero_smul_divisors_set [has_zero α] [has_zero β] [has_smul α β]
  [no_zero_smul_divisors α β] : no_zero_smul_divisors α (set β) :=
⟨λ a s h, begin
  by_contra' H,
  have hst : (a • s).nonempty := h.symm.subst zero_nonempty,
  simp_rw [←hst.of_image.subset_zero_iff, not_subset, mem_zero] at H,
  obtain ⟨ha, b, ht, hb⟩ := H,
  exact (eq_zero_or_eq_zero_of_smul_eq_zero $ h.subset $ smul_mem_smul_set ht).elim ha hb,
end⟩

instance [has_zero α] [has_mul α] [no_zero_divisors α] : no_zero_divisors (set α) :=
⟨λ s t h, eq_zero_or_eq_zero_of_smul_eq_zero h⟩

end smul

section vsub
variables {ι : Sort*} {κ : ι → Sort*} [has_vsub α β] {s s₁ s₂ t t₁ t₂ : set β} {u : set α} {a : α}
  {b c : β}
include α

instance has_vsub : has_vsub (set α) (set β) := ⟨image2 (-ᵥ)⟩

@[simp] lemma image2_vsub : (image2 has_vsub.vsub s t : set α) = s -ᵥ t := rfl

lemma image_vsub_prod : (λ x : β × β, x.fst -ᵥ x.snd) '' s ×ˢ t = s -ᵥ t := image_prod _

lemma mem_vsub : a ∈ s -ᵥ t ↔ ∃ x y, x ∈ s ∧ y ∈ t ∧ x -ᵥ y = a := iff.rfl

lemma vsub_mem_vsub (hb : b ∈ s) (hc : c ∈ t) : b -ᵥ c ∈ s -ᵥ t := mem_image2_of_mem hb hc

@[simp] lemma empty_vsub (t : set β) : ∅ -ᵥ t = ∅ := image2_empty_left
@[simp] lemma vsub_empty (s : set β) : s -ᵥ ∅ = ∅ := image2_empty_right
@[simp] lemma vsub_eq_empty : s -ᵥ t = ∅ ↔ s = ∅ ∨ t = ∅ := image2_eq_empty_iff
@[simp] lemma vsub_nonempty : (s -ᵥ t : set α).nonempty ↔ s.nonempty ∧ t.nonempty :=
image2_nonempty_iff
lemma nonempty.vsub : s.nonempty → t.nonempty → (s -ᵥ t : set α).nonempty := nonempty.image2
lemma nonempty.of_vsub_left : (s -ᵥ t :set α).nonempty → s.nonempty := nonempty.of_image2_left
lemma nonempty.of_vsub_right : (s -ᵥ t : set α).nonempty → t.nonempty := nonempty.of_image2_right
@[simp] lemma vsub_singleton (s : set β) (b : β) : s -ᵥ {b} = (-ᵥ b) '' s := image2_singleton_right
@[simp] lemma singleton_vsub (t : set β) (b : β) : {b} -ᵥ t = ((-ᵥ) b) '' t := image2_singleton_left
@[simp] lemma singleton_vsub_singleton : ({b} : set β) -ᵥ {c} = {b -ᵥ c} := image2_singleton

@[mono] lemma vsub_subset_vsub : s₁ ⊆ s₂ → t₁ ⊆ t₂ → s₁ -ᵥ t₁ ⊆ s₂ -ᵥ t₂ := image2_subset
lemma vsub_subset_vsub_left : t₁ ⊆ t₂ → s -ᵥ t₁ ⊆ s -ᵥ t₂ := image2_subset_left
lemma vsub_subset_vsub_right : s₁ ⊆ s₂ → s₁ -ᵥ t ⊆ s₂ -ᵥ t := image2_subset_right
lemma vsub_subset_iff : s -ᵥ t ⊆ u ↔ ∀ (x ∈ s) (y ∈ t), x -ᵥ y ∈ u := image2_subset_iff
lemma vsub_self_mono (h : s ⊆ t) : s -ᵥ s ⊆ t -ᵥ t := vsub_subset_vsub h h

lemma union_vsub : (s₁ ∪ s₂) -ᵥ t = s₁ -ᵥ t ∪ (s₂ -ᵥ t) := image2_union_left
lemma vsub_union : s -ᵥ (t₁ ∪ t₂) = s -ᵥ t₁ ∪ (s -ᵥ t₂) := image2_union_right
lemma inter_vsub_subset : s₁ ∩ s₂ -ᵥ t ⊆ (s₁ -ᵥ t) ∩ (s₂ -ᵥ t) := image2_inter_subset_left
lemma vsub_inter_subset : s -ᵥ t₁ ∩ t₂ ⊆ (s -ᵥ t₁) ∩ (s -ᵥ t₂) := image2_inter_subset_right
lemma inter_vsub_union_subset_union : (s₁ ∩ s₂) -ᵥ (t₁ ∪ t₂) ⊆ (s₁ -ᵥ t₁) ∪ (s₂ -ᵥ t₂) :=
image2_inter_union_subset_union
lemma union_vsub_inter_subset_union : (s₁ ∪ s₂) -ᵥ (t₁ ∩ t₂) ⊆ (s₁ -ᵥ t₁) ∪ (s₂ -ᵥ t₂) :=
image2_union_inter_subset_union

lemma Union_vsub_left_image : (⋃ a ∈ s, ((-ᵥ) a) '' t) = s -ᵥ t := Union_image_left _
lemma Union_vsub_right_image : (⋃ a ∈ t, (-ᵥ a) '' s) = s -ᵥ t := Union_image_right _

lemma Union_vsub (s : ι → set β) (t : set β) : (⋃ i, s i) -ᵥ t = ⋃ i, s i -ᵥ t :=
image2_Union_left _ _ _
lemma vsub_Union (s : set β) (t : ι → set β) : s -ᵥ (⋃ i, t i) = ⋃ i, s -ᵥ t i :=
image2_Union_right _ _ _

lemma Union₂_vsub (s : Π i, κ i → set β) (t : set β) : (⋃ i j, s i j) -ᵥ t = ⋃ i j, s i j -ᵥ t :=
image2_Union₂_left _ _ _

lemma vsub_Union₂ (s : set β) (t : Π i, κ i → set β) : s -ᵥ (⋃ i j, t i j) = ⋃ i j, s -ᵥ t i j :=
image2_Union₂_right _ _ _

lemma Inter_vsub_subset (s : ι → set β) (t : set β) : (⋂ i, s i) -ᵥ t ⊆ ⋂ i, s i -ᵥ t :=
image2_Inter_subset_left _ _ _

lemma vsub_Inter_subset (s : set β) (t : ι → set β) : s -ᵥ (⋂ i, t i) ⊆ ⋂ i, s -ᵥ t i :=
image2_Inter_subset_right _ _ _

lemma Inter₂_vsub_subset (s : Π i, κ i → set β) (t : set β) :
  (⋂ i j, s i j) -ᵥ t ⊆ ⋂ i j, s i j -ᵥ t :=
image2_Inter₂_subset_left _ _ _

lemma vsub_Inter₂_subset (s : set β) (t : Π i, κ i → set β) :
  s -ᵥ (⋂ i j, t i j) ⊆ ⋂ i j, s -ᵥ t i j :=
image2_Inter₂_subset_right _ _ _

end vsub

open_locale pointwise

@[to_additive] lemma image_smul_comm [has_smul α β] [has_smul α γ] (f : β → γ) (a : α) (s : set β) :
  (∀ b, f (a • b) = a • f b) → f '' (a • s) = a • f '' s :=
image_comm

@[to_additive] lemma image_smul_distrib [mul_one_class α] [mul_one_class β] [monoid_hom_class F α β]
  (f : F) (a : α) (s : set α) :
  f '' (a • s) = f a • f '' s :=
image_comm $ map_mul _ _

section has_smul
variables[has_smul αᵐᵒᵖ β] [has_smul β γ] [has_smul α γ]

-- TODO: replace hypothesis and conclusion with a typeclass
@[to_additive] lemma op_smul_set_smul_eq_smul_smul_set (a : α) (s : set β) (t : set γ)
  (h : ∀ (a : α) (b : β) (c : γ), (op a • b) • c = b • a • c) :
  (op a • s) • t = s • a • t :=
by { ext, simp [mem_smul, mem_smul_set, h] }

end has_smul

section smul_with_zero
variables [has_zero α] [has_zero β] [smul_with_zero α β] {s : set α} {t : set β}

/-!
Note that we have neither `smul_with_zero α (set β)` nor `smul_with_zero (set α) (set β)`
because `0 * ∅ ≠ 0`.
-/

lemma smul_zero_subset (s : set α) : s • (0 : set β) ⊆ 0 := by simp [subset_def, mem_smul]
lemma zero_smul_subset (t : set β) : (0 : set α) • t ⊆ 0 := by simp [subset_def, mem_smul]

lemma nonempty.smul_zero (hs : s.nonempty) : s • (0 : set β) = 0 :=
s.smul_zero_subset.antisymm $ by simpa [mem_smul] using hs

lemma nonempty.zero_smul (ht : t.nonempty) : (0 : set α) • t = 0 :=
t.zero_smul_subset.antisymm $ by simpa [mem_smul] using ht

/-- A nonempty set is scaled by zero to the singleton set containing 0. -/
lemma zero_smul_set {s : set β} (h : s.nonempty) : (0 : α) • s = (0 : set β) :=
by simp only [← image_smul, image_eta, zero_smul, h.image_const, singleton_zero]

lemma zero_smul_set_subset (s : set β) : (0 : α) • s ⊆ 0 :=
image_subset_iff.2 $ λ x _, zero_smul α x

lemma subsingleton_zero_smul_set (s : set β) : ((0 : α) • s).subsingleton :=
subsingleton_singleton.anti $ zero_smul_set_subset s

lemma zero_mem_smul_set {t : set β} {a : α} (h : (0 : β) ∈ t) : (0 : β) ∈ a • t :=
⟨0, h, smul_zero _⟩

variables [no_zero_smul_divisors α β] {a : α}

lemma zero_mem_smul_iff : (0 : β) ∈ s • t ↔ (0 : α) ∈ s ∧ t.nonempty ∨ (0 : β) ∈ t ∧ s.nonempty :=
begin
  split,
  { rintro ⟨a, b, ha, hb, h⟩,
    obtain rfl | rfl := eq_zero_or_eq_zero_of_smul_eq_zero h,
    { exact or.inl ⟨ha, b, hb⟩ },
    { exact or.inr ⟨hb, a, ha⟩ } },
  { rintro (⟨hs, b, hb⟩ | ⟨ht, a, ha⟩),
    { exact ⟨0, b, hs, hb, zero_smul _ _⟩ },
    { exact ⟨a, 0, ha, ht, smul_zero _⟩ } }
end

lemma zero_mem_smul_set_iff (ha : a ≠ 0) : (0 : β) ∈ a • t ↔ (0 : β) ∈ t :=
begin
  refine ⟨_, zero_mem_smul_set⟩,
  rintro ⟨b, hb, h⟩,
  rwa (eq_zero_or_eq_zero_of_smul_eq_zero h).resolve_left ha at hb,
end

end smul_with_zero

section semigroup
variables [semigroup α]

@[to_additive] lemma op_smul_set_mul_eq_mul_smul_set (a : α) (s : set α) (t : set α) :
  (op a • s) * t = s * a • t :=
op_smul_set_smul_eq_smul_smul_set _ _ _ $ λ _ _ _, mul_assoc _ _ _

end semigroup

section left_cancel_semigroup
variables [left_cancel_semigroup α] {s t : set α}

@[to_additive] lemma pairwise_disjoint_smul_iff :
  s.pairwise_disjoint (• t) ↔ (s ×ˢ t).inj_on (λ p, p.1 * p.2) :=
pairwise_disjoint_image_right_iff $ λ _ _, mul_right_injective _

end left_cancel_semigroup

section group
variables [group α] [mul_action α β] {s t A B : set β} {a : α} {x : β}

@[simp, to_additive]
lemma smul_mem_smul_set_iff : a • x ∈ a • s ↔ x ∈ s := (mul_action.injective _).mem_set_image

@[to_additive]
lemma mem_smul_set_iff_inv_smul_mem : x ∈ a • A ↔ a⁻¹ • x ∈ A :=
show x ∈ mul_action.to_perm a '' A ↔ _, from mem_image_equiv

@[to_additive]
lemma mem_inv_smul_set_iff : x ∈ a⁻¹ • A ↔ a • x ∈ A :=
by simp only [← image_smul, mem_image, inv_smul_eq_iff, exists_eq_right]

@[to_additive]
lemma preimage_smul (a : α) (t : set β) : (λ x, a • x) ⁻¹' t = a⁻¹ • t :=
((mul_action.to_perm a).symm.image_eq_preimage _).symm

@[to_additive]
lemma preimage_smul_inv (a : α) (t : set β) : (λ x, a⁻¹ • x) ⁻¹' t = a • t :=
preimage_smul (to_units a)⁻¹ t

@[simp, to_additive]
lemma set_smul_subset_set_smul_iff : a • A ⊆ a • B ↔ A ⊆ B :=
image_subset_image_iff $ mul_action.injective _

@[to_additive]
lemma set_smul_subset_iff : a • A ⊆ B ↔ A ⊆ a⁻¹ • B :=
(image_subset_iff).trans $ iff_of_eq $ congr_arg _ $
  preimage_equiv_eq_image_symm _ $ mul_action.to_perm _

@[to_additive]
lemma subset_set_smul_iff : A ⊆ a • B ↔ a⁻¹ • A ⊆ B :=
iff.symm $ (image_subset_iff).trans $ iff.symm $ iff_of_eq $ congr_arg _ $
  image_equiv_eq_preimage_symm _ $ mul_action.to_perm _

@[to_additive] lemma smul_set_inter : a • (s ∩ t) = a • s ∩ a • t :=
image_inter $ mul_action.injective a

@[to_additive] lemma smul_set_sdiff : a • (s \ t) = a • s \ a • t :=
image_diff (mul_action.injective a) _ _

@[to_additive] lemma smul_set_symm_diff : a • (s ∆ t) = (a • s) ∆ (a • t) :=
image_symm_diff (mul_action.injective a) _ _

@[simp, to_additive] lemma smul_set_univ : a • (univ : set β) = univ :=
image_univ_of_surjective $ mul_action.surjective a

@[simp, to_additive] lemma smul_univ {s : set α} (hs : s.nonempty) : s • (univ : set β) = univ :=
let ⟨a, ha⟩ := hs in eq_univ_of_forall $ λ b, ⟨a, a⁻¹ • b, ha, trivial, smul_inv_smul _ _⟩

@[to_additive]
lemma smul_inter_ne_empty_iff {s t : set α} {x : α} :
  x • s ∩ t ≠ ∅ ↔ ∃ a b, (a ∈ t ∧ b ∈ s) ∧ a * b⁻¹ = x :=
begin
  rw ←nonempty_iff_ne_empty,
  split,
  { rintros ⟨a, h, ha⟩,
    obtain ⟨b, hb, rfl⟩ := mem_smul_set.mp h,
    exact ⟨x • b, b, ⟨ha, hb⟩, by simp⟩, },
  { rintros ⟨a, b, ⟨ha, hb⟩, rfl⟩,
    exact ⟨a, mem_inter (mem_smul_set.mpr ⟨b, hb, by simp⟩) ha⟩, },
end

@[to_additive]
lemma smul_inter_ne_empty_iff' {s t : set α} {x : α} :
  x • s ∩ t ≠ ∅ ↔ ∃ a b, (a ∈ t ∧ b ∈ s) ∧ a / b = x :=
by simp_rw [smul_inter_ne_empty_iff, div_eq_mul_inv]

@[to_additive]
lemma op_smul_inter_ne_empty_iff {s t : set α} {x : αᵐᵒᵖ} :
  x • s ∩ t ≠ ∅ ↔ ∃ a b, (a ∈ s ∧ b ∈ t) ∧ a⁻¹ * b = mul_opposite.unop x :=
begin
  rw ←nonempty_iff_ne_empty,
  split,
  { rintros ⟨a, h, ha⟩,
    obtain ⟨b, hb, rfl⟩ := mem_smul_set.mp h,
    exact ⟨b, x • b, ⟨hb, ha⟩, by simp⟩, },
  { rintros ⟨a, b, ⟨ha, hb⟩, H⟩,
    have : mul_opposite.op (a⁻¹ * b) = x := congr_arg mul_opposite.op H,
    exact ⟨b, mem_inter (mem_smul_set.mpr ⟨a, ha, by simp [← this]⟩) hb⟩, },
end

@[simp, to_additive] lemma Union_inv_smul :
  (⋃ (g : α), g⁻¹ • s) = (⋃ (g : α), g • s) :=
function.surjective.supr_congr _ inv_surjective $ λ g, rfl

@[to_additive]
lemma Union_smul_eq_set_of_exists {s : set β} :
  (⋃ (g : α), g • s) = {a | ∃ (g : α), g • a ∈ s} :=
by simp_rw [← Union_set_of, ← Union_inv_smul, ← preimage_smul, preimage]

end group

section group_with_zero
variables [group_with_zero α] [mul_action α β] {s t : set β} {a : α}

@[simp] lemma smul_mem_smul_set_iff₀ (ha : a ≠ 0) (A : set β)
  (x : β) : a • x ∈ a • A ↔ x ∈ A :=
show units.mk0 a ha • _ ∈ _ ↔ _, from smul_mem_smul_set_iff

lemma mem_smul_set_iff_inv_smul_mem₀ (ha : a ≠ 0) (A : set β) (x : β) :
  x ∈ a • A ↔ a⁻¹ • x ∈ A :=
show _ ∈ units.mk0 a ha • _ ↔ _, from mem_smul_set_iff_inv_smul_mem

lemma mem_inv_smul_set_iff₀ (ha : a ≠ 0) (A : set β) (x : β) : x ∈ a⁻¹ • A ↔ a • x ∈ A :=
show _ ∈ (units.mk0 a ha)⁻¹ • _ ↔ _, from mem_inv_smul_set_iff

lemma preimage_smul₀ (ha : a ≠ 0) (t : set β) : (λ x, a • x) ⁻¹' t = a⁻¹ • t :=
preimage_smul (units.mk0 a ha) t

lemma preimage_smul_inv₀ (ha : a ≠ 0) (t : set β) :
  (λ x, a⁻¹ • x) ⁻¹' t = a • t :=
preimage_smul ((units.mk0 a ha)⁻¹) t

@[simp] lemma set_smul_subset_set_smul_iff₀ (ha : a ≠ 0) {A B : set β} :
  a • A ⊆ a • B ↔ A ⊆ B :=
show units.mk0 a ha • _ ⊆ _ ↔ _, from set_smul_subset_set_smul_iff

lemma set_smul_subset_iff₀ (ha : a ≠ 0) {A B : set β} : a • A ⊆ B ↔ A ⊆ a⁻¹ • B :=
show units.mk0 a ha • _ ⊆ _ ↔ _, from set_smul_subset_iff

lemma subset_set_smul_iff₀ (ha : a ≠ 0) {A B : set β} : A ⊆ a • B ↔ a⁻¹ • A ⊆ B :=
show _ ⊆ units.mk0 a ha • _ ↔ _, from subset_set_smul_iff

lemma smul_set_inter₀ (ha : a ≠ 0) : a • (s ∩ t) = a • s ∩ a • t :=
show units.mk0 a ha • _ = _, from smul_set_inter

lemma smul_set_sdiff₀ (ha : a ≠ 0) : a • (s \ t) = a • s \ a • t :=
image_diff (mul_action.injective₀ ha) _ _

lemma smul_set_symm_diff₀ (ha : a ≠ 0) : a • (s ∆ t) = (a • s) ∆ (a • t) :=
image_symm_diff (mul_action.injective₀ ha) _ _

lemma smul_set_univ₀ (ha : a ≠ 0) : a • (univ : set β) = univ :=
image_univ_of_surjective $ mul_action.surjective₀ ha

lemma smul_univ₀ {s : set α} (hs : ¬ s ⊆ 0) : s • (univ : set β) = univ :=
let ⟨a, ha, ha₀⟩ := not_subset.1 hs in eq_univ_of_forall $ λ b,
  ⟨a, a⁻¹ • b, ha, trivial, smul_inv_smul₀ ha₀ _⟩

lemma smul_univ₀' {s : set α} (hs : s.nontrivial) : s • (univ : set β) = univ :=
smul_univ₀ hs.not_subset_singleton

end group_with_zero

section monoid
variables [monoid α] [add_group β] [distrib_mul_action α β] (a : α) (s : set α) (t : set β)

@[simp] lemma smul_set_neg : a • -t = -(a • t) :=
by simp_rw [←image_smul, ←image_neg, image_image, smul_neg]

@[simp] protected lemma smul_neg : s • -t = -(s • t) :=
by { simp_rw ←image_neg, exact image_image2_right_comm smul_neg }

end monoid

section ring
variables [ring α] [add_comm_group β] [module α β] (a : α) (s : set α) (t : set β)

@[simp] lemma neg_smul_set : -a • t = -(a • t) :=
by simp_rw [←image_smul, ←image_neg, image_image, neg_smul]

@[simp] protected lemma neg_smul : -s • t = -(s • t) :=
by { simp_rw ←image_neg, exact image2_image_left_comm neg_smul }

end ring

end set


import GMLInit.Logic.Basic

variable {a b : Prop}

def Implies (a b : Prop) : Prop := a → b

/-- constructor for `Implies`

  Note: This is a fake constructor -- `Implies` is not an inductive type. Cannot be used for pattern matching.
-/
protected def Implies.intro : (a → b) → Implies a b := id

/-- recursor for `Implies`

  Note: This is a fake recursor -- `Implies` is not an inductive type.
-/
protected def Implies.rec.{u} {motive : (a → b) → Sort u} : (a → (h : b) → motive (λ _ => h)) → (t : a → b) → a → motive t :=
  λ h t ha => h ha (t ha)

protected def Implies.recOn.{u} {motive : (a → b) → Sort u} (t : a → b) := Implies.rec (motive:=motive) (t:=t)

protected def Implies.casesOn.{u} {motive : (a → b) → Sort u} := Implies.recOn (motive := motive)

/-- eliminator for `Implies` -/
protected def Implies.elim.{u} {motive : Sort u} := Implies.recOn (motive := λ _ : a → b => motive)

/-- modus ponens -/
protected abbrev Implies.mp : Implies a b → a → b := id

/-- modus tollens -/
protected abbrev Implies.mt : Implies a b → ¬b → ¬a := mt

/- constructor for `Not`

  Note: This is a fake constructor -- `Not` is not an inductive type. Cannot be used for pattern matching.
-/
-- assert def Not.intro : (a → False) → ¬a := id

/-- recursor for `Not`

  Note: This is a fake recursor -- `Not` is not an inductive type.
-/
@[eliminator] protected def Not.rec.{u} {motive : ¬a → Sort u} (t : ¬a) : a → motive t :=
  λ h => False.casesOn (motive := λ _ => motive t) (t h)

protected def Not.recOn.{u} {motive : ¬a → Sort u} (t : ¬a) := Not.rec (motive:=motive) t

protected def Not.casesOn.{u} {motive : ¬p → Sort u} := Not.recOn (motive:=motive)

/- eliminator for `Not`

  This is a fake eliminator -- `Not` is not an inductive type.
-/
-- assert def Not.elim.{u} {motive : Sort u} := Not.casesOn (motive := λ _ : ¬a => motive)

/- eliminator for `And` -/
-- assert def And.elim.{u} {motive : Sort u} := And.casesOn (motive := λ _ : a ∧ b => motive)

/- eliminator for `Iff` -/
-- assert def Iff.elim.{u} {motive : Sort u} := Iff.casesOn (motive := λ _ : a ↔ b => motive)

theorem Iff.eq_implies_and_implies (a b : Prop) : (a ↔ b) = ((a → b) ∧ (b → a)) :=
  propext (iff_iff_implies_and_implies a b)

protected def Iff.mt : (a ↔ b) → (¬b ↔ ¬a)
| Iff.intro hab hba => Iff.intro (mt hab) (mt hba)

/-- large recursor for `Or`

  Note: In order to eliminate into sorts other than `Prop`, we must assume that the propositions are decidable.
-/
protected def Or.recLarge.{u} {motive : a ∨ b → Sort u} : [Decidable a] → [Decidable b] →
  (inl : (h : a) → motive (Or.inl h)) → (inr : (h : b) → motive (Or.inr h)) → (t : a ∨ b) → motive t
| Decidable.isTrue ha, _, h, _, _ => h ha
| _, Decidable.isTrue hb, _, h, _ => h hb
| Decidable.isFalse ha, Decidable.isFalse hb, _, _, t =>
  absurd t λ | Or.inl h => ha h | Or.inr h => hb h

protected def Or.recLargeOn.{u} [Decidable a] [Decidable b] {motive : a ∨ b → Sort u} (t : a ∨ b) :=
  Or.recLarge (motive:=motive) (t:=t)

protected def Or.casesLargeOn.{u} [Decidable a] [Decidable b] {motive : a ∨ b → Sort u} :=
  Or.recLargeOn (motive:=motive)

/-- large eliminator for `Or`

  Note: In order to eliminate into sorts other than `Prop`, we must assume that the propositions are decidable.
-/
protected def Or.elimLarge.{u} [Decidable a] [Decidable b] {motive : Sort u} := Or.recLargeOn (motive := λ _ : a ∨ b => motive)

/-- modus tollendo ponens -/
theorem Or.mtp : a ∨ b → ¬b → a :=
  λ t => Or.elim t (λ h _ => h) absurd

/-- modus tollendo ponens (reversed) -/
theorem Or.mtpr : a ∨ b → ¬a → b :=
  λ t => Or.elim t absurd (λ h _ => h)

/-- `NOr` connective: `¬(a ∨ b)` -/
def NOr (a b : Prop) : Prop := ¬(a ∨ b)

protected def NOr.eq_def (a b : Prop) : NOr a b = ¬(a ∨ b) := rfl

/-- constructor for `NOr`

  Note: This is a fake constructor -- `NOr` is not an inductive type.
-/
protected def NOr.intro : ¬a → ¬b → NOr a b
| hn, _, Or.inl h => hn h
| _, hn, Or.inr h => hn h

/-- recursor for `NAnd`

  Note: This is a fake recursor -- `NOr` is not an inductive type.
-/
@[eliminator] protected def NOr.rec.{u} {motive : NOr a b → Sort u} : (intro : (na : ¬a) → (nb : ¬b) → motive (NOr.intro na nb)) → (t : NOr a b) → motive t :=
  λ h t => h (λ ha => t (Or.inl ha)) (λ hb => t (Or.inr hb))

/-- recursor for `NAnd`

  See `NAnd.rec`.
-/
protected def NOr.recOn.{u} {motive : NOr a b → Sort u} (t : NOr a b) := NOr.rec (motive:=motive) (t:=t)

/-- recursor for `NAnd`

  Note: This is a fake recursor -- `NOr` is not an inductive type.
-/
protected def NOr.casesOn.{u} {motive : NOr a b → Sort u} := NOr.recOn (motive:=motive)

/-- eliminator for `NOr`

  Note: This is a fake eliminator -- `NOr` is not an inductive type.
-/
protected def NOr.elim.{u} {motive : Sort u} (t : NOr a b) : (intro : ¬a → ¬b → motive) → motive :=
  NOr.recOn (motive := λ _ => motive) t

/-- left projection for `NOr` -/
protected def NOr.left : NOr a b → ¬a :=
  λ h => NOr.elim h (λ ha _ => ha)

/-- right projection for `NOr` -/
protected def NOr.right : NOr a b → ¬b :=
  λ h => NOr.elim h (λ _ hb => hb)

theorem nor_of_not_and_not : ¬a ∧ ¬b → ¬(a ∨ b)
| And.intro ha hb => NOr.intro ha hb

theorem not_and_not_of_nor : ¬(a ∨ b) → ¬a ∧ ¬b :=
  λ h => And.intro (λ ha => h (Or.inl ha)) (λ hb => h (Or.inr hb))

theorem nor_iff_not_and_not (a b : Prop) : ¬(a ∨ b) ↔ ¬a ∧ ¬b :=
  Iff.intro not_and_not_of_nor nor_of_not_and_not

theorem NOr.eq_not_and_not (a b : Prop) : NOr a b = (¬a ∧ ¬b) :=
  propext (nor_iff_not_and_not a b)

/-- de Morgan's law for `Or` -/
protected theorem Or.deMorgan : ¬(a ∨ b) ↔ ¬a ∧ ¬b := nor_iff_not_and_not a b

/-- `NAnd` connective: `¬(a ∧ b)` -/
def NAnd (a b : Prop) : Prop := ¬(a ∧ b)

protected def NAnd.eq_def (a b : Prop) : NAnd a b = ¬(a ∧ b) := rfl

/-- left constructor for `NAnd`

  Note: This is a fake constructor -- `NAnd` is not an inductive type. Cannot be used for pattern matching.
-/
protected def NAnd.inl : ¬a → NAnd a b
| hn, And.intro h _ => hn h

/-- right constructor for `NAnd`

  Note: This is a fake constructor -- `NAnd` is not an inductive type. Cannot be used for pattern matching.
-/
protected def NAnd.inr : ¬b → NAnd a b
| hn, And.intro _ h => hn h

/-- recursor for `NAnd`

  Only valid for weakly complemented propositions.
  Can only eliminate intro `Prop`, see `NAnd.recLarge` to eliminate into other sorts.

  Note: This is a fake recursor -- `NAnd` is not an inductive type.
-/
@[eliminator] protected def NAnd.rec {motive : NAnd a b → Prop} : [WeaklyComplemented a] → [WeaklyComplemented b] →
  (inl : (h : ¬a) → motive (NAnd.inl h)) → (inr : (h : ¬b) → motive (NAnd.inr h)) → (t : NAnd a b) → motive t
| WeaklyComplemented.isFalse ha, _, h, _, _ => h ha
| _, WeaklyComplemented.isFalse hb, _, h, _ => h hb
| WeaklyComplemented.isIrrefutable ha, WeaklyComplemented.isIrrefutable hb, _, _, t =>
  absurd t λ h => ha λ ha => hb λ hb => h (And.intro ha hb)

/-- recursor for `NAnd`

  See `NAnd.rec`.
-/
protected def NAnd.recOn {motive : NAnd a b → Prop} (t : NAnd a b) [WeaklyComplemented a] [WeaklyComplemented b] := NAnd.rec (motive:=motive) (t:=t)

/-- recursor for `NAnd`

  See `NAnd.rec`.
-/
protected def NAnd.casesOn {motive : NAnd a b → Prop} := NAnd.recOn (motive:=motive)

/-- eliminator for `NAnd`

  Can only eliminate intro `Prop`, see `NAnd.elimLarge` to eliminate into other sorts.

  Note: This is a fake eliminator -- `NAnd` is not an inductive type.
-/
protected def NAnd.elim {motive : Prop} := NAnd.recOn (motive := λ _ : NAnd a b => motive)

/-- large recursor for `NAnd`

  In order to eliminate into sorts other than `Prop`, we must assume that the propositions are weakly decidable.

  Note: This is a fake recursor -- `NAnd` is not an inductive type.
-/
protected def NAnd.recLarge.{u} {motive : NAnd a b → Sort u} : [WeaklyDecidable a] → [WeaklyDecidable b] →
  (inl : (h : ¬a) → motive (NAnd.inl h)) → (inr : (h : ¬b) → motive (NAnd.inr h)) → (t : NAnd a b) → motive t
| WeaklyDecidable.isFalse ha, _, h, _, _ => h ha
| _, WeaklyDecidable.isFalse hb, _, h, _ => h hb
| WeaklyDecidable.isIrrefutable ha, WeaklyDecidable.isIrrefutable hb, _, _, t =>
  absurd t λ h => ha λ ha => hb λ hb => h (And.intro ha hb)

protected def NAnd.recLargeOn.{u} {motive : NAnd a b → Sort u} (t : NAnd a b) [WeaklyDecidable a] [WeaklyDecidable b] := NAnd.recLarge (motive:=motive) (t:=t)

protected def NAnd.casesLargeOn.{u} {motive : NAnd a b → Sort u} := NAnd.recLargeOn (motive:=motive)

/-- large eliminator for `NAnd`

  In order to eliminate into sorts other than `Prop`, we must assume that the propositions are weakly decidable.

  Note: This is a fake eliminator -- `NAnd` is not an inductive type.
-/
protected def NAnd.elimLarge.{u} {motive : Sort u} := NAnd.recLargeOn (motive := λ _ : NAnd a b => motive)

theorem nand_of_not_or_not : ¬a ∨ ¬b → ¬(a ∧ b)
| Or.inl h => NAnd.inl h
| Or.inr h => NAnd.inr h

theorem not_or_not_of_nand [WeaklyComplemented a] [WeaklyComplemented b] : ¬(a ∧ b) → ¬a ∨ ¬b :=
  λ h => NAnd.elim h Or.inl Or.inr

theorem nand_iff_not_or_not (a b : Prop) [WeaklyComplemented a] [WeaklyComplemented b] : ¬(a ∧ b) ↔ ¬a ∨ ¬b :=
  Iff.intro not_or_not_of_nand nand_of_not_or_not

theorem NAnd.eq_not_or_not (a b : Prop) [WeaklyComplemented a] [WeaklyComplemented b] : NAnd a b = (¬a ∨ ¬b) :=
  propext (nand_iff_not_or_not a b)

/-- de Morgan's law for `Or`

  Only valid for weakly complemented propositions.
-/
protected theorem And.deMorgan [WeaklyComplemented a] [WeaklyComplemented b] : ¬(a ∧ b) ↔ ¬a ∨ ¬b := nand_iff_not_or_not a b


import Euclid.tarski_1
open classical set
namespace Euclidean_plane
variables {point : Type} [Euclidean_plane point]

local attribute [instance] prop_decidable

theorem six9 {a b p : point} : b ∈ ray p a → ray p a = ray p b :=
begin
intro h,
ext,
split,
  intro h1,
  cases h with h h2,
  cases h2 with h2 h3,
  cases h1 with h1 h4,
  cases h4 with h4 h5,
  split,
    exact h2,
  split,
    exact h4,
  cases h3,
    cases h5,
      exact five1 h.symm h3 h5,
    right,
    exact three6b h5 h3,
  cases h5,
    left,
    exact three6b h3 h5,
  exact five3 h3 h5,
intro h1,
cases h with h h2,
cases h2 with h2 h3,
cases h1 with h1 h4,
cases h4 with h4 h5,
split,
  exact h,
split,
exact h4,
cases h3,
  cases h5,
    left,
    exact three6b h3 h5,
  exact five3 h3 h5,
cases h5,
  exact five1 h2.symm h3 h5,
right,
exact three6b h5 h3
end

theorem six10 {a b c p q r : point} : sided a b c → sided p q r → eqd a b p q → eqd a c p r → cong a b c p q r :=
begin
intro h,
revert p q r,
wlog h4 : distle a b a c,
    exact (five10 a b a c),
  introv h1 h2 h3,
  repeat {split};
  try {assumption},
  have h5 : distle p q p r,
    exact five6 h4 h2 h3,
  have h6 : B a b c,
    exact (six12 h).1 h4,
  have h7 : B p q r,
    exact (six12 h1).1 h5,
  exact (four3 h6.symm h7.symm h3.flip h2.flip).flip,
have h1 := this h.symm a_1.symm a_3 a_2,
repeat {split},
    exact h1.2.2,
  exact h1.2.1.flip,
exact h1.1
end

theorem six10a {a b c a' b' c' : point} : sided a b c → cong a b c a' b' c' → sided a' b' c' :=
begin
intro h,
revert a' b' c',
wlog h1 : B a b c := (h.2.2) using b c,
  introv h2,
  split,
    intro h_1,
    subst b',
    exact h.1.symm (id_eqd h2.1),
  split,
    intro h_1,
    subst c',
    exact h.2.1.symm (id_eqd h2.2.2),
  exact or.inl (four6 h1 h2),
apply (this h.symm _).symm,
exact ⟨a_1.2.2, a_1.2.1.flip, a_1.1⟩
end

def l (a b : point) : set point := {x | col a b x}

def line (k : set point) : Prop := ∃ a b, a ≠ b ∧ k = l a b

lemma six14 {a b : point} : a ≠ b → line (l a b) :=
begin
intro h,
existsi a,
existsi b,
split,
  exact h,
refl
end

theorem six15 {p q r : point} : p ≠ q → p ≠ r → B q p r → l p q = ray p q ∪ {p} ∪ ray p r :=
begin
intros h h1 h2,
ext,
split,
  intro h3,
  cases em (x = p),
    left, right,
    rw h_1,
    simp,
  cases h3,
    left, left,
    split,
      exact h.symm,
    split,
      exact h_1,
    left,
    exact h3,
    cases h3,
    left, left,
    split,
      exact h.symm,
    split,
      exact h_1,
    right,
    exact h3.symm,
  right,
  split,
    exact h1.symm,
  split,
    exact h_1,
  exact five2 h.symm h2 h3.symm,
intro h3,
cases h3,
  cases h3,
    cases h3 with h3 h4,
    cases h4 with h4 h5,
    cases h5,
      left,
      exact h5,
    right, left,
    exact h5.symm,
  have : x = p,
    simpa using h3,
  right, left,
  rw this,
  exact three1 q p,
cases h3 with h3 h4,
cases h4 with h4 h5,
right, right,
cases h5,
  exact (three7b h2 h5 h1).symm,
exact (three5a h2 h5).symm
end

theorem six16 {p q r : point} : p ≠ q → p ≠ r → r ∈ l p q → l p q = l p r :=
begin
intros h h1 h2,
ext,
split,
  intro h3,
  exact five4 h h2 h3,
intro h3,
have : col p r q,
  exact (four11 h2).1,
exact five4 h1 this h3
end

theorem six16a {p q r : point} : sided p q r → l p q = l p r :=
λ h, six16 h.1.symm h.2.1.symm (four11 (six4.1 h).1).2.1

theorem six17 (p q : point) : l p q = l q p :=
begin
ext,
split,
  intro h1,
  exact (four11 h1).2.1,
intro h1,
exact (four11 h1).2.1
end

theorem line.symm {a b : point} (h : line (l a b)) : line (l b a) := (six17 a b) ▸ h

@[simp] theorem six17a (p q : point) : p ∈ l p q := (four11 (four12 p q)).1

@[simp] theorem six17b (p q : point) : q ∈ l p q := (four11 (four12 q p)).2.2.2.1

theorem six18 {a b : point} {L : set point} : line L → a ≠ b → a ∈ L → b ∈ L → L = l a b :=
begin
intros h h1 h2 h3,
cases h with p hp,
cases hp with q hq,
rw hq.2 at *,
cases em (a = p),
  rw h at *,
  exact six16 hq.1 h1 h3,
have ha : l p q = l p a,
  exact six16 hq.1 (ne.symm h) h2,
rw ha at *,
rw six17 p a at *,
exact six16 h h1 h3
end

theorem six18a {a p q : point} : a ∉ l p q → a ≠ p ∧ a ≠ q :=
begin
intro h,
split,
  intro h1,
  subst a,
  apply h,
  simp,
intro h1,
subst a,
simpa using h
end

theorem six19 {a b : point} : a ≠ b → ∃! L : set point, line L ∧ a ∈ L ∧ b ∈ L :=
begin
intro h,
existsi l a b,
split,
  split,
    existsi a,
    existsi b,
    split,
      exact h,
    refl,
  split;
  simp,
intros y hy,
exact six18 hy.1 h hy.2.1 hy.2.2
end

theorem six20 {a b c : point} {A : set point} : line A → a ∈ A → b ∈ A → a ≠ b → col a b c → c ∈ A :=
begin
intros h h1 h2 h3 h4,
suffices : A = l a b,
  subst A,
  exact h4,
exact six18 h h3 h1 h2
end

theorem six21 {a b : point} {A B : set point} : a ≠ b → line A → line B → a ∈ A → a ∈ B → b ∈ A → b ∈ B → A = B :=
begin
intros h h1 h2 h3 h4 h5 h6,
apply unique_of_exists_unique (six19 h),
  repeat {split, assumption},
  assumption,
assumption
end

def is (x : point) (A B : set point) : Prop := line A ∧ line B ∧ A ≠ B ∧ x ∈ A ∧ x ∈ B

theorem six21a {x y : point} {A B : set point} : line A → line B → A ≠ B → x ∈ A → x ∈ B → y ∈ A → y ∈ B → x = y :=
λ h h1 h2 h3 h4 h5 h6, classical.by_contradiction (λ h_1,
h2 (six21 h_1 h h1 h3 h4 h5 h6))

theorem six22 {x : point} {A : set point} : line A → x ∈ A → ∃ y, x ≠ y ∧ A = l x y :=
begin
intros h h1,
have h2 := h,
cases h with u hu,
cases hu with v hv,
cases em (u = x),
  rw h at *,
  constructor,
  exact hv,
constructor,
split,
  exact ne.symm h,
have : u ∈ A,
  rw hv.2,
  simp,
exact six18 h2 (ne.symm h) h1 this
end

theorem six23 {a b c : point} : col a b c ↔ ∃ (L : set point), line L ∧ a ∈ L ∧ b ∈ L ∧ c ∈ L :=
begin
split,
  intro h,
  cases em (a = b),
    rw h_1 at *,
    cases em (b = c),
      rw h_2 at *,
      cases three14 c c with p hp,
      existsi l c p,
      split,
        exact six14 hp.2,
      simp,
    existsi l b c,
    split,
      exact six14 h_2,
    simp,
  existsi l a b,
  split,
    exact six14 h_1,
  simpa using h,
intro h,
cases h with L h,
cases em (a = b),
  rw h_1,
  exact four12 b c,
have : L = l a b,
  exact six18 h.1 h_1 h.2.1 h.2.2.1,
rw this at *,
exact h.2.2.2
end

theorem six24 : ¬col (P1 : point) P2 P3 :=
begin
have h := two_dim point,
intro h1,
cases h1,
  exact h.1 h1,
cases h1,
  exact h.2.1 h1,
exact h.2.2 h1
end

theorem six25 {a b : point} : a ≠ b → ∃ c, ¬col a b c :=
begin
intro h1,
by_contradiction h2,
rw not_exists at h2,
simp at h2,
apply @six24 point,
apply six23.2,
exact ⟨l a b, six14 h1, h2 P1, h2 P2, h2 P3⟩
end

lemma six13a (a : point) : ¬line (l a a) :=
begin
intro h,
cases h with p hp,
cases hp with q hq,
cases six25 hq.1 with r hr,
apply hr,
suffices : r ∈ l a a,
  rw hq.2 at this,
  exact this,
left,
exact three3 a r
end

lemma six13 {a b : point} : line (l a b) → a ≠ b :=
begin
intros h h1,
subst b,
apply six13a a,
exact h
end

def tri (a b c : point) : Prop := a ≠ b ∧ b ≠ c ∧ a ≠ c

theorem six26 {a b c : point} : ¬col a b c → tri a b c :=
begin
intro h,
split,
  intro h,
  rw h at *,
  exact h (four12 b c),
split,
  intro h,
  rw h at *,
  exact h (four11 (four12 c a)).2.2.2.1,
intro h,
rw h at *,
exact h (four11 (four12 c b)).1
end

theorem six27 {a b c : point} {A : set point} : line A → a ∈ A → c ∈ A → B a b c → b ∈ A :=
begin
intros h h1 h2 h3,
cases em (a = c),
  rw h_1 at h3,
  have : c = b,
    exact bet_same h3,
  rwa this at h2,
have h4 := six18 h h_1 h1 h2,
rw h4,
right, left,
exact h3.symm
end

theorem six28 {a b c :point} : ¬col a b c → is a (l a b) (l a c) :=
begin
intro h,
split,
  exact six14 (six26 h).1,
split,
  exact six14 (six26 h).2.2,
split,
  intro h1,
  have h2 : c ∈ l a b,
    rw h1,
    simp,
  contradiction,
simp
end

-- middle points

def M (a m b : point) : Prop := B a m b ∧ eqd m a m b

theorem M.symm {a b m : point} : M a m b → M b m a :=
begin
intro h,
split,
  exact h.1.symm,
exact h.2.symm
end

theorem seven3 {a m : point} : M a m a ↔ a = m :=
begin
split,
  intro h,
  exact bet_same h.1,
intro h,
rw h at *,
split,
  exact three1 m m,
exact eqd.refl m m
end

theorem seven4 (a p : point) : ∃! q, M p a q :=
begin
cases em (a = p),
  rw h,
  existsi p,
  split,
    apply seven3.2,
    refl,
  intros y hy,
  cases hy with h1 h2,
  exact id_eqd h2.symm.flip,
cases seg_cons a a p p with q hq,
apply exists_unique.intro,
exact ⟨hq.1, hq.2.symm⟩,
intros y hy,
apply unique_of_exists_unique (two12 a a p p (ne.symm h)),
exact ⟨hy.1, hy.2.symm⟩,
exact hq
end

noncomputable def S (a p : point) : point := classical.some (seven4 a p)

theorem seven5 (a p : point) : M p a (S a p) := (classical.some_spec (seven4 a p)).1

theorem seven6 {a p q : point} : M p a q → q = S a p :=
begin
intro h,
exact unique_of_exists_unique (seven4 a p) h (classical.some_spec (seven4 a p)).1
end

@[simp] theorem seven7 (a p : point) : S a (S a p) = p :=
begin
cases seven5 a p with h1 h2,
generalize hq : S a p = q,
rw hq at *,
cases seven5 a q with h3 h4,
generalize hr : S a q = r,
rw hr at *,
cases em (q = a),
  rw h at *,
  have ha : a = r,
    exact id_eqd h4.symm,
  rw ha at *,
  exact id_eqd h2,
apply unique_of_exists_unique (two12 a a p q h),
  split,
    exact h3,
  exact (eqd.trans h2 h4).symm,
split,
  exact h1.symm,
exact eqd.refl a p
end

theorem seven8 (a p : point) : ∃! q, S a q = p :=
begin
existsi S a p,
split,
  exact seven7 a p,
intros q h,
rw ←h,
exact (seven7 a q).symm
end

theorem seven9 {a p q : point} : S a p = S a q → p = q :=
begin
intro h,
apply unique_of_exists_unique (seven8 a (S a p)),
  simp,
rw ←h
end

theorem seven9a {a b : point} (p : point) : a ≠ b → S p a ≠ S p b :=
begin
intros h h1,
exact h (seven9 h1)
end

theorem seven10 {a p : point} : S a p = p ↔ p = a :=
begin
split,
  intro h,
  have : M p a (S a p),
    exact seven5 a p,
  rw h at *,
  exact seven3.1 this,
intro h,
rw h,
have : M a a (S a a),
  exact seven5 a a,
cases this with h1 h2,
exact id_eqd h2.symm.flip
end

@[simp] theorem seven11 (a : point) : S a a = a :=
begin
apply seven10.2,
refl
end

theorem seven12a {a p : point} : a ≠ p → a ≠ S a p :=
begin
intros h h1,
apply h,
have h2 : S a a = a,
  exact seven11 a,
exact seven9 (eq.trans h2 h1)
end

theorem seven12b {a p : point} : a ≠ p → p ≠ S a p :=
λ h h1, h.symm (seven10.1 h1.symm)

theorem seven13 (a p q : point) : eqd p q (S a p) (S a q) :=
begin
have hp : M p a (S a p),
  exact seven5 a p,
have hq : M q a (S a q),
  exact seven5 a q,
generalize hp' : S a p = p',
generalize hq' : S a q = q',
rw hp' at *,
rw hq' at *,
cases em (p = a),
  have : S a p = p,
    exact seven10.2 h,
  rw h at *,
  rw this at *,
  rw ←hp' at *,
  exact hq.2,
cases seg_cons p q a p' with x hx,
cases seg_cons p' q a x with x' hx',
cases seg_cons q p a q' with y hy,
cases seg_cons q' p a y with y' hy',
have h1 : B a p x,
  exact three6a hp.1.symm hx.1,
have h2 : B p p' x',
  exact three6a hx.1.symm hx'.1,
have h3 : B a p' x',
  exact three6a hp.1 h2,
have h4 : B a q y,
  exact three6a hq.1.symm hy.1,
have h5 : B q q' y',
  exact three6a hy.1.symm hy'.1,
have h6 : B a q' y',
  exact three6a hq.1 h5,
have h7 : eqd a x y a,
  exact two11 h1 h4.symm hy.2.symm.flip hx.2,
have h8 : eqd a x a x',
  exact two11 h1 h3 hp.2 (eqd.trans hx.2 hx'.2.symm),
have h9 : eqd a x y' a,
  exact two11 h1 h6.symm hy'.2.symm.flip (eqd.trans hx.2 hq.2.flip),
have h10 : B x a p',
      exact three5b hx.1.symm hp.1,
have h11 : B y a q',
      exact three5b hy.1.symm hq.1,
have h12 : afs x a x' y' y' a y x,
  repeat {split},
    exact three6b h10 hx'.1,
    exact (three6b h11 hy'.1).symm,
    exact two4 h9,
    exact two5 (eqd.trans h8.symm h7),
    exact two5 (eqd.refl x y'),
  exact two4 h9.symm,
have h13 : x ≠ a,
  intro h_1,
  rw h_1 at h1,
  exact h (bet_same h1).symm,
have h14 : eqd x' y' y x,
  exact afive_seg h12 h13,
have h15 : ifs y q a x y' q' a x',
  repeat {split},
    exact h4.symm,
    exact h6.symm,
    exact eqd.trans h7.symm h9,
    exact hq.2.flip,
    exact two5 h14.symm,
  exact h8,
have h16 := four2 h15,
have h17 : ifs x p a q x' p' a q',
  repeat {split},
    exact h1.symm,
    exact h3.symm,
    exact h8.flip,
    exact hp.2.flip,
    exact h16.flip,
  exact hq.2,
exact four2 h17
end

theorem seven15 (a : point) {p q r : point} : B p q r ↔ B (S a p) (S a q) (S a r) :=
begin
split,
  intro h,
  apply four6 h,
  repeat {split};
  exact seven13 a _ _,
intro h,
rw ←(seven7 a p),
rw ←(seven7 a q),
rw ←(seven7 a r),
apply four6 h,
repeat {split};
exact seven13 a _ _,
end

theorem seven16 (a : point) {p q r s : point}: eqd p q r s ↔ eqd (S a p) (S a q) (S a r) (S a s) :=
begin
split,
  intro h,
  exact (seven13 a p q).symm.trans (h.trans (seven13 a r s)),
intro h,
have h1 := eqd.trans (seven13 a (S a p) (S a q)).symm (eqd.trans h (seven13 a (S a r) (S a s))),
simpa using h1
end

theorem seven16a (a : point) {p q r : point} : cong p q r (S a p) (S a q) (S a r) :=
begin
repeat {split};
exact seven13 a _ _
end

theorem seven14 (a : point) {p q r : point} : M p q r ↔ M (S a p) (S a q) (S a r) :=
begin
split,
  intro h,
  cases h with h h1,
  split,
    exact (seven15 a).1 h,
  exact (seven16 a).1 h1,
intro h,
cases h with h h1,
split,
  exact (seven15 a).2 h,
exact (seven16 a).2 h1
end

theorem S_of_col {p q r : point} (a : point) : col p q r ↔ col (S a p) (S a q) (S a r) :=
begin
split,
  intro h,
  unfold col,
  repeat {cases h};
  simp [(seven15 a).1 h],
intro h,
unfold col,
repeat {cases h};
simp [(seven15 a).2 h]
end

theorem seven17 {a b p q : point} : M p a q → M p b q → a = b :=
begin
intros h h1,
have h2 := seven6 h,
have h3 := seven13 a q b,
have h4 := seven7 a p,
rwa ←h2 at h4,
rw h4 at h3,
have h6 : eqd p b p (S a b),
  exact eqd.trans h1.2.flip h3,
have h7 := seven13 a p b,
rw ←h2 at h7,
have h8 : eqd q b q (S a b),
  exact eqd.trans h1.2.symm.flip h7,
have h9 : b = (S a b),
  exact four19 h1.1 h6 h8.flip,
exact (seven10.1 h9.symm).symm
end

theorem seven18 {a b p : point} : S a p = S b p → a = b :=
begin
intro h,
generalize h1 : S a p = q,
have h2 := seven5 a p,
rw h1 at h2,
have h3 := seven5 b p,
rw (eq.trans h.symm h1) at h3,
exact seven17 h2 h3
end

theorem seven18a {a b p : point} : a ≠ b → S a p ≠ S b p:=
λ h h1, h (seven18 h1)

theorem seven19 {a b p : point} : S a (S b p) = S b (S a p) ↔ a = b :=
begin
split,
  intro h,
  generalize h1 : S a p = q,
  have h2 := seven5 a p,
  rw h1 at *,
  have h3 := seven5 a (S b p),
  rw h at h3,
  cases h3 with h3 h4,
  have h5 := (seven15 b).1 h3,
  have h6 := (seven16 b).1 h4,
  rw seven7 b p at *,
  rw seven7 b q at *,
  have h7 : M p (S b a) q,
    split;
    assumption,
  have h8 : a = (S b a),
    exact seven17 h2 h7,
  exact seven10.1 h8.symm,
intro h,
rw h
end

theorem seven20 {a m b : point} : col a m b → eqd m a m b → a = b ∨ M a m b :=
begin
intros h h1,
cases h,
  right,
  split;
  assumption,
cases h,
  left,
  have h2 := three3 b m,
  have h3 : eqd a b b b,
    exact four3 h.symm h2 h1.flip (eqd.refl b m),
  exact id_eqd h3,
left,
have h2 := three3 a m,
have h3 : eqd b a a a,
  exact four3 h h2 h1.symm.flip (eqd.refl a m),
exact id_eqd h3.flip
end

theorem seven21 {a b c d p : point} : ¬col a b c → b ≠ d → eqd a b c d → eqd b c d a →
col a p c → col b p d → M a p c ∧ M b p d :=
begin
intros h h1 h2 h3 h4 h5,
cases four14 (four11 h5).1 (two5 (eqd.refl b d)) with q hq,
have h6 := four13 (four11 h5).1 hq,
have h7 : fs b d p a d b q c,
  split,
    exact (four11 h5).1,
  split,
    exact hq,
  split,
    exact h2.flip,
  exact h3.symm,
have h8 : fs b d p c d b q a,
  split,
    exact (four11 h5).1,
  split,
    exact hq,
  split,
    exact h3,
  exact h2.symm.flip,
have h9 := four16 h7 h1,
have h10 := four16 h8 h1,
have h11 : cong a p c c q a,
split,
  exact h9.flip,
split,
  exact h10,
exact two5 (eqd.refl a c),
have h12 : p = q,
  suffices : l a c ≠ l b d,
    apply six21a (six14 (six26 h).2.2) (six14 h1) this (four11 h4).1 (four11 h5).1 (four11 (four13 h4 h11)).2.2.2.1 (four11 h6).2.1,
  intro h_1,
  suffices : b ∉ l a c,
    simpa [h_1, (six17a b d)] using this,
  exact (four10 h).1,
subst q,
split,
  cases seven20 h4 h9,
    exact ((six26 h).2.2 h_1).elim,
  assumption,
cases seven20 h5 (hq.2.2).flip,
  contradiction,
assumption
end

def hourglass (a b c p q m n : point) : Prop := B a c p ∧ B b c q ∧ eqd c a c b ∧ eqd c p c q ∧
M a m b ∧ M p n q

lemma seven23 {a b c p q m n : point} : hourglass a b c p q m n → distle c a c q → B m c n :=
begin
intros h h_1,
cases h with h h1,
cases h1 with h1 h2,
cases h2 with h2 h3,
cases h3 with h3 h4,
cases h4 with h4 h5,
cases em (p = c),
  rw h_2 at *,
  have h_3 : q = c,
    exact id_eqd h3.symm.flip,
  rw h_3 at *,
  have h_4 : c = n,
    exact seven3.1 h5,
  rw h_4 at *,
  exact three1 m n,
generalize h6 : S c p = a',
generalize h7 : S c q = b',
generalize h8 : S c n = m',
have h9 : M a' m' b',
  have h_3 := (seven14 c).1 h5,
  rwa [h6, h7, h8] at h_3,
have h10 : M p c a',
  have h10 := seven5 c p,
  rwa h6 at h10,
have h11 : M q c b',
  have h11 := seven5 c q,
  rwa h7 at h11,
have h12 : M n c m',
  have h12 := seven5 c n,
  rwa h8 at h12,
have h13 : distle c a c a',
  exact five6 h_1 (eqd.refl c a) (eqd.trans h3.symm h10.2),
cases em (a = c),
  rw h_3 at *,
  have : b = c,
    exact id_eqd h2.symm.flip,
  rw this at *,
  have : c = m,
    exact seven3.1 h4,
  rw this,
  exact three3 m n,
have h_4 : a' ≠ c,
  intro h_4,
  rw h_4 at *,
  have : eqd c a c c,
    exact five9 h13 (five11 c c a),
  exact h_3 (id_eqd this.flip),
have h14 : sided c a a',
  apply six3.2,
  split,
    exact h_3,
  split,
    exact h_4,
  existsi p,
  split,
    exact h_2,
  split,
    exact h,
  exact h10.1.symm,
have h15 : B c a a',
  exact (six12 h14).1 h13,
have h16 : distle c b c b',
  exact five6 h_1 h2 h11.2,
have h_5 : q ≠ c,
  intro h_5,
  rw h_5 at *,
  exact h_2 (id_eqd h3.flip),
cases em (b = c),
  rw h_6 at *,
  have : a = c,
   exact id_eqd h2.flip,
  rw this at *,
  have : c = m,
    exact seven3.1 h4,
  rw this,
  exact three3 m n,
have h_7 : b' ≠ c,
  intro h_7,
  rw h_7 at *,
  have : eqd c b c c,
    exact five9 h16 (five11 c c b),
  exact h_6 (id_eqd this.flip),
have h17 : sided c b b',
  apply six3.2,
  split,
    exact h_6,
  split,
    exact h_7,
  existsi q,
  split,
    exact h_5,
  split,
    exact h1,
  exact h11.1.symm,
have h18 : B c b b',
  exact (six12 h17).1 h16,
cases three17 h15.symm h18.symm h9.1 with r hr,
have h19 : B r c n,
  exact three6a hr.1 h12.1.symm,
suffices : r = m,
  rwa this at h19,
have h20 : ifs a' a c m' b' b c m',
  repeat {split},
    exact h15.symm,
    exact h18.symm,
    exact eqd.trans h10.2.symm.flip (eqd.trans h3.flip h11.2.flip),
    exact h2.flip,
    exact h9.2.flip,
  exact eqd.refl c m',
have h20 := four2 h20,
have h21 : col m' c r,
  right, left,
  exact hr.1.symm,
have h22 : eqd r a r b,
  cases em (m' = c),
    rw h_8 at *,
    have : c = r,
      exact bet_same hr.1,
    rw this at *,
    exact h20.flip,
  exact four17 h_8 h21 h20.flip h2,
have h23 : M a r b,
  split,
    exact hr.2,
  exact h22,
exact seven17 h23 h4
end

theorem seven22 {a b c p q m n : point} : hourglass a b c p q m n → B m c n :=
begin
intro h,
cases five10 c a c q,
  exact seven23 h h_1,
cases h with h h1,
cases h1 with h1 h2,
cases h2 with h2 h3,
cases h3 with h3 h4,
cases h4 with h4 h5,
have h6 : hourglass q p c b a n m,
  repeat {split},
    exact h1.symm,
    exact h.symm,
    exact h3.symm,
    exact h2.symm,
    exact h5.1.symm,
    exact h5.2.symm,
    exact h4.1.symm,
  exact h4.2.symm,
exact (seven23 h6 h_1).symm
end

theorem seven24 {a p : point} {A : set point} : line A → a ∈ A → (p ∈ A ↔ (S a p) ∈ A) :=
begin
intros h h1,
split,
  intro h2,
  cases em (a = p),
    have h3 := seven10.2 h_1.symm,
    rwa h3,
  have h3 := six18 h h_1 h1 h2,
  rw h3,
  have h4 := seven5 a p,
  right, right,
  exact h4.1.symm,
intro h2,
cases em (a = (S a p)),
  have h3 := seven10.2 h_1.symm,
  rw ←seven7 a p,
  rwa h3,
have h3 := six18 h h_1 h1 h2,
rw h3,
have h4 := seven5 a p,
right, right,
exact h4.1
end

theorem seven25 {a b c : point} : eqd c a c b → ∃ x, M a x b :=
begin
intro h,
cases em (col a c b),
  cases seven20 h_1 h,
    rw h_2 at *,
    existsi b,
    split,
      exact three1 b b,
    exact eqd.refl b b,
  constructor, exact h_2,
cases three14 c a with p hp,
cases seg_cons b a p c with q hq,
cases pasch hp.1.symm hq.1.symm with r hr,
cases pasch hp.1 hr.2 with x hx,
existsi x,
suffices : eqd x a x b,
  split,
    exact hx.1,
  exact this,
suffices : eqd r a r b,
  have h1 : col c r x,
    right, left,
    exact hx.2,
  cases em (c = r),
    rw h_2 at hx,
    have : r = x,
      exact bet_same hx.2,
    rw this at *,
    exact this,
  exact four17 h_2 h1 h this,
have h1 : afs c a p b c b q a,
  repeat {split},
    exact hp.1,
    exact hq.1,
    exact h,
    exact hq.2.symm,
    exact h.symm,
  exact two5 (eqd.refl a b),
have h2 : eqd p b q a,
  exact afive_seg h1 (six26 h_1).1.symm,
cases four5 hr.2 h2.flip with r' hr',
have h3 : ifs b r p a a r' q b,
  repeat {split},
    exact hr.2,
    exact hr'.1,
    exact hr'.2.2.2,
    exact hr'.2.2.1,
    exact two4 (eqd.refl a b),
  exact hq.2.symm.flip,
have h4 : ifs b r p q a r' q p,
  repeat {split},
    exact hr.2,
    exact hr'.1,
    exact hr'.2.2.2,
    exact hr'.2.2.1,
    exact hq.2,
  exact two5 (eqd.refl p q),
have h5 := four2 h3,
have h6 := four2 h4,
have h7 : cong a r q b r' p,
  split,
    exact h5.flip,
  split,
    exact h6,
  exact h2.symm.flip,
have h8 : col a r q,
  left, exact hr.1,
have h9 := four13 h8 h7,
have h_2 : a ≠ q,
  intro h_2,
  rw ←h_2 at *,
  have : col a c b,
    right, left,
    exact hq.1,
  exact h_1 this,
have h_3 : b ≠ p,
  intro h_3,
  rw ←h_3 at *,
  have : col a c b,
    right, right,
    exact hp.1.symm,
  exact h_1 this,
have h10 : l a q ≠ l b p,
  intro h_4,
  suffices : a ∈ l b p,
    have h_6 : col a p c,
      right, right,
      exact hp.1,
    exact h_1 (five4 hp.2 h_6 (four11 this).2.2.2.2),
  rw ←h_4,
  simp,
have h11 : col b p r,
  right, left,
  exact hr.2.symm,
  have h12 : col a q r',
    right, left,
    exact hr'.1.symm,
suffices : r' = r,
  rwa this at h5,
exact six21a (six14 h_2) (six14 h_3) h10 h12 (four11 h9).1 (four11 h8).1 h11
end

end Euclidean_plane