import topology.instances.real

open filter real
open_locale topological_space

variable a : ℕ → ℝ

theorem part_a :
  ¬ (∀ l : ℝ, tendsto a at_top (𝓝 l)) ↔ tendsto a at_top at_top :=
begin
  sorry
end

theorem part_c :
  (∀ R > 0, ∃ N : ℕ, ∀ n ≥ N, a n > R) ↔ (tendsto a at_top at_top) :=
begin
  sorry
end

theorem part_d :
  ¬ (∀ L : ℝ, ∀ ε : ℝ, ∃ N : ℕ, ∀ n ≥ N, abs (a n - L) > ε) ↔ (tendsto a at_top at_top) :=
begin
  sorry
end

theorem part_e :
  (∀ ε > 0, ∃ N : ℕ, ∀ n ≥ N, a n > 1 / ε) ↔ (tendsto a at_top at_top) :=
begin
  sorry
end

theorem part_f :
  ¬ (∀ n : ℕ, a (n+1) > a n) ↔ (tendsto a at_top at_top) :=
begin
  sorry
end

theorem part_g :
  ¬ (∃ N : ℕ, ∀ R > 0, ∀ n ≥ N, a n > R) ↔ (tendsto a at_top at_top) :=
begin
  sorry
end

theorem part_h :
  ¬ (∀ R : ℝ, ∃ n : ℕ, a n > R) ↔ (tendsto a at_top at_top) :=
begin
  sorry
end


import Math.CategoryTheory.Monad.Basic
import Math.CategoryTheory.Adjunction.Basic

namespace CategoryTheory.Monad

open Category

variable [Category α]

structure Algebra (M : Monad α) where
  A : α
  eval : hom (M.T.obj A) A
  unit : eval ∘ M.η.app A = 𝟙 A := by simp
  assoc : eval ∘ M.T.map eval = eval ∘ M.μ.app A := by simp

attribute [simp] Algebra.unit Algebra.assoc

@[simp]
theorem Algebra.ev_T_η (M : Monad α) (alg : Algebra M) (f : hom X alg.A) : alg.eval ∘ M.T.map f ∘ M.η.app X = f :=
  by rw [← M.η.natural, ← comp_assoc]; unfold Functor.id; simp;

structure AlgebraHom {M : Monad α} (alg₁ alg₂ : Algebra M) where
  map : hom alg₁.A alg₂.A
  comm : map ∘ alg₁.eval = alg₂.eval ∘ M.T.map map := by simp

attribute [simp] AlgebraHom.comm

instance CatAlgebra (M : Monad α) : Category M.Algebra where
  hom := AlgebraHom
  id _ := { map := 𝟙 _ }
  comp g f := {
    map := g.map ∘ f.map,
    comm := by simp; rw [← comp_assoc, g.comm]; simp
  }
  comp_id _ := by simp
  id_comp _ := by simp
  comp_assoc _ _ _:= by simp

def free (M : Monad α) : Functor α M.Algebra where
  obj X := { A := M.T.obj X, eval := M.μ.app X }
  map f := { map := M.T.map f }
  map_id f := by simp; rfl
  map_comp g f := by simp; rfl

def forget (M : Monad α) : Functor M.Algebra α where
  obj alg := alg.A
  map f := f.map
  map_id f := by rfl
  map_comp g f := by rfl

def adjunction (M : Monad α) : M.free ⊣ M.forget where
  equiv X Y := {
    map := λ f => f.map ∘ M.η.app X,
    inv := λ g => {
      map := Y.eval ∘ M.T.map g,
      comm := by {
        unfold free;
        simp;
        congr;
        rw [← M.μ.natural];
        -- rw [← M.T.map_comp];
        unfold Functor.comp;
        dsimp;
        congr; -- probably not the way to go ..
        simp;
        sorry;
      },
    },
    map_inv := λ _ => by simp
    inv_map := λ f => by sorry
  }
  natural f g h := by {
    simp [forget, free];
    sorry;
  }

end CategoryTheory.Monad


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

! This file was ported from Lean 3 source module order.countable_dense_linear_order
! leanprover-community/mathlib commit 2705404e701abc6b3127da906f40bae062a169c9
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Order.Ideal
import Mathlib.Data.Finset.Lattice

/-!
# The back and forth method and countable dense linear orders

## Results

Suppose `α β` are linear orders, with `α` countable and `β` dense, nontrivial. Then there is an
order embedding `α ↪ β`. If in addition `α` is dense, nonempty, without endpoints and `β` is
countable, without endpoints, then we can upgrade this to an order isomorphism `α ≃ β`.

The idea for both results is to consider "partial isomorphisms", which identify a finite subset of
`α` with a finite subset of `β`, and prove that for any such partial isomorphism `f` and `a : α`, we
can extend `f` to include `a` in its domain.

## References

https://en.wikipedia.org/wiki/Back-and-forth_method

## Tags

back and forth, dense, countable, order
-/

noncomputable section

open Classical

namespace Order

/-- Suppose `α` is a nonempty dense linear order without endpoints, and
    suppose `lo`, `hi`, are finite subssets with all of `lo` strictly
    before `hi`. Then there is an element of `α` strictly between `lo`
    and `hi`. -/
