/-
Copyright (c) 2016 Floris van Doorn. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.

Authors: Floris van Doorn

Graphs and operations on graphs

Currently we only define the notion of a path in a graph, and prove properties and operations on
paths.
-/
import ..arity ..eq2 .relation ..cubical.pathover2
universes u v w

namespace hott
hott_theory

/-
  A path is a list of vertexes which are adjacent. We maybe use a weird ordering of cons, because
  the major example where we use this is a category where this ordering makes more sense.
  For the operations on paths we use the names from the corresponding operations on lists. Opening
  both the list and the paths namespace will lead to many name clashes, so that is not advised.
-/

inductive paths {A : Type u} (R : A → A → Type v) : A → A → Type (max u v)
| nil {} : Π{a : A}, paths a a
| cons   : Π{a₁ a₂ a₃ : A} (r : R a₂ a₃), paths a₁ a₂ → paths a₁ a₃

namespace graph
  export paths

  local notation h :: t  := cons h t
  local notation `[` l:(foldr `, ` (h t, cons h t) nil `]`) := l

  variables {A : Type _} {R : A → A → Type _} {a a' a₁ a₂ a₃ a₄ : A}

  @[hott] def concat (r : R a₁ a₂) (l : paths R a₂ a₃) : paths R a₁ a₃ :=
  begin
    hinduction l with a a₂ a₃ a₄ r' l IH,
    { exact [r]},
    { exact r' :: IH r}
  end

  @[hott] theorem concat_nil (r : R a₁ a₂) : concat r (@nil A R a₂) = [r] := idp

  @[hott] theorem concat_cons (r : R a₁ a₂) (r' : R a₃ a₄) (l : paths R a₂ a₃)
    : concat r (r'::l)  = r'::(concat r l) := idp

  @[hott] def append (l₂ : paths R a₂ a₃) (l₁ : paths R a₁ a₂) :
    paths R a₁ a₃ :=
  begin
    hinduction l₂ with a₂ a₂ a₃ a₄ r l₂ IH,
    { exact l₁ },
    { exact cons r (IH l₁) }
  end

  local infix ` ++ ` := append

  @[hott] def nil_append (l : paths R a₁ a₂) : nil ++ l = l := idp
  @[hott] def cons_append (r : R a₃ a₄) (l₂ : paths R a₂ a₃) (l₁ : paths R a₁ a₂) :
    (r :: l₂) ++ l₁ = r :: (l₂ ++ l₁) := idp

  @[hott] def singleton_append (r : R a₂ a₃) (l : paths R a₁ a₂) : [r] ++ l = r :: l := idp
  @[hott] def append_singleton (l : paths R a₂ a₃) (r : R a₁ a₂) : l ++ [r] = concat r l :=
  begin
    hinduction l with a₁ a₁ a₂ a₃ r l IH,
    { refl },
    { exact ap (cons r) (IH _) }
  end

  @[hott] def append_nil (l : paths R a₁ a₂) : l ++ nil = l :=
  begin
    hinduction l with a₁ a₁ a₂ a₃ r l IH,
    { refl },
    { exact ap (cons r) IH }
  end

  @[hott] def append_assoc (l₃ : paths R a₃ a₄) (l₂ : paths R a₂ a₃)
    (l₁ : paths R a₁ a₂) : (l₃ ++ l₂) ++ l₁ = l₃ ++ (l₂ ++ l₁) :=
  begin
    hinduction l₃ with a₃ a₃ a₄ a₅ r l₃ IH,
    { refl },
    { refine ap (cons r) (IH _) }
  end

  @[hott] theorem append_concat (l₂ : paths R a₃ a₄) (l₁ : paths R a₂ a₃) (r : R a₁ a₂) :
    l₂ ++ concat r l₁ = concat r (l₂ ++ l₁) :=
  begin
    hinduction l₂ with a₂ a₂ a₃ a₄ r' l₂ IH,
    { refl },
    { exact ap (cons r') (IH _) }
  end

  @[hott] def concat_append (l₂ : paths R a₃ a₄) (r : R a₂ a₃) (l₁ : paths R a₁ a₂) :
    concat r l₂ ++ l₁ = l₂ ++ r :: l₁ :=
  begin
    hinduction l₂ with a₂ a₂ a₃ a₄ r' l₂ IH,
    { refl },
    { exact ap (cons r') (IH _) }
  end

  @[hott] def paths.rec_tail {C : Π⦃a a' : A⦄, paths R a a' → Type _}
  (H0 : Π {a : A}, @C a a nil)
  (H1 : Π {a₁ a₂ a₃ : A} (r : R a₁ a₂) (l : paths R a₂ a₃), C l → C (concat r l)) :
  Π{a a' : A} (l : paths R a a'), C l :=
  begin
    have : Π{a₁ a₂ a₃ : A} (l₂ : paths R a₂ a₃) (l₁ : paths R a₁ a₂) (c : C l₂),
      C (l₂ ++ l₁),
    begin
      intros, revert a₃ l₂ c, hinduction l₁ with a₁ a₁ a₂ a₄ r l₁ IH; intros a₃ l₂ c,
      { rwr append_nil, exact c },
      { rwr [←concat_append], apply IH, apply H1, exact c }
    end,
    intros, rwr [←nil_append l], apply this, apply H0
  end

  @[hott] def cons_eq_concat (r : R a₂ a₃) (l : paths R a₁ a₂) :
    Σa (r' : R a₁ a) (l' : paths R a a₃), r :: l = concat r' l' :=
  begin
    revert a₃ r, hinduction l with a₁ a₁ a₂ a₃ r l IH; intros a₃' r',
    { exact ⟨a₃', r', nil, idp⟩ },
    { cases (IH r) with a₄ w, cases w with r₂ w, cases w with l p, clear IH,
      exact ⟨a₄, r₂, r' :: l, ap (cons r') p⟩ }
  end

  @[hott] def length (l : paths R a₁ a₂) : ℕ :=
  begin
    hinduction l with a₁ a₁ a₂ a₃ r l IH,
    { exact 0 },
    { exact IH.succ }
  end

  /- If we can reverse edges in the graph we can reverse paths -/

  @[hott] def reverse (rev : Π⦃a a'⦄, R a a' → R a' a) (l : paths R a₁ a₂) :
    paths R a₂ a₁ :=
  begin
    hinduction l with a₁ a₁ a₂ a₃ r l IH,
    { exact nil},
    { exact concat (rev r) IH}
  end

  @[hott] theorem reverse_nil (rev : Π⦃a a'⦄, R a a' → R a' a) : reverse rev (@nil A R a₁) = [] := idp

  @[hott] theorem reverse_cons (rev : Π⦃a a'⦄, R a a' → R a' a) (r : R a₂ a₃) (l : paths R a₁ a₂) :
    reverse rev (r::l) = concat (rev r) (reverse rev l) := idp

  @[hott] theorem reverse_singleton (rev : Π⦃a a'⦄, R a a' → R a' a) (r : R a₁ a₂) :
    reverse rev [r] = [rev r] := idp

  @[hott] theorem reverse_pair (rev : Π⦃a a'⦄, R a a' → R a' a) (r₂ : R a₂ a₃) (r₁ : R a₁ a₂) :
    reverse rev [r₂, r₁] = [rev r₁, rev r₂] := idp

  @[hott] theorem reverse_concat (rev : Π⦃a a'⦄, R a a' → R a' a) (r : R a₁ a₂) (l : paths R a₂ a₃) :
    reverse rev (concat r l) = rev r :: (reverse rev l) :=
  begin
    hinduction l with a₁ a₁ a₂ a₃ r l IH,
    { refl },
    { rwr [concat_cons, reverse_cons, IH]}
  end

  @[hott] theorem reverse_append (rev : Π⦃a a'⦄, R a a' → R a' a) (l₂ : paths R a₂ a₃)
    (l₁ : paths R a₁ a₂) : reverse rev (l₂ ++ l₁) = reverse rev l₁ ++ reverse rev l₂ :=
  begin
    hinduction l₂ with a₂ a₂ a₃ a₄ r l₂ IH,
    { exact (append_nil _)⁻¹ },
    { rwr [cons_append, reverse_cons, reverse_cons, append_concat, IH] }
  end

  @[hott] def realize (P : A → A → Type _) (f : Π⦃a a'⦄, R a a' → P a a') (ρ : Πa, P a a)
    (c : Π⦃a₁ a₂ a₃⦄, P a₁ a₂ → P a₂ a₃ → P a₁ a₃)
    ⦃a a' : A⦄ (l : paths R a a') : P a a' :=
  begin
    hinduction l with a a₁ a₂ a₃ r l IH,
    { exact ρ a },
    { exact c IH (f r) }
  end

  @[hott, hsimp] def realize_nil (P : A → A → Type _) (f : Π⦃a a'⦄, R a a' → P a a')
    (ρ : Πa, P a a) (c : Π⦃a₁ a₂ a₃⦄, P a₁ a₂ → P a₂ a₃ → P a₁ a₃) (a : A) :
    realize P f ρ c nil = ρ a :=
  by refl

  @[hott, hsimp] def realize_cons (P : A → A → Type _) (f : Π⦃a a'⦄, R a a' → P a a') (ρ : Πa, P a a)
    (c : Π⦃a₁ a₂ a₃⦄, P a₁ a₂ → P a₂ a₃ → P a₁ a₃)
    ⦃a₁ a₂ a₃ : A⦄ (r : R a₂ a₃) (l : paths R a₁ a₂) :
    realize P f ρ c (r :: l) = c (realize P f ρ c l) (f r) :=
  by refl

  @[hott] theorem realize_singleton {P : A → A → Type _} {f : Π⦃a a'⦄, R a a' → P a a'} {ρ : Πa, P a a}
    {c : Π⦃a₁ a₂ a₃⦄, P a₁ a₂ → P a₂ a₃ → P a₁ a₃}
    (id_left : Π⦃a₁ a₂⦄ (p : P a₁ a₂), c (ρ a₁) p = p)
    ⦃a₁ a₂ : A⦄ (r : R a₁ a₂) :
    realize P f ρ c [r] = f r :=
  id_left (f r)

  @[hott] theorem realize_pair {P : A → A → Type _} {f : Π⦃a a'⦄, R a a' → P a a'} {ρ : Πa, P a a}
    {c : Π⦃a₁ a₂ a₃⦄, P a₁ a₂ → P a₂ a₃ → P a₁ a₃}
    (id_left : Π⦃a₁ a₂⦄ (p : P a₁ a₂), c (ρ a₁) p = p)
    ⦃a₁ a₂ a₃ : A⦄ (r₂ : R a₂ a₃) (r₁ : R a₁ a₂) :
    realize P f ρ c [r₂, r₁] = c (f r₁) (f r₂) :=
  ap (λx, c x (f r₂)) (realize_singleton id_left r₁)

  @[hott] def realize_append {P : A → A → Type _} {f : Π⦃a a'⦄, R a a' → P a a'} {ρ : Πa, P a a}
    {c : Π⦃a₁ a₂ a₃⦄, P a₁ a₂ → P a₂ a₃ → P a₁ a₃}
    (assoc : Π⦃a₁ a₂ a₃ a₄⦄ (p : P a₁ a₂) (q : P a₂ a₃) (r : P a₃ a₄), c (c p q) r = c p (c q r))
    (id_right : Π⦃a₁ a₂⦄ (p : P a₁ a₂), c p (ρ a₂) = p)
    ⦃a₁ a₂ a₃ : A⦄ (l₂ : paths R a₂ a₃) (l₁ : paths R a₁ a₂) :
    realize P f ρ c (l₂ ++ l₁) = c (realize P f ρ c l₁) (realize P f ρ c l₂) :=
  begin
    hinduction l₂ with a₂ a₂ a₃ a₄ r l₂ IH,
    { exact (id_right _)⁻¹ },
    { rwr [cons_append, realize_cons, realize_cons, IH, assoc] }
  end

  /-
    We sometimes want to take quotients of paths (this library was developed to define the pushout of
    categories). The definition paths_rel will - given some basic reduction rules codified by Q -
    extend the reduction to a reflexive transitive relation respecting concatenation of paths.
  -/

  inductive paths_rel {A : Type u} {R : A → A → Type v}
    (Q : Π⦃a a' : A⦄, paths R a a' → paths R a a' → Type w)
    : Π⦃a a' : A⦄, paths R a a' → paths R a a' → Type (max u v w)
  | rrefl  : Π{a a' : A} (l : paths R a a'), paths_rel l l
  | rel    : Π{a₁ a₂ a₃ : A} {l₂ l₃ : paths R a₂ a₃} (l : paths R a₁ a₂) (q : Q l₂ l₃),
      paths_rel (l₂ ++ l) (l₃ ++ l)
  | rcons  : Π{a₁ a₂ a₃ : A} {l₁ l₂ : paths R a₁ a₂} (r : R a₂ a₃),
      paths_rel l₁ l₂ → paths_rel (cons r l₁) (cons r l₂)
  | rtrans : Π{a₁ a₂ : A} {l₁ l₂ l₃ : paths R a₁ a₂},
      paths_rel l₁ l₂ → paths_rel l₂ l₃ → paths_rel l₁ l₃

  open paths_rel
  attribute [refl] rrefl
  attribute [trans] rtrans
  variables {Q : Π⦃a a' : A⦄, paths R a a' → paths R a a' → Type _}

  @[hott] def paths_rel_of_Q {l₁ l₂ : paths R a₁ a₂} (q : Q l₁ l₂) :
    paths_rel Q l₁ l₂ :=
  begin
    rwr [←append_nil l₁, ←append_nil l₂], exact rel nil q,
  end

  @[hott] theorem rel_respect_append_left (l : paths R a₂ a₃) {l₃ l₄ : paths R a₁ a₂}
    (H : paths_rel Q l₃ l₄) : paths_rel Q (l ++ l₃) (l ++ l₄) :=
  begin
    hinduction l with a₁ a₁ a₂ a₃ r l IH,
    { exact H },
    { exact rcons r (IH H) }
  end

  @[hott] theorem rel_respect_append_right {l₁ l₂ : paths R a₂ a₃} (l : paths R a₁ a₂)
    (H₁ : paths_rel Q l₁ l₂) : paths_rel Q (l₁ ++ l) (l₂ ++ l) :=
  begin
    hinduction H₁ with a₁ a₂ l₁
                      a₂ a₃ a₄ l₂ l₂' l₁ q
                      a₂ a₃ a₄ l₁ l₂ r H₁ IH
                      a₂ a₃ l₁ l₂ l₂' H₁ H₁' IH IH',
    { refl },
    { rwr [append_assoc, append_assoc], exact rel _ q},
    { exact rcons r (IH l) },
    { exact rtrans (IH l) (IH' l)}
  end

  @[hott] theorem rel_respect_append {l₁ l₂ : paths R a₂ a₃} {l₃ l₄ : paths R a₁ a₂}
    (H₁ : paths_rel Q l₁ l₂) (H₂ : paths_rel Q l₃ l₄) :
    paths_rel Q (l₁ ++ l₃) (l₂ ++ l₄) :=
  begin
    hinduction H₁ with a₁ a₂ l
                       a₂ a₃ a₄ l₂ l₂' l q
                       a₂ a₃ a₄ l₁ l₂ r H₁ IH
                       a₂ a₃ l₁ l₂ l₂' H₁ H₁' IH IH',
    { exact rel_respect_append_left _ H₂},
    { rwr [append_assoc, append_assoc], transitivity _, exact rel _ q,
      apply rel_respect_append_left, apply rel_respect_append_left, exact H₂},
    { exact rcons r (IH H₂) },
    { refine rtrans (IH H₂) _, apply rel_respect_append_right, exact H₁'}
  end

  /- assuming some extra properties the relation respects reversing -/

  @[hott] theorem rel_respect_reverse (rev : Π⦃a a'⦄, R a a' → R a' a) {l₁ l₂ : paths R a₁ a₂}
    (H : paths_rel Q l₁ l₂)
    (rev_rel : Π⦃a a' : A⦄ {l l' : paths R a a'},
      Q l l' → paths_rel Q (reverse rev l) (reverse rev l')) :
    paths_rel Q (reverse rev l₁) (reverse rev l₂) :=
  begin
    hinduction H with a₁ a₂ l
                      a₂ a₃ a₄ l₂ l₂' l q
                      a₂ a₃ a₄ l₁ l₂ r H₁ IH
                      a₂ a₃ l₁ l₂ l₂' H₁ H₁' IH IH',
    { refl },
    { rwr [reverse_append, reverse_append], apply rel_respect_append_left, apply rev_rel q },
    { rwr [reverse_cons, reverse_cons,←append_singleton, ←append_singleton],
      apply rel_respect_append_right, exact IH },
    { exact rtrans IH IH' }
  end

  @[hott] theorem rel_left_inv (rev : Π⦃a a'⦄, R a a' → R a' a) (l : paths R a₁ a₂)
    (li : Π⦃a a' : A⦄ (r : R a a'), paths_rel Q [rev r, r] nil) :
    paths_rel Q (reverse rev l ++ l) nil :=
  begin
    hinduction l with a₁ a₁ a₂ a₃ r l IH,
    { refl },
    { rwr [reverse_cons, concat_append],
      refine rtrans _ IH, apply rel_respect_append_left,
      exact rel_respect_append_right _ (li r)}
  end

  @[hott] theorem rel_right_inv (rev : Π⦃a a'⦄, R a a' → R a' a) (l : paths R a₁ a₂)
    (ri : Π⦃a a' : A⦄ (r : R a a'), paths_rel Q [r, rev r] nil) :
    paths_rel Q (l ++ reverse rev l) nil :=
  begin
    hinduction l using paths.rec_tail,
    { refl },
    { rwr [reverse_concat, concat_append],
      refine rtrans _ a, apply rel_respect_append_left,
      exact rel_respect_append_right _ (ri r)}
  end

  @[hott] def realize_eq {P : A → A → Type _} {f : Π⦃a a'⦄, R a a' → P a a'} {ρ : Πa, P a a}
    {c : Π⦃a₁ a₂ a₃⦄, P a₁ a₂ → P a₂ a₃ → P a₁ a₃}
    (assoc : Π⦃a₁ a₂ a₃ a₄⦄ (p : P a₁ a₂) (q : P a₂ a₃) (r : P a₃ a₄), c (c p q) r = c p (c q r))
    (id_right : Π⦃a₁ a₂⦄ (p : P a₁ a₂), c p (ρ a₂) = p)
    (resp_rel : Π⦃a₁ a₂⦄ {l₁ l₂ : paths R a₁ a₂}, Q l₁ l₂ →
      realize P f ρ c l₁ = realize P f ρ c l₂)
    ⦃a a' : A⦄ {l l' : paths R a a'} (H : paths_rel Q l l') :
    realize P f ρ c l = realize P f ρ c l' :=
  begin
    hinduction H with a₁ a₂ l
                      a₂ a₃ a₄ l₂ l₂' l q
                      a₂ a₃ a₄ l₁ l₂ r H₁ IH
                      a₂ a₃ l₁ l₂ l₂' H₁ H₁' IH IH',
    { refl },
    { rwr [realize_append assoc id_right, realize_append assoc id_right],
      apply ap (c _), exact resp_rel q },
    { exact ap (λx, c x (f r)) IH },
    { exact IH ⬝ IH' }
  end

end graph

/- the following are words of paths in a graph, which means that for example
   (p ++ q) ++ r and p ++ (q ++ r) are different words. Furthermore, the paths can be reversed.
   This is used to represent 2-constructors in hit.two_quotient  -/
inductive pwords {A : Type u} (R : A → A → Type v) : A → A → Type (max u v)
| of_rel : Π{a a'} (r : R a a'), pwords a a'
| of_path : Π{a a'} (pp : a = a'), pwords a a'
| symm : Π{a a'} (r : pwords a a'), pwords a' a
| trans : Π{a a' a''} (r : pwords a a') (r' : pwords a' a''), pwords a a''

namespace graph
  export pwords
  infix ` ⬝r `:75 := pwords.trans
  postfix `⁻¹ʳ`:(max+10) := pwords.symm
  notation `[`:max a `]`:0 := pwords.of_rel a
  notation `<`:max p `>`:0 := pwords.of_path _ p
  abbreviation rfl {A : Type _} {R : A → A → Type _} {a : A} := of_path R (idpath a)
end graph

namespace graph

section
parameters {A : Type _}
            {R : A → A → Type _}
private abbreviation T := pwords R

variables ⦃a a' a'' : A⦄ {s : R a a'} {r : T a a} {B : Type _} {C : Type _}

@[hott] protected def pwords.elim {f : A → B}
  (e : Π⦃a a' : A⦄, R a a' → f a = f a') (t : T a a') : f a = f a' :=
begin
  induction t with a a' r a a' pp a a' r IH a a' a'' r r' IH₁ IH₂,
    exact e r,
    exact ap f pp,
    exact IH⁻¹,
    exact IH₁ ⬝ IH₂
end

@[hott, hsimp] protected def pwords.elim_symm {f : A → B}
  (e : Π⦃a a' : A⦄, R a a' → f a = f a') (t : T a a') :
    pwords.elim e t⁻¹ʳ = (pwords.elim e t)⁻¹ :=
by refl

@[hott, hsimp] protected def pwords.elim_trans {f : A → B}
  (e : Π⦃a a' : A⦄, R a a' → f a = f a') (t : T a a') (t' : T a' a'') :
    pwords.elim e (t ⬝r t') = pwords.elim e t ⬝ pwords.elim e t' :=
by refl

@[hott] def ap_pwords_elim_h {B C : Type _} {f : A → B} {g : B → C}
  (e : Π⦃a a' : A⦄, R a a' → f a = f a')
  {e' : Π⦃a a' : A⦄, R a a' → g (f a) = g (f a')}
  (p : Π⦃a a' : A⦄ (s : R a a'), ap g (e s) = e' s) (t : T a a')
  : ap g (pwords.elim e t) = pwords.elim e' t :=
begin
  induction t with a a' r a a' pp a a' r IH a a' a'' r r' IH₁ IH₂,
    apply p,
    induction pp, refl,
    exact ap_inv g (pwords.elim e r) ⬝ inverse2 IH,
    exact ap_con g (pwords.elim e r) (pwords.elim e r') ⬝ (IH₁ ◾ IH₂)
end

@[hott, hsimp] def ap_pwords_elim_h_symm {B C : Type _} {f : A → B} {g : B → C}
  (e : Π⦃a a' : A⦄, R a a' → f a = f a')
  {e' : Π⦃a a' : A⦄, R a a' → g (f a) = g (f a')}
  (p : Π⦃a a' : A⦄ (s : R a a'), ap g (e s) = e' s) (t : T a a') :
  ap_pwords_elim_h e p t⁻¹ʳ = ap_inv g (pwords.elim e t) ⬝ (ap_pwords_elim_h e p t)⁻² :=
by refl

@[hott, hsimp] def ap_pwords_elim_h_trans {B C : Type _} {f : A → B} {g : B → C}
  (e : Π⦃a a' : A⦄, R a a' → f a = f a')
  {e' : Π⦃a a' : A⦄, R a a' → g (f a) = g (f a')}
  (p : Π⦃a a' : A⦄ (s : R a a'), ap g (e s) = e' s) (t₁ : T a a') (t₂ : T a' a'') :
  ap_pwords_elim_h e p (t₁ ⬝r t₂) = ap_con g (pwords.elim e t₁) (pwords.elim e t₂) ⬝
    ap_pwords_elim_h e p t₁ ◾ ap_pwords_elim_h e p t₂ :=
by refl

@[hott] def ap_pwords_elim {B C : Type _} {f : A → B} (g : B → C)
  (e : Π⦃a a' : A⦄, R a a' → f a = f a') (t : T a a')
  : ap g (pwords.elim e t) = pwords.elim (λa a' r, ap g (e r)) t :=
ap_pwords_elim_h e (λa a' s, idp) t

@[hott, hsimp] def ap_pwords_elim_symm {B C : Type _} {f : A → B} (g : B → C)
  (e : Π⦃a a' : A⦄, R a a' → f a = f a') (t : T a a')
  : ap_pwords_elim g e t⁻¹ʳ = ap_inv g (pwords.elim e t) ⬝ (ap_pwords_elim g e t)⁻² :=
by refl

@[hott, hsimp] def ap_pwords_elim_trans {B C : Type _} {f : A → B} (g : B → C)
  (e : Π⦃a a' : A⦄, R a a' → f a = f a') (t : T a a') (t' : T a' a'')
  : ap_pwords_elim g e (t ⬝r t') = ap_con g (pwords.elim e t) (pwords.elim e t') ⬝
    (ap_pwords_elim g e t ◾ ap_pwords_elim g e t') :=
by refl

@[hott] def pwords_elim_eq {f : A → B}
  {e e' : Π⦃a a' : A⦄, R a a' → f a = f a'} (p : e ~3 e') (t : T a a')
  : pwords.elim e t = pwords.elim e' t :=
begin
  induction t with a a' r a a' pp a a' r IH a a' a'' r r' IH₁ IH₂,
    apply p,
    refl,
    exact IH⁻²,
    exact IH₁ ◾ IH₂
end

-- TODO: formulate and prove this without using function extensionality,
-- and modify the proofs using this to also not use function extensionality
-- strategy: use `pwords_elim_eq` instead of `ap ... (eq_of_homotopy3 p)`
@[hott] def ap_pwords_elim_h_eq {B C : Type _} {f : A → B} {g : B → C}
  (e : Π⦃a a' : A⦄, R a a' → f a = f a')
  {e' : Π⦃a a' : A⦄, R a a' → g (f a) = g (f a')}
  (p : Π⦃a a' : A⦄ (s : R a a'), ap g (e s) = e' s) (t : T a a')
  : ap_pwords_elim_h e p t =
    ap_pwords_elim g e t ⬝ ap (λx, pwords.elim x t) (eq_of_homotopy3 p) :=
begin
  fapply homotopy3.rec_on p,
  intro q, dsimp at q, hinduction q,
  dsimp [ap_pwords_elim],
  symmetry, refine whisker_left _ (ap02 _ (by exact eq_of_homotopy3_id _)) ⬝ _,
  refl
end

@[hott] def ap_ap_pwords_elim_h {B C D : Type _} {f : A → B}
  {g : B → C} (h : C → D)
  (e : Π⦃a a' : A⦄, R a a' → f a = f a')
  {e' : Π⦃a a' : A⦄, R a a' → g (f a) = g (f a')}
  (p : Π⦃a a' : A⦄ (s : R a a'), ap g (e s) = e' s) (t : T a a')
  : square (ap (ap h) (ap_pwords_elim_h e p t))
            (ap_pwords_elim_h e (λa a' s, ap_compose h g (e s)) t)
            (ap_compose h g (pwords.elim e t))⁻¹
            (ap_pwords_elim_h e' (λa a' s, (ap (ap h) (p s))⁻¹) t) :=
begin
  induction t with a a' r a a' pp a a' r IH a a' a'' r r' IH₁ IH₂,
  { dsimp,
    apply square_of_eq, exact con.right_inv _ ⬝ (con.left_inv _)⁻¹ },
  { induction pp, apply ids},
  { dsimp, rwr [ap_con (ap h)],
    refine (transpose (ap_compose_inv _ _ _))⁻¹ᵛ ⬝h _,
    rwr [con_inv, eq.inv_inv, ←inv2_inv],
    exact ap_inv2 _ ⬝v square_inv2 IH },
  { dsimp, rwr [ap_con (ap h)],
    refine (transpose (ap_compose_con _ _ _ _))⁻¹ᵛ ⬝h _,
    rwr [con_inv, eq.inv_inv, con2_inv],
    refine ap_con2 _ _ ⬝v square_con2 IH₁ IH₂ },
end

@[hott] def ap_ap_pwords_elim {B C D : Type _} {f : A → B}
  (g : B → C) (h : C → D)
  (e : Π⦃a a' : A⦄, R a a' → f a = f a') (t : T a a')
  : square (ap (ap h) (ap_pwords_elim g e t))
            (ap_pwords_elim_h e (λa a' s, ap_compose h g (e s)) t)
            (ap_compose h g (pwords.elim e t))⁻¹
            (ap_pwords_elim h (λa a' r, ap g (e r)) t) :=
ap_ap_pwords_elim_h _ _ _ _

@[hott] def ap_pwords_elim_h_compose {B C D : Type _} {f : A → B}
  {g : B → C} (h : C → D)
  (e : Π⦃a a' : A⦄, R a a' → f a = f a')
  {e' : Π⦃a a' : A⦄, R a a' → h (g (f a)) = h (g (f a'))}
  (p : Π⦃a a' : A⦄ (s : R a a'), ap (h ∘ g) (e s) = e' s) (t : T a a') :
    square (ap02 h (ap_pwords_elim g e t))
           (ap_pwords_elim_h e p t)
           (ap_compose h g (pwords.elim e t))⁻¹
           (ap_pwords_elim_h (λa a' s, ap g (e s)) (λa a' s, (ap_compose h g (e s))⁻¹ ⬝ p s) t) :=
begin
  induction t with a a' r a a' pp a a' r IH a a' a'' r r' IH₁ IH₂,
  { dsimp [ap_pwords_elim_h, ap_pwords_elim, ap02, pwords.elim],
    apply square_of_eq, apply idp_con },
  { induction pp, apply ids },
  -- the rest of the proof is almost the same as the proof of ap_ap_pwords_elim[_h].
  -- Is there a connection between these theorems?
  { dsimp [ap02], rwr [ap_con (ap h)],
    refine (transpose (ap_compose_inv _ _ _))⁻¹ᵛ ⬝h _,
    rwr [con_inv, eq.inv_inv, ←inv2_inv],
    exact ap_inv2 _ ⬝v square_inv2 IH },
  { dsimp [ap02], rwr [ap_con (ap h)],
    refine (transpose (ap_compose_con _ _ _ _))⁻¹ᵛ ⬝h _,
    rwr [con_inv, eq.inv_inv, con2_inv],
    refine ap_con2 _ _ ⬝v square_con2 IH₁ IH₂ },
end

@[hott] def ap_pwords_elim_h_zigzag {B C D : Type _} {f : A → B}
  {g : B → C} (h : C → D)
  (e : Π⦃a a' : A⦄, R a a' → f a = f a')
  {e' : Π⦃a a' : A⦄, R a a' → h (g (f a)) = h (g (f a'))}
  (p : Π⦃a a' : A⦄ (s : R a a'), ap (h ∘ g) (e s) = e' s) (t : T a a')
  : ap_pwords_elim   h (λa a' s, ap g (e s)) t ⬝
    (ap_pwords_elim_h e (λa a' s, ap_compose h g (e s)) t)⁻¹ ⬝
    ap_pwords_elim_h e p t =
    ap_pwords_elim_h (λa a' s, ap g (e s)) (λa a' s, (ap_compose h g (e s))⁻¹ ⬝ p s) t :=
begin
  refine whisker_right _ (eq_of_square (ap_ap_pwords_elim g h e t)⁻¹ʰ)⁻¹ ⬝ _,
  refine con.assoc _ _ _ ⬝ _, apply inv_con_eq_of_eq_con, apply eq_of_square,
  apply transpose,
  -- the rest of the proof is almost the same as the proof of ap_ap_pwords_elim[_h].
  -- Is there a connection between these theorems?
  induction t with a a' r a a' pp a a' r IH a a' a'' r r' IH₁ IH₂,
  { dsimp, apply square_of_eq, apply idp_con },
  { induction pp, apply ids },
  { dsimp, rwr [ap_con (ap h)],
    refine (transpose (ap_compose_inv _ _ _))⁻¹ᵛ ⬝h _,
    rwr [con_inv, eq.inv_inv, ←inv2_inv],
    exact ap_inv2 _ ⬝v square_inv2 IH },
  { dsimp, rwr [ap_con (ap h)],
    refine (transpose (ap_compose_con _ _ _ _))⁻¹ᵛ ⬝h _,
    rwr [con_inv, eq.inv_inv, con2_inv],
    refine ap_con2 _ _ ⬝v square_con2 IH₁ IH₂ },
end

open hott.relation
@[hott] def is_equivalence_pwords : is_equivalence T :=
begin
  constructor,
    intro a, exact rfl,
    intros a a' t, exact t⁻¹ʳ,
    intros a a' a'' t t', exact t ⬝r t',
end

/- dependent elimination -/

variables {P : B → Type _} {Q : C → Type _} {f : A → B} {g : B → C} {f' : Π(a : A), P (f a)}
@[hott] protected def pwords.elimo (p : Π⦃a a' : A⦄, R a a' → f a = f a')
  (po : Π⦃a a' : A⦄ (s : R a a'), f' a =[p s] f' a') (t : T a a')
  : f' a =[pwords.elim p t] f' a' :=
begin
  induction t with a a' r a a' pp a a' r IH a a' a'' r r' IH₁ IH₂,
    exact po r,
    induction pp, constructor,
    exact IH⁻¹ᵒ,
    exact IH₁ ⬝o IH₂
end

@[hott, hsimp] def elimo_symm (p : Π⦃a a' : A⦄, R a a' → f a = f a')
  (po : Π⦃a a' : A⦄ (s : R a a'), f' a =[p s] f' a') (t : T a a')
  : pwords.elimo p po t⁻¹ʳ = (pwords.elimo p po t)⁻¹ᵒ :=
by refl

@[hott, hsimp] def elimo_trans (p : Π⦃a a' : A⦄, R a a' → f a = f a')
  (po : Π⦃a a' : A⦄ (s : R a a'), f' a =[p s] f' a') (t : T a a') (t' : T a' a'')
  : pwords.elimo p po (t ⬝r t') = pwords.elimo p po t ⬝o pwords.elimo p po t' :=
by refl

@[hott] def ap_pwords_elimo_h  {g' : Πb, Q (g b)}
  (p : Π⦃a a' : A⦄, R a a' → f a = f a')
  (po : Π⦃a a' : A⦄ (s : R a a'), g' (f a) =[p s; Q ∘ g] g' (f a'))
  (q : Π⦃a a' : A⦄ (s : R a a'), apd g' (p s) = po s)
  (t : T a a') : apd g' (pwords.elim p t) = pwords.elimo p po t :=
begin
  induction t with a a' r a a' pp a a' r IH a a' a'' r r' IH₁ IH₂,
    apply q,
    induction pp, refl,
    exact apd_inv g' (pwords.elim p r) ⬝ IH⁻²ᵒ,
    exact apd_con g' (pwords.elim p r) (pwords.elim p r') ⬝ (IH₁ ◾o IH₂)
end

@[hott] theorem pwords_elimo_ap {g' : Π(a : A), Q (g (f a))}
  (p : Π⦃a a' : A⦄, R a a' → f a = f a')
  (po : Π⦃a a' : A⦄ (s : R a a'), g' a =[ap g (p s)] g' a')
  (t : T a a') : pwords.elimo p (λa a' s, pathover_of_pathover_ap Q g (po s)) t =
    pathover_of_pathover_ap Q g (change_path (ap_pwords_elim g p t)⁻¹
      (pwords.elimo (λa a' r, ap g (p r)) po t)) :=
begin
  induction t with a a' r a a' pp a a' r IH a a' a'' r r' IH₁ IH₂,
  { refl },
  { induction pp; refl },
  { rwr [elimo_symm, ap_pwords_elim_symm, IH, con_inv, change_path_con, ←inv2_inv], dsimp,
    rwr [change_path_invo, pathover_of_pathover_ap_invo] },
  { rwr [elimo_trans, elimo_trans, ap_pwords_elim_trans, IH₁, IH₂, con_inv, change_path_con],
    dsimp, rwr [con2_inv, change_path_cono, pathover_of_pathover_ap_cono] },
end

end
end graph
end hott


import types

def assign_lit (l : literal) : formula → formula
| [] := []
| (x :: f) :=
  (if l ∈ x then [] else [list.remove_all x [l_not l]]) ++ assign_lit f

def assign_all (f : formula) (lits : list literal) :=
list.foldl (λ f l, assign_lit l f) f lits

lemma assign_removes : ∀ (f : formula) (l : literal),
  l ∉ (assign_lit l f).join ∧ l_not l ∉ (assign_lit l f).join:=
begin
  intros f l,
  induction' f;
  rw assign_lit;
  simp,
  apply and.intro;
  intro h;
  cases' h;
  cases' h;
  cases' h,
  {
    cases' classical.em (l ∈ hd);
    simp [h] at left,
    {
      assumption,
    },
    {
      rw left at right,
      rw list.remove_all at right,
      simp [h] at right,
      assumption,
    },
  },
  {
    have not_in := ih l,
    simp at not_in,

    have not_in := (and.elim_left not_in) w left,
    exact not_in right,
  },
  {
    cases' classical.em (l ∈ hd);
    simp [h] at left,
    {
      assumption,
    },
    {
      rw left at right,
      rw list.remove_all at right,
      simp [h] at right,
      assumption,
    },

  },
  {
    have not_in := ih l,
    simp at not_in,

    have not_in := (and.elim_right not_in) w left,
    exact not_in right,
  },
end

lemma assign_subset : ∀ (f : formula) (l : literal),
  (assign_lit l f).join ⊆ f.join :=
begin
  intros f l_assign l h,
  induction f;
  rw assign_lit at h;
  simp [h],
  {
    apply h,
  },
  {
    simp at h,
    cases' h,
    {
      cases' h,
      cases' h,
      cases' classical.em (l_assign ∈ f_hd);
      simp [h] at left,
      {
        apply classical.by_contradiction,
        intros,
        assumption,
      },
      {
        rw left at right,
        have sub : list.remove_all f_hd [l_not l_assign] ⊆ f_hd :=
          by apply list.filter_subset,
        apply or.intro_left,
        apply sub,
        assumption,
      },
    },
    {
      cases' h,
      cases' h,
      apply or.intro_right,
      simp at f_ih,
      apply f_ih w left right,
    },
  },
end

lemma list_not_in_append {α : Type} (a b : list  α) (c : α) : c ∉ a ++ b ↔ c ∉ a ∧ c ∉ b :=
begin
  apply iff.intro,
  {
    intro h,

    induction' a,
    {
      simp at h,
      simp [h],
    },
    {
      simp [h],
      rw not_or_distrib,
      have n_in :=  list.ne_and_not_mem_of_not_mem_cons h,
      cases' n_in,
      simp [left],
      apply ih,
      exact right,
    },
  },
  {
    intro h,
    cases' h,
    exact list.not_mem_append left right,
  },
end

lemma assign_when_not_in_out : ∀ (f : formula) (l : literal) (c : clause),
  c ∈ f → c ∉ assign_lit l f → l_not l ∈ c ∨ l ∈ c :=
begin
  intros f l c c_f c_n_a_f,
  induction' f,
  {
    simp at c_f,
    contradiction,
  },
  {
    cases' classical.em (c ∈ f),
    {
      rw assign_lit at c_n_a_f,

      apply ih,
      {
        assumption,
      },
      {
        rw list_not_in_append at c_n_a_f,
        cases' c_n_a_f,
        assumption,
      },
    },
    {
      have eq : c = hd := begin
        cases' c_f,
        {
          assumption,
        },
        {
          contradiction,
        },
      end,
      rw assign_lit at c_n_a_f,
      rw eq,
      rw eq at c_n_a_f,

      apply classical.by_contradiction,
      intro h,
      rw not_or_distrib at h,
      cases h,
      simp [h_left, h_right] at c_n_a_f,
      rw not_or_distrib at c_n_a_f,
      cases c_n_a_f,

      have h_eq : list.remove_all hd [l_not l] = hd  := begin
        rw list.remove_all,
        simp,
        rw list.filter_eq_self,
        intros a h,
        intro h_eq,
        rw ←h_eq at h_left,
        contradiction,
      end,

      rw h_eq at c_n_a_f_left,
      contradiction,
    },
  },
end

lemma remove_all_length_impl {α : Type} [decidable_eq α]
  (l : list α) (r : α) : (l.remove_all [r]).length + (if r ∈ l then 1 else 0) ≤ l.length :=
begin
  induction' l,
  {
    rw list.remove_all,
    simp,

  },
  {
    rw list.remove_all,
    rw list.filter,
    simp,
    cases' classical.em (hd = r);
    have ih := ih r;
    rw list.remove_all at ih;
    cases' classical.em (r ∈ l);
    simp [h, h_1];
    simp [h_1] at ih,
    linarith,
    linarith,
    linarith,
    have neq := ne.symm h,
    simp [neq],
    apply ih,
  },
end

lemma remove_all_leq_length {α : Type} [decidable_eq α]
  (l : list α) (r : α) : (l.remove_all [r]).length ≤ l.length :=
begin
  have h := remove_all_length_impl l r,
  cases' classical.em (r ∈ l);
  simp [h_1] at h;
  linarith,
end

lemma remove_all_less_length {α : Type} [decidable_eq α]
  (l : list α) (r : α) (h : r ∈ l) : (l.remove_all [r]).length < l.length :=
begin
  have h_impl := remove_all_length_impl l r,
  simp [h] at h_impl,
  linarith,
end

lemma assign_without_present_eq  (f : formula) (l : literal) :
l ∉ f.join ∧ l_not l ∉ f.join → assign_lit l f = f :=
begin
  intro h,
  induction' f;
  rw assign_lit,
  simp at h,
  cases' h,
  rw not_or_distrib at left,
  rw not_or_distrib at right,
  cases' left,
  cases' right,
  simp [left],
  apply and.intro,
  {
    rw list.remove_all,
    rw list.filter_eq_self,
    simp,
    intros a h_in,
    intro eq,
    rw eq at h_in,
    contradiction,
  },
  {
    apply ih,
    simp [right, right_1],
  },
end

lemma assign_with_present_reduces_size :
∀ (f : formula) (l : literal),
l ∈ f.join ∨ l_not l ∈ f.join →
formula_size (assign_lit l f) < formula_size f :=
begin
  intros f l h,
  rw formula_size,
  rw formula_size,
  induction' f,
  {
    simp at h,
    contradiction,
  },
  {
    cases' classical.em (l ∈ f.join ∨ l_not l ∈ f.join),
    {
      rw assign_lit,
      simp,
      have leq : (list.map list.length (ite (l ∈ hd) list.nil
                  [list.remove_all hd [l_not l]])).sum ≤ hd.length :=
      begin
        cases' classical.em (l ∈ hd);
        simp [h_2],
        apply remove_all_leq_length,
      end,
      have ih := ih l h_1,
      simp at ih,
      linarith,
    },
    {
      rw not_or_distrib at h_1,
      have h_in : l ∈ hd ∨ l_not l ∈ hd := begin
        simp [h_1] at h,
        apply h,
      end,

      rw assign_lit,
      have h_eq := assign_without_present_eq _ _ h_1,
      rw h_eq,
      simp,

      cases classical.em (l ∈ hd);
      simp [h_2],
      {
        exact list.length_pos_of_mem h_2,
      },
      {
        simp [h_2] at h_in,
        exact remove_all_less_length _ _ h_in,
      },
    },
  },
end

lemma assign_leq_size (f : formula) (l : literal) :
formula_size (assign_lit l f) ≤ formula_size f :=
begin
  cases' classical.em (l ∉ f.join ∧ l_not l ∉ f.join),
  {
    have h := assign_without_present_eq _ _ h,
    rw h,
  },
  {
    rw not_and_distrib at h,
    have h : l ∈ f.join ∨ l_not l ∈ f.join := begin
      simp,
      simp at h,
      apply h,
    end,

    have less := assign_with_present_reduces_size _ _ h,
    linarith,
  },
end

lemma list_containment_l {α : Type} : ∀ (a b : list α) (c : α),
  c ∉ b → c ∈ a ++ b → c ∈ a :=
begin
  intros a b c h_1 h_2,
  induction' a;
  finish,
end

lemma removed_literal_must_be_contained
  (f : formula) (l : literal) (c : clause):
  c ∈ f → c ∉ assign_lit l f → l ∉ c → l_not l ∈ c →
  c.remove_all [l_not l] ∈ assign_lit l f :=
begin
  intros h_in_f h_n_in_a_f l_n_in_c n_l_in_c,
  induction' f,
  {
    simp at h_in_f,
    contradiction,
  },
  {
    cases' classical.em (c = hd),
    {
      rw assign_lit,
      rw h at l_n_in_c,
      simp [l_n_in_c],
      apply or.inl,
      rw h,
    },
    {
      have in_f : c ∈ f := list.mem_of_ne_of_mem h h_in_f,
      rw assign_lit,
      simp,
      apply or.inr,
      apply ih _ _ l_n_in_c n_l_in_c in_f,

      rw assign_lit at h_n_in_a_f,
      simp at h_n_in_a_f,
      rw not_or_distrib at h_n_in_a_f,
      cases' h_n_in_a_f,
      assumption,
    },
  },
end

def add_l_to_assign (a : assignment) (l : literal) : assignment :=
subtype.mk (a.val.remove_all [l_not l] ++ [l]) begin
  intros l_other h_l_in,
  simp,
  rw not_or_distrib,
  cases' classical.em (l = l_other),
  {
    rw h,
    apply and.intro,
    {
      intro h_in,
      apply list.of_mem_filter h_in,
      simp,
    },
    {
      intro h_eq,
      have neq := l_not_neq l_other,
      rw h_eq at neq,
      contradiction,
    },
  },
  {
    apply and.intro,
    {
      have in_filtered : l_other ∈ a.val.remove_all [l_not l] := begin
        apply list_containment_l _ _ _ _ h_l_in,
        simp,
        intro h_eq,
        rw h_eq at h,
        contradiction,
      end,
      have other_in : l_other ∈ a.val := begin
        rw list.remove_all at in_filtered,
        rw list.mem_filter at in_filtered,
        cases' in_filtered,
        exact left,
      end,
      have not_not_in : l_not l_other  ∉ a.val := begin
        apply a.property,
        exact other_in,
      end,
      rw list.remove_all,
      rw list.mem_filter,
      rw not_and_distrib,
      apply or.inl not_not_in,
    },
    {
      intro h_eq,
      rw ←h_eq at h_l_in,
      simp at h_l_in,
      apply list.of_mem_filter h_l_in,
      simp,
    },
  },
end

lemma assign_sat_implies_sat :
∀ (f : formula) (l : literal), sat (assign_lit l f) → sat f := begin
  intros f l h,
  set a_f := assign_lit l f,
  cases' h,
  let assigned := [l],
  let filtered := (w.val.remove_all [l_not l]),
  let new_a := filtered ++ assigned,

  apply exists.intro (add_l_to_assign w l),
  rw add_l_to_assign,
  rw formula_sat,
  intros c h_in_f,
  rw clause_sat,

  cases' classical.em (c ∈ a_f),
  {
    rw formula_sat at h,
    cases' (h c h_1),
    apply exists.intro w_1,
    cases' h_2,
    simp [right],

    have actually_in : w_1 ∈ list.join (assign_lit l f) := begin
      simp,
      apply exists.intro c,
      simp [h_1, right],
    end,
    have w_neq : w_1 ≠ l_not l := begin
      cases' (assign_removes f l),
      intro h_eq,
      rw h_eq at actually_in,
      contradiction,
    end,

    have h_in : w_1 ∈ filtered := begin
      apply list.mem_filter_of_mem,
      assumption,
      simp,
      apply w_neq,
    end,

    have is_in : w_1 ∈ new_a := by simp [h_in],
    simp only [new_a, filtered] at is_in,
    apply is_in,
  },
  {
    cases' classical.em (l ∈ c),
    {
      apply exists.intro l,
      simp [h_2],
      have l_in : l ∈ (filtered ++ assigned) := begin
        simp only [assigned],
        simp,
      end,
      apply l_in,
    },
    {
      have either := assign_when_not_in_out _ _ _ h_in_f h_1,
      simp [h_2] at either,

      let removed := c.remove_all [l_not l],
      have removed_in : removed ∈ a_f :=
        removed_literal_must_be_contained _ _ _ h_in_f h_1 h_2 either,
      rw formula_sat at h,
      have h := h removed removed_in,
      cases' h,
      apply exists.intro w_1,
      cases' h_3,
      have removed_sub : removed ⊆ c := by apply list.filter_subset,
      have neq_l : w_1 ≠ l := begin
        intro h,
        rw h at right,
        have in_c : l ∈ c := begin
          apply removed_sub,
          exact right,
        end,
        contradiction,
      end,
      have neq_n_l : w_1 ≠ l_not l := begin
        intro h,
        rw h at right,
        apply list.of_mem_filter right,
        simp,
      end,
      apply and.intro,
      {
        apply list.mem_append_left,
        apply list.mem_filter_of_mem left,
        simp,
        exact neq_n_l,
      },
      {
        apply removed_sub,
        exact right,
      },
    },
  },
end

lemma must_exist_filtered_clause (f : formula) (l : literal) (c : clause):
c ∉ f → c ∈ assign_lit l f →
(∃ (c' : clause), c'.remove_all [l_not l] = c ∧ c' ∈ f) :=
begin
  intros h_n_in_f h_in_a_f,
  induction' f,
  {
    rw assign_lit at h_in_a_f,
    simp at h_in_a_f,
    contradiction,
  },
  {
    cases' classical.em (hd.remove_all [l_not l] = c),
    {
      apply exists.intro hd,
      apply and.intro,
      {
        exact h,
      },
      {
        simp,
      },
    },
    {
      rw assign_lit at h_in_a_f,
      simp at h_in_a_f,
      cases' h_in_a_f,
      {
        cases' classical.em (l ∈ hd);
        simp [h_2] at h_1,
        {
          contradiction,
        },
        {
          rw h_1 at h,
          contradiction,
        },
      },
      {
        have ih := ih _ _ (list.not_mem_of_not_mem_cons h_n_in_f) h_1,
        cases' ih,
        apply exists.intro w,
        simp [h_2],
      },
    },
  },
end

lemma sat_implies_assign_sat_or_cant_exist (f : formula) (l : literal) :
(∃ (a : assignment), formula_sat a f ∧ l ∈ a) →
sat (assign_lit l f) :=
begin
  intros assign_exists,
  cases' assign_exists,
  cases' h,
  apply exists.intro w,
  rw formula_sat,
  intros c c_in,
  rw formula_sat at left,
  cases' classical.em (c ∈ f),
  {
    exact left c h,
  },
  {
    have exists_filtered := must_exist_filtered_clause _ _ _ h c_in,
    cases' exists_filtered,
    cases' h_1,
    have clause_sat_other := left w_1 right_1,
    rw clause_sat at clause_sat_other,
    cases' clause_sat_other,
    apply exists.intro w_2,
    simp [h_1],
    rw ←left_1,
    apply list.mem_filter_of_mem,
    {
      simp [h_1],
    },
    {
      intro h,
      simp at h,
      cases' h_1,
      rw h at left_2,
      apply w.property _ right left_2,
    },
  },
end

lemma assign_all_leq_size (f : formula) (lits : list literal)
: formula_size (assign_all f lits) ≤ formula_size f :=
begin
  rw assign_all,
  induction' lits;
  simp,
  have ih := ih (assign_lit hd f),
  have less : formula_size (assign_lit hd f) ≤ formula_size f :=
    by apply assign_leq_size,
  linarith,
end


/-
Copyright (c) 2022 Yakov Pechersky. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Kenny Lau, Johan Commelin, Mario Carneiro, Kevin Buzzard,
Amelia Livingston, Yury Kudryashov, Yakov Pechersky, Jireh Loreaux
-/
import group_theory.subsemigroup.basic

/-!
# Operations on `subsemigroup`s

In this file we define various operations on `subsemigroup`s and `mul_hom`s.

## Main definitions

### Conversion between multiplicative and additive definitions

* `subsemigroup.to_add_subsemigroup`, `subsemigroup.to_add_subsemigroup'`,
  `add_subsemigroup.to_subsemigroup`, `add_subsemigroup.to_subsemigroup'`:
  convert between multiplicative and additive subsemigroups of `M`,
  `multiplicative M`, and `additive M`. These are stated as `order_iso`s.

### (Commutative) semigroup structure on a subsemigroup

* `subsemigroup.to_semigroup`, `subsemigroup.to_comm_semigroup`: a subsemigroup inherits a
  (commutative) semigroup structure.

### Operations on subsemigroups

* `subsemigroup.comap`: preimage of a subsemigroup under a semigroup homomorphism as a subsemigroup
  of the domain;
* `subsemigroup.map`: image of a subsemigroup under a semigroup homomorphism as a subsemigroup of
  the codomain;
* `subsemigroup.prod`: product of two subsemigroups `s : subsemigroup M` and `t : subsemigroup N`
  as a subsemigroup of `M × N`;

### Semigroup homomorphisms between subsemigroups

* `subsemigroup.subtype`: embedding of a subsemigroup into the ambient semigroup.
* `subsemigroup.inclusion`: given two subsemigroups `S`, `T` such that `S ≤ T`, `S.inclusion T` is
  the inclusion of `S` into `T` as a semigroup homomorphism;
* `mul_equiv.subsemigroup_congr`: converts a proof of `S = T` into a semigroup isomorphism between
  `S` and `T`.
* `subsemigroup.prod_equiv`: semigroup isomorphism between `s.prod t` and `s × t`;

### Operations on `mul_hom`s

* `mul_hom.srange`: range of a semigroup homomorphism as a subsemigroup of the codomain;
* `mul_hom.restrict`: restrict a semigroup homomorphism to a subsemigroup;
* `mul_hom.cod_restrict`: restrict the codomain of a semigroup homomorphism to a subsemigroup;
* `mul_hom.srange_restrict`: restrict a semigroup homomorphism to its range;

### Implementation notes

This file follows closely `group_theory/submonoid/operations.lean`, omitting only that which is
necessary.

## Tags

subsemigroup, range, product, map, comap
-/

variables {M N P σ : Type*}

/-!
### Conversion to/from `additive`/`multiplicative`
-/

section

variables [has_mul M]

/-- Subsemigroups of semigroup `M` are isomorphic to additive subsemigroups of `additive M`. -/
@[simps]
def subsemigroup.to_add_subsemigroup : subsemigroup M ≃o add_subsemigroup (additive M) :=
{ to_fun := λ S,
  { carrier := additive.to_mul ⁻¹' S,
    add_mem' := S.mul_mem' },
  inv_fun := λ S,
  { carrier := additive.of_mul ⁻¹' S,
    mul_mem' := S.add_mem' },
  left_inv := λ x, by cases x; refl,
  right_inv := λ x, by cases x; refl,
  map_rel_iff' := λ a b, iff.rfl, }

/-- Additive subsemigroups of an additive semigroup `additive M` are isomorphic to subsemigroups
of `M`. -/
abbreviation add_subsemigroup.to_subsemigroup' : add_subsemigroup (additive M) ≃o subsemigroup M :=
subsemigroup.to_add_subsemigroup.symm

lemma subsemigroup.to_add_subsemigroup_closure (S : set M) :
  (subsemigroup.closure S).to_add_subsemigroup = add_subsemigroup.closure (additive.to_mul ⁻¹' S) :=
le_antisymm
  (subsemigroup.to_add_subsemigroup.le_symm_apply.1 $
    subsemigroup.closure_le.2 add_subsemigroup.subset_closure)
  (add_subsemigroup.closure_le.2 subsemigroup.subset_closure)

lemma add_subsemigroup.to_subsemigroup'_closure (S : set (additive M)) :
  (add_subsemigroup.closure S).to_subsemigroup' =
    subsemigroup.closure (multiplicative.of_add ⁻¹' S) :=
le_antisymm
  (add_subsemigroup.to_subsemigroup'.le_symm_apply.1 $
    add_subsemigroup.closure_le.2 subsemigroup.subset_closure)
  (subsemigroup.closure_le.2 add_subsemigroup.subset_closure)

end

section

variables {A : Type*} [has_add A]

/-- Additive subsemigroups of an additive semigroup `A` are isomorphic to
multiplicative subsemigroups of `multiplicative A`. -/
@[simps]
def add_subsemigroup.to_subsemigroup : add_subsemigroup A ≃o subsemigroup (multiplicative A) :=
{ to_fun := λ S,
  { carrier := multiplicative.to_add ⁻¹' S,
    mul_mem' := S.add_mem' },
  inv_fun := λ S,
  { carrier := multiplicative.of_add ⁻¹' S,
    add_mem' := S.mul_mem' },
  left_inv := λ x, by cases x; refl,
  right_inv := λ x, by cases x; refl,
  map_rel_iff' := λ a b, iff.rfl, }

/-- Subsemigroups of a semigroup `multiplicative A` are isomorphic to additive subsemigroups
of `A`. -/
abbreviation subsemigroup.to_add_subsemigroup' :
  subsemigroup (multiplicative A) ≃o add_subsemigroup A :=
add_subsemigroup.to_subsemigroup.symm

lemma add_subsemigroup.to_subsemigroup_closure (S : set A) :
  (add_subsemigroup.closure S).to_subsemigroup =
    subsemigroup.closure (multiplicative.to_add ⁻¹' S) :=
le_antisymm
  (add_subsemigroup.to_subsemigroup.to_galois_connection.l_le $
    add_subsemigroup.closure_le.2 subsemigroup.subset_closure)
  (subsemigroup.closure_le.2 add_subsemigroup.subset_closure)

lemma subsemigroup.to_add_subsemigroup'_closure (S : set (multiplicative A)) :
  (subsemigroup.closure S).to_add_subsemigroup' =
    add_subsemigroup.closure (additive.of_mul ⁻¹' S) :=
le_antisymm
  (subsemigroup.to_add_subsemigroup'.to_galois_connection.l_le $
    subsemigroup.closure_le.2 add_subsemigroup.subset_closure)
  (add_subsemigroup.closure_le.2 subsemigroup.subset_closure)

end

namespace subsemigroup

open set

/-!
### `comap` and `map`
-/

variables [has_mul M] [has_mul N] [has_mul P] (S : subsemigroup M)

/-- The preimage of a subsemigroup along a semigroup homomorphism is a subsemigroup. -/
@[to_additive "The preimage of an `add_subsemigroup` along an `add_semigroup` homomorphism is an
`add_subsemigroup`."]
def comap (f : M →ₙ* N) (S : subsemigroup N) : subsemigroup M :=
{ carrier := (f ⁻¹' S),
  mul_mem' := λ a b ha hb,
    show f (a * b) ∈ S, by rw map_mul; exact mul_mem ha hb }

@[simp, to_additive]
lemma coe_comap (S : subsemigroup N) (f : M →ₙ* N) : (S.comap f : set M) = f ⁻¹' S := rfl

@[simp, to_additive]
lemma mem_comap {S : subsemigroup N} {f : M →ₙ* N} {x : M} : x ∈ S.comap f ↔ f x ∈ S := iff.rfl

@[to_additive]
lemma comap_comap (S : subsemigroup P) (g : N →ₙ* P) (f : M →ₙ* N) :
  (S.comap g).comap f = S.comap (g.comp f) :=
rfl

@[simp, to_additive]
lemma comap_id (S : subsemigroup P) : S.comap (mul_hom.id _) = S :=
ext (by simp)

/-- The image of a subsemigroup along a semigroup homomorphism is a subsemigroup. -/
@[to_additive "The image of an `add_subsemigroup` along an `add_semigroup` homomorphism is
an `add_subsemigroup`."]
def map (f : M →ₙ* N) (S : subsemigroup M) : subsemigroup N :=
{ carrier := (f '' S),
  mul_mem' := begin rintros _ _ ⟨x, hx, rfl⟩ ⟨y, hy, rfl⟩,
    exact ⟨x * y, @mul_mem (subsemigroup M) M _ _ _ _ _ _ hx hy, by rw map_mul; refl⟩ end }

@[simp, to_additive]
lemma coe_map (f : M →ₙ* N) (S : subsemigroup M) :
  (S.map f : set N) = f '' S := rfl

@[simp, to_additive]
lemma mem_map {f : M →ₙ* N} {S : subsemigroup M} {y : N} :
  y ∈ S.map f ↔ ∃ x ∈ S, f x = y :=
mem_image_iff_bex

@[to_additive]
lemma mem_map_of_mem (f : M →ₙ* N) {S : subsemigroup M} {x : M} (hx : x ∈ S) : f x ∈ S.map f :=
mem_image_of_mem f hx

@[to_additive]
lemma apply_coe_mem_map (f : M →ₙ* N) (S : subsemigroup M) (x : S) : f x ∈ S.map f :=
mem_map_of_mem f x.prop

@[to_additive]
lemma map_map (g : N →ₙ* P) (f : M →ₙ* N) : (S.map f).map g = S.map (g.comp f) :=
set_like.coe_injective $ image_image _ _ _

@[to_additive]
lemma mem_map_iff_mem {f : M →ₙ* N} (hf : function.injective f) {S : subsemigroup M} {x : M} :
  f x ∈ S.map f ↔ x ∈ S :=
hf.mem_set_image

@[to_additive]
lemma map_le_iff_le_comap {f : M →ₙ* N} {S : subsemigroup M} {T : subsemigroup N} :
  S.map f ≤ T ↔ S ≤ T.comap f :=
image_subset_iff

@[to_additive]
lemma gc_map_comap (f : M →ₙ* N) : galois_connection (map f) (comap f) :=
λ S T, map_le_iff_le_comap

@[to_additive]
lemma map_le_of_le_comap {T : subsemigroup N} {f : M →ₙ* N} : S ≤ T.comap f → S.map f ≤ T :=
(gc_map_comap f).l_le

@[to_additive]
lemma le_comap_of_map_le {T : subsemigroup N} {f : M →ₙ* N} : S.map f ≤ T → S ≤ T.comap f :=
(gc_map_comap f).le_u

@[to_additive]
lemma le_comap_map {f : M →ₙ* N} : S ≤ (S.map f).comap f :=
(gc_map_comap f).le_u_l _

@[to_additive]
lemma map_comap_le {S : subsemigroup N} {f : M →ₙ* N} : (S.comap f).map f ≤ S :=
(gc_map_comap f).l_u_le _

@[to_additive]
lemma monotone_map {f : M →ₙ* N} : monotone (map f) :=
(gc_map_comap f).monotone_l

@[to_additive]
lemma monotone_comap {f : M →ₙ* N} : monotone (comap f) :=
(gc_map_comap f).monotone_u

@[simp, to_additive]
lemma map_comap_map {f : M →ₙ* N} : ((S.map f).comap f).map f = S.map f :=
(gc_map_comap f).l_u_l_eq_l _

@[simp, to_additive]
lemma comap_map_comap {S : subsemigroup N} {f : M →ₙ* N} :
  ((S.comap f).map f).comap f = S.comap f :=
(gc_map_comap f).u_l_u_eq_u _

@[to_additive]
lemma map_sup (S T : subsemigroup M) (f : M →ₙ* N) : (S ⊔ T).map f = S.map f ⊔ T.map f :=
(gc_map_comap f).l_sup

@[to_additive]
lemma map_supr {ι : Sort*} (f : M →ₙ* N) (s : ι → subsemigroup M) :
  (supr s).map f = ⨆ i, (s i).map f :=
(gc_map_comap f).l_supr

@[to_additive]
lemma comap_inf (S T : subsemigroup N) (f : M →ₙ* N) : (S ⊓ T).comap f = S.comap f ⊓ T.comap f :=
(gc_map_comap f).u_inf

@[to_additive]
lemma comap_infi {ι : Sort*} (f : M →ₙ* N) (s : ι → subsemigroup N) :
  (infi s).comap f = ⨅ i, (s i).comap f :=
(gc_map_comap f).u_infi

@[simp, to_additive] lemma map_bot (f : M →ₙ* N) : (⊥ : subsemigroup M).map f = ⊥ :=
(gc_map_comap f).l_bot

@[simp, to_additive] lemma comap_top (f : M →ₙ* N) : (⊤ : subsemigroup N).comap f = ⊤ :=
(gc_map_comap f).u_top

@[simp, to_additive] lemma map_id (S : subsemigroup M) : S.map (mul_hom.id M) = S :=
ext (λ x, ⟨λ ⟨_, h, rfl⟩, h, λ h, ⟨_, h, rfl⟩⟩)

section galois_coinsertion

variables {ι : Type*} {f : M →ₙ* N} (hf : function.injective f)

include hf

/-- `map f` and `comap f` form a `galois_coinsertion` when `f` is injective. -/
@[to_additive /-" `map f` and `comap f` form a `galois_coinsertion` when `f` is injective. "-/]
def gci_map_comap : galois_coinsertion (map f) (comap f) :=
(gc_map_comap f).to_galois_coinsertion
  (λ S x, by simp [mem_comap, mem_map, hf.eq_iff])

@[to_additive]
lemma comap_map_eq_of_injective (S : subsemigroup M) : (S.map f).comap f = S :=
(gci_map_comap hf).u_l_eq _

@[to_additive]
lemma comap_surjective_of_injective : function.surjective (comap f) :=
(gci_map_comap hf).u_surjective

@[to_additive]
lemma map_injective_of_injective : function.injective (map f) :=
(gci_map_comap hf).l_injective

@[to_additive]
lemma comap_inf_map_of_injective (S T : subsemigroup M) : (S.map f ⊓ T.map f).comap f = S ⊓ T :=
(gci_map_comap hf).u_inf_l _ _

@[to_additive]
lemma comap_infi_map_of_injective (S : ι → subsemigroup M) : (⨅ i, (S i).map f).comap f = infi S :=
(gci_map_comap hf).u_infi_l _

@[to_additive]
lemma comap_sup_map_of_injective (S T : subsemigroup M) : (S.map f ⊔ T.map f).comap f = S ⊔ T :=
(gci_map_comap hf).u_sup_l _ _

@[to_additive]
lemma comap_supr_map_of_injective (S : ι → subsemigroup M) : (⨆ i, (S i).map f).comap f = supr S :=
(gci_map_comap hf).u_supr_l _

@[to_additive]
lemma map_le_map_iff_of_injective {S T : subsemigroup M} : S.map f ≤ T.map f ↔ S ≤ T :=
(gci_map_comap hf).l_le_l_iff

@[to_additive]
lemma map_strict_mono_of_injective : strict_mono (map f) :=
(gci_map_comap hf).strict_mono_l

end galois_coinsertion

section galois_insertion

variables {ι : Type*} {f : M →ₙ* N} (hf : function.surjective f)

include hf

/-- `map f` and `comap f` form a `galois_insertion` when `f` is surjective. -/
@[to_additive /-" `map f` and `comap f` form a `galois_insertion` when `f` is surjective. "-/]
def gi_map_comap : galois_insertion (map f) (comap f) :=
(gc_map_comap f).to_galois_insertion
  (λ S x h, let ⟨y, hy⟩ := hf x in mem_map.2 ⟨y, by simp [hy, h]⟩)

@[to_additive]
lemma map_comap_eq_of_surjective (S : subsemigroup N) : (S.comap f).map f = S :=
(gi_map_comap hf).l_u_eq _

@[to_additive]
lemma map_surjective_of_surjective : function.surjective (map f) :=
(gi_map_comap hf).l_surjective

@[to_additive]
lemma comap_injective_of_surjective : function.injective (comap f) :=
(gi_map_comap hf).u_injective

@[to_additive]
lemma map_inf_comap_of_surjective (S T : subsemigroup N) : (S.comap f ⊓ T.comap f).map f = S ⊓ T :=
(gi_map_comap hf).l_inf_u _ _

@[to_additive]
lemma map_infi_comap_of_surjective (S : ι → subsemigroup N) : (⨅ i, (S i).comap f).map f = infi S :=
(gi_map_comap hf).l_infi_u _

@[to_additive]
lemma map_sup_comap_of_surjective (S T : subsemigroup N) : (S.comap f ⊔ T.comap f).map f = S ⊔ T :=
(gi_map_comap hf).l_sup_u _ _

@[to_additive]
lemma map_supr_comap_of_surjective (S : ι → subsemigroup N) : (⨆ i, (S i).comap f).map f = supr S :=
(gi_map_comap hf).l_supr_u _

@[to_additive]
lemma comap_le_comap_iff_of_surjective {S T : subsemigroup N} : S.comap f ≤ T.comap f ↔ S ≤ T :=
(gi_map_comap hf).u_le_u_iff

@[to_additive]
lemma comap_strict_mono_of_surjective : strict_mono (comap f) :=
(gi_map_comap hf).strict_mono_u

end galois_insertion

end subsemigroup

namespace mul_mem_class

variables {A : Type*} [has_mul M] [set_like A M] [hA : mul_mem_class A M] (S' : A)
include hA

/-- A submagma of a magma inherits a multiplication. -/
@[to_additive "An additive submagma of an additive magma inherits an addition.",
priority 900] -- lower priority so other instances are found first
instance has_mul : has_mul S' := ⟨λ a b, ⟨a.1 * b.1, mul_mem a.2 b.2⟩⟩

@[simp, norm_cast, to_additive, priority 900]
-- lower priority so later simp lemmas are used first; to appease simp_nf
lemma coe_mul (x y : S') : (↑(x * y) : M) = ↑x * ↑y := rfl

@[simp, to_additive, priority 900]
-- lower priority so later simp lemmas are used first; to appease simp_nf
lemma mk_mul_mk (x y : M) (hx : x ∈ S') (hy : y ∈ S') :
  (⟨x, hx⟩ : S') * ⟨y, hy⟩ = ⟨x * y, mul_mem hx hy⟩ := rfl

@[to_additive] lemma mul_def (x y : S') : x * y = ⟨x * y, mul_mem x.2 y.2⟩ := rfl

omit hA

/-- A subsemigroup of a semigroup inherits a semigroup structure. -/
@[to_additive "An `add_subsemigroup` of an `add_semigroup` inherits an `add_semigroup` structure."]
instance to_semigroup {M : Type*} [semigroup M] {A : Type*} [set_like A M] [mul_mem_class A M]
  (S : A) : semigroup S :=
subtype.coe_injective.semigroup coe (λ _ _, rfl)

/-- A subsemigroup of a `comm_semigroup` is a `comm_semigroup`. -/
@[to_additive "An `add_subsemigroup` of an `add_comm_semigroup` is an `add_comm_semigroup`."]
instance to_comm_semigroup {M} [comm_semigroup M] {A : Type*} [set_like A M] [mul_mem_class A M]
  (S : A) : comm_semigroup S :=
subtype.coe_injective.comm_semigroup coe (λ _ _, rfl)

include hA

/-- The natural semigroup hom from a subsemigroup of semigroup `M` to `M`. -/
@[to_additive "The natural semigroup hom from an `add_subsemigroup` of `add_semigroup` `M` to `M`."]
def subtype : S' →ₙ* M := ⟨coe, λ _ _, rfl⟩

@[simp, to_additive]

end mul_mem_class

namespace subsemigroup

variables [has_mul M] [has_mul N] [has_mul P] (S : subsemigroup M)

/-- The top subsemigroup is isomorphic to the semigroup. -/
@[to_additive "The top additive subsemigroup is isomorphic to the additive semigroup.", simps]
def top_equiv : (⊤ : subsemigroup M) ≃* M :=
{ to_fun    := λ x, x,
  inv_fun   := λ x, ⟨x, mem_top x⟩,
  left_inv  := λ x, x.eta _,
  right_inv := λ _, rfl,
  map_mul'  := λ _ _, rfl }

@[simp, to_additive] lemma top_equiv_to_mul_hom :
  (top_equiv : _ ≃* M).to_mul_hom = mul_mem_class.subtype (⊤ : subsemigroup M) :=
rfl

/-- A subsemigroup is isomorphic to its image under an injective function -/
@[to_additive "An additive subsemigroup is isomorphic to its image under an injective function"]
noncomputable def equiv_map_of_injective
  (f : M →ₙ* N) (hf : function.injective f) : S ≃* S.map f :=
{ map_mul' := λ _ _, subtype.ext (map_mul f _ _), ..equiv.set.image f S hf }

@[simp, to_additive] lemma coe_equiv_map_of_injective_apply
  (f : M →ₙ* N) (hf : function.injective f) (x : S) :
  (equiv_map_of_injective S f hf x : N) = f x := rfl

@[simp, to_additive]
lemma closure_closure_coe_preimage {s : set M} : closure ((coe : closure s → M) ⁻¹' s) = ⊤ :=
eq_top_iff.2 $ λ x, subtype.rec_on x $ λ x hx _, begin
  refine closure_induction' _ (λ g hg, _) (λ g₁ g₂ hg₁ hg₂, _) hx,
  { exact subset_closure hg },
  { exact subsemigroup.mul_mem _ },
end

/-- Given `subsemigroup`s `s`, `t` of semigroups `M`, `N` respectively, `s × t` as a subsemigroup
of `M × N`. -/
@[to_additive prod "Given `add_subsemigroup`s `s`, `t` of `add_semigroup`s `A`, `B` respectively,
`s × t` as an `add_subsemigroup` of `A × B`."]
def prod (s : subsemigroup M) (t : subsemigroup N) : subsemigroup (M × N) :=
{ carrier := (s : set M) ×ˢ (t : set N),
  mul_mem' := λ p q hp hq, ⟨s.mul_mem hp.1 hq.1, t.mul_mem hp.2 hq.2⟩ }

@[to_additive coe_prod]
lemma coe_prod (s : subsemigroup M) (t : subsemigroup N) :
 (s.prod t : set (M × N)) = (s : set M) ×ˢ (t : set N) :=
rfl

@[to_additive mem_prod]
lemma mem_prod {s : subsemigroup M} {t : subsemigroup N} {p : M × N} :
  p ∈ s.prod t ↔ p.1 ∈ s ∧ p.2 ∈ t := iff.rfl

@[to_additive prod_mono]
lemma prod_mono {s₁ s₂ : subsemigroup M} {t₁ t₂ : subsemigroup N} (hs : s₁ ≤ s₂) (ht : t₁ ≤ t₂) :
  s₁.prod t₁ ≤ s₂.prod t₂ :=
set.prod_mono hs ht

@[to_additive prod_top]
lemma prod_top (s : subsemigroup M) :
  s.prod (⊤ : subsemigroup N) = s.comap (mul_hom.fst M N) :=
ext $ λ x, by simp [mem_prod, mul_hom.coe_fst]

@[to_additive top_prod]
lemma top_prod (s : subsemigroup N) :
  (⊤ : subsemigroup M).prod s = s.comap (mul_hom.snd M N) :=
ext $ λ x, by simp [mem_prod, mul_hom.coe_snd]

@[simp, to_additive top_prod_top]
lemma top_prod_top : (⊤ : subsemigroup M).prod (⊤ : subsemigroup N) = ⊤ :=
(top_prod _).trans $ comap_top _

@[to_additive] lemma bot_prod_bot : (⊥ : subsemigroup M).prod (⊥ : subsemigroup N) = ⊥ :=
set_like.coe_injective $ by simp [coe_prod, prod.one_eq_mk]

/-- The product of subsemigroups is isomorphic to their product as semigroups. -/
@[to_additive prod_equiv "The product of additive subsemigroups is isomorphic to their product
as additive semigroups"]
def prod_equiv (s : subsemigroup M) (t : subsemigroup N) : s.prod t ≃* s × t :=
{ map_mul' := λ x y, rfl, .. equiv.set.prod ↑s ↑t }

open mul_hom

@[to_additive]
lemma mem_map_equiv {f : M ≃* N} {K : subsemigroup M} {x : N} :
  x ∈ K.map f.to_mul_hom ↔ f.symm x ∈ K :=
@set.mem_image_equiv _ _ ↑K f.to_equiv x

@[to_additive]
lemma map_equiv_eq_comap_symm (f : M ≃* N) (K : subsemigroup M) :
  K.map f.to_mul_hom = K.comap f.symm.to_mul_hom :=
set_like.coe_injective (f.to_equiv.image_eq_preimage K)

@[to_additive]
lemma comap_equiv_eq_map_symm (f : N ≃* M) (K : subsemigroup M) :
  K.comap f.to_mul_hom = K.map f.symm.to_mul_hom :=
(map_equiv_eq_comap_symm f.symm K).symm

@[simp, to_additive]
lemma map_equiv_top (f : M ≃* N) : (⊤ : subsemigroup M).map f.to_mul_hom = ⊤ :=
set_like.coe_injective $ set.image_univ.trans f.surjective.range_eq

@[to_additive le_prod_iff]
lemma le_prod_iff {s : subsemigroup M} {t : subsemigroup N} {u : subsemigroup (M × N)} :
  u ≤ s.prod t ↔ u.map (fst M N) ≤ s ∧ u.map (snd M N) ≤ t :=
begin
  split,
  { intros h,
    split,
    { rintros x ⟨⟨y1,y2⟩, ⟨hy1,rfl⟩⟩, exact (h hy1).1 },
    { rintros x ⟨⟨y1,y2⟩, ⟨hy1,rfl⟩⟩, exact (h hy1).2 }, },
  { rintros ⟨hH, hK⟩ ⟨x1, x2⟩ h, exact ⟨hH ⟨_ , h, rfl⟩, hK ⟨ _, h, rfl⟩⟩, }
end

end subsemigroup

namespace mul_hom

open subsemigroup

variables [has_mul M] [has_mul N] [has_mul P] (S : subsemigroup M)

/-- The range of a semigroup homomorphism is a subsemigroup. See Note [range copy pattern]. -/
@[to_additive "The range of an `add_hom` is an `add_subsemigroup`."]
def srange (f : M →ₙ* N) : subsemigroup N :=
((⊤ : subsemigroup M).map f).copy (set.range f) set.image_univ.symm

@[simp, to_additive]
lemma coe_srange (f : M →ₙ* N) :
  (f.srange : set N) = set.range f :=
rfl

@[simp, to_additive] lemma mem_srange {f : M →ₙ* N} {y : N} :
  y ∈ f.srange ↔ ∃ x, f x = y :=
iff.rfl

@[to_additive] lemma srange_eq_map (f : M →ₙ* N) : f.srange = (⊤ : subsemigroup M).map f :=
copy_eq _

@[to_additive]
lemma map_srange (g : N →ₙ* P) (f : M →ₙ* N) : f.srange.map g = (g.comp f).srange :=
by simpa only [srange_eq_map] using (⊤ : subsemigroup M).map_map g f

@[to_additive]
lemma srange_top_iff_surjective {N} [has_mul N] {f : M →ₙ* N} :
  f.srange = (⊤ : subsemigroup N) ↔ function.surjective f :=
set_like.ext'_iff.trans $ iff.trans (by rw [coe_srange, coe_top]) set.range_iff_surjective

/-- The range of a surjective semigroup hom is the whole of the codomain. -/
@[to_additive "The range of a surjective `add_semigroup` hom is the whole of the codomain."]
lemma srange_top_of_surjective {N} [has_mul N] (f : M →ₙ* N) (hf : function.surjective f) :
  f.srange = (⊤ : subsemigroup N) :=
srange_top_iff_surjective.2 hf

@[to_additive]
lemma mclosure_preimage_le (f : M →ₙ* N) (s : set N) :
  closure (f ⁻¹' s) ≤ (closure s).comap f :=
closure_le.2 $ λ x hx, set_like.mem_coe.2 $ mem_comap.2 $ subset_closure hx

/-- The image under a semigroup hom of the subsemigroup generated by a set equals the subsemigroup
generated by the image of the set. -/
@[to_additive "The image under an `add_semigroup` hom of the `add_subsemigroup` generated by a set
equals the `add_subsemigroup` generated by the image of the set."]
lemma map_mclosure (f : M →ₙ* N) (s : set M) :
  (closure s).map f = closure (f '' s) :=
le_antisymm
  (map_le_iff_le_comap.2 $ le_trans (closure_mono $ set.subset_preimage_image _ _)
    (mclosure_preimage_le _ _))
  (closure_le.2 $ set.image_subset _ subset_closure)

/-- Restriction of a semigroup hom to a subsemigroup of the domain. -/
@[to_additive "Restriction of an add_semigroup hom to an `add_subsemigroup` of the domain."]
def restrict {N : Type*} [has_mul N] [set_like σ M] [mul_mem_class σ M] (f : M →ₙ* N) (S : σ) :
  S →ₙ* N :=
f.comp (mul_mem_class.subtype S)

@[simp, to_additive]
lemma restrict_apply {N : Type*} [has_mul N] [set_like σ M] [mul_mem_class σ M] (f : M →ₙ* N)
  {S : σ} (x : S) : f.restrict S x = f x :=
rfl

/-- Restriction of a semigroup hom to a subsemigroup of the codomain. -/
@[to_additive "Restriction of an `add_semigroup` hom to an `add_subsemigroup` of the
codomain.", simps]
def cod_restrict [set_like σ N] [mul_mem_class σ N] (f : M →ₙ* N) (S : σ) (h : ∀ x, f x ∈ S) :
  M →ₙ* S :=
{ to_fun := λ n, ⟨f n, h n⟩,
  map_mul' := λ x y, subtype.eq (map_mul f x y) }

/-- Restriction of a semigroup hom to its range interpreted as a subsemigroup. -/
@[to_additive "Restriction of an `add_semigroup` hom to its range interpreted as a subsemigroup."]
def srange_restrict {N} [has_mul N] (f : M →ₙ* N) : M →ₙ* f.srange :=
f.cod_restrict f.srange $ λ x, ⟨x, rfl⟩

@[simp, to_additive]
lemma coe_srange_restrict {N} [has_mul N] (f : M →ₙ* N) (x : M) :
  (f.srange_restrict x : N) = f x :=
rfl

@[to_additive]
lemma srange_restrict_surjective (f : M →ₙ* N) : function.surjective f.srange_restrict :=
λ ⟨_, ⟨x, rfl⟩⟩, ⟨x, rfl⟩

@[to_additive]
lemma prod_map_comap_prod' {M' : Type*} {N' : Type*} [has_mul M'] [has_mul N']
  (f : M →ₙ* N) (g : M' →ₙ* N') (S : subsemigroup N) (S' : subsemigroup N') :
  (S.prod S').comap (prod_map f g) = (S.comap f).prod (S'.comap g) :=
set_like.coe_injective $ set.preimage_prod_map_prod f g _ _

/-- The `mul_hom` from the preimage of a subsemigroup to itself. -/
@[to_additive "the `add_hom` from the preimage of an additive subsemigroup to itself.", simps]
def subsemigroup_comap (f : M →ₙ* N) (N' : subsemigroup N) :
  N'.comap f →ₙ* N' :=
{ to_fun := λ x, ⟨f x, x.prop⟩,
  map_mul' := λ x y, subtype.eq (@map_mul M N _ _ _ _ f x y) }

/-- The `mul_hom` from a subsemigroup to its image.
See `mul_equiv.subsemigroup_map` for a variant for `mul_equiv`s. -/
@[to_additive "the `add_hom` from an additive subsemigroup to its image. See
`add_equiv.add_subsemigroup_map` for a variant for `add_equiv`s.", simps]
def subsemigroup_map (f : M →ₙ* N) (M' : subsemigroup M) :
  M' →ₙ* M'.map f :=
{ to_fun := λ x, ⟨f x, ⟨x, x.prop, rfl⟩⟩,
  map_mul' := λ x y, subtype.eq $ @map_mul M N _ _ _ _ f x y }

@[to_additive]
lemma subsemigroup_map_surjective (f : M →ₙ* N) (M' : subsemigroup M) :
  function.surjective (f.subsemigroup_map M') :=
by { rintro ⟨_, x, hx, rfl⟩, exact ⟨⟨x, hx⟩, rfl⟩ }

end mul_hom

namespace subsemigroup
open mul_hom

variables [has_mul M] [has_mul N] [has_mul P] (S : subsemigroup M)

@[simp, to_additive]
lemma srange_fst [nonempty N] : (fst M N).srange = ⊤ :=
(fst M N).srange_top_of_surjective $ prod.fst_surjective

@[simp, to_additive]
lemma srange_snd [nonempty M] : (snd M N).srange = ⊤ :=
(snd M N).srange_top_of_surjective $ prod.snd_surjective

@[to_additive]
lemma prod_eq_top_iff [nonempty M] [nonempty N] {s : subsemigroup M} {t : subsemigroup N} :
  s.prod t = ⊤ ↔ s = ⊤ ∧ t = ⊤ :=
by simp only [eq_top_iff, le_prod_iff, ← (gc_map_comap _).le_iff_le, ← srange_eq_map,
  srange_fst, srange_snd]

/-- The semigroup hom associated to an inclusion of subsemigroups. -/
@[to_additive "The `add_semigroup` hom associated to an inclusion of subsemigroups."]
def inclusion {S T : subsemigroup M} (h : S ≤ T) : S →ₙ* T :=
(mul_mem_class.subtype S).cod_restrict _ (λ x, h x.2)

@[simp, to_additive]
lemma range_subtype (s : subsemigroup M) : (mul_mem_class.subtype s).srange = s :=
set_like.coe_injective $ (coe_srange _).trans $ subtype.range_coe

@[to_additive] lemma eq_top_iff' : S = ⊤ ↔ ∀ x : M, x ∈ S :=
eq_top_iff.trans ⟨λ h m, h $ mem_top m, λ h m _, h m⟩

end subsemigroup

namespace mul_equiv

variables [has_mul M] [has_mul N] {S T : subsemigroup M}

/-- Makes the identity isomorphism from a proof that two subsemigroups of a multiplicative
    semigroup are equal. -/
@[to_additive "Makes the identity additive isomorphism from a proof two
subsemigroups of an additive semigroup are equal."]
def subsemigroup_congr (h : S = T) : S ≃* T :=
{ map_mul' :=  λ _ _, rfl, ..equiv.set_congr $ congr_arg _ h }

-- this name is primed so that the version to `f.range` instead of `f.srange` can be unprimed.
/-- A semigroup homomorphism `f : M →ₙ* N` with a left-inverse `g : N → M` defines a multiplicative
equivalence between `M` and `f.srange`.

This is a bidirectional version of `mul_hom.srange_restrict`. -/
@[to_additive /-"
An additive semigroup homomorphism `f : M →+ N` with a left-inverse `g : N → M` defines an additive
equivalence between `M` and `f.srange`.

This is a bidirectional version of `add_hom.srange_restrict`. "-/, simps {simp_rhs := tt}]
def of_left_inverse (f : M →ₙ* N) {g : N → M} (h : function.left_inverse g f) : M ≃* f.srange :=
{ to_fun := f.srange_restrict,
  inv_fun := g ∘ (mul_mem_class.subtype f.srange),
  left_inv := h,
  right_inv := λ x, subtype.ext $
    let ⟨x', hx'⟩ := mul_hom.mem_srange.mp x.prop in
    show f (g x) = x, by rw [←hx', h x'],
  .. f.srange_restrict }

/-- A `mul_equiv` `φ` between two semigroups `M` and `N` induces a `mul_equiv` between
a subsemigroup `S ≤ M` and the subsemigroup `φ(S) ≤ N`.
See `mul_hom.subsemigroup_map` for a variant for `mul_hom`s. -/
@[to_additive "An `add_equiv` `φ` between two additive semigroups `M` and `N` induces an `add_equiv`
between a subsemigroup `S ≤ M` and the subsemigroup `φ(S) ≤ N`. See `add_hom.add_subsemigroup_map`
for a variant for `add_hom`s.", simps]
def subsemigroup_map (e : M ≃* N) (S : subsemigroup M) : S ≃* S.map e.to_mul_hom :=
{ to_fun := λ x, ⟨e x, _⟩,
  inv_fun := λ x, ⟨e.symm x, _⟩, -- we restate this for `simps` to avoid `⇑e.symm.to_equiv x`
  ..e.to_mul_hom.subsemigroup_map S,
  ..e.to_equiv.image S }

end mul_equiv


/-
Copyright (c) 2021 James Gallicchio.

Authors: James Gallicchio
-/

import LeanColls.AuxLemmas

/-!
# Finger Trees

TODO: Describe

## References

See [Matthieu2007], section 4

-/

inductive Digit (τ : Type u) (msr : τ → M) [Monoid M]
| Digit1 : (a : τ) →
            Cached (msr a) → Digit τ msr
| Digit2 : (a : τ) → (b : τ) →
            Cached (msr a ++ msr b) → Digit τ msr
| Digit3 : (a : τ) → (b : τ) → (c : τ) →
            Cached (msr a ++ msr b ++ msr c) → Digit τ msr
| Digit4 : (a : τ) → (b : τ) → (c : τ) → (d : τ) →
            Cached (msr a ++ msr b ++ msr c ++ msr d) → Digit τ msr

namespace Digit
variable {msr : τ → M} [Monoid M] (d : Digit τ msr)

@[inline]
def tryAddLeft (a : τ) (av : Cached (msr a)) (sc : Digit τ msr → α) (fc : τ → τ → τ → τ → α) : α :=
  match d with
  | Digit1 b       v => sc (Digit2 a b ⟨av.1 ++ v.1,by simp [av.2]⟩)
  | Digit2 b c     v => sc (Digit3 a b c ⟨av.1 ++ v.1,by simp [av.2]⟩)
  | Digit3 b c d   v => sc (Digit4 a b c d ⟨av.1 ++ v.1,by simp [av.2]⟩)
  | Digit4 b c d e _ => fc b c d e

@[inline]
def tryFront (sc : τ → Digit τ msr → α) (fc : (a : τ) → Cached (msr a) → α) : α :=
  match d with
  | Digit1 a       v => fc a v
  | Digit2 a b     _ => sc a (Digit1 b (cached (msr b)))
  | Digit3 a b c   _ => sc a (Digit2 b c (cached (msr b ++ msr c)))
  | Digit4 a b c d _ => sc a (Digit3 b c d (cached (msr b ++ msr c ++ msr d)))

@[inline]
def tryAddRight (z : τ) (zv : Cached (msr z)) (sc : Digit τ msr → α) (fc : τ → τ → τ → τ → α) : α :=
  match h':d with
  | Digit1 y       v => sc (Digit2 y z ⟨v.1 ++ zv.1,by simp [zv.2]⟩)
  | Digit2 x y     v => sc (Digit3 x y z ⟨v.1 ++ zv.1,by simp [zv.2]⟩)
  | Digit3 w x y   v => sc (Digit4 w x y z ⟨v.1 ++ zv.1,by simp [zv.2]⟩)
  | Digit4 v w x y _ => fc v w x y

@[inline]
def tryBack (sc : τ → Digit τ msr → α) (fc : (a : τ) → Cached (msr a) → α) : α :=
  match d with
  | Digit1 z       v => fc z v
  | Digit2 y z     v => sc z (Digit1 y (cached (msr y)))
  | Digit3 x y z   v => sc z (Digit2 x y (cached (msr x ++ msr y)))
  | Digit4 w x y z v => sc z (Digit3 w x y (cached (msr w ++ msr x ++ msr y)))

def toList : Digit τ msr → List τ
| Digit1 a       _ => [a]
| Digit2 a b     _ => [a,b]
| Digit3 a b c   _ => [a,b,c]
| Digit4 a b c d _ => [a,b,c,d]

end Digit

open Digit

inductive Node (τ : Type u) (msr : τ → M) [Monoid M]
| Node2 : (a : τ) → (b : τ) →
          Cached (msr a ++ msr b) → Node τ msr
| Node3 : (a : τ) → (b : τ) → (c : τ) →
          Cached (msr a ++ msr b ++ msr c) → Node τ msr

namespace Node

def toDigit {msr : τ → M} [Monoid M] : Node τ msr → Digit τ msr
| Node2 a b   => Digit.Digit2 a b (cached (msr a ++ msr b))
| Node3 a b c => Digit.Digit3 a b c (cached (msr a ++ msr b ++ msr c))

def toList {msr : τ → M} [Monoid M] : Node τ msr → List τ
| Node2 a b   => [a,b]
| Node3 a b c => [a,b,c]

end  Node

open Node

inductive FingerTree [Monoid M] : (τ : Type u) → (msr : τ → M) → Type (u+3000)
| Empty : FingerTree τ msr
| Single : (t : τ) → FingerTree τ msr
| Deep : Digit τ msr → FingerTree (Node τ) msr → Digit τ msr → FingerTree τ msr

namespace FingerTree

def toList : FingerTree τ → List τ
| Empty => []
| Single x => [x]
| Deep pr tr sf => pr.toList ++ (tr.toList.bind Node.toList) ++ sf.toList

@[inline]
def cons (f : FingerTree τ) (a : τ) : FingerTree τ :=
  match f with
  | Empty => Single a
  | Single b => Deep (Digit1 a) Empty (Digit1 b)
  | Deep pr tr sf =>
    tryAddLeft pr a
      (λ pr' => Deep pr' tr sf)
      (λ b c d e => Deep (Digit2 a b) (tr.cons (Node3 c d e)) sf)

@[inline]
def front? (f : FingerTree τ) : Option (τ × FingerTree τ) :=
  match f with
  | Empty         => none
  | Single a      => some (a, Empty)
  | Deep pr tr sf => some (
    tryFront pr
      (λ a pr' => (a, Deep pr' tr sf))
      (λ a => /- pr = Digit1 a -/ (a,
        match front? tr with
        | some (n, tr') => Deep n.toDigit tr' sf
        | none => /- tr empty -/
          tryFront sf
            (λ b sf' => Deep (Digit1 b) Empty sf')
            (λ b => /- sf = Digit1 b -/
              Single b))))

theorem toList_cons (f : FingerTree τ) (a : τ)
  : (f.cons a).toList = a :: f.toList
  := by
  induction f
  simp [cons, toList]
  simp [cons, toList, Digit.toList, List.bind, List.map, List.join]
  case Deep pr tr sf ih =>
  simp [cons, tryAddLeft]
  split
  simp [toList, Digit.toList, List.bind, List.map, List.join]
  simp [toList, Digit.toList, List.bind, List.map, List.join]
  simp [toList, Digit.toList, List.bind, List.map, List.join]
  case h_4 b c d e =>
  simp [toList, Digit.toList, List.bind, List.map, List.join, ih]
  split
  simp [toList, Digit.toList, Node.toList, List.bind, List.map, List.join]
  simp [toList, Digit.toList, Node.toList, List.bind, List.map, List.join]
  simp [toList, Digit.toList, Node.toList, List.bind, List.map, List.join]
  simp [toList, Digit.toList, Node.toList, List.bind, List.map, List.join]

theorem toList_front (f : FingerTree τ)
  : f.front?.map (λ (a,f') => (a,f'.toList)) = f.toList.front?
  := by
  induction f
  simp [front?, toList, List.front?, Option.map, Option.bind]
  simp [front?, toList, List.front?, Option.map, Option.bind]
  case Deep pr tr sf ih =>
  match pr with
  | Digit2 a b     => simp [front?, toList, List.front?, tryFront, Option.map, Option.bind, HAppend.hAppend, Append.append, List.append]
  | Digit3 a b c   => simp [front?, toList, List.front?, tryFront, Option.map, Option.bind, HAppend.hAppend, Append.append, List.append]
  | Digit4 a b c d => simp [front?, toList, List.front?, tryFront, Option.map, Option.bind, HAppend.hAppend, Append.append, List.append]
  | Digit1 a =>
    match h:front? tr with
    | some (t,tr') =>
      rw [h] at ih
      simp [Option.map, Option.bind, List.front?] at ih
      split at ih
      contradiction
      case h_2 h_tr x =>
      cases x
      simp [h,h_tr,front?, toList, List.front?, tryFront, Option.map, Option.bind, HAppend.hAppend, Append.append, List.append, List.bind, List.map, List.join]
      cases t
      repeat {simp [Digit.toList, Node.toDigit, Node.toList]}
    | none =>
      rw [h] at ih
      simp [Option.map, Option.bind, List.front?] at ih
      split at ih
      focus {
        case h_1 h_tr x =>
        simp [h,h_tr,front?, toList, List.front?, tryFront, Option.map, Option.bind, HAppend.hAppend, Append.append, List.append, List.bind, List.map, List.join]
        split
        simp [Digit.toList, toList, List.bind, List.join, List.map]
        simp [Digit.toList, toList, List.bind, List.join, List.map]
        simp [Digit.toList, toList, List.bind, List.join, List.map]
        simp [Digit.toList, toList, List.bind, List.join, List.map]
      }
      contradiction

def snoc (f : FingerTree τ) (z : τ) : FingerTree τ :=
  match f with
  | Empty => Single z
  | Single b => Deep (Digit1 b) Empty (Digit1 z)
  | Deep pr tr sf =>
    tryAddRight sf z
      (λ sf' => Deep pr tr sf')
      (λ a b c d => Deep pr (tr.snoc (Node3 a b c)) (Digit2 d z))

def back? (f : FingerTree τ) : Option (FingerTree τ × τ) :=
  match f with
  | Empty         => none
  | Single z      => some (Empty, z)
  | Deep pr tr sf => some (
    tryBack pr
      (λ z sf' => (Deep pr tr sf', z))
      (λ z => /- sf = Digit1 z -/ (
        match back? tr with
        | some (tr', n) => Deep pr tr' n.toDigit
        | none => /- tr empty -/
          tryBack pr
            (λ y pr' => Deep pr' Empty (Digit1 y))
            (λ y => /- pr = Digit1 y -/
              Single y),
        z)))

theorem toList_snoc (f : FingerTree τ) (a : τ)
  : (f.snoc a).toList = f.toList.concat a
  := by
  induction f
  simp [snoc, toList, List.concat]
  simp [snoc, toList, Digit.toList, List.bind, List.map, List.join, List.concat]
  case Deep pr tr sf ih =>
  simp [snoc, tryAddRight]
  split
  simp [toList, Digit.toList, List.bind, List.map, List.join, List.concat_append, List.concat]
  simp [toList, Digit.toList, List.bind, List.map, List.join, List.concat_append, List.concat]
  simp [toList, Digit.toList, List.bind, List.map, List.join, List.concat_append, List.concat]
  case h_4 b c d e =>
  simp [toList, Digit.toList, List.bind, List.map, List.join, ih, List.concat_append, List.concat]
  split
  simp [toList, Digit.toList, Node.toList, List.bind, List.map, List.join, List.concat_append, List.concat, List.map_concat, List.join_concat, List.append_assoc]
  simp [toList, Digit.toList, Node.toList, List.bind, List.map, List.join, List.concat_append, List.concat, List.map_concat, List.join_concat, List.append_assoc]
  simp [toList, Digit.toList, Node.toList, List.bind, List.map, List.join, List.concat_append, List.concat, List.map_concat, List.join_concat, List.append_assoc]
  simp [toList, Digit.toList, Node.toList, List.bind, List.map, List.join, List.concat_append, List.concat, List.map_concat, List.join_concat, List.append_assoc]

theorem toList_back (f : FingerTree τ)
  : f.back?.map (λ (f',a) => (f'.toList,a)) = f.toList.back?
  := by sorry

def append (f1 f2 : FingerTree τ) : FingerTree τ :=
  match f1, f2 with
  | f1, Empty => f1
  | Empty, f2 => f2
  | f1, Single z => f1.snoc z
  | Single a, f1 => f1.cons a
  | Deep pr1 tr1 sf1, Deep pr2 tr2 sf2 =>
    let tr' := match sf1, pr2 with
    | Digit1 a, Digit1 b => (tr1.snoc (Node2 a b)).append tr2
    | Digit2 a b, Digit1 c => (tr1.snoc (Node3 a b c)).append tr2
    | Digit1 a, Digit2 b c => tr1.append (tr2.cons (Node3 a b c))
    | Digit3 a b c, Digit1 d => (tr1.snoc (Node2 a b)).append (tr2.cons (Node2 c d))
    | Digit2 a b, Digit2 c d => (tr1.snoc (Node2 a b)).append (tr2.cons (Node2 c d))
    | Digit1 a, Digit3 b c d => (tr1.snoc (Node2 a b)).append (tr2.cons (Node2 c d))
    | Digit4 a b c d, Digit1 e => (tr1.snoc (Node3 a b c)).append (tr2.cons (Node2 d e))
    | Digit3 a b c, Digit2 d e => (tr1.snoc (Node3 a b c)).append (tr2.cons (Node2 d e))
    | Digit2 a b, Digit3 c d e => (tr1.snoc (Node2 a b)).append (tr2.cons (Node3 c d e))
    | Digit1 a, Digit4 b c d e => (tr1.snoc (Node2 a b)).append (tr2.cons (Node3 c d e))
    | Digit4 a b c d, Digit2 e f => (tr1.snoc (Node3 a b c)).append (tr2.cons (Node3 d e f))
    | Digit3 a b c, Digit3 d e f => (tr1.snoc (Node3 a b c)).append (tr2.cons (Node3 d e f))
    | Digit2 a b, Digit4 c d e f => (tr1.snoc (Node3 a b c)).append (tr2.cons (Node3 d e f))
    | Digit4 a b c d, Digit3 e f g => (tr1.snoc (Node3 a b c)).append ((tr2.cons (Node2 f g)).cons (Node2 d e))
    | Digit3 a b c, Digit4 d e f g => ((tr1.snoc (Node2 a b)).snoc (Node2 c d)).append (tr2.cons (Node3 e f g))
    | Digit4 a b c d, Digit4 e f g h => (tr1.snoc (Node3 a b c)).append ((tr2.cons (Node3 f g h)).cons (Node2 d e))

    Deep pr1 tr' sf2

end FingerTree


/-
Copyright (c) 2021 Alena Gusakov, Bhavik Mehta, Kyle Miller. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Alena Gusakov, Bhavik Mehta, Kyle Miller
-/
import data.fintype.basic
import data.set.finite

/-!
# Hall's Marriage Theorem for finite index types

This module proves the basic form of Hall's theorem.
In constrast to the theorem described in `combinatorics.hall.basic`, this
version requires that the indexed family `t : ι → finset α` have `ι` be a `fintype`.
The `combinatorics.hall.basic` module applies a compactness argument to this version
to remove the `fintype` constraint on `ι`.

The modules are split like this since the generalized statement
depends on the topology and category theory libraries, but the finite
case in this module has few dependencies.

A description of this formalization is in [Gusakov2021].

## Main statements

* `finset.all_card_le_bUnion_card_iff_exists_injective'` is Hall's theorem with
  a finite index set.  This is elsewhere generalized to
  `finset.all_card_le_bUnion_card_iff_exists_injective`.

## Tags

Hall's Marriage Theorem, indexed families
-/

open finset

universes u v

namespace hall_marriage_theorem

variables {ι : Type u} {α : Type v} [fintype ι]

theorem hall_hard_inductive_zero (t : ι → finset α) (hn : fintype.card ι = 0) :
  ∃ (f : ι → α), function.injective f ∧ ∀ x, f x ∈ t x :=
begin
  rw fintype.card_eq_zero_iff at hn,
  exactI ⟨is_empty_elim, is_empty_elim, is_empty_elim⟩,
end

variables {t : ι → finset α} [decidable_eq α]

lemma hall_cond_of_erase {x : ι} (a : α)
  (ha : ∀ (s : finset ι), s.nonempty → s ≠ univ → s.card < (s.bUnion t).card)
  (s' : finset {x' : ι | x' ≠ x}) :
  s'.card ≤ (s'.bUnion (λ x', (t x').erase a)).card :=
begin
  haveI := classical.dec_eq ι,
  specialize ha (s'.image coe),
  rw [nonempty.image_iff, finset.card_image_of_injective s' subtype.coe_injective] at ha,
  by_cases he : s'.nonempty,
  { have ha' : s'.card < (s'.bUnion (λ x, t x)).card,
    { specialize ha he (λ h, by { have h' := mem_univ x, rw ←h at h', simpa using h' }),
      convert ha using 2,
      ext x,
      simp only [mem_image, mem_bUnion, exists_prop, set_coe.exists,
                 exists_and_distrib_right, exists_eq_right, subtype.coe_mk], },
    rw ←erase_bUnion,
    by_cases hb : a ∈ s'.bUnion (λ x, t x),
    { rw card_erase_of_mem hb,
      exact nat.le_pred_of_lt ha' },
    { rw erase_eq_of_not_mem hb,
      exact nat.le_of_lt ha' }, },
  { rw [nonempty_iff_ne_empty, not_not] at he,
    subst s',
    simp },
end

/--
First case of the inductive step: assuming that
`∀ (s : finset ι), s.nonempty → s ≠ univ → s.card < (s.bUnion t).card`
and that the statement of **Hall's Marriage Theorem** is true for all
`ι'` of cardinality ≤ `n`, then it is true for `ι` of cardinality `n + 1`.
-/
lemma hall_hard_inductive_step_A {n : ℕ} (hn : fintype.card ι = n + 1)
  (ht : ∀ (s : finset ι), s.card ≤ (s.bUnion t).card)
  (ih : ∀ {ι' : Type u} [fintype ι'] (t' : ι' → finset α),
        by exactI fintype.card ι' ≤ n →
                  (∀ (s' : finset ι'), s'.card ≤ (s'.bUnion t').card) →
                  ∃ (f : ι' → α), function.injective f ∧ ∀ x, f x ∈ t' x)
  (ha : ∀ (s : finset ι), s.nonempty → s ≠ univ → s.card < (s.bUnion t).card) :
  ∃ (f : ι → α), function.injective f ∧ ∀ x, f x ∈ t x :=
begin
  haveI : nonempty ι := fintype.card_pos_iff.mp (hn.symm ▸ nat.succ_pos _),
  haveI := classical.dec_eq ι,
  /- Choose an arbitrary element `x : ι` and `y : t x`. -/
  let x := classical.arbitrary ι,
  have tx_ne : (t x).nonempty,
  { rw ←finset.card_pos,
    apply nat.lt_of_lt_of_le nat.one_pos,
    convert ht {x},
    rw finset.singleton_bUnion, },
  rcases classical.indefinite_description _ tx_ne with ⟨y, hy⟩,
  /- Restrict to everything except `x` and `y`. -/
  let ι' := {x' : ι | x' ≠ x},
  let t' : ι' → finset α := λ x', (t x').erase y,
  have card_ι' : fintype.card ι' = n,
  { convert congr_arg (λ m, m - 1) hn,
    convert set.card_ne_eq _, },
  rcases ih t' card_ι'.le (hall_cond_of_erase y ha) with ⟨f', hfinj, hfr⟩,
  /- Extend the resulting function. -/
  refine ⟨λ z, if h : z = x then y else f' ⟨z, h⟩, _, _⟩,
  { rintro z₁ z₂,
    have key : ∀ {x}, y ≠ f' x,
    { intros x h,
      specialize hfr x,
      rw ←h at hfr,
      simpa using hfr, },
    by_cases h₁ : z₁ = x; by_cases h₂ : z₂ = x; simp [h₁, h₂, hfinj.eq_iff, key, key.symm], },
  { intro z,
    split_ifs with hz,
    { rwa hz },
    { specialize hfr ⟨z, hz⟩,
      rw mem_erase at hfr,
      exact hfr.2, }, },
end

lemma hall_cond_of_restrict {ι : Type u} {t : ι → finset α} {s : finset ι}
  (ht : ∀ (s : finset ι), s.card ≤ (s.bUnion t).card)
  (s' : finset (s : set ι)) :
  s'.card ≤ (s'.bUnion (λ a', t a')).card :=
begin
  haveI := classical.dec_eq ι,
  convert ht (s'.image coe) using 1,
  { rw card_image_of_injective _ subtype.coe_injective, },
  { apply congr_arg,
    ext y,
    simp, },
end

lemma hall_cond_of_compl {ι : Type u} {t : ι → finset α} {s : finset ι}
  (hus : s.card = (s.bUnion t).card)
  (ht : ∀ (s : finset ι), s.card ≤ (s.bUnion t).card)
  (s' : finset (sᶜ : set ι)) :
  s'.card ≤ (s'.bUnion (λ x', t x' \ s.bUnion t)).card :=
begin
  haveI := classical.dec_eq ι,
  have : s'.card = (s ∪ s'.image coe).card - s.card,
  { rw [card_disjoint_union, add_tsub_cancel_left,
        card_image_of_injective _ subtype.coe_injective],
    simp only [disjoint_left, not_exists, mem_image, exists_prop, set_coe.exists,
               exists_and_distrib_right, exists_eq_right, subtype.coe_mk],
    intros x hx hc h,
    exact (hc hx).elim },
  rw [this, hus],
  apply (tsub_le_tsub_right (ht _) _).trans _,
  rw ← card_sdiff,
  { have : (s ∪ s'.image subtype.val).bUnion t \ s.bUnion t ⊆ s'.bUnion (λ x', t x' \ s.bUnion t),
    { intros t,
      simp only [mem_bUnion, mem_sdiff, not_exists, mem_image, and_imp, mem_union,
                 exists_and_distrib_right, exists_imp_distrib],
      rintro x (hx | ⟨x', hx', rfl⟩) rat hs,
      { exact (hs x hx rat).elim },
      { exact ⟨⟨x', hx', rat⟩, hs⟩, } },
    exact (card_le_of_subset this).trans le_rfl, },
  { apply bUnion_subset_bUnion_of_subset_left,
    apply subset_union_left }
end

/--
Second case of the inductive step: assuming that
`∃ (s : finset ι), s ≠ univ → s.card = (s.bUnion t).card`
and that the statement of Hall's Marriage Theorem is true for all
`ι'` of cardinality ≤ `n`, then it is true for `ι` of cardinality `n + 1`.
-/
lemma hall_hard_inductive_step_B {n : ℕ} (hn : fintype.card ι = n + 1)
  (ht : ∀ (s : finset ι), s.card ≤ (s.bUnion t).card)
  (ih : ∀ {ι' : Type u} [fintype ι'] (t' : ι' → finset α),
        by exactI fintype.card ι' ≤ n →
                  (∀ (s' : finset ι'), s'.card ≤ (s'.bUnion t').card) →
                  ∃ (f : ι' → α), function.injective f ∧ ∀ x, f x ∈ t' x)
  (s : finset ι)
  (hs : s.nonempty)
  (hns : s ≠ univ)
  (hus : s.card = (s.bUnion t).card) :
  ∃ (f : ι → α), function.injective f ∧ ∀ x, f x ∈ t x :=
begin
  haveI := classical.dec_eq ι,
  /- Restrict to `s` -/
  let t' : s → finset α := λ x', t x',
  rw nat.add_one at hn,
  have card_ι'_le : fintype.card s ≤ n,
  { apply nat.le_of_lt_succ,
    rw ←hn,
    convert (card_lt_iff_ne_univ _).mpr hns,
    convert fintype.card_coe _ },
  rcases ih t' card_ι'_le (hall_cond_of_restrict ht) with ⟨f', hf', hsf'⟩,
  /- Restrict to `sᶜ` in the domain and `(s.bUnion t)ᶜ` in the codomain. -/
  set ι'' := (s : set ι)ᶜ with ι''_def,
  let t'' : ι'' → finset α := λ a'', t a'' \ s.bUnion t,
  have card_ι''_le : fintype.card ι'' ≤ n,
  { apply nat.le_of_lt_succ,
    rw ←hn,
    convert (card_compl_lt_iff_nonempty _).mpr hs,
    convert fintype.card_coe (sᶜ),
    exact (finset.coe_compl s).symm },
  rcases ih t'' card_ι''_le (hall_cond_of_compl hus ht) with ⟨f'', hf'', hsf''⟩,
  /- Put them together -/
  have f'_mem_bUnion : ∀ {x'} (hx' : x' ∈ s), f' ⟨x', hx'⟩ ∈ s.bUnion t,
  { intros x' hx',
    rw mem_bUnion,
    exact ⟨x', hx', hsf' _⟩, },
  have f''_not_mem_bUnion : ∀ {x''} (hx'' : ¬ x'' ∈ s), ¬ f'' ⟨x'', hx''⟩ ∈ s.bUnion t,
  { intros x'' hx'',
    have h := hsf'' ⟨x'', hx''⟩,
    rw mem_sdiff at h,
    exact h.2, },
  have im_disj : ∀ {x' x'' : ι} {hx' : x' ∈ s} {hx'' : ¬x'' ∈ s}, f' ⟨x', hx'⟩ ≠ f'' ⟨x'', hx''⟩,
  { intros _ _ hx' hx'' h,
    apply f''_not_mem_bUnion hx'',
    rw ←h,
    apply f'_mem_bUnion, },
  refine ⟨λ x, if h : x ∈ s then f' ⟨x, h⟩ else f'' ⟨x, h⟩, _, _⟩,
  { exact hf'.dite _ hf'' @im_disj },
  { intro x,
    split_ifs,
    { exact hsf' ⟨x, h⟩ },
    { exact sdiff_subset _ _ (hsf'' ⟨x, h⟩) } }
end

/--
If `ι` has cardinality `n + 1` and the statement of Hall's Marriage Theorem
is true for all `ι'` of cardinality ≤ `n`, then it is true for `ι`.
-/
theorem hall_hard_inductive_step {n : ℕ} (hn : fintype.card ι = n + 1)
  (ht : ∀ (s : finset ι), s.card ≤ (s.bUnion t).card)
  (ih : ∀ {ι' : Type u} [fintype ι'] (t' : ι' → finset α),
        by exactI fintype.card ι' ≤ n →
                  (∀ (s' : finset ι'), s'.card ≤ (s'.bUnion t').card) →
                  ∃ (f : ι' → α), function.injective f ∧ ∀ x, f x ∈ t' x) :
  ∃ (f : ι → α), function.injective f ∧ ∀ x, f x ∈ t x :=
begin
  by_cases h : ∀ (s : finset ι), s.nonempty → s ≠ univ → s.card < (s.bUnion t).card,
  { exact hall_hard_inductive_step_A hn ht @ih h, },
  { push_neg at h,
    rcases h with ⟨s, sne, snu, sle⟩,
    have seq := nat.le_antisymm (ht _) sle,
    exact hall_hard_inductive_step_B hn ht @ih s sne snu seq, },
end

/--
Here we combine the base case and the inductive step into
a full strong induction proof, thus completing the proof
of the second direction.
-/
theorem hall_hard_inductive {n : ℕ} (hn : fintype.card ι = n)
  (ht : ∀ (s : finset ι), s.card ≤ (s.bUnion t).card) :
  ∃ (f : ι → α), function.injective f ∧ ∀ x, f x ∈ t x :=
begin
  tactic.unfreeze_local_instances,
  revert ι,
  refine nat.strong_induction_on n (λ n' ih, _),
  intros _ _ t hn ht,
  rcases n' with (_|_),
  { exact hall_hard_inductive_zero t hn },
  { apply hall_hard_inductive_step hn ht,
    introsI ι' _ _ hι',
    exact ih (fintype.card ι') (nat.lt_succ_of_le hι') rfl, },
end

end hall_marriage_theorem

/--
This is the version of **Hall's Marriage Theorem** in terms of indexed
families of finite sets `t : ι → finset α` with `ι` a `fintype`.
It states that there is a set of distinct representatives if and only
if every union of `k` of the sets has at least `k` elements.

See `finset.all_card_le_bUnion_card_iff_exists_injective` for a version
where the `fintype ι` constraint is removed.
-/
theorem finset.all_card_le_bUnion_card_iff_exists_injective'
  {ι α : Type*} [fintype ι] [decidable_eq α] (t : ι → finset α) :
  (∀ (s : finset ι), s.card ≤ (s.bUnion t).card) ↔
    (∃ (f : ι → α), function.injective f ∧ ∀ x, f x ∈ t x) :=
begin
  split,
  { exact hall_marriage_theorem.hall_hard_inductive rfl },
  { rintro ⟨f, hf₁, hf₂⟩ s,
    rw ←card_image_of_injective s hf₁,
    apply card_le_of_subset,
    intro _,
    rw [mem_image, mem_bUnion],
    rintros ⟨x, hx, rfl⟩,
    exact ⟨x, hx, hf₂ x⟩, },
end