/-
Copyright (c) 2023 Jeremy Avigad. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jeremy Avigad, Wojciech Nawrocki
-/

import Mathlib.Data.Finset.Card
import Mathlib.Data.Finset.Powerset
import Mathlib.Data.PNat.Basic
import Mathlib.Algebra.BigOperators.Basic
import ProofChecker.Data.ICnf
import ProofChecker.Model.PropVars

open Nat
abbrev Cube := Array ILit

namespace ILit

theorem mkPos_var_true (l : ILit) (h : l.polarity = true) :
    mkPos (var l) = l := by
  conv => rhs; rw [←eta l]; simp [h, mk]

theorem mkPos_var_false (l : ILit) (h : l.polarity = false) :
    mkPos (var l) = -l := by
  conv => rhs; rw [←eta_neg l]; simp [h, mk]

end ILit

namespace PropForm

def partitioned [DecidableEq ν]: PropForm ν → Prop
  | tr         => True
  | fls        => True
  | var _      => True
  | neg φ      => φ.partitioned
  | disj φ ψ   => φ.partitioned ∧ ψ.partitioned ∧ ∀ v, ¬ (φ.eval v ∧ ψ.eval v)
  | conj φ ψ   => φ.partitioned ∧ ψ.partitioned ∧ (φ.vars ∩ ψ.vars = ∅)
  | impl _ _   => False
  | biImpl _ _ => False

def listConj (φs : List (PropForm Var)) : PropForm Var :=
  φs.foldr (init := .tr) (f := .conj)

def listConjTerm' (φs : List (PropForm Var)) : PropTerm Var :=
  φs.foldr (init := ⊤) (f := (⟦·⟧ ⊓ ·)) -- fold using the monocle capybara operator

def listConjTerm (φs : List (PropTerm Var)) : PropTerm Var :=
  φs.foldr (init := ⊤) (f := (· ⊓ ·))

open PropTerm in
theorem satisfies_listConjTerm (φs : List (PropTerm Var)) (τ : PropAssignment Var) :
    τ ⊨ listConjTerm φs ↔ ∀ φ ∈ φs, τ ⊨ φ := by
  dsimp [listConjTerm]
  induction φs <;> simp_all

@[simp]
theorem listConjTerm_nil : listConjTerm [] = ⊤ := rfl

lemma mem_vars_foldr_conj (φs : List (PropForm Var)) (x : Var) :
    x ∈ (φs.foldr (init := PropForm.tr) (f := .conj)).vars ↔
      ∃ i : Fin (φs.length), x ∈ (φs.get i).vars := by
  induction φs
  . simp [PropForm.vars]
  . next φ φs ih =>
    simp [PropForm.vars, ih, Fin.exists_fin_succ]

theorem partitioned_listConj (φs : List (PropForm Var)) :
    (listConj φs).partitioned ↔
      ∀ i : Fin φs.length, (φs.get i).partitioned ∧
      ∀ j : Fin φs.length, i ≠ j → (φs.get i).vars ∩ (φs.get j).vars = ∅ := by
  induction φs
  . dsimp [listConj, partitioned]; simp
  . next φ φs ih =>
    dsimp [listConj, partitioned] at *
    simp only [ih, Finset.inter_self, List.get, not_true, IsEmpty.forall_iff, true_and,
      add_eq, add_zero, Fin.eta, mem_vars_foldr_conj, Fin.forall_fin_succ]
    have aux : vars φ ∩ vars (List.foldr conj tr φs) = ∅ ↔
        ∀ i : Fin (List.length φs), vars φ ∩ vars (List.get φs i) = ∅ := by
      simp only [Finset.eq_empty_iff_forall_not_mem, Finset.mem_inter, not_and, mem_vars_foldr_conj,
        not_exists]
      aesop
    have aux2 : ∀ i : Fin (List.length φs),
        vars (List.get φs i) ∩ vars φ = vars φ ∩ vars (List.get φs i) := by
      intro i; rw [Finset.inter_comm]
    have aux3 : ∀ i : Fin (List.length φs), ¬ 0 = Fin.succ i := by
      intro i; apply Ne.symm; apply Fin.succ_ne_zero
    aesop

def arrayConj (φs : Array (PropForm Var)) : PropForm Var := listConj φs.data

theorem mem_vars_arrayConj (φs : Array (PropForm Var)) (x : Var) :
    x ∈ (arrayConj φs).vars ↔ ∃ i : Fin φs.size, x ∈ φs[i].vars :=
  mem_vars_foldr_conj φs.data x

theorem partitioned_arrayConj (φs : Array (PropForm Var)) :
    (arrayConj φs).partitioned ↔
      ∀ i : Fin φs.size, φs[i].partitioned ∧
      ∀ j : Fin φs.size, i ≠ j → φs[i].vars ∩ φs[j].vars = ∅ := by
  dsimp [arrayConj]; rw [partitioned_listConj]; rfl

def arrayConjTerm (φs : Array (PropForm Var)) : PropTerm Var :=
  φs.data.foldr (init := ⊤) (f := fun φ acc => ⟦φ⟧ ⊓ acc)

theorem arrayConjTerm_eq_listConjTerm_data (φs : Array (PropForm Var)) :
    arrayConjTerm φs = listConjTerm (φs.data.map (⟦·⟧)) := by
  dsimp [arrayConjTerm, listConjTerm]
  induction φs.data <;> simp_all

@[simp]
theorem mk_arrayConj (φs : Array (PropForm Var)) : ⟦arrayConj φs⟧ = arrayConjTerm φs := by
  dsimp [arrayConj, listConj, arrayConjTerm]
  induction φs.data <;> simp_all

open PropTerm in
theorem satisfies_arrayConjTerm (φs : Array (PropForm Var)) (τ : PropAssignment Var) :
    τ ⊨ arrayConjTerm φs ↔ ∀ φ ∈ φs.data, τ ⊨ ⟦φ⟧ := by
  dsimp [arrayConjTerm]
  induction φs.data <;> aesop

def withPolarity (p : PropForm Var) (l : ILit) := cond (l.polarity) p p.neg

@[simp] theorem withPolarity_mkPos (p : PropForm Var) (x : Var) :
  withPolarity p (.mkPos x) = p := by simp [withPolarity]

@[simp] theorem withPolarity_mkNeg (p : PropForm Var) (x : Var) :
  withPolarity p (.mkNeg x) = p.neg := by simp [withPolarity]

end PropForm

/-
The current implementation assumes that nodes are added consecutively, without gaps, and throws an
exception otherwise. This enables us to maintain the invariant that the variable (possibly an
extension variable) corresponding to the entry at index `n` is `n + 1`.

We nonetheless store the variable anyhow, to make it easier to loosen that requirement in the
future. We can do that straightforwardly by adding a hashmap that maps each variable to the
corresponding index.
-/

inductive PogElt where
  | var  : Var → PogElt
  | disj : Var → ILit → ILit → PogElt
  | conj : Var → Cube → PogElt
deriving Repr, DecidableEq, Inhabited

namespace PogElt

def varNum : PogElt → Var
  | var x      => x
  | disj x _ _ => x
  | conj x _   => x

-- If we generalize to let variables come in any order, we need only change this to add the indexing
-- function and require `index left.var < index n`, etc.

def args_decreasing : PogElt → Prop
  | var _             => true
  | disj n left right => left.var < n ∧ right.var < n
  | conj n args       =>  ∀ i : Fin args.size, args[i].var < n

end PogElt

-- To generalize this, add a hashmap for the indexing function.

structure Pog where
  elts : Array PogElt
  wf : ∀ i : Fin elts.size, elts[i].args_decreasing
  inv : ∀ i : Fin elts.size, i = elts[i].varNum.natPred

def PogError := String

instance : ToString PogError where
  toString := id

namespace Pog
open PogElt

def empty : Pog where
  elts := #[]
  wf := fun i => i.elim0
  inv := fun i => i.elim0