theorem exists_between_finsets {α : Type _} [LinearOrder α] [DenselyOrdered α] [NoMinOrder α]
    [NoMaxOrder α] [nonem : Nonempty α] (lo hi : Finset α) (lo_lt_hi : ∀ x ∈ lo, ∀ y ∈ hi, x < y) :
    ∃ m : α, (∀ x ∈ lo, x < m) ∧ ∀ y ∈ hi, m < y :=
  if nlo : lo.Nonempty then
    if nhi : hi.Nonempty then
      -- both sets are nonempty, use densely_ordered
        Exists.elim
        (exists_between (lo_lt_hi _ (Finset.max'_mem _ nlo) _ (Finset.min'_mem _ nhi))) fun m hm ↦
        ⟨m, fun x hx ↦ lt_of_le_of_lt (Finset.le_max' lo x hx) hm.1, fun y hy ↦
          lt_of_lt_of_le hm.2 (Finset.min'_le hi y hy)⟩
    else-- upper set is empty, use `NoMaxOrder`
        Exists.elim
        (exists_gt (Finset.max' lo nlo)) fun m hm ↦
        ⟨m, fun x hx ↦ lt_of_le_of_lt (Finset.le_max' lo x hx) hm, fun y hy ↦ (nhi ⟨y, hy⟩).elim⟩
  else
    if nhi : hi.Nonempty then
      -- lower set is empty, use `NoMinOrder`
        Exists.elim
        (exists_lt (Finset.min' hi nhi)) fun m hm ↦
        ⟨m, fun x hx ↦ (nlo ⟨x, hx⟩).elim, fun y hy ↦ lt_of_lt_of_le hm (Finset.min'_le hi y hy)⟩
    else-- both sets are empty, use nonempty
          nonem.elim
        fun m ↦ ⟨m, fun x hx ↦ (nlo ⟨x, hx⟩).elim, fun y hy ↦ (nhi ⟨y, hy⟩).elim⟩
#align order.exists_between_finsets Order.exists_between_finsets

variable (α β : Type _) [LinearOrder α] [LinearOrder β]

-- Porting note: Mathport warning: expanding binder collection (p q «expr ∈ » f)
/-- The type of partial order isomorphisms between `α` and `β` defined on finite subsets.
    A partial order isomorphism is encoded as a finite subset of `α × β`, consisting
    of pairs which should be identified. -/
def PartialIso : Type _ :=
  { f : Finset (α × β) //
    ∀ (p) (_ : p ∈ f) (q) (_ : q ∈ f),
      cmp (Prod.fst p) (Prod.fst q) = cmp (Prod.snd p) (Prod.snd q) }
#align order.partial_iso Order.PartialIso

namespace PartialIso

instance : Inhabited (PartialIso α β) := ⟨⟨∅, fun _p h _q ↦ (Finset.not_mem_empty _ h).elim⟩⟩

instance : Preorder (PartialIso α β) := Subtype.preorder _

variable {α β}

/-- For each `a`, we can find a `b` in the codomain, such that `a`'s relation to
the domain of `f` is `b`'s relation to the image of `f`.

Thus, if `a` is not already in `f`, then we can extend `f` by sending `a` to `b`.
-/
theorem exists_across [DenselyOrdered β] [NoMinOrder β] [NoMaxOrder β] [Nonempty β]
    (f : PartialIso α β) (a : α) : ∃ b : β, ∀ p ∈ f.val, cmp (Prod.fst p) a = cmp (Prod.snd p) b :=
  by
  by_cases h : ∃ b, (a, b) ∈ f.val
  · cases' h with b hb
    exact ⟨b, fun p hp ↦ f.prop _ hp _ hb⟩
  have :
    ∀ x ∈ (f.val.filter fun p : α × β ↦ p.fst < a).image Prod.snd,
      ∀ y ∈ (f.val.filter fun p : α × β ↦ a < p.fst).image Prod.snd, x < y := by
    intro x hx y hy
    rw [Finset.mem_image] at hx hy
    rcases hx with ⟨p, hp1, rfl⟩
    rcases hy with ⟨q, hq1, rfl⟩
    rw [Finset.mem_filter] at hp1 hq1
    rw [← lt_iff_lt_of_cmp_eq_cmp (f.prop _ hp1.1 _ hq1.1)]
    exact lt_trans hp1.right hq1.right
  cases' exists_between_finsets _ _ this with b hb
  use b
  rintro ⟨p1, p2⟩ hp
  have : p1 ≠ a := fun he ↦ h ⟨p2, he ▸ hp⟩
  cases' lt_or_gt_of_ne this with hl hr
  · have : p1 < a ∧ p2 < b :=
      ⟨hl, hb.1 _ (Finset.mem_image.mpr ⟨(p1, p2), Finset.mem_filter.mpr ⟨hp, hl⟩, rfl⟩)⟩
    rw [← cmp_eq_lt_iff, ← cmp_eq_lt_iff] at this
    exact this.1.trans this.2.symm
  · have : a < p1 ∧ b < p2 :=
      ⟨hr, hb.2 _ (Finset.mem_image.mpr ⟨(p1, p2), Finset.mem_filter.mpr ⟨hp, hr⟩, rfl⟩)⟩
    rw [← cmp_eq_gt_iff, ← cmp_eq_gt_iff] at this
    exact this.1.trans this.2.symm
#align order.partial_iso.exists_across Order.PartialIso.exists_across

/-- A partial isomorphism between `α` and `β` is also a partial isomorphism between `β` and `α`. -/
protected def comm : PartialIso α β → PartialIso β α :=
  Subtype.map (Finset.image (Equiv.prodComm _ _)) fun f hf p hp q hq ↦
    Eq.symm <|
      hf ((Equiv.prodComm α β).symm p)
        (by
          rw [← Finset.mem_coe, Finset.coe_image, Equiv.image_eq_preimage] at hp
          rwa [← Finset.mem_coe])
        ((Equiv.prodComm α β).symm q)
        (by
          rw [← Finset.mem_coe, Finset.coe_image, Equiv.image_eq_preimage] at hq
          rwa [← Finset.mem_coe])
#align order.partial_iso.comm Order.PartialIso.comm

variable (β)

/-- The set of partial isomorphisms defined at `a : α`, together with a proof that any
    partial isomorphism can be extended to one defined at `a`. -/
def definedAtLeft [DenselyOrdered β] [NoMinOrder β] [NoMaxOrder β] [Nonempty β] (a : α) :
    Cofinal (PartialIso α β) where
  carrier f := ∃ b : β, (a, b) ∈ f.val
  mem_gt f := by
    cases' exists_across f a with b a_b
    refine
      ⟨⟨insert (a, b) f.val, fun p hp q hq ↦ ?_⟩, ⟨b, Finset.mem_insert_self _ _⟩,
        Finset.subset_insert _ _⟩
    rw [Finset.mem_insert] at hp hq
    rcases hp with (rfl | pf) <;> rcases hq with (rfl | qf)
    · simp only [cmp_self_eq_eq]
    · rw [cmp_eq_cmp_symm]
      exact a_b _ qf
    · exact a_b _ pf
    · exact f.prop _ pf _ qf
#align order.partial_iso.defined_at_left Order.PartialIso.definedAtLeft

variable (α) {β}

/-- The set of partial isomorphisms defined at `b : β`, together with a proof that any
    partial isomorphism can be extended to include `b`. We prove this by symmetry. -/
def definedAtRight [DenselyOrdered α] [NoMinOrder α] [NoMaxOrder α] [Nonempty α] (b : β) :
    Cofinal (PartialIso α β) where
  carrier f := ∃ a, (a, b) ∈ f.val
  mem_gt f := by
    rcases (definedAtLeft α b).mem_gt f.comm with ⟨f', ⟨a, ha⟩, hl⟩
    refine' ⟨f'.comm, ⟨a, _⟩, _⟩
    · change (a, b) ∈ f'.val.image _
      rwa [← Finset.mem_coe, Finset.coe_image, Equiv.image_eq_preimage]
    · change _ ⊆ f'.val.image _
      rwa [← Finset.coe_subset, Finset.coe_image, ← Equiv.subset_image, ← Finset.coe_image,
        Finset.coe_subset]
#align order.partial_iso.defined_at_right Order.PartialIso.definedAtRight

variable {α}

/-- Given an ideal which intersects `definedAtLeft β a`, pick `b : β` such that
    some partial function in the ideal maps `a` to `b`. -/
def funOfIdeal [DenselyOrdered β] [NoMinOrder β] [NoMaxOrder β] [Nonempty β] (a : α)
    (I : Ideal (PartialIso α β)) :
    (∃ f, f ∈ definedAtLeft β a ∧ f ∈ I) → { b // ∃ f ∈ I, (a, b) ∈ Subtype.val f } :=
  Classical.indefiniteDescription _ ∘ fun ⟨f, ⟨b, hb⟩, hf⟩ ↦ ⟨b, f, hf, hb⟩
#align order.partial_iso.fun_of_ideal Order.PartialIso.funOfIdeal

/-- Given an ideal which intersects `definedAtRight α b`, pick `a : α` such that
    some partial function in the ideal maps `a` to `b`. -/
def invOfIdeal [DenselyOrdered α] [NoMinOrder α] [NoMaxOrder α] [Nonempty α] (b : β)
    (I : Ideal (PartialIso α β)) :
    (∃ f, f ∈ definedAtRight α b ∧ f ∈ I) → { a // ∃ f ∈ I, (a, b) ∈ Subtype.val f } :=
  Classical.indefiniteDescription _ ∘ fun ⟨f, ⟨a, ha⟩, hf⟩ ↦ ⟨a, f, hf, ha⟩
#align order.partial_iso.inv_of_ideal Order.PartialIso.invOfIdeal

end PartialIso

open PartialIso

-- variable (α β)

/-- Any countable linear order embeds in any nontrivial dense linear order. -/
theorem embedding_from_countable_to_dense [Encodable α] [DenselyOrdered β] [Nontrivial β] :
    Nonempty (α ↪o β) := by
  rcases exists_pair_lt β with ⟨x, y, hxy⟩
  cases' exists_between hxy with a ha
  haveI : Nonempty (Set.Ioo x y) := ⟨⟨a, ha⟩⟩
  let our_ideal : Ideal (PartialIso α _) :=
    idealOfCofinals default (definedAtLeft (Set.Ioo x y))
  let F a := funOfIdeal a our_ideal (cofinal_meets_idealOfCofinals _ _ a)
  refine
    ⟨RelEmbedding.trans (OrderEmbedding.ofStrictMono (fun a ↦ (F a).val) fun a₁ a₂ ↦ ?_)
        (OrderEmbedding.subtype _)⟩
  rcases(F a₁).prop with ⟨f, hf, ha₁⟩
  rcases(F a₂).prop with ⟨g, hg, ha₂⟩
  rcases our_ideal.directed _ hf _ hg with ⟨m, _hm, fm, gm⟩
  exact (lt_iff_lt_of_cmp_eq_cmp <| m.prop (a₁, _) (fm ha₁) (a₂, _) (gm ha₂)).mp
#align order.embedding_from_countable_to_dense Order.embedding_from_countable_to_dense

/-- Any two countable dense, nonempty linear orders without endpoints are order isomorphic. -/
theorem iso_of_countable_dense [Encodable α] [DenselyOrdered α] [NoMinOrder α] [NoMaxOrder α]
    [Nonempty α] [Encodable β] [DenselyOrdered β] [NoMinOrder β] [NoMaxOrder β] [Nonempty β] :
    Nonempty (α ≃o β) :=
  let to_cofinal : Sum α β → Cofinal (PartialIso α β) := fun p ↦
    Sum.recOn p (definedAtLeft β) (definedAtRight α)
  let our_ideal : Ideal (PartialIso α β) := idealOfCofinals default to_cofinal
  let F a := funOfIdeal a our_ideal (cofinal_meets_idealOfCofinals _ to_cofinal (Sum.inl a))
  let G b := invOfIdeal b our_ideal (cofinal_meets_idealOfCofinals _ to_cofinal (Sum.inr b))
  ⟨OrderIso.ofCmpEqCmp (fun a ↦ (F a).val) (fun b ↦ (G b).val) fun a b ↦ by
      rcases(F a).prop with ⟨f, hf, ha⟩
      rcases(G b).prop with ⟨g, hg, hb⟩
      rcases our_ideal.directed _ hf _ hg with ⟨m, _, fm, gm⟩
      exact m.prop (a, _) (fm ha) (_, b) (gm hb)⟩
#align order.iso_of_countable_dense Order.iso_of_countable_dense

end Order


import data.set

variables {α β: Type}

def Property (α : Type) : Type := α → Prop

structure Claim (α : Type) :=
(X : set α)
(P : Property α)

@[instance] def claim_default {α : Type} : inhabited (Claim α) :=
⟨Claim.mk ∅ (λ x, true)⟩

@[reducible]
def meaning {α : Type} (C : Claim α) : Prop :=
∀ x ∈ C.X, C.P x

notation ⟦C⟧ := meaning C

structure Strategy (α : Type) :=
(parent : Claim α) (decomp : Claim α → list (Claim α))

@[instance] def strat_default {α : Type} : inhabited (Strategy α) :=
⟨Strategy.mk (default (Claim α)) (λ c, [])⟩

def deductive (α : Type) (S : Strategy α) : Prop :=
let subclaims := (S.decomp) S.parent in
(∀ clm ∈ subclaims, ⟦clm⟧) →  ⟦S.parent⟧

namespace property

@[reducible]
def decomposition
(Ps : list (Property α))
(Clm : Claim α) : list (Claim α) :=
list.map (Claim.mk Clm.X) Ps

structure input (α : Type) :=
(Clm : Claim α)
(Props : list (Property α))

@[instance] def input_default {α : Type} : inhabited (input α) :=
⟨input.mk (default (Claim α)) []⟩

namespace input

@[reducible]
def length (Γ : input α) : ℕ := Γ.Props.length

lemma len_decomp (Γ : input α) :
Γ.length = (decomposition Γ.Props Γ.Clm).length :=
by {rw decomposition, simp}

@[reducible]
def subsets (Γ : input α) : fin (Γ.length) → set α :=
λ i, set_of (Γ.Props.nth_le i.1 i.2)

end input

def justified
(Γ : input α) : Prop :=
(⋂ i, Γ.subsets i) ⊆ {x | Γ.Clm.P x}

@[reducible]
def strategy (Γ : input α) : Strategy α :=
{ parent := Γ.Clm,
  decomp := property.decomposition Γ.Props }

theorem deductive_of_justfd
: Π {Γ : property.input α},
justified Γ → deductive α (property.strategy Γ) :=
begin
  intro Γ,
  rw [justified,deductive, meaning,strategy],
  simp only [fin.val_eq_coe],
  intros H1 H2 x xMem, apply H1,
  simp only [set.mem_Inter, set.mem_set_of_eq],
  intro i,
  replace H2 := H2 ((decomposition Γ.Props Γ.Clm).nth_le i.1 (fin.cast (input.len_decomp Γ) i).2),
  simp at H2, apply H2,
  apply list.nth_le_mem, assumption,
end

end property

/-
namespace domain

@[reducible]
def to_claim {α : Type}
(P : Property α) (X : set α) : Claim α :=
Claim.mk X P

@[reducible]
def preimages {α β: Type}
(f : α → β)
(Clm : Claim α)
(bs : list (set β)) : list (set α) :=
list.map (set.preimage f) bs

@[reducible]
def decomposition {α β: Type}
(f : α → β)
(sets_range : list (set β))
(Clm : Claim α) : list (Claim α) :=
(preimages f Clm sets_range).map (to_claim Clm.P)

structure auxiliary (α β : Type) :=
(Clm : Claim α)
(f : α → β)
(range_sets : list (set β))

def set_of_list : list α → set α
| [] := ∅
| (h::t) := {h} ∪ set_of_list t

def complete (Γ : auxiliary α β) : Prop :=
 ∀ b : β, ∃ s ∈ Γ.range_sets, b ∈ s

def to_strategy (Γ : auxiliary α β) : strategy α :=
strategy.mk (Γ.Clm) (domain.decomposition Γ.f Γ.range_sets)

theorem deductive_of_justfd_comp (Γ : auxiliary α β) : complete Γ →  deductive α (to_strategy Γ) :=
begin
  rw [complete, deductive, meaning, to_strategy],
  simp only [fin.val_eq_coe],
  intros H1 H2 x xMem,
  unfold decomposition at H2,simp at H2,
  unfold to_claim at H2,
  have H3 : ∃ s ∈ Γ.range_sets, Γ.f x ∈ s, from H1 (Γ.f x),
  rcases H3 with ⟨s,H3,H4⟩,
  replace H2 := H2 s H3,
  apply H2, assumption,
end

end domain
-/


/-
Copyright (c) 2022 James Gallicchio.

Authors: James Gallicchio
-/

import LeanColls.Array.Basic
import LeanColls.Array.VarArray

namespace LeanColls

structure ArrayBuffer (α) where
  cap : Nat
  h_cap : cap > 0
  size : Nat
  h_size : size ≤ cap
  backing : ArrayUninit α cap size h_size

namespace ArrayBuffer

def empty (_ : Unit) (initCap : Nat := 16) (h_cap : 1 ≤ initCap := by decide) : ArrayBuffer α := ⟨
  initCap,
  h_cap,
  0,
  Nat.zero_le _,
  ArrayUninit.new initCap
  ⟩

@[inline] def full (A : ArrayBuffer α) : Bool := A.size = A.cap

def grow : ArrayBuffer α → ArrayBuffer α :=
λ ⟨cap, h_cap, size, h_size, backing⟩ =>
  let newCap := 2 * cap
  have : cap < newCap := by
    have := Nat.mul_lt_mul_of_pos_right (Nat.lt_succ_self 1) h_cap
    simp at this ⊢
    assumption
  ⟨newCap, Nat.le_trans h_cap <| Nat.le_of_lt this,
    size,
    Nat.le_trans h_size <| Nat.le_of_lt this,
    backing.resize newCap (Nat.le_trans h_size <| Nat.le_of_lt this)⟩

theorem grow_notfull (A : ArrayBuffer α)
  : ¬A.grow.full
  := by
    simp [full,grow]
    apply (decide_eq_false_iff_not _).mpr
    suffices A.size < 2 * A.cap from
      Nat.ne_of_lt this
    have := Nat.mul_lt_mul_of_pos_right (Nat.lt_succ_self 1) A.h_cap
    simp at this ⊢
    apply Nat.lt_of_le_of_lt A.h_size
    assumption

@[inline] def push_notfull (A : ArrayBuffer α) (h : ¬A.full) (a : α) : ArrayBuffer α
  :=
    match A with
    | ⟨cap, h_cap, size, h_size, backing⟩ =>
    have h_size : size < cap :=
      Nat.lt_of_le_of_ne h_size <| by simp [full] at h; exact h
    ⟨ cap, h_cap,
      size + 1, h_size,
      backing.push a h_size⟩

def push (A : ArrayBuffer α) (a : α) : ArrayBuffer α :=
  if h:A.size = A.cap then
    A.grow.push_notfull (A.grow_notfull) a
  else
    A.push_notfull (by simp [full,h]) a

def toArray (A : ArrayBuffer α) : Array α A.size :=
  match A with
  | ⟨_, _, size, h_size, backing⟩ =>
  if ArrayUninit.isExclusive A
  then ⟨backing.resize size (Nat.le_refl _)⟩
  else Array.init (n := size) (fun ⟨i,h⟩ =>
    backing.get i (Nat.lt_of_lt_of_le h h_size) h)

instance : Enumerable (VarArray α) α where
  ρ := ArrayBuffer α
  insert A :=
    match A with
    | some ⟨a,A⟩ => A.push a
    | none => ArrayBuffer.empty ()
  fromEnumerator A := ⟨A.size, ⟨A.toArray⟩⟩

def foldl (f : _ → _ → _) (acc : β) (A : ArrayBuffer α) :=
  (Range.mk A.size).foldl' (fun acc i h =>
    f acc (A.backing.get i (Nat.lt_of_lt_of_le h A.h_size) h)
  ) acc

instance : Foldable (ArrayBuffer α) α where
  fold A f acc := A.foldl f acc


/-
Copyright (c) 2019 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import set_theory.game.state

/-!
# Domineering as a combinatorial game.

We define the game of Domineering, played on a chessboard of arbitrary shape
(possibly even disconnected).
Left moves by placing a domino vertically, while Right moves by placing a domino horizontally.

This is only a fragment of a full development;
in order to successfully analyse positions we would need some more theorems.
Most importantly, we need a general statement that allows us to discard irrelevant moves.
Specifically to domineering, we need the fact that
disjoint parts of the chessboard give sums of games.
-/

namespace pgame

namespace domineering

open function

/-- The embedding `(x, y) ↦ (x, y+1)`. -/
def shift_up : ℤ × ℤ ↪ ℤ × ℤ :=
(embedding.refl ℤ).prod_map ⟨λ n, n + 1, add_left_injective 1⟩
/-- The embedding `(x, y) ↦ (x+1, y)`. -/
def shift_right : ℤ × ℤ ↪ ℤ × ℤ :=
embedding.prod_map ⟨λ n, n + 1, add_left_injective 1⟩ (embedding.refl ℤ)

/-- A Domineering board is an arbitrary finite subset of `ℤ × ℤ`. -/
@[derive inhabited]
def board := finset (ℤ × ℤ)
local attribute [reducible] board

/-- Left can play anywhere that a square and the square below it are open. -/
def left  (b : board) : finset (ℤ × ℤ) := b ∩ b.map shift_up
/-- Right can play anywhere that a square and the square to the left are open. -/
def right (b : board) : finset (ℤ × ℤ) := b ∩ b.map shift_right

/-- After Left moves, two vertically adjacent squares are removed from the board. -/
def move_left (b : board) (m : ℤ × ℤ) : board :=
(b.erase m).erase (m.1, m.2 - 1)
/-- After Left moves, two horizontally adjacent squares are removed from the board. -/
def move_right (b : board) (m : ℤ × ℤ) : board :=
(b.erase m).erase (m.1 - 1, m.2)

lemma card_of_mem_left {b : board} {m : ℤ × ℤ} (h : m ∈ left b) : 2 ≤ finset.card b :=
begin
  dsimp [left] at h,
  have w₁ : m ∈ b,
  { rw finset.mem_inter at h,
    exact h.1 },
  have w₂ : (m.1, m.2 - 1) ∈ b.erase m,
  { simp only [finset.mem_erase],
    fsplit,
    { exact λ w, pred_ne_self m.2 (congr_arg prod.snd w) },
    { rw finset.mem_inter at h,
      have h₂ := h.2, clear h,
      rw finset.mem_map at h₂,
      rcases h₂ with ⟨m', ⟨h₂, rfl⟩⟩,
      dsimp [shift_up],
      simpa, }, },
  have i₁ := finset.card_erase_lt_of_mem w₁,
  have i₂ := nat.lt_of_le_of_lt (nat.zero_le _) (finset.card_erase_lt_of_mem w₂),
  exact nat.lt_of_le_of_lt i₂ i₁,
end

lemma card_of_mem_right {b : board} {m : ℤ × ℤ} (h : m ∈ right b) : 2 ≤ finset.card b :=
begin
  dsimp [right] at h,
  have w₁ : m ∈ b,
  { rw finset.mem_inter at h,
    exact h.1 },
  have w₂ : (m.1 - 1, m.2) ∈ b.erase m,
  { simp only [finset.mem_erase],
    fsplit,
    { exact λ w, pred_ne_self m.1 (congr_arg prod.fst w) },
    { rw finset.mem_inter at h,
      have h₂ := h.2, clear h,
      rw finset.mem_map at h₂,
      rcases h₂ with ⟨m', ⟨h₂, rfl⟩⟩,
      dsimp [shift_right],
      simpa, }, },
  have i₁ := finset.card_erase_lt_of_mem w₁,
  have i₂ := nat.lt_of_le_of_lt (nat.zero_le _) (finset.card_erase_lt_of_mem w₂),
  exact nat.lt_of_le_of_lt i₂ i₁,
end

lemma move_left_card {b : board} {m : ℤ × ℤ} (h : m ∈ left b) :
  finset.card (move_left b m) + 2 = finset.card b :=
begin
  dsimp [move_left],
  rw finset.card_erase_of_mem,
  { rw finset.card_erase_of_mem,
    { exact nat.sub_add_cancel (card_of_mem_left h), },
    { exact finset.mem_of_mem_inter_left h, } },
  { apply finset.mem_erase_of_ne_of_mem,
    { exact λ w, pred_ne_self m.2 (congr_arg prod.snd w), },
    { have t := finset.mem_of_mem_inter_right h,
      dsimp [shift_up] at t,
      simp only [finset.mem_map, prod.exists] at t,
      rcases t with ⟨x,y,w,h⟩,
      rw ←h,
      convert w,
      simp, } }
end
lemma move_right_card {b : board} {m : ℤ × ℤ} (h : m ∈ right b) :
  finset.card (move_right b m) + 2 = finset.card b :=
begin
  dsimp [move_right],
  rw finset.card_erase_of_mem,
  { rw finset.card_erase_of_mem,
    { exact nat.sub_add_cancel (card_of_mem_right h), },
    { exact finset.mem_of_mem_inter_left h, } },
  { apply finset.mem_erase_of_ne_of_mem,
    { exact λ w, pred_ne_self m.1 (congr_arg prod.fst w), },
    { have t := finset.mem_of_mem_inter_right h,
      dsimp [shift_right] at t,
      simp only [finset.mem_map, prod.exists] at t,
      rcases t with ⟨x,y,w,h⟩,
      rw ←h,
      convert w,
      simp, } }
end

lemma move_left_smaller {b : board} {m : ℤ × ℤ} (h : m ∈ left b) :
  finset.card (move_left b m) / 2 < finset.card b / 2 :=
by simp [←move_left_card h, lt_add_one]
lemma move_right_smaller {b : board} {m : ℤ × ℤ} (h : m ∈ right b) :
  finset.card (move_right b m) / 2 < finset.card b / 2 :=
by simp [←move_right_card h, lt_add_one]

/-- The instance describing allowed moves on a Domineering board. -/
instance state : state board :=
{ turn_bound := λ s, s.card / 2,
  L := λ s, (left s).image (move_left s),
  R := λ s, (right s).image (move_right s),
  left_bound := λ s t m,
  begin
    simp only [finset.mem_image, prod.exists] at m,
    rcases m with ⟨_, _, ⟨h, rfl⟩⟩,
    exact move_left_smaller h
  end,
  right_bound := λ s t m,
  begin
    simp only [finset.mem_image, prod.exists] at m,
    rcases m with ⟨_, _, ⟨h, rfl⟩⟩,
    exact move_right_smaller h
  end, }

end domineering

/-- Construct a pre-game from a Domineering board. -/
def domineering (b : domineering.board) : pgame := pgame.of b

/-- All games of Domineering are short, because each move removes two squares. -/
instance short_domineering (b : domineering.board) : short (domineering b) :=
by { dsimp [domineering], apply_instance }

/-- The Domineering board with two squares arranged vertically, in which Left has the only move. -/
def domineering.one := domineering ([(0,0), (0,1)].to_finset)

/-- The `L` shaped Domineering board, in which Left is exactly half a move ahead. -/
def domineering.L := domineering ([(0,2), (0,1), (0,0), (1,0)].to_finset)

instance short_one : short domineering.one := by { dsimp [domineering.one], apply_instance }
instance short_L : short domineering.L := by { dsimp [domineering.L], apply_instance }

-- The VM can play small games successfully:
-- #eval to_bool (domineering.one ≈ 1)
-- #eval to_bool (domineering.L + domineering.L ≈ 1)

-- The following no longer works since Lean 3.29, since definitions by well-founded
-- recursion no longer reduce definitionally.

-- We can check that `decidable` instances reduce as expected,
-- and so our implementation of domineering is computable.
-- run_cmd tactic.whnf `(by apply_instance : decidable (domineering.one ≤ 1)) >>= tactic.trace

-- dec_trivial can handle most of the dictionary of small games described in [conway2001]
-- example : domineering.one ≈ 1 := dec_trivial
-- example : domineering.L + domineering.L ≈ 1 := dec_trivial
-- example : domineering.L ≈ pgame.of_lists [0] [1] := dec_trivial
-- example : (domineering ([(0,0), (0,1), (0,2), (0,3)].to_finset) ≈ 2) := dec_trivial
-- example : (domineering ([(0,0), (0,1), (1,0), (1,1)].to_finset) ≈ pgame.of_lists [1] [-1]) :=
--   dec_trivial.

-- The 3x3 grid is doable, but takes a minute...
-- example :
--   (domineering ([(0,0), (0,1), (0,2), (1,0), (1,1), (1,2), (2,0), (2,1), (2,2)].to_finset) ≈
--     pgame.of_lists [1] [-1]) := dec_trivial

-- The 5x5 grid is actually 0, but brute-forcing this is too challenging even for the VM.
-- #eval to_bool (domineering ([
--   (0,0), (0,1), (0,2), (0,3), (0,4),
--   (1,0), (1,1), (1,2), (1,3), (1,4),
--   (2,0), (2,1), (2,2), (2,3), (2,4),
--   (3,0), (3,1), (3,2), (3,3), (3,4),
--   (4,0), (4,1), (4,2), (4,3), (4,4)
--   ].to_finset) ≈ 0)

end pgame


/-
Copyright (c) 2021 Heather Macbeth. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Heather Macbeth
-/
import topology.algebra.mul_action
import topology.metric_space.lipschitz

/-!
# Compatibility of algebraic operations with metric space structures

In this file we define mixin typeclasses `has_lipschitz_mul`, `has_lipschitz_add`,
`has_bounded_smul` expressing compatibility of multiplication, addition and scalar-multiplication
operations with an underlying metric space structure.  The intended use case is to abstract certain
properties shared by normed groups and by `R≥0`.

## Implementation notes

We deduce a `has_continuous_mul` instance from `has_lipschitz_mul`, etc.  In principle there should
be an intermediate typeclass for uniform spaces, but the algebraic hierarchy there (see
`uniform_group`) is structured differently.

-/

open_locale nnreal

noncomputable theory

variables (α β : Type*) [pseudo_metric_space α] [pseudo_metric_space β]

section has_lipschitz_mul

/-- Class `has_lipschitz_add M` says that the addition `(+) : X × X → X` is Lipschitz jointly in
the two arguments. -/
class has_lipschitz_add [add_monoid β] : Prop :=
( lipschitz_add : ∃ C, lipschitz_with C (λ p : β × β, p.1 + p.2) )

/-- Class `has_lipschitz_mul M` says that the multiplication `(*) : X × X → X` is Lipschitz jointly
in the two arguments. -/
@[to_additive] class has_lipschitz_mul [monoid β] : Prop :=
( lipschitz_mul : ∃ C, lipschitz_with C (λ p : β × β, p.1 * p.2) )

variables [monoid β]

/-- The Lipschitz constant of a monoid `β` satisfying `has_lipschitz_mul` -/
@[to_additive "The Lipschitz constant of an `add_monoid` `β` satisfying `has_lipschitz_add`"]
def has_lipschitz_mul.C [_i : has_lipschitz_mul β] : ℝ≥0 :=
classical.some _i.lipschitz_mul

variables {β}

@[to_additive] lemma lipschitz_with_lipschitz_const_mul_edist [_i : has_lipschitz_mul β] :
  lipschitz_with (has_lipschitz_mul.C β) (λ p : β × β, p.1 * p.2) :=
classical.some_spec _i.lipschitz_mul

variables [has_lipschitz_mul β]

@[to_additive] lemma lipschitz_with_lipschitz_const_mul :
  ∀ p q : β × β, dist (p.1 * p.2) (q.1 * q.2) ≤ (has_lipschitz_mul.C β) * dist p q :=
begin
  rw ← lipschitz_with_iff_dist_le_mul,
  exact lipschitz_with_lipschitz_const_mul_edist,
end

@[to_additive, priority 100] -- see Note [lower instance priority]
instance has_lipschitz_mul.has_continuous_mul : has_continuous_mul β :=
⟨ lipschitz_with_lipschitz_const_mul_edist.continuous ⟩

@[to_additive] instance submonoid.has_lipschitz_mul (s : submonoid β) : has_lipschitz_mul s :=
{ lipschitz_mul := ⟨has_lipschitz_mul.C β, begin
    rintros ⟨x₁, x₂⟩ ⟨y₁, y₂⟩,
    convert lipschitz_with_lipschitz_const_mul_edist ⟨(x₁:β), x₂⟩ ⟨y₁, y₂⟩ using 1
  end⟩ }

-- this instance could be deduced from `normed_group.has_lipschitz_add`, but we prove it separately
-- here so that it is available earlier in the hierarchy
instance real.has_lipschitz_add : has_lipschitz_add ℝ :=
{ lipschitz_add := ⟨2, begin
    rw lipschitz_with_iff_dist_le_mul,
    intros p q,
    simp only [real.dist_eq, prod.dist_eq, prod.fst_sub, prod.snd_sub, nnreal.coe_one,
      nnreal.coe_bit0],
    convert le_trans (abs_add (p.1 - q.1) (p.2 - q.2)) _ using 2,
    { abel },
    have := le_max_left (|p.1 - q.1|) (|p.2 - q.2|),
    have := le_max_right (|p.1 - q.1|) (|p.2 - q.2|),
    linarith,
  end⟩ }

-- this instance has the same proof as `add_submonoid.has_lipschitz_add`, but the former can't
-- directly be applied here since `ℝ≥0` is a subtype of `ℝ`, not an additive submonoid.
instance nnreal.has_lipschitz_add : has_lipschitz_add ℝ≥0 :=
{ lipschitz_add := ⟨has_lipschitz_add.C ℝ, begin
    rintros ⟨x₁, x₂⟩ ⟨y₁, y₂⟩,
    convert lipschitz_with_lipschitz_const_add_edist ⟨(x₁:ℝ), x₂⟩ ⟨y₁, y₂⟩ using 1
  end⟩ }

end has_lipschitz_mul

section has_bounded_smul

variables [has_zero α] [has_zero β] [has_scalar α β]

/-- Mixin typeclass on a scalar action of a metric space `α` on a metric space `β` both with
distinguished points `0`, requiring compatibility of the action in the sense that
`dist (x • y₁) (x • y₂) ≤ dist x 0 * dist y₁ y₂` and
`dist (x₁ • y) (x₂ • y) ≤ dist x₁ x₂ * dist y 0`. -/
class has_bounded_smul : Prop :=
( dist_smul_pair' : ∀ x : α, ∀ y₁ y₂ : β, dist (x • y₁) (x • y₂) ≤ dist x 0 * dist y₁ y₂ )
( dist_pair_smul' : ∀ x₁ x₂ : α, ∀ y : β, dist (x₁ • y) (x₂ • y) ≤ dist x₁ x₂ * dist y 0 )

variables {α β} [has_bounded_smul α β]

lemma dist_smul_pair  (x : α) (y₁ y₂ : β) : dist (x • y₁) (x • y₂) ≤ dist x 0 * dist y₁ y₂ :=
has_bounded_smul.dist_smul_pair' x y₁ y₂

lemma dist_pair_smul (x₁ x₂ : α) (y : β) : dist (x₁ • y) (x₂ • y) ≤ dist x₁ x₂ * dist y 0 :=
has_bounded_smul.dist_pair_smul' x₁ x₂ y

/-- The typeclass `has_bounded_smul` on a metric-space scalar action implies continuity of the
action. -/
@[priority 100] -- see Note [lower instance priority]
instance has_bounded_smul.has_continuous_smul : has_continuous_smul α β :=
{ continuous_smul := begin
    rw metric.continuous_iff,
    rintros ⟨a, b⟩ ε hε,
    have : 0 ≤ dist a 0 := dist_nonneg,
    have : 0 ≤ dist b 0 := dist_nonneg,
    let δ : ℝ := min 1 ((dist a 0 + dist b 0 + 2)⁻¹ * ε),
    have hδ_pos : 0 < δ,
    { refine lt_min_iff.mpr ⟨by norm_num, mul_pos _ hε⟩,
      rw inv_pos,
      linarith },
    refine ⟨δ, hδ_pos, _⟩,
    rintros ⟨a', b'⟩ hab',
    calc _ ≤ _ : dist_triangle _ (a • b') _
    ... ≤ δ * (dist a 0 + dist b 0 + δ) : _
    ... < ε : _,
    { have : 0 ≤ dist a' a := dist_nonneg,
      have := dist_triangle b' b 0,
      have := dist_comm (a • b') (a' • b'),
      have := dist_comm a a',
      have : dist a' a ≤ dist (a', b') (a, b) := le_max_left _ _,
      have : dist b' b ≤ dist (a', b') (a, b) := le_max_right _ _,
      have := dist_smul_pair a b' b,
      have := dist_pair_smul a a' b',
      nlinarith },
    { have : δ ≤ _ := min_le_right _ _,
      have : δ ≤ _ := min_le_left _ _,
      have : (dist a 0 + dist b 0 + 2)⁻¹ * (ε * (dist a 0 + dist b 0 + δ)) < ε,
      { rw inv_mul_lt_iff; nlinarith },
      nlinarith }
  end }

-- this instance could be deduced from `normed_space.has_bounded_smul`, but we prove it separately
-- here so that it is available earlier in the hierarchy
instance real.has_bounded_smul : has_bounded_smul ℝ ℝ :=
{ dist_smul_pair' := λ x y₁ y₂, by simpa [real.dist_eq, mul_sub] using (abs_mul x (y₁ - y₂)).le,
  dist_pair_smul' := λ x₁ x₂ y, by simpa [real.dist_eq, sub_mul] using (abs_mul (x₁ - x₂) y).le }

instance nnreal.has_bounded_smul : has_bounded_smul ℝ≥0 ℝ≥0 :=
{ dist_smul_pair' := λ x y₁ y₂, by convert dist_smul_pair (x:ℝ) (y₁:ℝ) y₂ using 1,
  dist_pair_smul' := λ x₁ x₂ y, by convert dist_pair_smul (x₁:ℝ) x₂ (y:ℝ) using 1 }

end has_bounded_smul


/-
Copyright (c) 2021 Tianchen Zhao. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Tianchen Zhao
-/
import congruence.basic

/-!
# Angle orderness

This file defines how an angle is less than another and proves basic properties such as
transitivity and trichotomy.

## References

* See [Geometry: Euclid and Beyond]

-/

open incidence_geometry incidence_order_geometry hilbert_plane

variables [C : hilbert_plane]

include C

/--ang `α` is less than `β` if a part of it is congruent to `β`. That is,
there exists a point inside `α` with one ray of `α` forms an ang congruent to `β`-/
def ang_lt (α β : ang) : Prop :=
 ∃ a b p : C.pts, β = (∠ a β.vertex b) ∧ inside_ang p (∠ a β.vertex b)
  ∧ ((∠ a β.vertex p) ≅ₐ α)

notation a`<ₐ`b := ang_lt a b

lemma three_pt_ang_lt {a o b : C.pts} {α : ang} :
(α <ₐ (∠ a o b)) ↔ ∃ p : C.pts, inside_ang p (∠ a o b) ∧ ((∠ a o p) ≅ₐ α):=
begin
  split,
  { rintros ⟨a', b', p, haoba'ob', hp, ha'op⟩,
    rw three_pt_ang_vertex at haoba'ob' hp ha'op,
    have ha'ob' := ang_proper_iff_noncol.1 (inside_ang_proper hp),
    have haob : noncol a o b,
      rw [←ang_proper_iff_noncol, haoba'ob'],
      exact inside_ang_proper hp,
    have hoa := (noncol_neq haob).1.symm,
    cases ((three_pt_ang_eq_iff ha'ob').1 haoba'ob'.symm).2,
    { have haopa'op : (∠ a o p) = (∠ a' o p),
        rw [ang_symm, ang_symm a' _ _ ],
        refine ang_eq_same_side_pt _ _,
        exact same_side_pt_symm h.1,
      use p, rw [haoba'ob', haopa'op],
      exact ⟨hp, ha'op⟩ },
    { rcases extend_congr_ang (inside_ang_proper' hp).1 hoa
        (noncol_in12 (noncol12 haob)) with ⟨q, ha'opqoa, hqb, -⟩,
      use q, split,
      refine (congr_ang_sub hp hqb _ _ _).1,
      exact (same_side_pt_neq h.2).2.symm,
      rw haoba'ob', exact ang_congr_refl _,
      rw [ang_symm, ang_symm a o q], exact ha'opqoa,
      rw ang_symm, rw ang_symm at ha'op,
      exact ang_congr_trans (ang_congr_symm ha'opqoa) ha'op } },
  { rintros ⟨p, hp, haopα⟩,
    use [a, b, p],
    rw three_pt_ang_vertex, exact ⟨rfl, hp, haopα⟩ }
end

lemma ang_lt_congr {α β γ : ang} (hαβ : α ≅ₐ β) :
((α <ₐ γ) → (β <ₐ γ)) ∧ (ang_proper β → (γ <ₐ α) → (γ <ₐ β)) :=
begin
  rcases ang_three_pt α with ⟨a₁, b₁, hα⟩,
  rcases ang_three_pt β with ⟨a₂, b₂, hβ⟩,
  rcases ang_three_pt γ with ⟨a₃, b₃, hγ⟩,
  rw [hα, hβ, hγ], rw [hα, hβ] at hαβ,
  set o₁ := α.vertex, set o₂ := β.vertex, set o₃ := γ.vertex,
  split,
  { intro hαγ,
    rcases three_pt_ang_lt.1 hαγ with ⟨p, hpin, hp⟩,
    rw three_pt_ang_lt, use p,
    split, exact hpin,
    exact ang_congr_trans hp hαβ },
  { intros h hγα,
    rcases three_pt_ang_lt.1 hγα with ⟨p, hpin, hp⟩,
    rw ang_proper_iff_noncol at h,
    rcases extend_congr_ang (inside_ang_proper' hpin).1 (noncol_neq h).1.symm
      (noncol_in12 (noncol12 h)) with ⟨q, hq, hqb₂, -⟩,
    rw three_pt_ang_lt,
    rw ang_symm q _ _ at hq,
    use q, split,
    apply (congr_ang_sub hpin hqb₂ _ _ _).1,
    exact (noncol_neq h).1.symm,
    exact hαβ,
    rw ang_symm, exact hq,
    rw ang_symm at hq, exact ang_congr_trans (ang_congr_symm hq) hp }
end

lemma ang_lt_trans {α β γ : ang} :
ang_proper α → (α <ₐ β) → (β <ₐ γ) → (α <ₐ γ) :=
begin
  intros hα hαβ hβγ,
  rcases ang_three_pt β with ⟨a₂, b₂, hβ⟩,
  rcases ang_three_pt γ with ⟨a₃, b₃, hγ⟩,
  rw hγ, rw hβ at hαβ, rw [hβ, hγ] at hβγ,
  set o₂ := β.vertex, set o₃ := γ.vertex,
  rcases three_pt_ang_lt.1 hαβ with ⟨p, hpin, hp⟩,
  rcases three_pt_ang_lt.1 hβγ with ⟨q, hqin, hq⟩,
  have ha₃o₃b₃ := ang_proper_iff_noncol.1 (inside_ang_proper hqin),
  rcases extend_congr_ang hα (noncol_neq ha₃o₃b₃).1.symm (noncol_in23
    (ang_proper_iff_noncol.1 (inside_ang_proper' hqin).1)) with ⟨x, hx, hxq, -⟩,
  rw three_pt_ang_lt,
  use x, split,
  apply inside_ang_trans hqin,
  apply (congr_ang_sub hpin hxq _ _ _).1,
  exact (noncol_neq (ang_proper_iff_noncol.1
    (inside_ang_proper hqin))).1.symm,
  exact ang_congr_symm hq,
  rw ang_symm at hx, exact ang_congr_trans hp hx,
  rw ang_symm, exact ang_congr_symm hx
end

lemma ang_tri {α β : ang} (ha'o'b' : ang_proper α) (haob : ang_proper β) :
((α <ₐ β) ∨ (α ≅ₐ β) ∨ (β <ₐ α))
∧ ¬((α <ₐ β) ∧ (α ≅ₐ β)) ∧ ¬((α <ₐ β) ∧ (β <ₐ α)) ∧ ¬(((α ≅ₐ β) ∧ (β <ₐ α))) :=
begin
  rcases ang_three_pt β with ⟨a, b, hβ⟩,
  rw [hβ, ang_proper_iff_noncol] at haob, set o := β.vertex,
  have hao := (noncol_neq haob).1,
  have hbo := (noncol_neq haob).2.2.symm,
  rcases extend_congr_ang ha'o'b' hao.symm (noncol_in12
    (noncol12 haob)) with ⟨x, hx, hlxb, hu⟩,
  have hxo := (same_side_line_neq hlxb).1,
  have h₁ : same_side_line (o-ₗb) x a ↔ (α <ₐ β),
    rw hβ, split; rw three_pt_ang_lt,
    intro h₁,
    use x, split,
    rw inside_three_pt_ang,
    exact ⟨same_side_line_symm hlxb, same_side_line_symm h₁⟩,
    rw ang_symm, exact ang_congr_symm hx,
    rintros ⟨y, hyin, hy⟩, rw inside_three_pt_ang at hyin, rw ang_symm at hy,
    specialize hu y (same_side_line_trans (line_in_lines hao.symm) hlxb hyin.1)
      (ang_congr_symm hy),
    have hoxb := col_noncol (col_in13' ((ray_in_line o x) hu))
      (noncol23 (same_side_line_noncol hyin.2 hbo.symm).2) hxo.symm,
    have hyo := (same_side_line_neq' hyin.1).1,
    apply same_side_line_trans (line_in_lines hbo.symm) _ (same_side_line_symm hyin.2),
    rw line_symm,
    exact t_shape_ray (noncol132 hoxb) (ray_in_neq hyo hu),
  have h₂ : x ∈ (o-ₗb) ↔ (α ≅ₐ β),
    rw hβ, split; intro h₂,
    have : (∠ x o a) = (∠ a o b),
      rw ang_symm,
      apply ang_eq_same_side_pt _ _,
      cases (line_separation ⟨(o-ₗb), line_in_lines hbo.symm,
        pt_left_in_line o b, h₂, pt_right_in_line o b⟩ hxo hbo).1,
      exact h,
      { have hx := (same_side_line_notin hlxb).1,
        have hb := (same_side_line_notin hlxb).2,
        rw ←not_diff_side_line at hlxb, exfalso, apply hlxb,
        apply diff_side_pt_line h (line_in_lines hao.symm) (pt_left_in_line o a) hx hb,
        exact hx, exact hb },
    rw ←this, exact hx,
    { rw line_symm at hlxb, rw ang_symm at hx,
      exact col_in13 (ang_unique_same_side hao hlxb
        (ang_congr_trans (ang_congr_symm hx) h₂)).2 hbo.symm },
  have h₃ : diff_side_line (o-ₗb) x a ↔ (β <ₐ α),
    split; intro h₃,
    apply (ang_lt_congr (ang_congr_symm hx)).2 ha'o'b', rw ang_symm,
    rw three_pt_ang_lt, use b,
    split,
    rw inside_three_pt_ang, split, exact hlxb,
    exact diff_same_side_line' (diff_side_line_symm h₃) (same_side_line_symm hlxb),
    rw hβ, exact ang_congr_refl _,
    have : ang_proper (∠ x o a),
      rw ang_proper_iff_noncol,
      intro hxoa, exact (same_side_line_notin hlxb).1 (col_in23 hxoa hao.symm),
    have := (ang_lt_congr hx).2 this h₃, rw [ang_symm, three_pt_ang_lt] at this,
    rcases this with ⟨p, hpin, hp⟩, rw hβ at hp,
    have hopb : same_side_pt o p b,
      rw inside_three_pt_ang at hpin,
      rw line_symm at hpin hlxb,
      exact ang_unique_same_side hao
        (same_side_line_trans (line_in_lines hao) (same_side_line_symm hpin.1) hlxb) hp,
    { have hbin := ray_inside_ang hpin hopb,
      cases crossbar hbin with y hy,
      rw seg_symm at hy,
      use y, exact ⟨(ray_in_line o b) hy.1, hy.2⟩,
      rw inside_three_pt_ang at hbin,
      exact ⟨noncol_in13 (same_side_line_noncol hbin.2 hxo.symm).2, noncol_in23 haob⟩ },
  rw [←h₁, ←h₂, ←h₃],
  split, by_cases x ∈ (o-ₗb),
  right, left, exact h,
  cases (plane_separation h (noncol_in23 haob)).1 with h h,
  left, exact h, right, right, exact h,
  split, intro hf,
  exact (same_side_line_notin hf.1).1 hf.2,
  split, intro hf, rw ←not_diff_side_line at hf, exact hf.1 hf.2,
  exact hf.2.2.1, exact hf.2.2.2,
  intro hf, exact hf.2.2.1 hf.1
end

lemma ang_lt_supplementary {α α' β β' : ang} (hαα' : α <ₐ α')
(hαβ : supplementary α β) (hα'β' : supplementary α' β') : β' <ₐ β :=
begin
  have hαβ := hαβ,
  rcases hαβ with ⟨⟨a, b, c, d, hα, hβ, hcad⟩, hbac, hbad⟩,
  rw hβ at hbad,
  rcases hα'β' with ⟨⟨a', b', c', d', hα', hβ', hc'a'd'⟩, hb'a'c', hb'a'd'⟩,
  rw [hα', ang_proper_iff_noncol] at hb'a'c',
  rw [hβ', ang_proper_iff_noncol] at hb'a'd',
  rw [hβ, hβ'], rw [hα, hα'] at hαα',
  rw [hα, hβ] at hαβ,
  rw [ang_symm b' a' c'] at hαα',
  rcases three_pt_ang_lt.1 hαα' with ⟨e', he', hc'a'e'bac⟩,
  have ha'c' := (noncol_neq hb'a'c').2.2,
  have ha'd' := (noncol_neq hb'a'd').2.2,
  have ha'c'e' := (same_side_line_noncol (inside_three_pt_ang.1 he').1 ha'c').2,
  have ha'd'e' := col_noncol (col12 (between_col hc'a'd')) ha'c'e' ha'd',
  have : supplementary (∠ e' a' c') (∠ e' a' d'),
    rw three_pt_ang_supplementary,
    exact ⟨hc'a'd', noncol132 ha'c'e', noncol132 ha'd'e'⟩,
  rw ang_symm at hc'a'e'bac,
  have hbade'a'd' := supplementary_congr hαβ this (ang_congr_symm hc'a'e'bac),
  apply (ang_lt_congr (ang_congr_symm hbade'a'd')).2 hbad,
  rw ang_symm e' a' d',
  rw three_pt_ang_lt, use b',
  split,
  rw ang_symm,
  { apply inside_ang_trans' hc'a'd',
    rw ang_symm,
    exact he' },
  { rw ang_symm,
    exact ang_congr_refl _ }
end


/-
Copyright (c) 2018 Jeremy Avigad. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jeremy Avigad, Simon Hudon
-/
import data.pfunctor.multivariate.W
import data.qpf.multivariate.basic

/-!
# The initial algebra of a multivariate qpf is again a qpf.

For a `(n+1)`-ary QPF `F (α₀,..,αₙ)`, we take the least fixed point of `F` with
regards to its last argument `αₙ`. The result is a `n`-ary functor: `fix F (α₀,..,αₙ₋₁)`.
Making `fix F` into a functor allows us to take the fixed point, compose with other functors
and take a fixed point again.

## Main definitions

 * `fix.mk`     - constructor
 * `fix.dest    - destructor
 * `fix.rec`    - recursor: basis for defining functions by structural recursion on `fix F α`
 * `fix.drec`   - dependent recursor: generalization of `fix.rec` where
                  the result type of the function is allowed to depend on the `fix F α` value
 * `fix.rec_eq` - defining equation for `recursor`
 * `fix.ind`    - induction principle for `fix F α`

## Implementation notes

For `F` a QPF`, we define `fix F α` in terms of the W-type of the polynomial functor `P` of `F`.
We define the relation `Wequiv` and take its quotient as the definition of `fix F α`.

```lean
inductive Wequiv {α : typevec n} : q.P.W α → q.P.W α → Prop
| ind (a : q.P.A) (f' : q.P.drop.B a ⟹ α) (f₀ f₁ : q.P.last.B a → q.P.W α) :
    (∀ x, Wequiv (f₀ x) (f₁ x)) → Wequiv (q.P.W_mk a f' f₀) (q.P.W_mk a f' f₁)
| abs (a₀ : q.P.A) (f'₀ : q.P.drop.B a₀ ⟹ α) (f₀ : q.P.last.B a₀ → q.P.W α)
      (a₁ : q.P.A) (f'₁ : q.P.drop.B a₁ ⟹ α) (f₁ : q.P.last.B a₁ → q.P.W α) :
      abs ⟨a₀, q.P.append_contents f'₀ f₀⟩ = abs ⟨a₁, q.P.append_contents f'₁ f₁⟩ →
        Wequiv (q.P.W_mk a₀ f'₀ f₀) (q.P.W_mk a₁ f'₁ f₁)
| trans (u v w : q.P.W α) : Wequiv u v → Wequiv v w → Wequiv u w
```

See [avigad-carneiro-hudon2019] for more details.

## Reference

 * Jeremy Avigad, Mario M. Carneiro and Simon Hudon.
   [*Data Types as Quotients of Polynomial Functors*][avigad-carneiro-hudon2019]
-/

universes u v

namespace mvqpf
open typevec
open mvfunctor (liftp liftr)
open_locale mvfunctor

variables {n : ℕ} {F : typevec.{u} (n+1) → Type u} [mvfunctor F] [q : mvqpf F]
include q

/-- `recF` is used as a basis for defining the recursor on `fix F α`. `recF`
traverses recursively the W-type generated by `q.P` using a function on `F`
as a recursive step -/
def recF {α : typevec n} {β : Type*} (g : F (α.append1 β) → β) : q.P.W α → β :=
q.P.W_rec (λ a f' f rec, g (abs ⟨a, split_fun f' rec⟩))

theorem recF_eq {α : typevec n} {β : Type*} (g : F (α.append1 β) → β)
    (a : q.P.A) (f' : q.P.drop.B a ⟹ α) (f : q.P.last.B a → q.P.W α) :
  recF g (q.P.W_mk a f' f) =  g (abs ⟨a, split_fun f' (recF g ∘ f)⟩) :=
by rw [recF, mvpfunctor.W_rec_eq]; refl

theorem recF_eq' {α : typevec n} {β : Type*} (g : F (α.append1 β) → β)
    (x : q.P.W α) :
  recF g x = g (abs ((append_fun id (recF g)) <$$> q.P.W_dest' x)) :=
begin
  apply q.P.W_cases _ x,
  intros a f' f,
  rw [recF_eq, q.P.W_dest'_W_mk, mvpfunctor.map_eq, append_fun_comp_split_fun,
    typevec.id_comp]
end

/-- Equivalence relation on W-types that represent the same `fix F`
value -/
inductive Wequiv {α : typevec n} : q.P.W α → q.P.W α → Prop
| ind (a : q.P.A) (f' : q.P.drop.B a ⟹ α) (f₀ f₁ : q.P.last.B a → q.P.W α) :
    (∀ x, Wequiv (f₀ x) (f₁ x)) → Wequiv (q.P.W_mk a f' f₀) (q.P.W_mk a f' f₁)
| abs (a₀ : q.P.A) (f'₀ : q.P.drop.B a₀ ⟹ α) (f₀ : q.P.last.B a₀ → q.P.W α)
      (a₁ : q.P.A) (f'₁ : q.P.drop.B a₁ ⟹ α) (f₁ : q.P.last.B a₁ → q.P.W α) :
      abs ⟨a₀, q.P.append_contents f'₀ f₀⟩ = abs ⟨a₁, q.P.append_contents f'₁ f₁⟩ →
        Wequiv (q.P.W_mk a₀ f'₀ f₀) (q.P.W_mk a₁ f'₁ f₁)
| trans (u v w : q.P.W α) : Wequiv u v → Wequiv v w → Wequiv u w

theorem recF_eq_of_Wequiv (α : typevec n) {β : Type*} (u : F (α.append1 β) → β)
    (x y : q.P.W α) :
  Wequiv x y → recF u x = recF u y :=
begin
  apply q.P.W_cases _ x,
  intros a₀ f'₀ f₀,
  apply q.P.W_cases _ y,
  intros a₁ f'₁ f₁,
  intro h, induction h,
  case mvqpf.Wequiv.ind : a f' f₀ f₁ h ih { simp only [recF_eq, function.comp, ih] },
  case mvqpf.Wequiv.abs : a₀ f'₀ f₀ a₁ f'₁ f₁ h
    { simp only [recF_eq', abs_map, mvpfunctor.W_dest'_W_mk, h] },
  case mvqpf.Wequiv.trans : x y z e₁ e₂ ih₁ ih₂
    { exact eq.trans ih₁ ih₂ }
end

theorem Wequiv.abs' {α : typevec n} (x y : q.P.W α)
    (h : abs (q.P.W_dest' x) = abs (q.P.W_dest' y)) :
  Wequiv x y :=
begin
  revert h,
  apply q.P.W_cases _ x,
  intros a₀ f'₀ f₀,
  apply q.P.W_cases _ y,
  intros a₁ f'₁ f₁,
  apply Wequiv.abs
end

theorem Wequiv.refl {α : typevec n} (x : q.P.W α) : Wequiv x x :=
by apply q.P.W_cases _ x; intros a f' f; exact Wequiv.abs a f' f a f' f rfl

theorem Wequiv.symm {α : typevec n} (x y : q.P.W α) : Wequiv x y → Wequiv y x :=
begin
  intro h, induction h,
  case mvqpf.Wequiv.ind : a f' f₀ f₁ h ih
    { exact Wequiv.ind _ _ _ _ ih },
  case mvqpf.Wequiv.abs : a₀ f'₀ f₀ a₁ f'₁ f₁ h
    { exact Wequiv.abs _ _ _ _ _ _ h.symm },
  case mvqpf.Wequiv.trans : x y z e₁ e₂ ih₁ ih₂
    { exact mvqpf.Wequiv.trans _ _ _ ih₂ ih₁}
end

/-- maps every element of the W type to a canonical representative -/
def Wrepr {α : typevec n} : q.P.W α → q.P.W α := recF (q.P.W_mk' ∘ repr)

theorem Wrepr_W_mk  {α : typevec n}
    (a : q.P.A) (f' : q.P.drop.B a ⟹ α) (f : q.P.last.B a → q.P.W α) :
  Wrepr (q.P.W_mk a f' f) =
    q.P.W_mk' (repr (abs ((append_fun id Wrepr) <$$> ⟨a, q.P.append_contents f' f⟩))) :=
by rw [Wrepr, recF_eq', q.P.W_dest'_W_mk]; refl

theorem Wrepr_equiv {α : typevec n} (x : q.P.W α) : Wequiv (Wrepr x) x :=
begin
  apply q.P.W_ind _ x, intros a f' f ih,
  apply Wequiv.trans _ (q.P.W_mk' ((append_fun id Wrepr) <$$> ⟨a, q.P.append_contents f' f⟩)),
  { apply Wequiv.abs',
    rw [Wrepr_W_mk, q.P.W_dest'_W_mk', q.P.W_dest'_W_mk', abs_repr] },
  rw [q.P.map_eq, mvpfunctor.W_mk', append_fun_comp_split_fun, id_comp],
  apply Wequiv.ind, exact ih
end

theorem Wequiv_map {α β : typevec n} (g : α ⟹ β) (x y : q.P.W α) :
  Wequiv x y → Wequiv (g <$$> x) (g <$$> y) :=
begin
  intro h, induction h,
  case mvqpf.Wequiv.ind : a f' f₀ f₁ h ih
    { rw [q.P.W_map_W_mk, q.P.W_map_W_mk], apply Wequiv.ind, apply ih },
  case mvqpf.Wequiv.abs : a₀ f'₀ f₀ a₁ f'₁ f₁ h
    { rw [q.P.W_map_W_mk, q.P.W_map_W_mk], apply Wequiv.abs,
      show abs (q.P.obj_append1 a₀ (g ⊚ f'₀) (λ x, q.P.W_map g (f₀ x))) =
           abs (q.P.obj_append1 a₁ (g ⊚ f'₁) (λ x, q.P.W_map g (f₁ x))),
      rw [←q.P.map_obj_append1, ←q.P.map_obj_append1, abs_map, abs_map, h] },
  case mvqpf.Wequiv.trans : x y z e₁ e₂ ih₁ ih₂
    { apply mvqpf.Wequiv.trans, apply ih₁, apply ih₂ }
end

/--
Define the fixed point as the quotient of trees under the equivalence relation.
-/
def W_setoid (α : typevec n) : setoid (q.P.W α) :=
⟨Wequiv, @Wequiv.refl _ _ _ _ _, @Wequiv.symm _ _ _ _ _, @Wequiv.trans _ _ _ _ _⟩

local attribute [instance] W_setoid

/-- Least fixed point of functor F. The result is a functor with one fewer parameters
than the input. For `F a b c` a ternary functor, fix F is a binary functor such that

```lean
fix F a b = F a b (fix F a b)
```
-/
def fix {n : ℕ} (F : typevec (n+1) → Type*) [mvfunctor F] [q : mvqpf F] (α : typevec n) :=
quotient (W_setoid α : setoid (q.P.W α))

attribute [nolint has_inhabited_instance] fix

/-- `fix F` is a functor -/
def fix.map {α β : typevec n} (g : α ⟹ β) : fix F α → fix F β :=
quotient.lift (λ x : q.P.W α, ⟦q.P.W_map g x⟧)
  (λ a b h, quot.sound (Wequiv_map _ _ _ h))

instance fix.mvfunctor : mvfunctor (fix F) :=
{ map := @fix.map _ _ _ _}

variable {α : typevec.{u} n}

/-- Recursor for `fix F` -/
def fix.rec {β : Type u} (g : F (α ::: β) → β) : fix F α → β :=
quot.lift (recF g) (recF_eq_of_Wequiv α g)

/-- Access W-type underlying `fix F`  -/
def fix_to_W : fix F α → q.P.W α :=
quotient.lift Wrepr (recF_eq_of_Wequiv α (λ x, q.P.W_mk' (repr x)))

/-- Constructor for `fix F` -/
def fix.mk (x : F (append1 α (fix F α))) : fix F α :=
  quot.mk _ (q.P.W_mk' (append_fun id fix_to_W <$$> repr x))

/-- Destructor for `fix F` -/
def fix.dest : fix F α → F (append1 α (fix F α)) :=
fix.rec (mvfunctor.map (append_fun id fix.mk))

theorem fix.rec_eq {β : Type u} (g : F (append1 α β) → β) (x : F (append1 α (fix F α))) :
  fix.rec g (fix.mk x) = g (append_fun id (fix.rec g) <$$> x) :=
have recF g ∘ fix_to_W = fix.rec g,
  by { apply funext, apply quotient.ind, intro x, apply recF_eq_of_Wequiv,
       apply Wrepr_equiv },
begin
  conv { to_lhs, rw [fix.rec, fix.mk], dsimp },
  cases h : repr x with a f,
  rw [mvpfunctor.map_eq, recF_eq', ←mvpfunctor.map_eq, mvpfunctor.W_dest'_W_mk'],
  rw [←mvpfunctor.comp_map, abs_map, ←h, abs_repr, ←append_fun_comp, id_comp, this]
end

theorem fix.ind_aux (a : q.P.A) (f' : q.P.drop.B a ⟹ α) (f : q.P.last.B a → q.P.W α) :
  fix.mk (abs ⟨a, q.P.append_contents f' (λ x, ⟦f x⟧)⟩) = ⟦q.P.W_mk a f' f⟧ :=
have fix.mk (abs ⟨a, q.P.append_contents f' (λ x, ⟦f x⟧)⟩) = ⟦Wrepr (q.P.W_mk a f' f)⟧,
  begin
    apply quot.sound, apply Wequiv.abs',
    rw [mvpfunctor.W_dest'_W_mk', abs_map, abs_repr, ←abs_map, mvpfunctor.map_eq],
    conv { to_rhs, rw [Wrepr_W_mk, q.P.W_dest'_W_mk', abs_repr, mvpfunctor.map_eq] },
    congr' 2, rw [mvpfunctor.append_contents, mvpfunctor.append_contents],
    rw [append_fun, append_fun, ←split_fun_comp, ←split_fun_comp],
    reflexivity
  end,
by { rw this, apply quot.sound, apply Wrepr_equiv }

theorem fix.ind_rec {β : Type*} (g₁ g₂ : fix F α → β)
    (h : ∀ x : F (append1 α (fix F α)),
      (append_fun id g₁) <$$> x = (append_fun id g₂) <$$> x → g₁ (fix.mk x) = g₂ (fix.mk x)) :
  ∀ x, g₁ x = g₂ x :=
begin
  apply quot.ind,
  intro x,
  apply q.P.W_ind _ x, intros a f' f ih,
  show g₁ ⟦q.P.W_mk a f' f⟧ = g₂ ⟦q.P.W_mk a f' f⟧,
  rw [←fix.ind_aux a f' f], apply h,
  rw [←abs_map, ←abs_map, mvpfunctor.map_eq, mvpfunctor.map_eq],
  congr' 2,
  rw [mvpfunctor.append_contents, append_fun, append_fun, ←split_fun_comp, ←split_fun_comp],
  have : g₁ ∘ (λ x, ⟦f x⟧) = g₂ ∘ (λ x, ⟦f x⟧),
  { ext x, exact ih x },
  rw this
end

theorem fix.rec_unique {β : Type*} (g : F (append1 α β) → β) (h : fix F α → β)
    (hyp : ∀ x, h (fix.mk x) = g (append_fun id h <$$> x)) :
  fix.rec g = h :=
begin
  ext x,
  apply fix.ind_rec,
  intros x hyp',
  rw [hyp, ←hyp', fix.rec_eq]
end

theorem fix.mk_dest (x : fix F α) : fix.mk (fix.dest x) = x :=
begin
  change (fix.mk ∘ fix.dest) x = x,
  apply fix.ind_rec,
  intro x, dsimp,
  rw [fix.dest, fix.rec_eq, ←comp_map, ←append_fun_comp, id_comp],
  intro h, rw h,
  show fix.mk (append_fun id id <$$> x) = fix.mk x,
  rw [append_fun_id_id, mvfunctor.id_map]
end

theorem fix.dest_mk (x : F (append1 α (fix F α))) : fix.dest (fix.mk x) = x :=
begin
  unfold fix.dest, rw [fix.rec_eq, ←fix.dest, ←comp_map],
  conv { to_rhs, rw ←(mvfunctor.id_map x) },
  rw [←append_fun_comp, id_comp],
  have : fix.mk ∘ fix.dest = id, {ext x, apply fix.mk_dest },
  rw [this, append_fun_id_id]
end

theorem fix.ind {α : typevec n} (p : fix F α → Prop)
    (h : ∀ x : F (α.append1 (fix F α)), liftp (pred_last α p) x → p (fix.mk x)) :
  ∀ x, p x :=
begin
  apply quot.ind,
  intro x,
  apply q.P.W_ind _ x, intros a f' f ih,
  change p ⟦q.P.W_mk a f' f⟧,
  rw [←fix.ind_aux a f' f],
  apply h,
  rw mvqpf.liftp_iff,
  refine ⟨_, _, rfl, _⟩,
  intros i j,
  cases i,
  { apply ih },
  { trivial },
end

instance mvqpf_fix : mvqpf (fix F) :=
{ P         := q.P.Wp,
  abs       := λ α, quot.mk Wequiv,
  repr      := λ α, fix_to_W,
  abs_repr  := by { intros α, apply quot.ind, intro a, apply quot.sound, apply Wrepr_equiv },
  abs_map   :=
    begin
      intros α β g x, conv { to_rhs, dsimp [mvfunctor.map]},
      rw fix.map, apply quot.sound,
      apply Wequiv.refl
    end }

/-- Dependent recursor for `fix F` -/
def fix.drec {β : fix F α → Type u}
  (g : Π x : F (α ::: sigma β), β (fix.mk $ (id ::: sigma.fst) <$$> x)) (x : fix F α) : β x :=
let y := @fix.rec _ F _ _ α (sigma β) (λ i, ⟨_,g i⟩) x in
have x = y.1,
  by { symmetry, dsimp [y], apply fix.ind_rec _ id _ x, intros x' ih,
       rw fix.rec_eq, dsimp, simp [append_fun_id_id] at ih,
       congr, conv { to_rhs, rw [← ih] }, rw [mvfunctor.map_map,← append_fun_comp,id_comp], },
cast (by rw this) y.2

end mvqpf


import tactic

universe u
noncomputable theory
open set tactic classical
local attribute [instance] prop_decidable

namespace logic
section signature

 -- The type of signatures, which defines a first-order language with modalities.
 -- It has room for defining your
 -- own preferred variable type.
 @[derive inhabited]
 structure signature : Type (u+1) :=
     (modality : Type u := pempty)
     (arity : modality → ℕ := λ_, 0)
     (functional_symbol : set modality := ∅)
     (relational_symbol : set modality := ∅)
     (logical_symbol : set modality := ∅)
     (necessary_symbol : set modality := ∅)
     (essential_symbol : set modality := ∅)

 variable (σ : signature)

 -- the type of functional symbols of arity n
 def signature.nary (σ : signature) (n : ℕ) := subtype {f : σ.functional_symbol | σ.arity f = n}

 -- the type of relational symbols of arity n
 def signature.nrary (σ : signature) (n : ℕ) := subtype {r : σ.relational_symbol | σ.arity r = n}

 -- the type of modal symbols of arity n
 def signature.nmary (n : ℕ) := subtype {r : σ.modality | σ.arity r = n}

 -- the predicate defining, and the type of, constants
 def is_constant (f : σ.functional_symbol) := σ.arity f = 0
 def signature.const (σ : signature) := σ.nary 0

 -- the type of formulas in the language
 inductive signature.formula
 | var : ℕ → signature.formula
 | mod   {n : ℕ} (box : σ.nmary n) (v : fin n → signature.formula) :  signature.formula
 | all  :  ℕ →  signature.formula →  signature.formula
 | if_then  :  signature.formula →  signature.formula →  signature.formula
 | equation : signature.formula →  signature.formula →  signature.formula
 | false    :  signature.formula

 instance inh_formula : inhabited σ.formula := ⟨formula.var (default ℕ)⟩
 -- @[reducible, simp]
 instance nat_coe_formula : has_coe ℕ σ.formula := ⟨formula.var⟩

 end signature

section notations

 variable {σ : signature}

 -- a convenient notation to set up for if_then
 reserve infixr ` ⇒ `:55
 class has_if_then (α : Type u) := (exp : α → α → α)
 infixr ⇒ := has_if_then.exp

 -- a convenient notation to set up for iff
 reserve infixr ` ⇔ `:55
 class has_iff (α : Type u) := (exp : α → α → α)
 infixr ⇔ := has_iff.exp

 -- a convenient notation to set up for equality (which is semantically different from iff)
 reserve infixr ` ≡ `:60
 class has_eq (α : Type u) := (eq : α → α → α)
 infixr ≡ := has_eq.eq

 -- a convenient notation to set up for inequality
 reserve infixr ` ≢ `:60
 class has_neq (α : Type u) := (neq : α → α → α)
 infixr ≢ := has_neq.neq

 instance signature.formula.has_if_then : has_if_then  σ.formula := ⟨signature.formula.if_then⟩
 instance signature.formula.has_eq : has_eq σ.formula := ⟨signature.formula.equation⟩

 -- definition of connectives
 @[reducible, simp]
 def signature.formula.not (φ :  σ.formula)   := φ ⇒ formula.false
 @[reducible, simp]
 def signature.formula.or  (φ ψ :  σ.formula) := φ.not ⇒ ψ
 @[reducible, simp]
 def signature.formula.and (φ ψ :  σ.formula) := (φ.not.or ψ.not).not
 @[reducible, simp]
 def signature.formula.iff (φ ψ :  σ.formula) := (φ ⇒ ψ).and (ψ ⇒ φ)
 @[reducible, simp]
 def signature.formula.neq (φ ψ :  σ.formula) := (φ ≡ ψ).not
 @[reducible, simp]
 def signature.formula.exists (φ : σ.formula) (x : ℕ) := (formula.all x φ.not).not
 @[reducible, simp]
 def signature.formula.strictly_below (φ ψ :  σ.formula) := (φ ⇒ ψ).and (φ.neq ψ)

 instance signature.formula.has_neg : has_neg σ.formula := ⟨signature.formula.not⟩
 instance signature.formula.has_sup : has_sup σ.formula := ⟨signature.formula.or⟩
 instance signature.formula.has_inf : has_inf σ.formula := ⟨signature.formula.and⟩
 instance signature.formula.has_iff : has_iff  σ.formula := ⟨signature.formula.iff⟩
 instance signature.formula.has_neq : has_neq σ.formula := ⟨signature.formula.neq⟩
 instance signature.formula.has_bot : has_bot σ.formula := ⟨signature.formula.false⟩
 instance signature.formula.has_top : has_top σ.formula := ⟨⊥ ⇒ ⊥⟩

 infixr `⇒'`:55 := signature.formula.strictly_below

 @[reducible, simp]
 def signature.formula.necessary (φ : σ.formula) : σ.formula := φ ≡ ⊤
 @[reducible, simp]
 def signature.formula.possible (φ : σ.formula) : σ.formula := φ.not.necessary.not
 @[reducible, simp]
 def signature.formula.entails (φ ψ : σ.formula) : σ.formula := (φ ⇒ ψ).necessary
 @[reducible, simp]
 def signature.formula.strictly_entails (φ ψ : σ.formula) : σ.formula := (φ ⇒ ψ).necessary ⊓ φ ≢ ψ

 -- a convenient notation to set up for necessity
 reserve prefix ` □ `:100
 class has_box (α : Type u) := (box : α → α)
 prefix □ := has_box.box

 -- a convenient notation to set up for possibility
 reserve prefix ` ⋄ `:100
 class has_diamond (α : Type u) := (diamond : α → α)
 prefix ⋄ := has_diamond.diamond

 -- a convenient notation to set up for entailment
 reserve infix ` ⟹ `:55
 class has_ent (α : Type u) := (ent : α → α → α)
 infix ⟹ := has_ent.ent

 instance signature.formula.has_box : has_box σ.formula := ⟨signature.formula.necessary⟩
 instance signature.formula.has_diamond : has_diamond σ.formula := ⟨signature.formula.possible⟩
 instance signature.formula.has_ent : has_ent σ.formula := ⟨signature.formula.entails⟩

 infixr `⟹'`:55 := signature.formula.strictly_entails

 end notations

section semantics

 -- modalities interpretation
 structure signature.structure (σ : signature) (ω : Type u) :=
     (I : Π {n}, σ.nmary n → (fin n → set ω) → set ω)
     (ne : nonempty ω)

 -- variable interpretation/assignment
 def vasgn (ω : Type u) := ℕ → set ω

 variables {σ : signature} {ω : Type u}

 -- bind the value of a variable to `S` in an assignment
 -- (generates a new assignment).
 def vasgn.bind (asg : vasgn ω) (x : ℕ) (S : set ω) : vasgn ω :=
     λy, if y = x then S else asg y

 def signature.structure.ref' (M : σ.structure ω) : σ.formula → vasgn ω → set ω
 | (formula.var x) asg := asg x
 | (@formula.mod _ 0 box v) asg := M.I box fin_zero_elim
 | (@formula.mod _ (n+1) box v) asg := M.I box (λ k, signature.structure.ref' (v k) asg)
 | (formula.all x φ) asg := ⋂ S : set ω, signature.structure.ref' φ (asg.bind x S)
 | (formula.if_then φ ψ) asg := -(signature.structure.ref' φ asg) ∪ (signature.structure.ref' ψ asg)
 | (formula.equation φ ψ) asg := if (signature.structure.ref' φ asg) = (signature.structure.ref' ψ asg)
                                 then univ
                                 else ∅
 | formula.false _ := ∅

 @[simp]
 def signature.structure.satisfies' (M : σ.structure ω) : ω → σ.formula → vasgn ω → Prop
 | w φ asg := w ∈ (M.ref' φ asg)

 @[simp]
 def signature.structure.satisfies (M : σ.structure ω) : ω → σ.formula → Prop
 | w φ := ∀ asg, M.satisfies' w φ asg

 @[simp]
 def signature.structure.valid' (M : σ.structure ω) : σ.formula → vasgn ω → Prop
 | φ asg := ∀ w, M.satisfies' w φ asg

 @[simp]
 def signature.structure.possible' (M : σ.structure ω) : σ.formula → vasgn ω → Prop
 | φ asg := ∃ w, M.satisfies' w φ asg

 @[simp]
 def signature.structure.valid (M : σ.structure ω) : σ.formula → Prop
 | φ := ∀ w, M.satisfies w φ

 @[simp]
 def tautology (φ : σ.formula) : Prop :=
     ∀ {ω : Type u} (M : σ.structure ω), M.valid φ

 @[simp]
 def logical (φ : σ.formula) : Prop :=
     ∀ {ω : Type u} (M : σ.structure ω) asg, M.valid' φ asg ∨ M.valid' (-φ) asg

 -- TODO: specify a free variable for quantification
--  @[simp]
 def signature.formula.world (φ : σ.formula) : σ.formula :=
    let x := (@formula.var σ 0) in
    (φ ≢ ⊥) ⊓ (formula.all 0 $
    (x ≢ ⊥) ⟹ ((φ ⟹ x) ⊔ (φ ⟹ -x)))

-- should be in the standard library but isn't.
 theorem Inter_eq_univ_iff : ∀ {α I} {f : I → set α}, ((⋂ i : I, f i) = univ) ↔ ∀ i, f i = univ :=
    begin
        intros,
        constructor; intro h,
            intro i,
            ext, constructor; intro H, triv,
            rw ←h at H,
            simp at H,
            exact H i,
        ext, constructor; intro H, triv,
        simp,
        intro i,
        rw h i,
        triv,
    end

 variables {M : σ.structure ω} (φ ψ: σ.formula) (asg : vasgn ω)

 #check ({1} : set ℕ)

--  lemma world_semantics : M.valid' φ.world asg ↔ ∃ w, M.ref' φ asg = {w} :=
--     begin
--         dunfold signature.formula.world,
--         simp[signature.structure.ref'],
--         dunfold signature.structure.ref',
--         simp[vasgn.bind],
--         constructor; intro h,
--         swap,
--             obtain ⟨w, h⟩ := h,
--             rw h,
--             intros,
--             constructor,
--                 admit,
--             intros,
--             set r := M.ref' φ (λ (y : ℕ), ite (y = 0) i (asg y)),
--             by_cases c₀ : i = ∅; simp [c₀],
--                 admit,
--             -- TODO: prove this side by cases
--             -- on the assumption 0 does not appear in φ,
--             -- the cases are whether w ∈ i or not,
--             -- by the assumption r is turned into a singleton
--             -- via an auxiliary lemma about binding of variables
--             -- that do not appear in a formula. Then the goal
--             -- simplifies to true.
--                 admit,

--         obtain ⟨w⟩ := M.ne,
--         obtain ⟨h₁, h₂⟩ := h w,

--     end

 -- lemma logical_world : logical φ.world :=
 --     begin
 --         dunfold logical,
 --         intros,
 --         let r := M.ref' φ asg,
 --         let r_singleton := ∃ w, {w} = r,
 --         by_cases r_singleton,
 --             left,
 --             dunfold signature.structure.valid',
 --             dunfold signature.structure.satisfies',
 --             obtain ⟨w, h⟩ := h,
 --             intro w',

 --             dunfold signature.formula.world,
 --             dunfold signature.structure.ref',
 --             simp,
 --             intros,
 --             simp [ signature.structure.ref'
 --                  , coe
 --                  , lift_t
 --                  , has_lift_t.lift
 --                  , coe_t
 --                  , has_coe_t.coe
 --                  , coe_b
 --                  , has_neg.neg
 --                  , vasgn.bind
 --                  ],
 --             by_cases c₀ : i = ∅,
 --                 simp [c₀],
 --                 set r₂ := signature.structure.ref' M φ (λ (y : ℕ), ite (y = 0) ∅ (asg y)),
 --                 have c₁ : (M.ref' (has_coe.coe 0) (λ (y : ℕ), ite (y = 0) ∅ (asg y))) = ∅ := sorry,
 --                 simp [c₁],
 --                 by_cases c₂ : ∅ = r₂; simp [c₂],
 --             have c₁ : (M.ref' (has_coe.coe 0) (λ (y : ℕ), ite (y = 0) i (asg y))) = i := sorry,
 --             set r₂ := signature.structure.ref' M φ (λ (y : ℕ), ite (y = 0) i (asg y)),
 --             simp [c₁, c₀],
 --             by_cases c₃ : compl i ∪ r₂ = univ;
 --             simp [c₃],
 --                 admit,

 --     end

            -- dunfold signature.structure.ref',
            -- simp,
            -- by_cases c₀ : i = ∅,
            --     right,
            --     simp [c₀],
            -- left,
            -- dunfold signature.structure.ref',
            -- simp,
            -- intros,

            -- intros,
            -- dunfold signature.structure.ref',
            -- simp,
            -- left,
            -- intros,
        -- intros,
        -- -- induction φ;
        -- -- simp [vasgn.bind, signature.structure.ref'],
        -- right,
        -- intros,
        -- dunfold vasgn.bind,
        -- simp,
        -- existsi -(singleton w),
        -- push_neg,
        -- -- have c : {w} ≠ ∅ := sorry,
        -- -- simp[c],
        -- constructor,
        --     constructor,
        --         intro h,
        --         admit,

        -- dunfold signature.structure.ref',
        -- simp,
        -- left,
        -- intros,
        -- right,
        -- intros,
    -- end

 theorem necessity_logical : logical φ.necessary :=
    begin
        simp,
        intros,
        dunfold signature.structure.ref',
        simp,
        set r := M.ref' φ asg,
        by_cases c₀ : r = univ; simp [c₀],
    end

 theorem possibility_logical : logical φ.possible :=
    begin
        simp,
        intros,
        dunfold signature.structure.ref',
        simp,
        set r := M.ref' φ asg,
        by_cases c₀ : -r = univ; simp [c₀],
    end

 theorem definability_of_validity' : M.valid' φ asg ↔ M.valid' (□φ) asg :=
    begin
        simp,
        dunfold signature.structure.ref',
        simp,
        set r := signature.structure.ref' M φ asg,
        by_cases c₀ : r = univ; simp [c₀],
        constructor; intro h,
            have c₁ : r = univ,
                ext, constructor; intro hyp, triv,
                exact h x,
            contradiction,
        intro w,
        specialize h w,
        contradiction,
    end

 theorem necessity_valid_iff_possible : M.valid' (□φ) asg ↔ M.possible' (□φ) asg :=
    begin
        simp,
        dunfold signature.structure.ref',
        simp,
        set r := signature.structure.ref' M φ asg,
        by_cases c₀ : r = univ; simp [c₀];
        obtain ⟨w⟩ := M.ne;
        existsi w;
        triv,
    end

 theorem necessity_T : tautology (□φ ⇒ φ) :=
    begin
        simp,
        intros,
        dunfold signature.structure.ref',
        simp,
        set r := signature.structure.ref' M φ asg,
        by_cases c₀ : r = univ; simp [c₀],
    end

 theorem necessity_K : tautology (□(φ ⇒ ψ) ⇒ □φ ⇒ □ψ) :=
    begin
        simp,
        intros,
        dunfold signature.structure.ref',
        simp,
        set r₁ := M.ref' φ asg,
        set r₂ := M.ref' ψ asg,
        by_cases c₀ : r₁ = univ; simp [c₀],
        by_cases c₁ : r₂ = univ; simp [c₁],
    end

 theorem necessity_4 : tautology (□φ ⇒ □□φ) :=
    begin
        simp,
        intros,
        dunfold signature.structure.ref',
        simp,
        set r := M.ref' φ asg,
        by_cases c₀ : r = univ; simp [c₀],
    end

 theorem necessity_5 : tautology (⋄φ ⇒ □⋄φ) :=
    begin
        simp,
        intros,
        dunfold signature.structure.ref',
        simp,
        set r₁ := M.ref' φ asg,
        by_cases c₀ : -r₁ = univ; simp [c₀],
    end

 theorem necessity_necessitation : tautology.{u} φ → tautology.{u} □φ :=
    begin
        simp,
        intros,
        dunfold signature.structure.ref',
        simp,
        set r := M.ref' φ asg,
        by_cases c₀ : r = univ; simp [c₀],
        specialize a M,
        have c₁ : r = univ,
                ext, constructor; intro h, triv,
                exact a x asg,
        contradiction,
    end

 theorem necessity_barcan : ∀ x : ℕ, tautology (formula.all x □φ ⇒ □formula.all x φ) :=
    begin
        simp,
        intros,
        dunfold signature.structure.ref',
        simp,
        by_cases c₀ : (⋂ (S : set ω), signature.structure.ref' M φ (vasgn.bind asg x S)) = univ;
        simp [c₀],
        have c₁ : ∃ i, M.ref' φ (asg.bind x i) ≠ univ,
            by_contradiction h,
            push_neg at h,
            have c₂ := Inter_eq_univ_iff.2 h,
            contradiction,
        obtain ⟨i, h⟩ := c₁,
        existsi i,
        simp [h],
    end

 theorem necessity_converse_barcan : ∀ x : ℕ, tautology (□formula.all x φ ⇒ formula.all x □φ) :=
    begin
        simp,
        intros,
        dunfold signature.structure.ref',
        simp,
        by_cases c₀ : (⋂ (S : set ω), signature.structure.ref' M φ (vasgn.bind asg x S)) = univ;
        simp [c₀],
        intro i,
        have c₁ := Inter_eq_univ_iff.mp c₀ i,
        simp [c₁],
    end

    theorem universal_entailment_logical : ∀ x : ℕ, logical (formula.all x φ ⟹ ψ) :=
    begin
        simp,
        intros,
        dunfold signature.structure.ref',
        simp,
        set r₁ := (-⋂ (S : set ω), M.ref' φ (asg.bind x S)),
        set r₂ := M.ref' ψ asg,
        by_cases c₀ : r₁ ∪ r₂ = univ;
        simp [c₀],
    end

 end semantics

end logic