def push (pog : Pog) (pogElt : PogElt)
    (hwf : pogElt.args_decreasing) (hinv : pogElt.varNum = succPNat pog.elts.size) : Pog where
  elts := pog.elts.push pogElt
  wf := by
    intro ⟨i, h'⟩
    rw [Array.size_push] at h'
    cases (lt_or_eq_of_le (le_of_lt_succ h'))
    . case inl h' =>
      dsimp; rw [Array.get_push_lt _ _ _ h']
      apply pog.wf ⟨i, h'⟩
    . case inr h' =>
      dsimp; cases h'; rw [Array.get_push_eq]
      exact hwf
  inv := by
      intro ⟨i, h'⟩
      rw [Array.size_push] at h'
      cases (lt_or_eq_of_le (le_of_lt_succ h'))
      . case inl h' =>
        dsimp; rw [Array.get_push_lt _ _ _ h']
        apply pog.inv ⟨i, h'⟩
      . case inr h' =>
        cases h'; dsimp
        rw [Array.get_push_eq, hinv, natPred_succPNat]

theorem get_push_elts_lt (pog : Pog) (pogElt : PogElt)
      (hwf : pogElt.args_decreasing) (hinv : pogElt.varNum = succPNat pog.elts.size)
      (i : Nat) (h : i < pog.elts.size) (h' : i < (pog.push pogElt hwf hinv).elts.size) :
    (pog.push pogElt hwf hinv).elts[i] = pog.elts[i] :=
  Array.get_push_lt _ _ _ h

lemma get_push_elts_nat_Pred_varNum (pog : Pog) (pogElt : PogElt)
      (hwf : pogElt.args_decreasing) (hinv : pogElt.varNum = succPNat pog.elts.size)
      (h' : PNat.natPred (varNum pogElt) < Array.size (push pog pogElt hwf hinv).elts) :
    (pog.push pogElt hwf hinv).elts[PNat.natPred pogElt.varNum] = pogElt := by
  simp only [hinv, natPred_succPNat]
  apply Array.get_push_eq

def size_push_elts (pog : Pog) (pogElt : PogElt)
      (hwf : pogElt.args_decreasing) (hinv : pogElt.varNum = succPNat pog.elts.size) :
    (pog.push pogElt hwf hinv).elts.size = pog.elts.size + 1 :=
  Array.size_push _ _

def addVar (pog : Pog) (x : Var) : Except PogError Pog :=
  if h : x = succPNat pog.elts.size then
    .ok <| pog.push (var x) (by trivial) h
  else
    .error s!"Pog variable {x} added, {pog.elts.size + 1} expected"

def addDisj (pog : Pog) (x : Var) (left right : ILit) : Except PogError Pog :=
  if h : x = succPNat pog.elts.size then
    if hleft : left.var < x then
      if hright : right.var < x then
        .ok <| pog.push (disj x left right) ⟨hleft, hright⟩ h
      else
        .error s!"Pog disjunction {x} added, right argument {right} missing"
    else
      .error s!"Pog disjunction {x} added, left argument {left} missing"
  else
    .error s!"Pog disjunction {x} added, {pog.elts.size + 1} expected"

def addConj (pog : Pog)(x : Var) (args : Cube)  : Except PogError Pog :=
  if h : x = succPNat pog.elts.size then
    if hargs : ∀ i : Fin args.size, args[i].var < x then
      .ok <| pog.push (conj x args) hargs h
    else
      .error s!"Pog conjunction {x} added, argument missing"
  else
    .error s!"Pog conjunction {x} added, {pog.elts.size + 1} expected"

/-- This avoids having to repeat a calculation. -/
lemma lt_aux {n : Nat} {y : Var} (hlt: y < x) (hinv: n = x.natPred) :
  y.natPred < n := by rwa [hinv, PNat.natPred_lt_natPred]

def toPropForm (pog : Pog) (l : ILit) : PropForm Var :=
  if h : l.var.natPred < pog.elts.size then
    aux l.var.natPred h |>.withPolarity l
  else
    l.toPropForm
where
  aux : (i : Nat) → i < pog.elts.size → PropForm Var
  | i, h =>
    match pog.elts[i], pog.wf ⟨i, h⟩, pog.inv ⟨i, h⟩ with
    | var x, _, _ => PropForm.var x
    | disj x left right, ⟨hleft, hright⟩, hinv =>
        have h_left_lt : left.var.natPred < i := lt_aux hleft hinv
        have h_right_lt : right.var.natPred < i := lt_aux hright hinv
        .disj (aux _ (h_left_lt.trans h) |>.withPolarity left)
              (aux _ (h_right_lt.trans h) |>.withPolarity right)
    | conj x args, hwf, hinv =>
        .arrayConj <| Array.ofFn fun (j : Fin args.size) =>
          have h_lt : args[j].var.natPred < i := lt_aux (hwf j) hinv
          aux args[j].var.natPred (h_lt.trans h) |>.withPolarity args[j]

theorem toPropForm_of_polarity_eq_false (pog : Pog) (l : ILit) (hl : l.polarity = false) :
    pog.toPropForm l = .neg (pog.toPropForm (-l)) := by
  rw [toPropForm]
  split
  . next h =>
    rw [toPropForm, ILit.var_negate, dif_pos h, PropForm.withPolarity, hl, cond_false,
      PropForm.withPolarity, ILit.polarity_negate, hl, Bool.not_false, cond_true]
  . next h =>
    rw [toPropForm, ILit.var_negate, dif_neg h]
    rw [ILit.toPropForm, hl]; simp only [ite_false, PropForm.neg.injEq]
    rw [ILit.toPropForm, ILit.polarity_negate, hl]; simp only [ILit.var_negate, ite_true]

theorem toPropForm_aux_eq (pog : Pog) (i : Nat) (h : i < pog.elts.size) :
  toPropForm.aux pog i h =
    match pog.elts[i] with
      | var x => PropForm.var x
      | disj _ left right => .disj (pog.toPropForm left) (pog.toPropForm right)
      | conj _ args =>
          .arrayConj <| Array.ofFn fun (j : Fin args.size) => pog.toPropForm args[j] := by
  rw [toPropForm.aux]
  split
  . simp [*]
  . next x left right hleft hright hinv heq _ _ =>
    simp only [heq]
    have h_left_lt : left.var.natPred < i := lt_aux hleft hinv
    have h_right_lt : right.var.natPred < i := lt_aux hright hinv
    rw [toPropForm, dif_pos (h_left_lt.trans h), toPropForm, dif_pos (h_right_lt.trans h)]
  . next x args hwf hinv heq _ _ =>
    simp only [heq]
    congr; ext j
    have h_lt : args[j].var.natPred < i := lt_aux (hwf j) hinv
    rw [toPropForm, dif_pos (h_lt.trans h)]

theorem toPropForm_push_of_lt (pog : Pog) (pogElt : PogElt)
      (hwf : pogElt.args_decreasing) (hinv : pogElt.varNum = succPNat pog.elts.size)
      (l : ILit) (hl : PNat.natPred l.var < pog.elts.size) :
    (pog.push pogElt hwf hinv).toPropForm l = pog.toPropForm l := by
  have hl' : PNat.natPred l.var < (pog.push pogElt hwf hinv).elts.size := by
    dsimp [Pog.push]; rw [Array.size_push]; exact hl.trans (lt_succ_self _)
  rw [toPropForm, toPropForm, dif_pos hl, dif_pos hl', aux]
where
  aux :
    (i : Nat) → (h : i < pog.elts.size) → (h' : i < (pog.push pogElt hwf hinv).elts.size) →
     toPropForm.aux (pog.push pogElt hwf hinv) i h' = toPropForm.aux pog i h
  | i, h, h' => by
    rw [toPropForm.aux]; conv => rhs; rw [toPropForm.aux]
    have heq := pog.get_push_elts_lt pogElt hwf hinv i h h'
    split <;> split <;> simp [*] at heq <;> try { injection heq } <;> try { simp only [heq] }
    . next x left right hleft hright hinv' _ _ _ =>
      simp only [heq]
      have _ : left.var.natPred < i := by
        dsimp at hinv'; rwa [hinv', PNat.natPred_lt_natPred]
      have _ : right.var.natPred < i := by
        dsimp at hinv'; rwa [hinv', PNat.natPred_lt_natPred]
      rw [aux (PNat.natPred (ILit.var left)), aux (PNat.natPred (ILit.var right))]
    . next x args hargs hinv' _ _ _ _ _ _ x' args' _ _ _ _ _ =>
      cases heq.2
      cases heq.1
      apply congr_arg PropForm.arrayConj
      apply congr_arg Array.ofFn
      ext j; dsimp
      have _ : args[j].var.natPred < i := by
        dsimp at hinv'; rw [hinv', PNat.natPred_lt_natPred]
        exact hargs j
      rw [aux (PNat.natPred (ILit.var _))]

theorem toPropForm_push_of_ne (y : Var) (pog : Pog) (pogElt : PogElt)
      (hwf : pogElt.args_decreasing) (hinv : pogElt.varNum = succPNat pog.elts.size)
      (hne : pogElt.varNum ≠ y) :
    (pog.push pogElt hwf hinv).toPropForm (.mkPos y) = pog.toPropForm (.mkPos y) := by
  rw [toPropForm, toPropForm]
  simp only [ILit.var_mkPos, PropForm.withPolarity_mkPos]
  cases le_or_gt pogElt.varNum y
  case inl hle =>
    have : Array.size pog.elts ≤ PNat.natPred y :=
      by rwa [←succPNat_le_succPNat, ←hinv, PNat.succPNat_natPred]
    rw [dif_neg (not_lt_of_le this), dif_neg]
    rw [not_lt, size_push_elts, succ_le_iff]
    apply (lt_of_le_of_ne this)
    contrapose! hne
    rw [hinv, hne, PNat.succPNat_natPred]
  case inr hle =>
    have : PNat.natPred y < Array.size pog.elts :=
      by rwa [←succPNat_lt_succPNat, ←hinv, PNat.succPNat_natPred]
    rw [dif_pos this, dif_pos, toPropForm_push_of_lt.aux]
    rw [size_push_elts]
    apply lt_succ_of_lt this

theorem toPropForm_empty (l : ILit) : empty.toPropForm l = l.toPropForm := by
  dsimp [toPropForm]
  split
  next h =>
    simp [empty] at h
  next =>
    rfl

theorem toPropForm_neg (p : Pog) (x : Var) :
    p.toPropForm (.mkNeg x) = .neg (p.toPropForm (.mkPos x)) := by
  rw [toPropForm, toPropForm]; simp; split <;> simp [ILit.toPropForm]

theorem toPropForm_addVar (p p' : Pog) (x : Var) :
    p.addVar x = .ok p' →
    p'.toPropForm (.mkPos x) = .var x := by
  rw [addVar]
  split
  . next h =>
    intro h'
    injection h' with h'
    rw [←h', toPropForm]
    split
    . next h'' =>
      rw [toPropForm.aux]
      have heq : ∀ h1 h2,
          (push p (var x) h1 h2).elts[PNat.natPred (ILit.var (ILit.mkPos x))] = var x :=
        fun h1 h2 => get_push_elts_nat_Pred_varNum _ _ _ _ _
      split <;> simp only [heq] at *
      next x' _ _ _ _ heq' =>
        injection heq' with heq'
        simp [heq']
    . simp [ILit.toPropForm]
  . intro; contradiction

theorem toPropForm_addVar_lit (p p' : Pog) (l : ILit) :
    p.addVar l.var = .ok p' →
    p'.toPropForm l = l.toPropForm := by
  cases l.mkPos_or_mkNeg <;>
    next hMk =>
      intro h
      rw [hMk]
      have := toPropForm_addVar _ _ _ h
      simp [toPropForm_neg, this]

theorem toPropForm_addVar_of_ne (x y : Var) (p p' : Pog) :
    p.addVar x = .ok p' → x ≠ y →
    p'.toPropForm (.mkPos y) = p.toPropForm (.mkPos y) := by
  rw [addVar]
  split
  . next h =>
    intro h'
    injection h' with h'
    intro hne
    rw [←h']
    apply toPropForm_push_of_ne
    exact hne
  . intro; contradiction

theorem toPropForm_addVar_lit_of_ne (x : Var) (l : ILit) (p p' : Pog) :
    p.addVar x = .ok p' → x ≠ l.var →
    p'.toPropForm l = p.toPropForm l := by
  cases l.mkPos_or_mkNeg <;>
    next hMk =>
      intro h hNe
      rw [hMk]
      have := toPropForm_addVar_of_ne _ _ _ _ h hNe
      simp [toPropForm_neg, this]

theorem toPropForm_addDisj (x : Var) (l₁ l₂ : ILit) (p p' : Pog) :
    p.addDisj x l₁ l₂ = .ok p' →
    p'.toPropForm (.mkPos x) = .disj (p.toPropForm l₁) (p.toPropForm l₂) := by
  rw [addDisj]
  split
  . next h =>
    split
    . next hleft =>
      split
      . next hright =>
          intro h'
          injection h' with h'
          rw [←h', toPropForm]
          split
          . next h'' =>
            rw [toPropForm.aux]
            have heq : ∀ h1 h2,
                (push p (disj x l₁ l₂) h1 h2).elts[PNat.natPred (ILit.var (ILit.mkPos x))] =
                  disj x l₁ l₂ :=
              fun h1 h2 => get_push_elts_nat_Pred_varNum _ _ _ _ _
            split <;> simp only [heq] at *
            next x' left' right' _ _ _ _ _ heq' =>
              injection heq' with heq₁ heq₂ heq₃
              cases heq₁
              cases heq₂
              cases heq₃
              simp only [PropForm.withPolarity_mkPos, PropForm.disj.injEq]
              constructor
              . rw [toPropForm, dif_pos, toPropForm_push_of_lt.aux]
                rwa [←succPNat_lt_succPNat, PNat.succPNat_natPred, ←h]
              . rw [toPropForm, dif_pos, toPropForm_push_of_lt.aux]
                rwa [←succPNat_lt_succPNat, PNat.succPNat_natPred, ←h]
          . next h'' =>
            exfalso
            apply h''
            rw [size_push_elts, h, ILit.var_mkPos, natPred_succPNat]
            exact lt_succ_self _
      . intro; contradiction
    . intro; contradiction
  . intro; contradiction

theorem toPropForm_addDisj_of_ne (x y : Var) (l₁ l₂ : ILit) (p p' : Pog) :
    p.addDisj x l₁ l₂ = .ok p' → x ≠ y →
    p'.toPropForm (.mkPos y) = p.toPropForm (.mkPos y) := by
  rw [addDisj]
  split
  . next h =>
    split
    . next hleft =>
      split
      . next hright =>
          intro h'
          injection h' with h'
          intro hne
          rw [←h']
          apply toPropForm_push_of_ne
          exact hne
      . intro; contradiction
    . intro; contradiction
  . intro; contradiction

theorem toPropForm_addDisj_lit_of_ne (x : Var) (l l₁ l₂ : ILit) (p p' : Pog) :
    p.addDisj x l₁ l₂ = .ok p' → x ≠ l.var →
    p'.toPropForm l = p.toPropForm l := by
  cases l.mkPos_or_mkNeg <;>
    next hMk =>
      intro h hNe
      rw [hMk]
      have := p.toPropForm_addDisj_of_ne _ _ _ _ _ h hNe
      simp [toPropForm_neg, this]

theorem toPropForm_addConj (x : Var) (ls : Array ILit) (p p' : Pog) :
    p.addConj x ls = .ok p' →
    p'.toPropForm (.mkPos x) = .arrayConj (ls.map p.toPropForm) := by
  rw [addConj]
  split
  . next h =>
    split
    . next hargs =>
        intro h'
        injection h' with h'
        rw [←h', toPropForm]
        split
        . next h'' =>
          rw [toPropForm.aux]
          have heq : ∀ h1 h2,
              (push p (conj x ls) h1 h2).elts[PNat.natPred (ILit.var (ILit.mkPos x))] =
                conj x ls :=
            fun h1 h2 => get_push_elts_nat_Pred_varNum _ _ _ _ _
          split <;> simp only [heq] at *
          next x' ls' _ _ _ _ _ heq' =>
            injection heq' with heq₁ heq₂
            cases heq₁
            cases heq₂
            simp only [PropForm.withPolarity_mkPos, PropForm.conj.injEq]
            congr
            apply Array.ext
            . rw [Array.size_map, Array.size_ofFn]
            . intro j hj₁ hj₂
              simp only [getElem_fin, Array.getElem_ofFn, Array.getElem_map]
              rw [toPropForm, dif_pos, toPropForm_push_of_lt.aux]
              rw [←succPNat_lt_succPNat, PNat.succPNat_natPred, ←h]
              rw [Array.size_ofFn] at hj₁
              apply hargs ⟨j, hj₁⟩
        . next h'' =>
          exfalso
          apply h''
          rw [size_push_elts, h, ILit.var_mkPos, natPred_succPNat]
          exact lt_succ_self _
    . intro; contradiction
  . intro; contradiction

theorem toPropForm_addConj_of_ne (x y : Var) (ls : Array ILit) (p p' : Pog) :
    p.addConj x ls = .ok p' → x ≠ y →
    p'.toPropForm (.mkPos y) = p.toPropForm (.mkPos y) := by
  rw [addConj]
  split
  . next h =>
    split
    . next args =>
        intro h'
        injection h' with h'
        intro hne
        rw [←h']
        apply toPropForm_push_of_ne
        exact hne
    . intro; contradiction
  . intro; contradiction

theorem toPropForm_addConj_lit_of_ne (x : Var) (l : ILit) (ls : Array ILit) (p p' : Pog) :
    p.addConj x ls = .ok p' → x ≠ l.var →
    p'.toPropForm l = p.toPropForm l := by
  cases l.mkPos_or_mkNeg <;>
    next hMk =>
      intro h hNe
      rw [hMk]
      have := p.toPropForm_addConj_of_ne _ _ _ _ h hNe
      simp [toPropForm_neg, this]

/-
Even though we are not using this now, a Pog can keep track of its variables, and if the client
can ensure that conjunctions and disjunctions refer to previous variables, we can eliminate the
checks in `addDisj` and `addConj`.
-/

def vars (pog : Pog) : Finset Var := Finset.range pog.elts.size |>.image succPNat

theorem mem_vars_aux {pog : Pog} {n : Var} : n ∈ pog.vars ↔ n ≤ pog.elts.size := by
  simp only [Pog.vars, Finset.mem_image, Finset.mem_range]
  constructor
  . rintro ⟨m, hm, rfl⟩
    exact hm
  . rintro hle
    use n.natPred
    rw [lt_iff_add_one_le, ←succ_eq_add_one, ←succPNat_coe, PNat.succPNat_natPred]
    exact ⟨hle, rfl⟩

theorem mem_vars {pog : Pog} {n : Var} :
    n ∈ pog.vars ↔ ∃ i : Fin pog.elts.size, pog.elts[i].varNum = n := by
  rw [mem_vars_aux]
  constructor
  . intro hle
    have : n.natPred < pog.elts.size := by
      apply lt_of_succ_le
      rw [←succPNat_coe, PNat.succPNat_natPred]
      exact hle
    use ⟨n.natPred, this⟩
    rw [←PNat.natPred_inj]
    symm; apply pog.inv ⟨n.natPred, this⟩
  . rintro ⟨i, rfl⟩
    have := congr_arg succPNat (pog.inv i)
    rw [PNat.succPNat_natPred] at this
    rw [←this, succPNat_coe]
    exact i.isLt

theorem vars_push (pog : Pog) (pogElt : PogElt)
      (hwf : args_decreasing pogElt) (hinv : pogElt.varNum = succPNat pog.elts.size) :
    vars (pog.push pogElt hwf hinv) = insert (succPNat pog.elts.size) pog.vars := by
  ext i
  rw [mem_vars_aux, Pog.push, Array.size_push, Finset.mem_insert, mem_vars_aux,
          le_iff_eq_or_lt, ←Nat.lt_succ, ←succ_eq_add_one, ←succPNat_coe, PNat.coe_inj]

theorem vars_addVar {pog newPog : Pog} {n : Var} (h : (pog.addVar n) = .ok newPog) :
    newPog.vars = insert n pog.vars := by
  rw [addVar] at h
  split at h
  case inr h' =>
    contradiction
  case inl h' =>
    ext i
    injection h with h
    rw [←h, vars_push, h']

theorem vars_addDisj {pog newPog : Pog} {n : Var} (left right : ILit)
      (h : (pog.addDisj n left right) = .ok newPog) :
    newPog.vars = insert n pog.vars := by
  rw [addDisj] at h
  split at h <;> try { contradiction }
  split at h <;> try { contradiction }
  split at h <;> try { contradiction }
  next h' _ _ =>
    ext i
    injection h with h
    rw [←h, vars_push, h']

theorem vars_addConj {pog newPog : Pog} {n : Var} (args : Array ILit)
      (h : (pog.addConj n args) = .ok newPog) :
    newPog.vars = insert n pog.vars := by
  rw [addConj] at h
  split at h <;> try { contradiction }
  split at h <;> try { contradiction }
  next h' _ =>
    ext i
    injection h with h
    rw [←h, vars_push, h']

end Pog


/-
Copyright (c) 2019 Reid Barton. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Patrick Massot, Sébastien Gouëzel, Zhouhang Zhou, Reid Barton
-/
import logic.equiv.fin
import topology.dense_embedding
import topology.support

/-!
# Homeomorphisms

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

This file defines homeomorphisms between two topological spaces. They are bijections with both
directions continuous. We denote homeomorphisms with the notation `≃ₜ`.

# Main definitions

* `homeomorph α β`: The type of homeomorphisms from `α` to `β`.
  This type can be denoted using the following notation: `α ≃ₜ β`.

# Main results

* Pretty much every topological property is preserved under homeomorphisms.
* `homeomorph.homeomorph_of_continuous_open`: A continuous bijection that is
  an open map is a homeomorphism.

-/

open set filter
open_locale topology

variables {α : Type*} {β : Type*} {γ : Type*} {δ : Type*}

/-- Homeomorphism between `α` and `β`, also called topological isomorphism -/
@[nolint has_nonempty_instance] -- not all spaces are homeomorphic to each other
structure homeomorph (α : Type*) (β : Type*) [topological_space α] [topological_space β]
  extends α ≃ β :=
(continuous_to_fun  : continuous to_fun . tactic.interactive.continuity')
(continuous_inv_fun : continuous inv_fun . tactic.interactive.continuity')

infix ` ≃ₜ `:25 := homeomorph

namespace homeomorph
variables [topological_space α] [topological_space β] [topological_space γ] [topological_space δ]

instance : has_coe_to_fun (α ≃ₜ β) (λ _, α → β) := ⟨λe, e.to_equiv⟩

@[simp] lemma homeomorph_mk_coe (a : equiv α β) (b c) :
  ((homeomorph.mk a b c) : α → β) = a :=
rfl

/-- Inverse of a homeomorphism. -/
protected def symm (h : α ≃ₜ β) : β ≃ₜ α :=
{ continuous_to_fun  := h.continuous_inv_fun,
  continuous_inv_fun := h.continuous_to_fun,
  to_equiv := h.to_equiv.symm }

/-- See Note [custom simps projection]. We need to specify this projection explicitly in this case,
  because it is a composition of multiple projections. -/
def simps.apply (h : α ≃ₜ β) : α → β := h
/-- See Note [custom simps projection] -/
def simps.symm_apply (h : α ≃ₜ β) : β → α := h.symm

initialize_simps_projections homeomorph
  (to_equiv_to_fun → apply, to_equiv_inv_fun → symm_apply, -to_equiv)

@[simp] lemma coe_to_equiv (h : α ≃ₜ β) : ⇑h.to_equiv = h := rfl
@[simp] lemma coe_symm_to_equiv (h : α ≃ₜ β) : ⇑h.to_equiv.symm = h.symm := rfl

lemma to_equiv_injective : function.injective (to_equiv : α ≃ₜ β → α ≃ β)
| ⟨e, h₁, h₂⟩ ⟨e', h₁', h₂'⟩ rfl := rfl

@[ext] lemma ext {h h' : α ≃ₜ β} (H : ∀ x, h x = h' x) : h = h' :=
to_equiv_injective $ equiv.ext H

@[simp] lemma symm_symm (h : α ≃ₜ β) : h.symm.symm = h := ext $ λ _, rfl

/-- Identity map as a homeomorphism. -/
@[simps apply {fully_applied := ff}]
protected def refl (α : Type*) [topological_space α] : α ≃ₜ α :=
{ continuous_to_fun := continuous_id,
  continuous_inv_fun := continuous_id,
  to_equiv := equiv.refl α }

/-- Composition of two homeomorphisms. -/
protected def trans (h₁ : α ≃ₜ β) (h₂ : β ≃ₜ γ) : α ≃ₜ γ :=
{ continuous_to_fun  := h₂.continuous_to_fun.comp h₁.continuous_to_fun,
  continuous_inv_fun := h₁.continuous_inv_fun.comp h₂.continuous_inv_fun,
  to_equiv := equiv.trans h₁.to_equiv h₂.to_equiv }

@[simp] lemma trans_apply (h₁ : α ≃ₜ β) (h₂ : β ≃ₜ γ) (a : α) : h₁.trans h₂ a = h₂ (h₁ a) := rfl

@[simp] lemma homeomorph_mk_coe_symm (a : equiv α β) (b c) :
  ((homeomorph.mk a b c).symm : β → α) = a.symm :=
rfl

@[simp] lemma refl_symm : (homeomorph.refl α).symm = homeomorph.refl α := rfl

@[continuity]
protected lemma continuous (h : α ≃ₜ β) : continuous h := h.continuous_to_fun

@[continuity] -- otherwise `by continuity` can't prove continuity of `h.to_equiv.symm`
protected lemma continuous_symm (h : α ≃ₜ β) : continuous (h.symm) := h.continuous_inv_fun

@[simp] lemma apply_symm_apply (h : α ≃ₜ β) (x : β) : h (h.symm x) = x :=
h.to_equiv.apply_symm_apply x

@[simp] lemma symm_apply_apply (h : α ≃ₜ β) (x : α) : h.symm (h x) = x :=
h.to_equiv.symm_apply_apply x

@[simp] lemma self_trans_symm (h : α ≃ₜ β) : h.trans h.symm = homeomorph.refl α :=
by { ext, apply symm_apply_apply }

@[simp] lemma symm_trans_self (h : α ≃ₜ β) : h.symm.trans h = homeomorph.refl β :=
by { ext, apply apply_symm_apply }

protected lemma bijective (h : α ≃ₜ β) : function.bijective h := h.to_equiv.bijective
protected lemma injective (h : α ≃ₜ β) : function.injective h := h.to_equiv.injective
protected lemma surjective (h : α ≃ₜ β) : function.surjective h := h.to_equiv.surjective

/-- Change the homeomorphism `f` to make the inverse function definitionally equal to `g`. -/
def change_inv (f : α ≃ₜ β) (g : β → α) (hg : function.right_inverse g f) : α ≃ₜ β :=
have g = f.symm, from funext (λ x, calc g x = f.symm (f (g x)) : (f.left_inv (g x)).symm
                                        ... = f.symm x : by rw hg x),
{ to_fun := f,
  inv_fun := g,
  left_inv := by convert f.left_inv,
  right_inv := by convert f.right_inv,
  continuous_to_fun := f.continuous,
  continuous_inv_fun := by convert f.symm.continuous }

@[simp] lemma symm_comp_self (h : α ≃ₜ β) : ⇑h.symm ∘ ⇑h = id :=
funext h.symm_apply_apply

@[simp] lemma self_comp_symm (h : α ≃ₜ β) : ⇑h ∘ ⇑h.symm = id :=
funext h.apply_symm_apply

@[simp] lemma range_coe (h : α ≃ₜ β) : range h = univ :=
h.surjective.range_eq

lemma image_symm (h : α ≃ₜ β) : image h.symm = preimage h :=
funext h.symm.to_equiv.image_eq_preimage

lemma preimage_symm (h : α ≃ₜ β) : preimage h.symm = image h :=
(funext h.to_equiv.image_eq_preimage).symm

@[simp] lemma image_preimage (h : α ≃ₜ β) (s : set β) : h '' (h ⁻¹' s) = s :=
h.to_equiv.image_preimage s

@[simp] lemma preimage_image (h : α ≃ₜ β) (s : set α) : h ⁻¹' (h '' s) = s :=
h.to_equiv.preimage_image s

protected lemma inducing (h : α ≃ₜ β) : inducing h :=
inducing_of_inducing_compose h.continuous h.symm.continuous $
  by simp only [symm_comp_self, inducing_id]

lemma induced_eq (h : α ≃ₜ β) : topological_space.induced h ‹_› = ‹_› := h.inducing.1.symm

protected lemma quotient_map (h : α ≃ₜ β) : quotient_map h :=
quotient_map.of_quotient_map_compose h.symm.continuous h.continuous $
  by simp only [self_comp_symm, quotient_map.id]

lemma coinduced_eq (h : α ≃ₜ β) : topological_space.coinduced h ‹_› = ‹_› :=
h.quotient_map.2.symm

protected lemma embedding (h : α ≃ₜ β) : embedding h :=
⟨h.inducing, h.injective⟩

/-- Homeomorphism given an embedding. -/
noncomputable def of_embedding (f : α → β) (hf : embedding f) : α ≃ₜ (set.range f) :=
{ continuous_to_fun := hf.continuous.subtype_mk _,
  continuous_inv_fun := by simp [hf.continuous_iff, continuous_subtype_coe],
  to_equiv := equiv.of_injective f hf.inj }

protected lemma second_countable_topology [topological_space.second_countable_topology β]
  (h : α ≃ₜ β) :
  topological_space.second_countable_topology α :=
h.inducing.second_countable_topology

lemma is_compact_image {s : set α} (h : α ≃ₜ β) : is_compact (h '' s) ↔ is_compact s :=
h.embedding.is_compact_iff_is_compact_image.symm

lemma is_compact_preimage {s : set β} (h : α ≃ₜ β) : is_compact (h ⁻¹' s) ↔ is_compact s :=
by rw ← image_symm; exact h.symm.is_compact_image

@[simp] lemma comap_cocompact (h : α ≃ₜ β) : comap h (cocompact β) = cocompact α :=
(comap_cocompact_le h.continuous).antisymm $
  (has_basis_cocompact.le_basis_iff (has_basis_cocompact.comap h)).2 $ λ K hK,
    ⟨h ⁻¹' K, h.is_compact_preimage.2 hK, subset.rfl⟩

@[simp] lemma map_cocompact (h : α ≃ₜ β) : map h (cocompact α) = cocompact β :=
by rw [← h.comap_cocompact, map_comap_of_surjective h.surjective]

protected lemma compact_space [compact_space α] (h : α ≃ₜ β) : compact_space β :=
{ is_compact_univ := by { rw [← image_univ_of_surjective h.surjective, h.is_compact_image],
    apply compact_space.is_compact_univ } }

protected lemma t0_space [t0_space α] (h : α ≃ₜ β) : t0_space β :=
h.symm.embedding.t0_space

protected lemma t1_space [t1_space α] (h : α ≃ₜ β) : t1_space β :=
h.symm.embedding.t1_space

protected lemma t2_space [t2_space α] (h : α ≃ₜ β) : t2_space β :=
h.symm.embedding.t2_space

protected lemma t3_space [t3_space α] (h : α ≃ₜ β) : t3_space β :=
h.symm.embedding.t3_space

protected lemma dense_embedding (h : α ≃ₜ β) : dense_embedding h :=
{ dense   := h.surjective.dense_range,
  .. h.embedding }

@[simp] lemma is_open_preimage (h : α ≃ₜ β) {s : set β} : is_open (h ⁻¹' s) ↔ is_open s :=
h.quotient_map.is_open_preimage

@[simp] lemma is_open_image (h : α ≃ₜ β) {s : set α} : is_open (h '' s) ↔ is_open s :=
by rw [← preimage_symm, is_open_preimage]

protected lemma is_open_map (h : α ≃ₜ β) : is_open_map h := λ s, h.is_open_image.2

@[simp] lemma is_closed_preimage (h : α ≃ₜ β) {s : set β} : is_closed (h ⁻¹' s) ↔ is_closed s :=
by simp only [← is_open_compl_iff, ← preimage_compl, is_open_preimage]

@[simp] lemma is_closed_image (h : α ≃ₜ β) {s : set α} : is_closed (h '' s) ↔ is_closed s :=
by rw [← preimage_symm, is_closed_preimage]

protected lemma is_closed_map (h : α ≃ₜ β) : is_closed_map h := λ s, h.is_closed_image.2

protected lemma open_embedding (h : α ≃ₜ β) : open_embedding h :=
open_embedding_of_embedding_open h.embedding h.is_open_map

protected lemma closed_embedding (h : α ≃ₜ β) : closed_embedding h :=
closed_embedding_of_embedding_closed h.embedding h.is_closed_map

protected lemma normal_space [normal_space α] (h : α ≃ₜ β) : normal_space β :=
h.symm.closed_embedding.normal_space

lemma preimage_closure (h : α ≃ₜ β) (s : set β) : h ⁻¹' (closure s) = closure (h ⁻¹' s) :=
h.is_open_map.preimage_closure_eq_closure_preimage h.continuous _

lemma image_closure (h : α ≃ₜ β) (s : set α) : h '' (closure s) = closure (h '' s) :=
by rw [← preimage_symm, preimage_closure]

lemma image_interior (h : α ≃ₜ β) (s : set α) : h '' (interior s) = interior (h '' s) :=
by rw [← preimage_symm, preimage_interior]

lemma preimage_frontier (h : α ≃ₜ β) (s : set β) : h ⁻¹' (frontier s) = frontier (h ⁻¹' s) :=
h.is_open_map.preimage_frontier_eq_frontier_preimage h.continuous _

lemma image_frontier (h : α ≃ₜ β) (s : set α) : h '' frontier s = frontier (h '' s) :=
by rw [←preimage_symm, preimage_frontier]

@[to_additive]
lemma _root_.has_compact_mul_support.comp_homeomorph {M} [has_one M] {f : β → M}
  (hf : has_compact_mul_support f) (φ : α ≃ₜ β) : has_compact_mul_support (f ∘ φ) :=
hf.comp_closed_embedding φ.closed_embedding

@[simp] lemma map_nhds_eq (h : α ≃ₜ β) (x : α) : map h (𝓝 x) = 𝓝 (h x) :=
h.embedding.map_nhds_of_mem _ (by simp)

lemma symm_map_nhds_eq (h : α ≃ₜ β) (x : α) : map h.symm (𝓝 (h x)) = 𝓝 x :=
by rw [h.symm.map_nhds_eq, h.symm_apply_apply]

lemma nhds_eq_comap (h : α ≃ₜ β) (x : α) : 𝓝 x = comap h (𝓝 (h x)) :=
h.embedding.to_inducing.nhds_eq_comap x

@[simp] lemma comap_nhds_eq (h : α ≃ₜ β) (y : β) : comap h (𝓝 y) = 𝓝 (h.symm y) :=
by rw [h.nhds_eq_comap, h.apply_symm_apply]

/-- If an bijective map `e : α ≃ β` is continuous and open, then it is a homeomorphism. -/
def homeomorph_of_continuous_open (e : α ≃ β) (h₁ : continuous e) (h₂ : is_open_map e) :
  α ≃ₜ β :=
{ continuous_to_fun := h₁,
  continuous_inv_fun := begin
    rw continuous_def,
    intros s hs,
    convert ← h₂ s hs using 1,
    apply e.image_eq_preimage
  end,
  to_equiv := e }

@[simp] lemma comp_continuous_on_iff (h : α ≃ₜ β) (f : γ → α) (s : set γ) :
  continuous_on (h ∘ f) s ↔ continuous_on f s :=
h.inducing.continuous_on_iff.symm

@[simp] lemma comp_continuous_iff (h : α ≃ₜ β) {f : γ → α} :
  continuous (h ∘ f) ↔ continuous f :=
h.inducing.continuous_iff.symm

@[simp] lemma comp_continuous_iff' (h : α ≃ₜ β) {f : β → γ} :
  continuous (f ∘ h) ↔ continuous f :=
h.quotient_map.continuous_iff.symm

lemma comp_continuous_at_iff (h : α ≃ₜ β) (f : γ → α) (x : γ) :
  continuous_at (h ∘ f) x ↔ continuous_at f x :=
h.inducing.continuous_at_iff.symm

lemma comp_continuous_at_iff' (h : α ≃ₜ β) (f : β → γ) (x : α) :
  continuous_at (f ∘ h) x ↔ continuous_at f (h x) :=
h.inducing.continuous_at_iff' (by simp)

lemma comp_continuous_within_at_iff (h : α ≃ₜ β) (f : γ → α) (s : set γ) (x : γ) :
  continuous_within_at f s x ↔ continuous_within_at (h ∘ f) s x :=
h.inducing.continuous_within_at_iff

@[simp] lemma comp_is_open_map_iff (h : α ≃ₜ β) {f : γ → α} :
  is_open_map (h ∘ f) ↔ is_open_map f :=
begin
  refine ⟨_, λ hf, h.is_open_map.comp hf⟩,
  intros hf,
  rw [← function.comp.left_id f, ← h.symm_comp_self, function.comp.assoc],
  exact h.symm.is_open_map.comp hf,
end

@[simp] lemma comp_is_open_map_iff' (h : α ≃ₜ β) {f : β → γ} :
  is_open_map (f ∘ h) ↔ is_open_map f :=
begin
  refine ⟨_, λ hf, hf.comp h.is_open_map⟩,
  intros hf,
  rw [← function.comp.right_id f, ← h.self_comp_symm, ← function.comp.assoc],
  exact hf.comp h.symm.is_open_map,
end

/-- If two sets are equal, then they are homeomorphic. -/
def set_congr {s t : set α} (h : s = t) : s ≃ₜ t :=
{ continuous_to_fun := continuous_inclusion h.subset,
  continuous_inv_fun := continuous_inclusion h.symm.subset,
  to_equiv := equiv.set_congr h }

/-- Sum of two homeomorphisms. -/
def sum_congr (h₁ : α ≃ₜ β) (h₂ : γ ≃ₜ δ) : α ⊕ γ ≃ₜ β ⊕ δ :=
{ continuous_to_fun  := h₁.continuous.sum_map h₂.continuous,
  continuous_inv_fun := h₁.symm.continuous.sum_map h₂.symm.continuous,
  to_equiv := h₁.to_equiv.sum_congr h₂.to_equiv }

/-- Product of two homeomorphisms. -/
def prod_congr (h₁ : α ≃ₜ β) (h₂ : γ ≃ₜ δ) : α × γ ≃ₜ β × δ :=
{ continuous_to_fun  := (h₁.continuous.comp continuous_fst).prod_mk
    (h₂.continuous.comp continuous_snd),
  continuous_inv_fun := (h₁.symm.continuous.comp continuous_fst).prod_mk
    (h₂.symm.continuous.comp continuous_snd),
  to_equiv := h₁.to_equiv.prod_congr h₂.to_equiv }

@[simp] lemma prod_congr_symm (h₁ : α ≃ₜ β) (h₂ : γ ≃ₜ δ) :
  (h₁.prod_congr h₂).symm = h₁.symm.prod_congr h₂.symm := rfl

@[simp] lemma coe_prod_congr (h₁ : α ≃ₜ β) (h₂ : γ ≃ₜ δ) :
  ⇑(h₁.prod_congr h₂) = prod.map h₁ h₂ := rfl

section
variables (α β γ)

/-- `α × β` is homeomorphic to `β × α`. -/
def prod_comm : α × β ≃ₜ β × α :=
{ continuous_to_fun  := continuous_snd.prod_mk continuous_fst,
  continuous_inv_fun := continuous_snd.prod_mk continuous_fst,
  to_equiv := equiv.prod_comm α β }

@[simp] lemma prod_comm_symm : (prod_comm α β).symm = prod_comm β α := rfl
@[simp] lemma coe_prod_comm : ⇑(prod_comm α β) = prod.swap := rfl

/-- `(α × β) × γ` is homeomorphic to `α × (β × γ)`. -/
def prod_assoc : (α × β) × γ ≃ₜ α × (β × γ) :=
{ continuous_to_fun  := (continuous_fst.comp continuous_fst).prod_mk
    ((continuous_snd.comp continuous_fst).prod_mk continuous_snd),
  continuous_inv_fun := (continuous_fst.prod_mk (continuous_fst.comp continuous_snd)).prod_mk
    (continuous_snd.comp continuous_snd),
  to_equiv := equiv.prod_assoc α β γ }

/-- `α × {*}` is homeomorphic to `α`. -/
@[simps apply {fully_applied := ff}]
def prod_punit : α × punit ≃ₜ α :=
{ to_equiv := equiv.prod_punit α,
  continuous_to_fun := continuous_fst,
  continuous_inv_fun := continuous_id.prod_mk continuous_const }

/-- `{*} × α` is homeomorphic to `α`. -/
def punit_prod : punit × α ≃ₜ α :=
(prod_comm _ _).trans (prod_punit _)

@[simp] lemma coe_punit_prod : ⇑(punit_prod α) = prod.snd := rfl

/-- If both `α` and `β` have a unique element, then `α ≃ₜ β`. -/
@[simps] def _root_.homeomorph.homeomorph_of_unique [unique α] [unique β] : α ≃ₜ β :=
{ continuous_to_fun := @continuous_const α β _ _ default,
  continuous_inv_fun := @continuous_const β α _ _ default,
  .. equiv.equiv_of_unique α β }

end

/-- If each `β₁ i` is homeomorphic to `β₂ i`, then `Π i, β₁ i` is homeomorphic to `Π i, β₂ i`. -/
@[simps apply to_equiv] def Pi_congr_right {ι : Type*} {β₁ β₂ : ι → Type*}
  [Π i, topological_space (β₁ i)] [Π i, topological_space (β₂ i)] (F : Π i, β₁ i ≃ₜ β₂ i) :
  (Π i, β₁ i) ≃ₜ (Π i, β₂ i) :=
{ continuous_to_fun := continuous_pi (λ i, (F i).continuous.comp $ continuous_apply i),
  continuous_inv_fun := continuous_pi (λ i, (F i).symm.continuous.comp $ continuous_apply i),
  to_equiv := equiv.Pi_congr_right (λ i, (F i).to_equiv) }

@[simp] lemma Pi_congr_right_symm {ι : Type*} {β₁ β₂ : ι → Type*} [Π i, topological_space (β₁ i)]
  [Π i, topological_space (β₂ i)] (F : Π i, β₁ i ≃ₜ β₂ i) :
  (Pi_congr_right F).symm = Pi_congr_right (λ i, (F i).symm) := rfl

/-- `ulift α` is homeomorphic to `α`. -/
def {u v} ulift {α : Type u} [topological_space α] : ulift.{v u} α ≃ₜ α :=
{ continuous_to_fun := continuous_ulift_down,
  continuous_inv_fun := continuous_ulift_up,
  to_equiv := equiv.ulift }

section distrib

/-- `(α ⊕ β) × γ` is homeomorphic to `α × γ ⊕ β × γ`. -/
def sum_prod_distrib : (α ⊕ β) × γ ≃ₜ α × γ ⊕ β × γ :=
homeomorph.symm $ homeomorph_of_continuous_open (equiv.sum_prod_distrib α β γ).symm
  ((continuous_inl.prod_map continuous_id).sum_elim (continuous_inr.prod_map continuous_id)) $
  (is_open_map_inl.prod is_open_map.id).sum_elim (is_open_map_inr.prod is_open_map.id)

/-- `α × (β ⊕ γ)` is homeomorphic to `α × β ⊕ α × γ`. -/
def prod_sum_distrib : α × (β ⊕ γ) ≃ₜ α × β ⊕ α × γ :=
(prod_comm _ _).trans $
sum_prod_distrib.trans $
sum_congr (prod_comm _ _) (prod_comm _ _)

variables {ι : Type*} {σ : ι → Type*} [Π i, topological_space (σ i)]

/-- `(Σ i, σ i) × β` is homeomorphic to `Σ i, (σ i × β)`. -/
def sigma_prod_distrib : ((Σ i, σ i) × β) ≃ₜ (Σ i, (σ i × β)) :=
homeomorph.symm $ homeomorph_of_continuous_open (equiv.sigma_prod_distrib σ β).symm
  (continuous_sigma $ λ i, continuous_sigma_mk.fst'.prod_mk continuous_snd)
  (is_open_map_sigma.2 $ λ i, is_open_map_sigma_mk.prod is_open_map.id)

end distrib

/-- If `ι` has a unique element, then `ι → α` is homeomorphic to `α`. -/
@[simps { fully_applied := ff }]
def fun_unique (ι α : Type*) [unique ι] [topological_space α] : (ι → α) ≃ₜ α :=
{ to_equiv := equiv.fun_unique ι α,
  continuous_to_fun := continuous_apply _,
  continuous_inv_fun := continuous_pi (λ _, continuous_id) }

/-- Homeomorphism between dependent functions `Π i : fin 2, α i` and `α 0 × α 1`. -/
@[simps { fully_applied := ff }]
def {u} pi_fin_two (α : fin 2 → Type u) [Π i, topological_space (α i)] : (Π i, α i) ≃ₜ α 0 × α 1 :=
{ to_equiv := pi_fin_two_equiv α,
  continuous_to_fun := (continuous_apply 0).prod_mk (continuous_apply 1),
  continuous_inv_fun := continuous_pi $ fin.forall_fin_two.2 ⟨continuous_fst, continuous_snd⟩ }

/-- Homeomorphism between `α² = fin 2 → α` and `α × α`. -/
@[simps { fully_applied := ff }] def fin_two_arrow : (fin 2 → α) ≃ₜ α × α :=
{ to_equiv := fin_two_arrow_equiv α, ..  pi_fin_two (λ _, α) }

/--
A subset of a topological space is homeomorphic to its image under a homeomorphism.
-/
@[simps] def image (e : α ≃ₜ β) (s : set α) : s ≃ₜ e '' s :=
{ continuous_to_fun := by continuity!,
  continuous_inv_fun := by continuity!,
  to_equiv := e.to_equiv.image s, }

/-- `set.univ α` is homeomorphic to `α`. -/
@[simps { fully_applied := ff }]
def set.univ (α : Type*) [topological_space α] : (univ : set α) ≃ₜ α :=
{ to_equiv := equiv.set.univ α,
  continuous_to_fun := continuous_subtype_coe,
  continuous_inv_fun := continuous_id.subtype_mk _ }

/-- `s ×ˢ t` is homeomorphic to `s × t`. -/
@[simps] def set.prod (s : set α) (t : set β) : ↥(s ×ˢ t) ≃ₜ s × t :=
{ to_equiv := equiv.set.prod s t,
  continuous_to_fun := (continuous_subtype_coe.fst.subtype_mk _).prod_mk
    (continuous_subtype_coe.snd.subtype_mk _),
  continuous_inv_fun := (continuous_subtype_coe.fst'.prod_mk
    continuous_subtype_coe.snd').subtype_mk _ }

section

variable {ι : Type*}

/-- The topological space `Π i, β i` can be split as a product by separating the indices in ι
  depending on whether they satisfy a predicate p or not.-/
@[simps] def pi_equiv_pi_subtype_prod (p : ι → Prop) (β : ι → Type*) [Π i, topological_space (β i)]
  [decidable_pred p] : (Π i, β i) ≃ₜ (Π i : {x // p x}, β i) × Π i : {x // ¬p x}, β i :=
{ to_equiv := equiv.pi_equiv_pi_subtype_prod p β,
  continuous_to_fun := by apply continuous.prod_mk; exact continuous_pi (λ j, continuous_apply j),
  continuous_inv_fun := continuous_pi $ λ j, begin
    dsimp only [equiv.pi_equiv_pi_subtype_prod], split_ifs,
    exacts [(continuous_apply _).comp continuous_fst, (continuous_apply _).comp continuous_snd],
  end }

variables [decidable_eq ι] (i : ι)

/-- A product of topological spaces can be split as the binary product of one of the spaces and
  the product of all the remaining spaces. -/
@[simps] def pi_split_at (β : ι → Type*) [Π j, topological_space (β j)] :
  (Π j, β j) ≃ₜ β i × Π j : {j // j ≠ i}, β j :=
{ to_equiv := equiv.pi_split_at i β,
  continuous_to_fun := (continuous_apply i).prod_mk (continuous_pi $ λ j, continuous_apply j),
  continuous_inv_fun := continuous_pi $ λ j, by { dsimp only [equiv.pi_split_at],
    split_ifs, subst h, exacts [continuous_fst, (continuous_apply _).comp continuous_snd] } }

/-- A product of copies of a topological space can be split as the binary product of one copy and
  the product of all the remaining copies. -/
@[simps] def fun_split_at : (ι → β) ≃ₜ β × ({j // j ≠ i} → β) := pi_split_at i _

end

end homeomorph

/-- An inducing equiv between topological spaces is a homeomorphism. -/
@[simps] def equiv.to_homeomorph_of_inducing [topological_space α] [topological_space β] (f : α ≃ β)
  (hf : inducing f) :
  α ≃ₜ β :=
{ continuous_to_fun := hf.continuous,
  continuous_inv_fun := hf.continuous_iff.2 $ by simpa using continuous_id,
  .. f }

namespace continuous
variables [topological_space α] [topological_space β]

lemma continuous_symm_of_equiv_compact_to_t2 [compact_space α] [t2_space β]
  {f : α ≃ β} (hf : continuous f) : continuous f.symm :=
begin
  rw continuous_iff_is_closed,
  intros C hC,
  have hC' : is_closed (f '' C) := (hC.is_compact.image hf).is_closed,
  rwa equiv.image_eq_preimage at hC',
end

/-- Continuous equivalences from a compact space to a T2 space are homeomorphisms.

This is not true when T2 is weakened to T1
(see `continuous.homeo_of_equiv_compact_to_t2.t1_counterexample`). -/
@[simps]
def homeo_of_equiv_compact_to_t2 [compact_space α] [t2_space β]
  {f : α ≃ β} (hf : continuous f) : α ≃ₜ β :=
{ continuous_to_fun := hf,
  continuous_inv_fun := hf.continuous_symm_of_equiv_compact_to_t2,
  ..f }

end continuous


/-
Copyright (c) 2022 Yuma Mizuno. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yuma Mizuno, Junyan Xu
-/
import category_theory.path_category
import category_theory.functor.fully_faithful
import category_theory.bicategory.free
import category_theory.bicategory.locally_discrete
/-!
# The coherence theorem for bicategories

In this file, we prove the coherence theorem for bicategories, stated in the following form: the
free bicategory over any quiver is locally thin.

The proof is almost the same as the proof of the coherence theorem for monoidal categories that
has been previously formalized in mathlib, which is based on the proof described by Ilya Beylin
and Peter Dybjer. The idea is to view a path on a quiver as a normal form of a 1-morphism in the
free bicategory on the same quiver. A normalization procedure is then described by
`normalize : pseudofunctor (free_bicategory B) (locally_discrete (paths B))`, which is a
pseudofunctor from the free bicategory to the locally discrete bicategory on the path category.
It turns out that this pseudofunctor is locally an equivalence of categories, and the coherence
theorem follows immediately from this fact.

## Main statements

* `locally_thin` : the free bicategory is locally thin, that is, there is at most one
  2-morphism between two fixed 1-morphisms.

## References

* [Ilya Beylin and Peter Dybjer, Extracting a proof of coherence for monoidal categories from a
   proof of normalization for monoids][beylin1996]
-/

open quiver (path) quiver.path

namespace category_theory

open bicategory category
open_locale bicategory

universes v u

namespace free_bicategory

variables {B : Type u} [quiver.{v+1} B]

/-- Auxiliary definition for `inclusion_path`. -/
@[simp]
def inclusion_path_aux {a : B} : ∀ {b : B}, path a b → hom a b
| _ nil         := hom.id a
| _ (cons p f)  := (inclusion_path_aux p).comp (hom.of f)

/--
The discrete category on the paths includes into the category of 1-morphisms in the free
bicategory.
-/
def inclusion_path (a b : B) : discrete (path.{v+1} a b) ⥤ hom a b :=
discrete.functor inclusion_path_aux

/--
The inclusion from the locally discrete bicategory on the path category into the free bicategory
as a prelax functor. This will be promoted to a pseudofunctor after proving the coherence theorem.
See `inclusion`.
-/
def preinclusion (B : Type u) [quiver.{v+1} B] :
  prelax_functor (locally_discrete (paths B)) (free_bicategory B) :=
{ obj   := id,
  map   := λ a b, (inclusion_path a b).obj,
  map₂  := λ a b f g η, (inclusion_path a b).map η }

@[simp]
lemma preinclusion_obj (a : B) :
  (preinclusion B).obj a = a :=
rfl

@[simp]
lemma preinclusion_map₂ {a b : B} (f g : discrete (path.{v+1} a b)) (η : f ⟶ g) :
  (preinclusion B).map₂ η = eq_to_hom (congr_arg _ (discrete.ext _ _ (discrete.eq_of_hom η))) :=
begin
  rcases η with ⟨⟨⟩⟩,
  cases discrete.ext _ _ η,
  exact (inclusion_path a b).map_id _
end

/--
The normalization of the composition of `p : path a b` and `f : hom b c`.
`p` will eventually be taken to be `nil` and we then get the normalization
of `f` alone, but the auxiliary `p` is necessary for Lean to accept the definition of
`normalize_iso` and the `whisker_left` case of `normalize_aux_congr` and `normalize_naturality`.
-/
@[simp]
def normalize_aux {a : B} : ∀ {b c : B}, path a b → hom b c → path a c
| _ _ p (hom.of f)      := p.cons f
| _ _ p (hom.id b)      := p
| _ _ p (hom.comp f g)  := normalize_aux (normalize_aux p f) g

/-
We may define
```
def normalize_aux' : ∀ {a b : B}, hom a b → path a b
| _ _ (hom.of f) := f.to_path
| _ _ (hom.id b) := nil
| _ _ (hom.comp f g) := (normalize_aux' f).comp (normalize_aux' g)
```
and define `normalize_aux p f` to be `p.comp (normalize_aux' f)` and this will be
equal to the above definition, but the equality proof requires `comp_assoc`, and it
thus lacks the correct definitional property to make the definition of `normalize_iso`
typecheck.
```
example {a b c : B} (p : path a b) (f : hom b c) :
  normalize_aux p f = p.comp (normalize_aux' f) :=
by { induction f, refl, refl,
  case comp : _ _ _ _ _ ihf ihg { rw [normalize_aux, ihf, ihg], apply comp_assoc } }
```
-/

/--
A 2-isomorphism between a partially-normalized 1-morphism in the free bicategory to the
fully-normalized 1-morphism.
-/
@[simp]
def normalize_iso {a : B} : ∀ {b c : B} (p : path a b) (f : hom b c),
  (preinclusion B).map ⟨p⟩ ≫ f ≅ (preinclusion B).map ⟨normalize_aux p f⟩
| _ _ p (hom.of f)      := iso.refl _
| _ _ p (hom.id b)      := ρ_ _
| _ _ p (hom.comp f g)  := (α_ _ _ _).symm ≪≫
    whisker_right_iso (normalize_iso p f) g ≪≫ normalize_iso (normalize_aux p f) g

/--
Given a 2-morphism between `f` and `g` in the free bicategory, we have the equality
`normalize_aux p f = normalize_aux p g`.
-/
lemma normalize_aux_congr {a b c : B} (p : path a b) {f g : hom b c} (η : f ⟶ g) :
  normalize_aux p f = normalize_aux p g :=
begin
  rcases η,
  apply @congr_fun _ _ (λ p, normalize_aux p f),
  clear p,
  induction η,
  case vcomp { apply eq.trans; assumption },
  /- p ≠ nil required! See the docstring of `normalize_aux`. -/
  case whisker_left  : _ _ _ _ _ _ _ ih { funext, apply congr_fun ih },
  case whisker_right : _ _ _ _ _ _ _ ih { funext, apply congr_arg2 _ (congr_fun ih p) rfl },
  all_goals { funext, refl }
end

/-- The 2-isomorphism `normalize_iso p f` is natural in `f`. -/
lemma normalize_naturality {a b c : B} (p : path a b) {f g : hom b c} (η : f ⟶ g) :
  (preinclusion B).map ⟨p⟩ ◁ η ≫ (normalize_iso p g).hom =
    (normalize_iso p f).hom ≫
      (preinclusion B).map₂ (eq_to_hom (discrete.ext _ _ (normalize_aux_congr p η))) :=
begin
  rcases η, induction η,
  case id : { simp },
  case vcomp : _ _ _ _ _ _ _ ihf ihg
  { rw [mk_vcomp, bicategory.whisker_left_comp],
    slice_lhs 2 3 { rw ihg },
    slice_lhs 1 2 { rw ihf },
    simp },
  case whisker_left : _ _ _ _ _ _ _ ih
  /- p ≠ nil required! See the docstring of `normalize_aux`. -/
  { dsimp, simp_rw [associator_inv_naturality_right_assoc, whisker_exchange_assoc, ih, assoc] },
  case whisker_right : _ _ _ _ _ h η ih
  { dsimp,
    rw [associator_inv_naturality_middle_assoc, ←comp_whisker_right_assoc, ih, comp_whisker_right],
    have := dcongr_arg (λ x, (normalize_iso x h).hom) (normalize_aux_congr p (quot.mk _ η)),
    dsimp at this, simp [this] },
  all_goals { dsimp, dsimp [id_def, comp_def], simp }
end

@[simp]
lemma normalize_aux_nil_comp {a b c : B} (f : hom a b) (g : hom b c) :
  normalize_aux nil (f.comp g) = (normalize_aux nil f).comp (normalize_aux nil g) :=
begin
  induction g generalizing a,
  case id { refl },
  case of { refl },
  case comp : _ _ _ g _ ihf ihg { erw [ihg (f.comp g), ihf f, ihg g, comp_assoc] }
end

/-- The normalization pseudofunctor for the free bicategory on a quiver `B`. -/
def normalize (B : Type u) [quiver.{v+1} B] :
  pseudofunctor (free_bicategory B) (locally_discrete (paths B)) :=
{ obj       := id,
  map       := λ a b f, ⟨normalize_aux nil f⟩,
  map₂      := λ a b f g η, eq_to_hom $ discrete.ext _ _ $ normalize_aux_congr nil η,
  map_id    := λ a, eq_to_iso $ discrete.ext _ _ rfl,
  map_comp  := λ a b c f g, eq_to_iso $ discrete.ext _ _ $ normalize_aux_nil_comp f g }

/-- Auxiliary definition for `normalize_equiv`. -/
def normalize_unit_iso (a b : free_bicategory B) :
  𝟭 (a ⟶ b) ≅ (normalize B).map_functor a b ⋙ inclusion_path a b :=
nat_iso.of_components (λ f, (λ_ f).symm ≪≫ normalize_iso nil f)
begin
  intros f g η,
  erw [left_unitor_inv_naturality_assoc, assoc],
  congr' 1,
  exact normalize_naturality nil η
end

/-- Normalization as an equivalence of categories. -/
def normalize_equiv (a b : B) : hom a b ≌ discrete (path.{v+1} a b) :=
equivalence.mk ((normalize _).map_functor a b) (inclusion_path a b)
  (normalize_unit_iso a b)
  (discrete.nat_iso (λ f, eq_to_iso (by { induction f; induction f; tidy })))

/-- The coherence theorem for bicategories. -/
instance locally_thin {a b : free_bicategory B} : quiver.is_thin (a ⟶ b) :=
λ _ _, ⟨λ η θ, (normalize_equiv a b).functor.map_injective (subsingleton.elim _ _)⟩

/-- Auxiliary definition for `inclusion`. -/
def inclusion_map_comp_aux {a b : B} : ∀ {c : B} (f : path a b) (g : path b c),
  (preinclusion _).map (⟨f⟩ ≫ ⟨g⟩) ≅ (preinclusion _).map ⟨f⟩ ≫ (preinclusion _).map ⟨g⟩
| _ f nil := (ρ_ ((preinclusion _).map ⟨f⟩)).symm
| _ f (cons g₁ g₂) := whisker_right_iso (inclusion_map_comp_aux f g₁) (hom.of g₂) ≪≫ α_ _ _ _

/--
The inclusion pseudofunctor from the locally discrete bicategory on the path category into the
free bicategory.
-/
def inclusion (B : Type u) [quiver.{v+1} B] :
  pseudofunctor (locally_discrete (paths B)) (free_bicategory B) :=
{ map_id    := λ a, iso.refl (𝟙 a),
  map_comp  := λ a b c f g, inclusion_map_comp_aux f.as g.as,
  -- All the conditions for 2-morphisms are trivial thanks to the coherence theorem!
  .. preinclusion B }

end free_bicategory

end category_theory