/-
Copyright (c) 2018 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Simon Hudon
-/
import data.pfun category.functor category.applicative data.list.sort data.list.basic

universes u v

lemma eq_mp_heq :
  ∀ {α β : Sort*} {a : α} {a' : β} (h₂ : a == a'), (eq.mp (type_eq_of_heq h₂) a) = a'
| α ._ a a' heq.rfl := rfl

namespace sigma
variables {α₁ α₂ α₃ : Type u}
variables {β₁ : α₁ → Type v} {β₂ : α₂ → Type v} {β₃ : α₃ → Type v}
variables {g : sigma β₂ → sigma β₃} {f : sigma β₁ → sigma β₂}

theorem eq_fst {s₁ s₂ : sigma β₁} : s₁ = s₂ → s₁.1 = s₂.1 :=
by cases s₁; cases s₂; cc

theorem eq_snd {s₁ s₂ : sigma β₁} : s₁ = s₂ → s₁.2 == s₂.2 :=
by cases s₁; cases s₂; cc

@[extensionality]
lemma ext {x₀ x₁ : sigma β₁}
  (h₀ : x₀.1 = x₁.1)
  (h₁ : x₀.1 = x₁.1 → x₀.2 == x₁.2) :
  x₀ = x₁ :=
by casesm* sigma _; cases h₀; cases h₁ h₀; refl

lemma eta (x : sigma β₁) : sigma.mk x.1 x.2 = x :=
by cases x; refl

end sigma

namespace list

def zip_with₃ {α β γ φ} (f : α → β → γ → φ) : list α → list β → list γ → list φ
| (x::xs) (y::ys) (z::zs) := f x y z :: zip_with₃ xs ys zs
| _ _ _ := []

variables {m : Type u → Type v} [applicative m]

def mzip_with₃ {α β γ φ} (f : α → β → γ → m φ) : list α → list β → list γ → m (list φ)
| (x::xs) (y::ys) (z::zs) := (::) <$> f x y z <*> mzip_with₃ xs ys zs
| _ _ _ := pure []

def mzip_with₄ {α β γ φ ψ} (f : α → β → γ → φ → m ψ) :
  list α → list β → list γ → list φ → m (list ψ)
| (w :: ws) (x::xs) (y::ys) (z::zs) := (::) <$> f w x y z <*> mzip_with₄ ws xs ys zs
| _ _ _ _ := pure []

-- def mmap_enum_if' {α} (p : α → Prop) [decidable_pred p] (f : ℕ → α → m α) : ℕ → list α → m (list α)
-- | n [] := pure []
-- | n (x :: xs) :=
--   if p x then (::) <$> f n x <*> mmap_enum_if' (n+1) xs
--          else cons x <$> mmap_enum_if' n xs

-- def mmap_enum_if {α} (p : α → Prop) [decidable_pred p] (f : ℕ → α → m α) : list α → m (list α) :=
-- mmap_enum_if' p f 0

end list
namespace roption
variables {α : Type*} {β : Type*} {γ : Type*}

open function
lemma assert_if_neg {p : Prop}
  (x : p → roption α)
  (h : ¬ p)
: assert p x = roption.none :=
by { dsimp [assert,roption.none],
     have : (∃ (h : p), (x h).dom) ↔ false,
     { split ; intros h' ; repeat { cases h' with h' },
       exact h h' },
     congr,
     repeat { rw this <|> apply hfunext },
     intros h h', cases h', }

lemma assert_if_pos {p : Prop}
  (x : p → roption α)
  (h : p)
: assert p x = x h :=
by { dsimp [assert],
     have : (∃ (h : p), (x h).dom) ↔ (x h).dom,
     { split ; intros h'
       ; cases h' <|> split
       ; assumption, },
     cases hx : x h, congr, rw [this,hx],
     apply hfunext, rw [this,hx],
     intros, simp [hx] }

@[simp]
lemma roption.none_bind {α β : Type*} (f : α → roption β)
: roption.none >>= f = roption.none :=
by simp [roption.none,has_bind.bind,roption.bind,assert_if_neg]

end roption

namespace monad

@[simp]
lemma bind_pure_star {m} [monad m] [is_lawful_monad m] (x : m punit) :
  x >>= (λ (_x : punit), pure punit.star : punit → m punit) = x :=
by { transitivity,
     { apply congr_arg, ext z, cases z, refl },
     { simp } }

variables {α β γ : Type u}
variables {m : Type u → Type v} [monad m]

@[reducible]
def pipe (a : α → m β) (b : β → m γ) : α → m γ :=
λ x, a x >>= b

infixr ` >=> `:55 := pipe

@[functor_norm]
lemma map_bind_eq_bind_comp {α β γ} {m} [monad m] [is_lawful_monad m]
  (f : α → β) (cmd : m α) (g : β → m γ) :
  (f <$> cmd) >>= g = cmd >>= g ∘ f :=
by rw [← bind_pure_comp_eq_map,bind_assoc,(∘)]; simp

@[functor_norm]
lemma bind_map {α β γ} {m} [monad m] [is_lawful_monad m]
  (f : α → γ → β) (cmd : m α) (g : α → m γ) :
  cmd >>= (λ x, f x <$> g x) = do { x ← cmd, y ← g x, pure $ f x y }  :=
by congr; ext; rw [← bind_pure (g x),map_bind]; simp

@[functor_norm]
lemma bind_seq {α β γ : Type u} {m} [monad m] [is_lawful_monad m]
  (f : α → m (γ → β)) (cmd : m α) (g : α → m γ) :
  cmd >>= (λ x, f x <*> g x) = do { x ← cmd, h ← f x, y ← g x, pure $ h y }  :=
by congr; ext; simp [seq_eq_bind_map] with functor_norm

end monad

attribute [functor_norm] bind_assoc has_bind.and_then map_bind seq_left_eq seq_right_eq

namespace sum

variables {e : Type v} {α β : Type u}

protected def seq : Π (x : sum e (α → β)) (f : sum e α), sum e β
| (sum.inl e) _ := sum.inl e
| (sum.inr f) x := f <$> x

instance : applicative (sum e) :=
{ seq := @sum.seq e,
  pure := @sum.inr e }

instance : is_lawful_applicative (sum e) :=
by constructor; intros;
   casesm* _ ⊕ _; simp [(<*>),sum.seq,pure,(<$>)];
   refl

end sum

namespace functor
def foldl (α : Type u) (β : Type v) := α → α
def foldr (α : Type u) (β : Type v) := α → α

instance foldr.applicative {α} : applicative (foldr α) :=
{ pure := λ _ _, id,
  seq := λ _ _ f x, f ∘ x }

instance foldl.applicative {α} : applicative (foldl α) :=
{ pure := λ _ _, id,
  seq := λ _ _ f x, x ∘ f }

instance foldr.is_lawful_applicative {α} : is_lawful_applicative (foldr α) :=
by refine { .. }; intros; refl

instance foldl.is_lawful_applicative {α} : is_lawful_applicative (foldl α) :=
by refine { .. }; intros; refl

def foldr.eval {α β} (x : foldr α β) : α → α := x

def foldl.eval {α β} (x : foldl α β) : α → α := x

def foldl.cons {α β} (x : α) : foldl (list α) β :=
list.cons x

def foldr.cons {α β} (x : α) : foldr (list α) β :=
list.cons x

def foldl.cons' {α} (x : α) : foldl (list α) punit :=
list.cons x

def foldl.lift {α} (x : α → α) : foldl α punit := x
def foldr.lift {α} (x : α → α) : foldr α punit := x

end functor

instance {α : Type u} : traversable (prod.{u u} α) :=
{ map := λ β γ f (x : α × β), prod.mk x.1 $ f x.2,
  traverse := λ m _ β γ f (x : α × β), by exactI prod.mk x.1 <$> f x.2 }

namespace traversable

variables {t : Type u → Type u} [traversable t]

def to_list {α} (x : t α) : list α :=
@functor.foldr.eval _ (t punit) (traverse functor.foldr.cons x) []

end traversable

/-
namespace name

-- def append_suffix : name → string → name
-- | (mk_string s n) s' := mk_string (s ++ s') n
-- | n _ := n

end name
-/

namespace level

meta def fold_mvar {α} : level → (name → α → α) → α → α
| zero f := id
| (succ a) f := fold_mvar a f
| (param a) f := id
| (mvar a) f := f a
| (max a b) f := fold_mvar a f ∘ fold_mvar b f
| (imax a b) f := fold_mvar a f ∘ fold_mvar b f

meta def pred : level → level
| level.zero := level.zero
| (level.succ a) := a
| (level.max a b) := max (pred a) (pred b)
| (level.imax a b) := max (pred a) (pred b)
| l@(level.param a) := l
| l@(level.mvar a) := l

end level

namespace native
namespace rb_map

-- #check rb_map

variables {key : Type} {val val' : Type}

-- section

variables [has_lt key] [decidable_rel ((<) : key → key → Prop)]
variables (f : val → val → val)

-- def intersect' : list (key × val) → list (key × val) → list (key × val)
-- | [] m := []
-- | ((k,x)::xs) [] := []
-- | ((k,x)::xs) ((k',x')::xs') :=
-- if h : k < k' then intersect' xs ((k',x')::xs')
-- else if k' < k then intersect' ((k,x)::xs) xs'
-- else (k,f x x') :: intersect' xs xs'

open function (on_fun)
def sort {α : Type} (f : α → key) : list α → list α := list.merge_sort (on_fun (<) f)

-- end

meta def filter_map (f : key → val → option val') (x : rb_map key val) : rb_map key val' :=
fold x (mk _ _) $ λa b m', (insert m' a <$> f a b).get_or_else m'

meta def intersect_with (m m' : rb_map key val) : rb_map key val :=
m.filter_map $ λ k x, f x <$> m'.find k

meta def intersect (x y : rb_map key val) : rb_map key val :=
intersect_with (function.const val) x y

meta def difference (m m' : rb_map key val) : rb_map key val :=
m.filter_map (λ k x, guard (¬ m'.contains k) >> pure x)

end rb_map
end native

namespace expr

meta def replace_all (e : expr) (p : expr → Prop) [decidable_pred p] (r : expr) : expr :=
e.replace $ λ e i, guard (p e) >> pure (r.lift_vars 0 i)

meta def const_params : expr → list level
| (const _ ls) := ls
| _ := []

meta def sort_univ : expr → level
| (sort ls) := ls
| _ := level.zero

meta def collect_meta_univ (e : expr) : list name :=
native.rb_set.to_list $ e.fold native.mk_rb_set $ λ e' i s,
match e' with
| (sort u) := u.fold_mvar (flip native.rb_set.insert) s
| (const _ ls) := ls.foldl (λ s' l, l.fold_mvar (flip native.rb_set.insert) s') s
| _ := s
end

meta def instantiate_pi : expr → list expr → expr
| (expr.pi n bi d b) (e::es) := instantiate_pi (b.instantiate_var e) es
| e _ := e

end expr

namespace tactic

meta def unify_univ (u u' : level) : tactic unit :=
unify (expr.sort u) (expr.sort u')

meta def add_decl' (d : declaration) : tactic expr :=
do add_decl d,
   pure $ expr.const d.to_name $ d.univ_params.map level.param

meta def renew : expr → tactic expr
| (expr.local_const uniq pp bi t) := mk_local' pp bi t
| e := fail format!"{e} is not a local constant"

meta def trace_expr (e : expr) : tactic expr :=
do t ← infer_type e >>= pp,
   e' ← pp e,
   trace format!"{e'} : {t}",
   pure e

open declaration (defn)
meta def trace_def (n : name) : tactic unit :=
do (defn n _ t df _ _) ← get_decl n,
   t ← pp t, df ← pp df,
   trace format!"\ndef {n} : {t} :=\n{df}\n"

meta def is_type (e : expr) : tactic bool :=
do (expr.sort _) ← infer_type e | pure ff,
   pure tt

meta def list_macros : expr → list (name × list expr) | e :=
e.fold [] (λ m i s,
  match m with
  | (expr.macro m args) := (expr.macro_def_name m, args) :: s
  | _ := s end)

meta def expand_untrusted (tac : tactic unit) : tactic unit :=
do tgt ← target,
   mv  ← mk_meta_var tgt,
   gs ← get_goals,
   set_goals [mv],
   tac,
   env ← get_env,
   pr ← env.unfold_untrusted_macros <$> instantiate_mvars mv,
   set_goals gs,
   exact pr

meta def binders : expr → tactic (list expr)
| (expr.pi n bi d b) :=
  do v ← mk_local' n bi d,
     (::) v <$> binders (b.instantiate_var v)
| _ := pure []

meta def rec_args_count (t c : name) : tactic ℕ :=
do ct ← mk_const c >>= infer_type,
   (list.length ∘ list.filter (λ v : expr, v.local_type.is_app_of t)) <$> binders ct

meta def match_induct_hyp (n : name) : list expr → list expr → tactic (list $ expr × option expr)
| [] [] := pure []
| [] _ := fail "wrong number of inductive hypotheses"
| (x :: xs) [] := (::) (x,none) <$> match_induct_hyp xs []
| (x :: xs) (h :: hs) :=
do t ← infer_type x,
   if t.is_app_of n
     then (::) (x,h) <$> match_induct_hyp xs hs
     else (::) (x,none) <$> match_induct_hyp xs (h :: hs)

meta def is_recursive_type (n : name) : tactic bool :=
do e ← get_env,
   let cs := e.constructors_of n,
   rs ← cs.mmap (rec_args_count n),
   pure $ rs.any (λ r, r > 0)

meta def better_induction (e : expr) : tactic $ list (name × list (expr × option expr) × list (name × expr)) :=
do t ← infer_type e,
   let tn := t.get_app_fn.const_name,
   env ← get_env,
   focus1 $
   do vs ← induction e,
      gs ← get_goals,
      vs' ← list.mzip_with₃ (λ n g (pat : name × list expr × list (name × expr)),
        do let ⟨_,args,σ⟩ := pat,
           set_goals [g],
           nrec ← rec_args_count tn n,
           let ⟨args,rec⟩ := args.split_at (args.length - nrec),
           args ← match_induct_hyp tn args rec,
           pure ((n,args,σ))) (env.constructors_of tn) gs vs,
      set_goals gs,
      pure vs'

meta def extract_def' {α} (n : name) (trusted : bool) (elab_def : tactic α) : tactic α :=
do cxt ← list.map to_implicit <$> local_context,
   t ← target,
   (r,d) ← solve_aux t elab_def,
   d ← instantiate_mvars d,
   t' ← pis cxt t,
   d' ← lambdas cxt d,
   let univ := t'.collect_univ_params,
   add_decl $ declaration.defn n univ t' d' (reducibility_hints.regular 1 tt) trusted,
   r <$ (applyc n; assumption)

open expr list nat

meta def remove_intl_const : expr → tactic expr
| v@(local_const uniq pp bi _) :=
  do t ← infer_type v,
     pure $ local_const uniq pp bi t
| e := pure e

meta def intron' : ℕ → tactic (list expr)
| 0 := pure []
| (succ n) := (::) <$> intro1 <*> intron' n

meta def unpi : expr → tactic (list expr × expr)
| (pi n bi d b) :=
  do v ← mk_local' n bi d,
     prod.map (cons v) id <$> unpi (b.instantiate_var v)
| e := pure ([],e)

meta def unify_app_aux : expr → expr → list expr → tactic expr
| e (pi _ _ d b) (a :: as) :=
do t ← infer_type a,
   unify t d,
   e' ← head_beta (e a),
   b' ← whnf (b.instantiate_var a),
   unify_app_aux e' b' as
| e t (_ :: _) := fail "too many arguments"
| e _ [] := pure e

meta def unify_app (e : expr) (args : list expr) : tactic expr :=
do t ← infer_type e >>= whnf,
   unify_app_aux e t args

meta def unify_mapp_aux : expr → expr → list (option expr) → tactic expr
| e (pi _ _ d b) (none :: as) :=
do a ← mk_mvar,
   t ← infer_type a,
   unify t d,
   e' ← head_beta (e a),
   b' ← whnf (b.instantiate_var a),
   unify_mapp_aux e' b' as
| e (pi _ _ d b) (some a :: as) :=
do t ← infer_type a,
   unify t d,
   e' ← head_beta (e a),
   b' ← whnf (b.instantiate_var a),
   unify_mapp_aux e' b' as
| e t (_ :: _) := fail "too many arguments"
| e _ [] := pure e

meta def unify_mapp (e : expr) (args : list (option expr)) : tactic expr :=
do t ← infer_type e >>= whnf,
   unify_mapp_aux e t args

meta def mk_to_string (t : expr) (fn of_string : name) (ls : list expr) (out : expr) : tactic expr :=
do let n := t.get_app_fn.const_name,
   d ← get_decl n,
   let r : reducibility_hints := reducibility_hints.regular 1 tt,
   env ← get_env,
   ls ← local_context,
   sig ← to_expr ``(%%t → %%out),
   of_string ← mk_const of_string,
   (_,df) ← solve_aux sig $ do
     { match env.structure_fields n with
       | (some fs) :=
       do a ← intro1,
          [(_,xs,_)] ← cases_core a,
          let l := xs.length,
          fn' ← mk_const fn,
          out ← list.mzip_with₄ (λ x (fn : name) (y : expr) z,
            do let fn := (fn.update_prefix name.anonymous).to_string,
               to_expr ``(%%of_string (%%(reflect x) ++ %%(reflect fn) ++ " := ") ++ %%fn' %%y ++ %%of_string %%(reflect z)))
            ("{ " :: list.repeat "  " (l-1)) fs xs (list.repeat ",\n" (l-1) ++ [" }"]),
          to_expr (out.foldr (λ e acc, ``(%%e ++ %%acc)) ``(%%of_string %%(reflect "" : expr))) >>= exact,
          pure ()
       | none :=
       do g ← main_goal,
          a ← intro1,
          xs ← cases_core a,
          fn ← mk_const fn,
          out ← xs.mmap $ λ ⟨c,xs,_⟩,
            do { out ← xs.mmap $ λ x, to_expr ``(%%of_string " (" ++ %%fn %%x ++ %%of_string ")"),
                 let c := (c.update_prefix name.anonymous).to_string,
                 to_expr (out.foldr (λ e acc, ``(%%e ++ %%acc)) ``(%%of_string %%(reflect c : expr))) >>= exact },
          pure () end },
   df ← instantiate_mvars df >>= lambdas ls,
   t ← infer_type df,
   add_decl' $ declaration.defn (n ++ fn) d.univ_params t df r d.is_trusted

meta def mk_has_to_format : tactic unit :=
do `(has_to_format %%t) ← target,
   ls ← local_context,
   e ← mk_to_string t `to_fmt `format.of_string ls `(format),
   refine ``( { to_format := %%(e.mk_app ls) } ),
   pure ()

meta def mk_has_repr : tactic unit :=
do `(has_repr %%t) ← target,
   ls ← local_context,
   e ← mk_to_string t `repr `id ls `(string),
   refine ``( { repr := %%(e.mk_app ls) } ),
   pure ()

@[derive_handler]
meta def has_repr_derive_handler : derive_handler :=
instance_derive_handler ``has_repr mk_has_repr

@[derive_handler]
meta def has_to_format_derive_handler : derive_handler :=
instance_derive_handler ``has_to_format mk_has_to_format

instance name.has_repr : has_repr name :=
{ repr := λ x, "`" ++ x.to_string }

private meta def report_invalid_simp_lemma {α : Type} (n : name): tactic α :=
fail format!"invalid simplification lemma '{n}' (use command 'set_option trace.simp_lemmas true' for more details)"

private meta def check_no_overload (p : pexpr) : tactic unit :=
when p.is_choice_macro $
  match p with
  | macro _ ps :=
    fail $ to_fmt "ambiguous overload, possible interpretations" ++
           format.join (ps.map (λ p, (to_fmt p).indent 4))
  | _ := failed
  end

private meta def add_simps : simp_lemmas → list name → tactic simp_lemmas
| s []      := return s
| s (n::ns) := do s' ← s.add_simp n, add_simps s' ns

private meta def simp_lemmas.resolve_and_add (s : simp_lemmas) (u : list name) (n : name) (ref : pexpr) : tactic (simp_lemmas × list name) :=
do
  p ← resolve_name n,
  check_no_overload p,
  -- unpack local refs
  let e := p.erase_annotations.get_app_fn.erase_annotations,
  match e with
  | const n _           :=
    (do b ← is_valid_simp_lemma_cnst n, guard b, save_const_type_info n ref, s ← s.add_simp n, return (s, u))
    <|>
    (do eqns ← get_eqn_lemmas_for tt n, guard (eqns.length > 0), save_const_type_info n ref, s ← add_simps s eqns, return (s, u))
    <|>
    (do env ← get_env, guard (env.is_projection n).is_some, return (s, n::u))
    <|>
    report_invalid_simp_lemma n
  | _ :=
    (do e ← i_to_expr_no_subgoals p, b ← is_valid_simp_lemma e, guard b, try (save_type_info e ref), s ← s.add e, return (s, u))
    <|>
    report_invalid_simp_lemma n
  end

meta def simp_lemmas.add_pexpr (s : simp_lemmas) (u : list name) (p : pexpr) : tactic (simp_lemmas × list name) :=
match p with
| (const c [])          := simp_lemmas.resolve_and_add s u c p
| (local_const c _ _ _) := simp_lemmas.resolve_and_add s u c p
| _                     := do new_e ← i_to_expr_no_subgoals p, s ← s.add new_e, return (s, u)
end

meta def simp_lemmas.append_pexprs : simp_lemmas → list name → list pexpr → tactic (simp_lemmas × list name)
| s u []      := return (s, u)
| s u (l::ls) := do (s, u) ← simp_lemmas.add_pexpr s u l, simp_lemmas.append_pexprs s u ls

meta def simp_only (ls : list pexpr) (attrs : list name := []) : tactic unit :=
do let ls := ls.map (simp_arg_type.expr), -- >>= simp_lemmas.append_pexprs simp_lemmas.mk [],
   -- interactive.dsimp tt ls [] (interactive.loc.ns [none])
   interactive.simp none tt ls attrs (interactive.loc.ns [none])

meta def mk_substitution (vs : list expr) : tactic (list expr × list (name × expr)) :=
do vs' ← intron' vs.length,
   let σ := (vs.map expr.local_uniq_name).zip vs',
   pure (vs', σ)
open interactive.types interactive lean.parser

@[user_command]
meta def test_signature_cmd (_ : parse $ tk "#test") : lean.parser unit :=
do e ← ident,
show tactic unit, from
do d ← get_decl e,
   let e := @const tt d.to_name d.univ_levels,
   t ← infer_type e >>= pp,
   e.collect_meta_univ.enum.mmap' $ λ ⟨i,v⟩, unify_univ (level.mvar v) (level.param ("u_" ++ to_string i : string)),
   e ← instantiate_mvars e,
   e ← pp e,
   trace format!"\nexample : {t} :=\n{e}\n",
   pure ()

end tactic

namespace tactic.interactive

open lean lean.parser interactive interactive.types tactic

local postfix `*`:9000 := many

meta def splita := split; [skip, assumption]

@[hole_command]
meta def whnf_type_hole : hole_command :=
{ name := "Reduce expected type",
  descr := "Reduce expected type",
  action := λ es,
    do t ← match es with
           | [h] := to_expr h >>= infer_type >>= whnf
           | [] := target >>= whnf
           | _ := fail "too many expressions"
           end,
       trace t,
       pure [] }

meta def trace_error {α} (tac : tactic α) : tactic α
| s :=
match tac s with
| r@(interaction_monad.result.success a a_1) := r
| r@(interaction_monad.result.exception none a_1 a_2) := (trace "(no error message)" >> interaction_monad.result.exception none a_1) s
| r@(interaction_monad.result.exception (some msg) a_1 a_2) := (trace (msg ()) >> interaction_monad.result.exception none a_1) s
end

end tactic.interactive

instance subsingleton.fin0 {α} : subsingleton (fin 0 → α) :=
subsingleton.intro $ λ a b, funext $ λ i, fin.elim0 i

attribute [extensionality] function.hfunext

meta def options.list_names (o : options) : list name := o.fold [] (::)

namespace expr

meta def bracket (p : ℕ) (fmt : format) (p' : ℕ) : format :=
if p' < p then format.paren fmt else fmt

meta def fmt_binder (n : name) : binder_info → format → format
| binder_info.default t := format!"({n} : {t})"
| binder_info.implicit t := format!"{{{n} : {t}}"
| binder_info.strict_implicit t := format!"⦃{n} : {t}⦄"
| binder_info.inst_implicit t := format!"[{n} : {t}]"
| binder_info.aux_decl t := "_"

meta def parsable_printer' : expr → list name → ℕ → format
| (expr.var a) l := λ _, format!"@{(l.nth a).get_or_else name.anonymous}"
| (expr.sort level.zero) l := λ _, to_fmt "Prop"
| (expr.sort (level.succ u)) l := λ _, format!"Type.{{{u}}"
| (expr.sort u) l := λ _, format!"Sort.{{{u}}"
| (expr.const a []) l := λ _, format!"@{a}"
| (expr.const a ls) l := λ _, format!"@{a}.{{{format.intercalate  \" \" $ list.map to_fmt ls}}"
| (expr.mvar a a_1 a_2) l := λ _, to_fmt a
| (expr.local_const a a_1 a_2 a_3) l := λ _, to_fmt a_1
| (expr.app a a_1) l := bracket 10 $ format!"{parsable_printer' a l 10} {parsable_printer' a_1 l 9}"
| (expr.lam a a_1 a_2 a_3) l := bracket 8 $ format!"λ {fmt_binder a a_1 $ parsable_printer' a_2 l 10}, {parsable_printer' a_3 (a :: l) 10}"
| (expr.pi a a_1 a_2 a_3) l :=
       if a_3.has_var_idx 0
          then bracket 8 $ format!"Π {fmt_binder a a_1 $ parsable_printer' a_2 l 10}, {parsable_printer' a_3 (a :: l) 10}"
          else bracket 8 $ format!"{parsable_printer' a_2 l 7} → {parsable_printer' a_3 (a :: l) 7}"
| (expr.elet a a_1 a_2 a_3) l := bracket 8 $ format!"let {a} : {parsable_printer' a_1 l 10} := {parsable_printer' a_2 l 10} in {parsable_printer' a_3 (a :: l) 10}"
| (expr.macro a a_1) l := λ _, to_fmt "unsupported"

meta def parsable_printer (e : expr) : format := parsable_printer' e [] 10

meta def as_binder (e : expr) := fmt_binder e.local_pp_name e.binding_info (parsable_printer e.local_type)

end expr

meta def stack_trace : vm_monitor ℕ :=
{ init := 0,
  step := λ i,
  do j ← vm.stack_size,
     if i = j then pure i else do
       fn ← vm.curr_fn,
       vm.put_str $ (list.repeat ' ' j).as_string ++ fn.to_string,
       pure j }

lemma mpr_mpr : Π {α β} (h : α = β) (h' : β = α) (x : α), h.mpr (h'.mpr x) = x
| _ _ rfl rfl x := rfl


/-
## SSA environment

This file implements the SSA environment which maps variables names from
different scopes to explicitly-typed values. It is, conceptually, a map
`SSAVal → (α: MLIRType δ) × α` for each scope.

The main concern with such state is the definition, maintainance and use of the
property that the values are defined only once, allowing us to study sections
of the code while skipping/omitting operations very freely. Bundling uniqueness
invariants with the data structure would result in very tedious and context-
dependent maintenance, which is not a friendly option.

Instead, we ignore the SSA constraints when defining semantics and interpreting
programs, assuming the language allows shadowing and overriding values (of
course, valid programs won't do that). We only define SSA constraints later on
to prove that transformations are context-independent.

`SSAScope` implements a single scope as a list of name/value pairs and supports
edition.

`SSAEnv` implements a stack of scopes. New scopes are created when entering
regions. Here again nothing prevents a region from shadowing variables or
accessing out-of-scope values (in the case of an isolated region), but we only
care when proving the correction of transformations.
-/

import MLIR.Semantics.Fitree
import MLIR.Semantics.Types
import MLIR.Util.WriterT
import MLIR.Util.Tactics

import MLIR.AST
open MLIR.AST

section
variable {α σ: Type} {ε: σ → Type}

-- SSAScope

def SSAScope (δ: Dialect α σ ε) :=
  List (SSAVal × (τ: MLIRType δ) × τ.eval)

@[simp]
def SSAScope.getT {δ: Dialect α σ ε} (name: SSAVal):
  SSAScope δ → Option ((τ: MLIRType δ) × τ.eval)
  | [] => none
  | ⟨name', τ, v⟩ :: l =>
      if name' = name then some ⟨τ,v⟩ else getT name l

@[simp]
def SSAScope.get {δ: Dialect α σ ε} (name: SSAVal):
  SSAScope δ → (τ: MLIRType δ) → Option τ.eval
  | [], _ => none
  | ⟨name', τ', v'⟩ :: l, τ =>
      if H: name' = name then
        if H': τ' = τ then
          some (cast (by simp [H']) v')
        else
          none
      else get name l τ

@[simp]
def SSAScope.set {δ: Dialect α σ ε} (name: SSAVal) (τ: MLIRType δ) (v: τ.eval):
  SSAScope δ → SSAScope δ
  | [] => [⟨name, τ, v⟩]
  | ⟨name', τ', v'⟩ :: l =>
      if name' = name
      then ⟨name', τ, v⟩ :: l
      else ⟨name', τ', v'⟩ :: set name τ v l

def SSAScope.str {δ: Dialect α σ ε} (scope: SSAScope δ): String :=
  "\n".intercalate <| scope.map fun ⟨name, τ, v⟩ => s!"{name} = {v} : {τ}"

-- Leibniz-ish equality
def SSAScope.equiv {δ: Dialect α σ ε} (scope1 scope2: SSAScope δ): Prop :=
  ∀ name τ, scope1.get name τ = scope2.get name τ

instance {δ: Dialect α σ ε}: ToString (SSAScope δ) where
  toString := SSAScope.str

/- Maybe useful in the future, for proofs
def SSAScope.has (name: SSAVal) (l: SSAScope): Bool :=
  l.any (fun ⟨name', _, _⟩ => name' == name)

def SSAScope.free (name: SSAVal) (l: SSAScope): Bool :=
  l.all (fun ⟨name', _, _⟩ => name' != name)

def SSAScope.maps (l: SSAScope) (name: SSAVal) (τ: MLIRTy) (v: τ.eval) :=
  l.Mem ⟨name, τ, v⟩ -/

/-
### SSAScope proofs
-/

theorem SSAScope.equiv_refl {δ: Dialect α σ ε} (scope: SSAScope δ):
  scope.equiv scope := by intros name τ; rfl

theorem SSAScope.equiv_symm {δ: Dialect α σ ε} ⦃scope scope': SSAScope δ⦄:
    scope.equiv scope' → scope'.equiv scope := by
  intros H name τ
  specialize H name τ
  simp [H]

theorem SSAScope.equiv_trans {δ: Dialect α σ ε} ⦃scope₁ scope₂: SSAScope δ⦄:
    scope₁.equiv scope₂ →
    ∀ ⦃scope₃⦄, scope₂.equiv scope₃ →
    scope₁.equiv scope₃ := by
  intros H1 scope₃ H2 name τ
  specialize H1 name τ
  specialize H2 name τ
  simp [H1, H2]

theorem SSAScope.get_to_getT {δ: Dialect α σ ε} (name: SSAVal)
    (scope: SSAScope δ) (τ: MLIRType δ):
  scope.get name τ =
    match scope.getT name with
    | none => none
    | some ⟨τ', v'⟩ =>
      if H: τ' = τ then
        some (cast (by simp [H]) v')
      else
        none := by
  induction scope
  case nil => simp
  case cons head tail HInd =>
  unfold getT get
  byCases Hname: head.fst = name
  case h2 =>
    rw [HInd]

theorem SSAScope.get_some_getT {δ: Dialect α σ ε} ⦃name: SSAVal⦄
  ⦃scope: SSAScope δ⦄ ⦃τ: MLIRType δ⦄ ⦃v⦄:
    scope.get name τ = some v →
    scope.getT name = some ⟨τ, v⟩ := by
  rw [get_to_getT]
  split <;> simp at * <;> try contradiction
  case h_2 _ τ' _ Hget =>
  byCases Hτ: τ' = τ
  intros H
  rw [←H, Hget]
  rfl

theorem SSAScope.getT_none_get {δ: Dialect α σ ε} ⦃name: SSAVal⦄
  ⦃scope: SSAScope δ⦄:
    scope.getT name = none →
    ∀ τ, scope.get name τ = none := by
  induction scope <;> simp
  case cons head tail HInd =>
  byCases Hname: head.fst = name <;> assumption

theorem SSAScope.getT_some_get {δ: Dialect α σ ε} ⦃name: SSAVal⦄
  ⦃scope: SSAScope δ⦄ ⦃τ v⦄:
    scope.getT name = some ⟨τ, v⟩ →
    scope.get name τ = some v := by
  induction scope <;> simp
  case cons head tail HInd =>
  byCases Hname: head.fst = name <;> try assumption
  have ⟨headName, headτ, headVal⟩ := head; simp at *
  intros H; cases H
  simp;

theorem SSAScope.get_none_getT {δ: Dialect α σ ε} ⦃name: SSAVal⦄
  ⦃scope: SSAScope δ⦄:
    (∀ τ, scope.get name τ = none) →
    scope.getT name = none := by
  induction scope <;> simp
  case cons head tail HInd =>
  byCases Hname: head.fst = name <;> try assumption

theorem SSAScope.getT_set_ne ⦃v v': SSAVal⦄:
    v' ≠ v →
    ∀ ⦃scope: SSAScope δ⦄ ⦃τ: MLIRType δ⦄ ⦃val⦄,
    getT v (set v' τ val scope) = getT v scope := by
  intros Hne scope τ val
  induction scope with
  | nil => simp [Hne]
  | cons head tail =>
    simp
    byCases H: head.fst = v'
    . simp [Hne]
    . byCases H2: head.fst = v
      assumption

theorem SSAScope.getT_set_eq (scope: SSAScope δ) (v: SSAVal) (τ: MLIRType δ) val:
    getT v (set v τ val scope) = some ⟨τ, val⟩  := by
  induction scope with
  | nil => simp
  | cons head tail =>
    simp
    byCases H: head.fst = v
    assumption

theorem SSAScope.get_set_ne_val ⦃v v': SSAVal⦄:
    v' ≠ v →
    ∀ ⦃scope: SSAScope δ⦄ ⦃τ τ' val⦄,
    get v (set v' τ val scope) τ' = get v scope τ' := by
  intros Hne scope τ τ' val
  induction scope with
  | nil => simp [Hne]
  | cons head nil =>
    simp
    byCases H: head.fst = v'
    . simp [Hne]
    . byCases H2: head.fst = v <;> try assumption

theorem SSAScope.get_set_ne_type ⦃τ τ': MLIRType δ⦄:
    τ' ≠ τ →
    ∀ ⦃scope: SSAScope δ⦄ ⦃v: SSAVal⦄ ⦃val⦄,
    get v (set v τ' val scope) τ = none := by
  intros Hne scope v val
  induction scope with
  | nil => simp [Hne]
  | cons head tail Hind =>
    simp
    byCases H: head.fst = v
    . simp [Hne]
    . byCases H2: head.fst = v <;> try assumption

theorem SSAScope.get_set_eq (v: SSAVal) (scope: SSAScope δ) (τ: MLIRType δ) val:
    get v (set v τ val scope) τ = some val := by
  induction scope with
  | nil => simp;
  | cons head nil =>
    simp
    byCases H: head.fst = v <;> try apply cast_eq
    assumption

theorem SSAScope.set_commutes ⦃v v': SSAVal⦄:
    v' ≠ v →
    ∀ ⦃scope: SSAScope δ⦄ ⦃τ τ' val val'⦄,
    (set v τ val (set v' τ' val' scope)).equiv (set v' τ' val' (set v τ val scope)) := by
  intros Hne scope τ τ' val val'
  induction scope with
  | nil =>
    simp; simp [Hne, Hne.symm]
    simp [equiv]; intros name τ''
    byCases Hv: v' = name
    byCases Hτ: τ' = τ'' <;> simp [Hne.symm]
  | cons head tail Hind =>
    simp [equiv] at *
    intros name; specialize Hind name
    simp at *
    byCases Hv': head.fst = v' <;> simp [Hne]
    byCases Hv: head.fst = v <;> simp [Hv']
    byCases Hname: head.fst = name <;> assumption

/-
### SSAEnv
-/

inductive SSAEnv (δ: Dialect α σ ε) :=
  | One (scope: SSAScope δ)
  | Cons (head: SSAScope δ) (tail: SSAEnv δ)

instance: Inhabited (SSAEnv δ) where
  default := .One []

-- An SSA environment with a single empty SSAScope
def SSAEnv.empty {δ: Dialect α σ ε}: SSAEnv δ := One []

def SSAEnv.str {δ: Dialect α σ ε} (env: SSAEnv δ): String :=
  match env with
  | One s => s.toString
  | Cons head tail => head.toString ++ "---\n" ++ tail.str

instance {δ: Dialect α σ ε}: ToString (SSAEnv δ) where
  toString := SSAEnv.str

def SSAEnv.getT {δ: Dialect α σ ε} (name: SSAVal):
  SSAEnv δ → Option ((τ: MLIRType δ) × τ.eval)
  | One s => s.getT name
  | Cons s l => s.getT name <|> getT name l

def SSAEnv.get {δ: Dialect α σ ε} (name: SSAVal) (τ: MLIRType δ) (env: SSAEnv δ) : Option (τ.eval) :=
  match env.getT name with
  | none => none
  | some ⟨τ', v'⟩ =>
      if H': τ' = τ then
        some (cast (by simp [H']) v')
      else
        none

def SSAEnv.set {δ: Dialect α σ ε} (name: SSAVal) (τ: MLIRType δ) (v: τ.eval):
  SSAEnv δ → SSAEnv δ
  | One s => One (s.set name τ v)
  | Cons s l => Cons (s.set name τ v) l

@[simp] def SSAEnv.set_One:
  SSAEnv.set name τ v (.One scope) = .One (scope.set name τ v) := rfl

instance {δ: Dialect α σ ε}: DecidableEq ((τ: MLIRType δ) × τ.eval) :=
  fun ⟨τ₁, v₁⟩ ⟨τ₂, v₂⟩ =>
    if H: τ₁ = τ₂ then
      if H': cast (by simp [H]) v₁ = v₂ then
        isTrue (by cases H; cases H'; simp [cast_eq])
      else isFalse fun h => by cases h; cases H' rfl
    else isFalse fun h => by cases h; cases H rfl

def SSAEnv.eqOn (l: List SSAVal) (env₁ env₂: SSAEnv δ): Bool :=
  l.all (fun v => env₁.getT v == env₂.getT v)

-- Leibniz-ish equality
def SSAEnv.equiv (env₁ env₂: SSAEnv δ): Prop :=
  ∀ name τ, env₁.get name τ = env₂.get name τ

-- SSAEnv theorems

theorem SSAEnv.equiv_rfl {δ: Dialect α σ ε} (env: SSAEnv δ):
  env.equiv env := by intros v τ; rfl

theorem SSAEnv.equiv_symm {δ: Dialect α σ ε} ⦃env env': SSAEnv δ⦄:
    env.equiv env' → env'.equiv env := by
  intros H name
  specialize H name
  simp [H]

theorem SSAEnv.equiv_trans {δ: Dialect α σ ε}:
    ∀ ⦃env₁ env₂: SSAEnv δ⦄, env₁.equiv env₂ →
    ∀ ⦃env₃⦄, env₂.equiv env₃ →
    env₁.equiv env₃ := by
  intros _ _ H1 _ H2 name
  specialize H1 name
  specialize H2 name
  simp [H1, H2]

theorem SSAEnv.getT_set_ne ⦃v v': SSAVal⦄:
    v' ≠ v →
    ∀ ⦃env: SSAEnv δ⦄ ⦃τ: MLIRType δ⦄ ⦃val⦄,
    getT v (set v' τ val env) = getT v env := by
  intros Hne env τ val
  cases env with
  | One s =>
    simp [getT, set]
    rw [SSAScope.getT_set_ne]
    assumption
  | Cons head tail =>
    simp [getT, set, HOrElse.hOrElse, OrElse.orElse, Option.orElse]
    rw [SSAScope.getT_set_ne]
    assumption

theorem SSAEnv.getT_set_eq (env: SSAEnv δ) (v: SSAVal) (τ: MLIRType δ) val:
    getT v (SSAEnv.set v τ val env) = some ⟨τ, val⟩  := by
  cases env with
  | One s =>
    simp [getT, set]
    rw [SSAScope.getT_set_eq]
  | Cons head tail =>
    simp [getT, set, HOrElse.hOrElse, OrElse.orElse, Option.orElse]
    simp [SSAScope.getT_set_eq]

theorem SSAEnv.get_set_ne_val ⦃v v': SSAVal⦄:
    v' ≠ v →
    ∀ ⦃env: SSAEnv δ⦄ ⦃τ τ': MLIRType δ⦄ ⦃val⦄,
    get v τ (set v' τ' val env) = get v τ env := by
  intros Hne env τ τ' val
  simp [get]
  rw [SSAEnv.getT_set_ne]
  assumption

theorem SSAEnv.get_set_eq_val {δ: Dialect α σ ε} (τ τ': MLIRType δ)
  (env: SSAEnv δ) (v: SSAVal) (val: τ'.eval):
    get v τ (set v τ' val env) =
      if H': τ' = τ then
        some (cast (by simp [H']) val)
      else
        none := by
  simp [get, getT_set_eq]

theorem SSAEnv.get_set {δ: Dialect α σ ε} (τ τ': MLIRType δ)
  (env: SSAEnv δ) (v v': SSAVal) (val: τ'.eval):
    get v τ (set v' τ' val env) =
      if v' = v then
        if H: τ' = τ then
          some (cast (by simp [H]) val)
        else
          none
      else
        get v τ env := by
  byCases H: v' = v
  . simp [get_set_eq_val]
  . rw [get_set_ne_val]
    assumption

theorem SSAEnv.get_set_eq (v: SSAVal) (env: SSAEnv δ) (τ: MLIRType δ) val:
    get v τ (set v τ val env) = some val := by
  simp [get, getT_set_eq]

theorem SSAEnv.get_set_neq (v v': SSAVal) (NEQ: v' ≠ v) (env: SSAEnv δ) (τ: MLIRType δ) val:
    get v τ (set v' τ val env) = get v τ env := by
  simp[get];
  rw[SSAEnv.getT_set_ne]; try assumption;

theorem SSAEnv.equiv_set {δ: Dialect α σ ε} ⦃env₁ env₂: SSAEnv δ⦄:
    env₁.equiv env₂ →
    ∀ ⦃name τ v⦄, (set name τ v env₁).equiv (set name τ v env₂) := by
  intros HEnv name τ v name' τ'
  byCases Hname: name = name'
  . simp [get_set_eq_val]
  . repeat rw [get_set_ne_val] <;> try assumption
    apply HEnv

theorem SSAEnv.set_commutes ⦃v v': SSAVal⦄:
    v' ≠ v →
    ∀ ⦃env: SSAEnv δ⦄ ⦃τ τ': MLIRType δ⦄ ⦃val val'⦄,
    equiv (set v τ val (set v' τ' val' env)) (set v' τ' val' (set v τ val env)) := by
  intros Hne env τ τ' val val' v₂ τ₂
  repeat rw [get_set]
  split
  . subst v
    simp [Hne]
  . split <;> simp

/-
### Interactions manipulating the environment
-/

inductive SSAEnvE (δ: Dialect α σ ε): Type → Type where
  | Get: (τ: MLIRType δ) → [Inhabited τ.eval] → SSAVal → SSAEnvE δ τ.eval
  | Set: (τ: MLIRType δ) → SSAVal → τ.eval → SSAEnvE δ Unit

@[simp_itree]
def SSAEnvE.handle {E}: SSAEnvE δ ~> StateT (SSAEnv δ) (Fitree E) :=
  fun _ e env =>
    match e with
    | Get τ name =>
        match env.get name τ with
        | some v => return (v, env)
        | none => return (default, env)
    | Set τ name v =>
        return (.unit, env.set name τ v)

def SSAEnvE.handleLogged {E}:
    SSAEnvE δ ~> WriterT (StateT (SSAEnv δ) (Fitree E)) :=
  fun _ e => do
    let env <- WriterT.lift StateT.get
    match e with
    | Get τ name =>
        match env.get name τ with
        | some v => do
            logWriterT s!"get {name} (={v}); "
            return v
        | none =>
            logWriterT s!"get {name} (not found!); "
            return default
    | Set τ name v =>
        logWriterT s!"set {name}={v}; "
        WriterT.lift $ StateT.set (env.set name τ v)
        return ()

@[simp_itree]
def SSAEnv.get? {E} (δ: Dialect α σ ε) [Member (SSAEnvE δ) E]
  (τ: MLIRType δ) (name: SSAVal): Fitree E τ.eval :=
    Fitree.trigger (SSAEnvE.Get τ name)

@[simp_itree]
def SSAEnv.set? {E} {δ: Dialect α σ ε} [Member (SSAEnvE δ) E]
    (τ: MLIRType δ) (name?: Option SSAVal) (v: τ.eval): Fitree E Unit :=
  match name? with
  | some name =>
      Fitree.trigger (SSAEnvE.Set τ name v)
  | none =>
      return ()

-- Handlers

def interpSSA (t: Fitree (SSAEnvE δ) R): StateT (SSAEnv δ) (Fitree Void1) R :=
  t.interpState SSAEnvE.handle

def interpSSA' {E} (t: Fitree (SSAEnvE δ +' E) R):
    StateT (SSAEnv δ) (Fitree E) R :=
  t.interpState (Fitree.case SSAEnvE.handle Fitree.liftHandler)

def interpSSALogged (t: Fitree (SSAEnvE δ) R):
    WriterT (StateT (SSAEnv δ) (Fitree Void1)) R :=
  t.interp SSAEnvE.handleLogged

def interpSSALogged' {E} (t: Fitree (SSAEnvE δ +' E) R):
    WriterT (StateT (SSAEnv δ) (Fitree E)) R :=
  t.interp (Fitree.case SSAEnvE.handleLogged Fitree.liftHandler)

@[simp] theorem interpSSA'_Vis_left {δ: Dialect α σ ε}
    (k: T → Fitree (SSAEnvE δ +' E) R) (e: SSAEnvE δ T) (s₁: SSAEnv δ):
  interpSSA' (Fitree.Vis (Sum.inl e) k) s₁ =
  Fitree.bind (SSAEnvE.handle _ e s₁) (fun (x,s₂) => interpSSA' (k x) s₂) :=
  rfl

@[simp] theorem interpSSA'_Vis_right (k: T → Fitree (SSAEnvE Δ +' E) R):
  interpSSA' (Fitree.Vis (Sum.inr e) k) =
  fun s => Fitree.Vis e (fun x => interpSSA' (k x) s) := rfl

@[simp] theorem interpSSA'_ret {δ: Dialect α σ ε}:
  @interpSSA' _ _ _ δ _ E (Fitree.ret r) = fun s => Fitree.ret (r,s) := rfl

private theorem pair_eta {α β: Type} (x: α × β): (x.fst, x.snd) = x :=
  match x with
  | (_, _) => rfl

@[simp] theorem interpSSA'_trigger_MemberSumL {Δ: Dialect α' σ' ε'}
    (e: SSAEnvE Δ T) (s₁: SSAEnv Δ):
  interpSSA' (@Fitree.trigger (SSAEnvE Δ) (SSAEnvE Δ +' E) _ MemberSumL e) s₁ =
  SSAEnvE.handle _ e s₁ := by
  simp [Fitree.trigger, pair_eta]

theorem interpSSA'_bind {δ: Dialect α σ ε}
    (t: Fitree (SSAEnvE δ +' E) T) (k: T → Fitree (SSAEnvE δ +' E) R)
    (s₁: SSAEnv δ):
  interpSSA' (δ := δ) (Fitree.bind t k) s₁ =
  Fitree.bind (interpSSA' t s₁) (fun (x,s₂) => interpSSA' (k x) s₂) := by
  apply Fitree.interpState_bind

macro "simp_ssaenv" : tactic =>
  `(tactic| repeat progress (
            try rw [SSAEnv.getT_set_eq];
            try rw [SSAEnv.getT_set_ne (by assumption)]
            try rw [SSAEnv.get_set_eq]
            try rw [SSAEnv.get_set_eq_val]
            try rw [SSAEnv.get_set_ne_val (by assumption)]) )

macro "simp_ssaenv" "at" Hname:ident : tactic =>
  `(tactic| (repeat rw [SSAEnv.getT_set_eq] at $Hname:ident) <;>
            (repeat rw [SSAEnv.getT_set_ne (by assumption)] at $Hname:ident) <;>
            (repeat rw [SSAEnv.get_set_eq] at $Hname:ident) <;>
            (repeat rw [SSAEnv.get_set_eq_val] at $Hname:ident) <;>
            (repeat rw [SSAEnv.get_set_ne_val (by assumption)] at $Hname:ident))

macro "simp_ssaenv" "at" "*" : tactic =>
  `(tactic| (repeat rw [SSAEnv.getT_set_eq] at *) <;>
            (repeat rw [SSAEnv.getT_set_ne (by assumption)] at *) <;>
            (repeat rw [SSAEnv.get_set_eq] at *) <;>
            (repeat rw [SSAEnv.get_set_eq_val] at *) <;>
            (repeat rw [SSAEnv.get_set_ne_val (by assumption)] at *))


/-
Copyright (c) 2020 Adam Topaz. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta, Adam Topaz
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.fintype.basic
import Mathlib.data.fin
import Mathlib.category_theory.concrete_category.bundled
import Mathlib.category_theory.concrete_category.default
import Mathlib.category_theory.full_subcategory
import Mathlib.category_theory.skeletal
import Mathlib.PostPort

universes u_1

namespace Mathlib

/-!
# The category of finite types.

We define the category of finite types, denoted `Fintype` as
(bundled) types with a `fintype` instance.

We also define `Fintype.skeleton`, the standard skeleton of `Fintype` whose objects are `fin n`
for `n : ℕ`. We prove that the obvious inclusion functor `Fintype.skeleton ⥤ Fintype` is an
equivalence of categories in `Fintype.skeleton.equivalence`.
We prove that `Fintype.skeleton` is a skeleton of `Fintype` in `Fintype.is_skeleton`.
-/

/-- The category of finite types. -/
def Fintype :=
  category_theory.bundled fintype

namespace Fintype

/-- Construct a bundled `Fintype` from the underlying type and typeclass. -/
def of (X : Type u_1) [fintype X] : Fintype :=
  category_theory.bundled.of X

protected instance inhabited : Inhabited Fintype :=
  { default := category_theory.bundled.mk pempty }

protected instance fintype {X : Fintype} : fintype ↥X :=
  category_theory.bundled.str X

protected instance category_theory.category : category_theory.category Fintype :=
  category_theory.induced_category.category category_theory.bundled.α

/-- The fully faithful embedding of `Fintype` into the category of types. -/
@[simp] theorem incl_map (x : category_theory.induced_category (Type u_1) category_theory.bundled.α) (y : category_theory.induced_category (Type u_1) category_theory.bundled.α) (f : x ⟶ y) : ∀ (ᾰ : category_theory.bundled.α x), category_theory.functor.map incl f ᾰ = f ᾰ :=
  fun (ᾰ : category_theory.bundled.α x) => Eq.refl (f ᾰ)

protected instance category_theory.concrete_category : category_theory.concrete_category Fintype :=
  category_theory.concrete_category.mk incl

/--
The "standard" skeleton for `Fintype`. This is the full subcategory of `Fintype` spanned by objects
of the form `fin n` for `n : ℕ`. We parameterize the objects of `Fintype.skeleton` directly as `ℕ`,
as the type `fin m ≃ fin n` is nonempty if and only if `n = m`.
-/
def skeleton :=
  ℕ

namespace skeleton

/-- Given any natural number `n`, this creates the associated object of `Fintype.skeleton`. -/
def mk : ℕ → skeleton :=
  id

protected instance inhabited : Inhabited skeleton :=
  { default := mk 0 }

/-- Given any object of `Fintype.skeleton`, this returns the associated natural number. -/
def to_nat : skeleton → ℕ :=
  id

protected instance category_theory.category : category_theory.category skeleton :=
  category_theory.category.mk

theorem is_skeletal : category_theory.skeletal skeleton := sorry

/-- The canonical fully faithful embedding of `Fintype.skeleton` into `Fintype`. -/
def incl : skeleton ⥤ Fintype :=
  category_theory.functor.mk (fun (X : skeleton) => of (fin X)) fun (_x _x_1 : skeleton) (f : _x ⟶ _x_1) => f

protected instance incl.category_theory.full : category_theory.full incl :=
  category_theory.full.mk
    fun (_x _x_1 : skeleton) (f : category_theory.functor.obj incl _x ⟶ category_theory.functor.obj incl _x_1) => f

protected instance incl.category_theory.faithful : category_theory.faithful incl :=
  category_theory.faithful.mk

protected instance incl.category_theory.ess_surj : category_theory.ess_surj incl :=
  category_theory.ess_surj.mk
    fun (X : Fintype) =>
      let F : ↥X ≃ fin (fintype.card ↥X) := trunc.out (fintype.equiv_fin ↥X);
      Exists.intro (fintype.card ↥X) (Nonempty.intro (category_theory.iso.mk ⇑(equiv.symm F) ⇑F))

protected instance incl.category_theory.is_equivalence : category_theory.is_equivalence incl :=
  category_theory.equivalence.equivalence_of_fully_faithfully_ess_surj incl

/-- The equivalence between `Fintype.skeleton` and `Fintype`. -/
def equivalence : skeleton ≌ Fintype :=
  category_theory.functor.as_equivalence incl

@[simp] theorem incl_mk_nat_card (n : ℕ) : fintype.card ↥(category_theory.functor.obj incl (mk n)) = n :=
  finset.card_fin n

end skeleton

/-- `Fintype.skeleton` is a skeleton of `Fintype`. -/
def is_skeleton : category_theory.is_skeleton_of Fintype skeleton skeleton.incl :=
  category_theory.is_skeleton_of.mk skeleton.is_skeletal skeleton.incl.category_theory.is_equivalence


/-
Copyright (c) 2017 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Patrick Massot, Scott Morrison, Mario Carneiro, Andrew Yang
-/
import topology.category.Top.epi_mono
import category_theory.limits.preserves.limits
import category_theory.category.ulift
import category_theory.limits.shapes.types
import category_theory.limits.concrete_category

/-!
# The category of topological spaces has all limits and colimits

Further, these limits and colimits are preserved by the forgetful functor --- that is, the
underlying types are just the limits in the category of types.
-/

open topological_space
open category_theory
open category_theory.limits
open opposite

universes u v w

noncomputable theory

namespace Top

variables {J : Type u} [small_category J]

local notation `forget` := forget Top

/--
A choice of limit cone for a functor `F : J ⥤ Top`.
Generally you should just use `limit.cone F`, unless you need the actual definition
(which is in terms of `types.limit_cone`).
-/
def limit_cone (F : J ⥤ Top.{u}) : cone F :=
{ X := Top.of {u : Π j : J, F.obj j | ∀ {i j : J} (f : i ⟶ j), F.map f (u i) = u j},
  π :=
  { app := λ j,
    { to_fun := λ u, u.val j,
      continuous_to_fun := show continuous ((λ u : Π j : J, F.obj j, u j) ∘ subtype.val),
        by continuity } } }

/--
A choice of limit cone for a functor `F : J ⥤ Top` whose topology is defined as an
infimum of topologies infimum.
Generally you should just use `limit.cone F`, unless you need the actual definition
(which is in terms of `types.limit_cone`).
-/
def limit_cone_infi (F : J ⥤ Top.{u}) : cone F :=
{ X := ⟨(types.limit_cone (F ⋙ forget)).X, ⨅j,
        (F.obj j).str.induced ((types.limit_cone (F ⋙ forget)).π.app j)⟩,
  π :=
  { app := λ j, ⟨(types.limit_cone (F ⋙ forget)).π.app j,
                 continuous_iff_le_induced.mpr (infi_le _ _)⟩,
    naturality' := λ j j' f,
                   continuous_map.coe_inj ((types.limit_cone (F ⋙ forget)).π.naturality f) } }

/--
The chosen cone `Top.limit_cone F` for a functor `F : J ⥤ Top` is a limit cone.
Generally you should just use `limit.is_limit F`, unless you need the actual definition
(which is in terms of `types.limit_cone_is_limit`).
-/
def limit_cone_is_limit (F : J ⥤ Top.{u}) : is_limit (limit_cone F) :=
{ lift := λ S, { to_fun := λ x, ⟨λ j, S.π.app _ x, λ i j f, by { dsimp, erw ← S.w f, refl }⟩ },
  uniq' := λ S m h, by { ext : 3, simpa [← h] } }

/--
The chosen cone `Top.limit_cone_infi F` for a functor `F : J ⥤ Top` is a limit cone.
Generally you should just use `limit.is_limit F`, unless you need the actual definition
(which is in terms of `types.limit_cone_is_limit`).
-/
def limit_cone_infi_is_limit (F : J ⥤ Top.{u}) : is_limit (limit_cone_infi F) :=
by { refine is_limit.of_faithful forget (types.limit_cone_is_limit _) (λ s, ⟨_, _⟩) (λ s, rfl),
     exact continuous_iff_coinduced_le.mpr (le_infi $ λ j,
       coinduced_le_iff_le_induced.mp $ (continuous_iff_coinduced_le.mp (s.π.app j).continuous :
         _) ) }

instance Top_has_limits : has_limits.{u} Top.{u} :=
{ has_limits_of_shape := λ J 𝒥, by exactI
  { has_limit := λ F, has_limit.mk { cone := limit_cone F, is_limit := limit_cone_is_limit F } } }

instance forget_preserves_limits : preserves_limits (forget : Top.{u} ⥤ Type u) :=
{ preserves_limits_of_shape := λ J 𝒥,
  { preserves_limit := λ F,
    by exactI preserves_limit_of_preserves_limit_cone
      (limit_cone_is_limit F) (types.limit_cone_is_limit (F ⋙ forget)) } }

/--
A choice of colimit cocone for a functor `F : J ⥤ Top`.
Generally you should just use `colimit.coone F`, unless you need the actual definition
(which is in terms of `types.colimit_cocone`).
-/
def colimit_cocone (F : J ⥤ Top.{u}) : cocone F :=
{ X := ⟨(types.colimit_cocone (F ⋙ forget)).X, ⨆ j,
        (F.obj j).str.coinduced ((types.colimit_cocone (F ⋙ forget)).ι.app j)⟩,
  ι :=
  { app := λ j, ⟨(types.colimit_cocone (F ⋙ forget)).ι.app j,
                 continuous_iff_coinduced_le.mpr (le_supr _ j)⟩,
    naturality' := λ j j' f,
                   continuous_map.coe_inj ((types.colimit_cocone (F ⋙ forget)).ι.naturality f) } }

/--
The chosen cocone `Top.colimit_cocone F` for a functor `F : J ⥤ Top` is a colimit cocone.
Generally you should just use `colimit.is_colimit F`, unless you need the actual definition
(which is in terms of `types.colimit_cocone_is_colimit`).
-/
def colimit_cocone_is_colimit (F : J ⥤ Top.{u}) : is_colimit (colimit_cocone F) :=
by { refine is_colimit.of_faithful forget (types.colimit_cocone_is_colimit _) (λ s, ⟨_, _⟩)
       (λ s, rfl),
     exact continuous_iff_le_induced.mpr (supr_le $ λ j,
       coinduced_le_iff_le_induced.mp $ (continuous_iff_coinduced_le.mp (s.ι.app j).continuous :
         _) ) }

instance Top_has_colimits : has_colimits.{u} Top.{u} :=
{ has_colimits_of_shape := λ J 𝒥, by exactI
  { has_colimit := λ F, has_colimit.mk { cocone := colimit_cocone F, is_colimit :=
    colimit_cocone_is_colimit F } } }

instance forget_preserves_colimits : preserves_colimits (forget : Top.{u} ⥤ Type u) :=
{ preserves_colimits_of_shape := λ J 𝒥,
  { preserves_colimit := λ F,
    by exactI preserves_colimit_of_preserves_colimit_cocone
      (colimit_cocone_is_colimit F) (types.colimit_cocone_is_colimit (F ⋙ forget)) } }

/-- The projection from the product as a bundled continous map. -/
abbreviation pi_π {ι : Type u} (α : ι → Top.{u}) (i : ι) : Top.of (Π i, α i) ⟶ α i :=
⟨λ f, f i, continuous_apply i⟩

/-- The explicit fan of a family of topological spaces given by the pi type. -/
@[simps X π_app]
def pi_fan {ι : Type u} (α : ι → Top.{u}) : fan α :=
fan.mk (Top.of (Π i, α i)) (pi_π α)

/-- The constructed fan is indeed a limit -/
def pi_fan_is_limit {ι : Type u} (α : ι → Top.{u}) : is_limit (pi_fan α) :=
{ lift := λ S, { to_fun := λ s i, S.π.app i s },
  uniq' := by { intros S m h, ext x i, simp [← h i] } }

/--
The product is homeomorphic to the product of the underlying spaces,
equipped with the product topology.
-/
def pi_iso_pi {ι : Type u} (α : ι → Top.{u}) : ∏ α ≅ Top.of (Π i, α i) :=
(limit.is_limit _).cone_point_unique_up_to_iso (pi_fan_is_limit α)

@[simp, reassoc]
lemma pi_iso_pi_inv_π {ι : Type u} (α : ι → Top) (i : ι) :
  (pi_iso_pi α).inv ≫ pi.π α i = pi_π α i :=
by simp [pi_iso_pi]

@[simp]
lemma pi_iso_pi_inv_π_apply {ι : Type u} (α : ι → Top.{u}) (i : ι) (x : Π i, α i) :
  (pi.π α i : _) ((pi_iso_pi α).inv x) = x i :=
concrete_category.congr_hom (pi_iso_pi_inv_π α i) x

@[simp]
lemma pi_iso_pi_hom_apply {ι : Type u} (α : ι → Top.{u}) (i : ι) (x : ∏ α) :
  (pi_iso_pi α).hom x i = (pi.π α i : _) x :=
begin
  have := pi_iso_pi_inv_π α i,
  rw iso.inv_comp_eq at this,
  exact concrete_category.congr_hom this x
end

/-- The inclusion to the coproduct as a bundled continous map. -/
abbreviation sigma_ι {ι : Type u} (α : ι → Top.{u}) (i : ι) : α i ⟶ Top.of (Σ i, α i) :=
⟨sigma.mk i⟩

/-- The explicit cofan of a family of topological spaces given by the sigma type. -/
@[simps X ι_app]
def sigma_cofan {ι : Type u} (α : ι → Top.{u}) : cofan α :=
cofan.mk (Top.of (Σ i, α i)) (sigma_ι α)

/-- The constructed cofan is indeed a colimit -/
def sigma_cofan_is_colimit {ι : Type u} (α : ι → Top.{u}) : is_colimit (sigma_cofan α) :=
{ desc := λ S, { to_fun := λ s, S.ι.app s.1 s.2,
    continuous_to_fun := by { continuity, dsimp only, continuity } },
  uniq' := by { intros S m h,  ext ⟨i, x⟩, simp [← h i] } }

/--
The coproduct is homeomorphic to the disjoint union of the topological spaces.
-/
def sigma_iso_sigma {ι : Type u} (α : ι → Top.{u}) : ∐ α ≅ Top.of (Σ i, α i) :=
(colimit.is_colimit _).cocone_point_unique_up_to_iso (sigma_cofan_is_colimit α)

@[simp, reassoc]
lemma sigma_iso_sigma_hom_ι {ι : Type u} (α : ι → Top) (i : ι) :
  sigma.ι α i ≫ (sigma_iso_sigma α).hom = sigma_ι α i :=
by simp [sigma_iso_sigma]

@[simp]
lemma sigma_iso_sigma_hom_ι_apply {ι : Type u} (α : ι → Top) (i : ι) (x : α i) :
  (sigma_iso_sigma α).hom ((sigma.ι α i : _) x) = sigma.mk i x :=
concrete_category.congr_hom (sigma_iso_sigma_hom_ι α i) x

@[simp]
lemma sigma_iso_sigma_inv_apply {ι : Type u} (α : ι → Top) (i : ι) (x : α i) :
  (sigma_iso_sigma α).inv ⟨i, x⟩ = (sigma.ι α i : _) x :=
by { rw [← sigma_iso_sigma_hom_ι_apply, ← comp_app], simp, }

lemma induced_of_is_limit {F : J ⥤ Top.{u}} (C : cone F) (hC : is_limit C) :
  C.X.topological_space = ⨅ j, (F.obj j).topological_space.induced (C.π.app j) :=
begin
  let homeo := homeo_of_iso (hC.cone_point_unique_up_to_iso (limit_cone_infi_is_limit F)),
  refine homeo.inducing.induced.trans _,
  change induced homeo (⨅ (j : J), _) = _,
  simpa [induced_infi, induced_compose],
end

lemma limit_topology (F : J ⥤ Top.{u}) :
  (limit F).topological_space = ⨅ j, (F.obj j).topological_space.induced (limit.π F j) :=
induced_of_is_limit _ (limit.is_limit F)

section prod

/-- The first projection from the product. -/
abbreviation prod_fst {X Y : Top.{u}} : Top.of (X × Y) ⟶ X := ⟨prod.fst⟩

/-- The second projection from the product. -/
abbreviation prod_snd {X Y : Top.{u}} : Top.of (X × Y) ⟶ Y := ⟨prod.snd⟩

/-- The explicit binary cofan of `X, Y` given by `X × Y`. -/
def prod_binary_fan (X Y : Top.{u}) : binary_fan X Y :=
binary_fan.mk prod_fst prod_snd

/-- The constructed binary fan is indeed a limit -/
def prod_binary_fan_is_limit (X Y : Top.{u}) : is_limit (prod_binary_fan X Y) :=
{ lift := λ (S : binary_fan X Y), { to_fun := λ s, (S.fst s, S.snd s) },
  fac' := begin
    rintros S (_|_),
    tidy
  end,
  uniq' := begin
    intros S m h,
    ext x,
    { specialize h walking_pair.left,
      apply_fun (λ e, (e x)) at h,
      exact h },
     { specialize h walking_pair.right,
      apply_fun (λ e, (e x)) at h,
      exact h },
  end }

/--
The homeomorphism between `X ⨯ Y` and the set-theoretic product of `X` and `Y`,
equipped with the product topology.
-/
def prod_iso_prod (X Y : Top.{u}) : X ⨯ Y ≅ Top.of (X × Y) :=
(limit.is_limit _).cone_point_unique_up_to_iso (prod_binary_fan_is_limit X Y)

@[simp, reassoc] lemma prod_iso_prod_hom_fst (X Y : Top.{u}) :
  (prod_iso_prod X Y).hom ≫ prod_fst = limits.prod.fst :=
by simpa [← iso.eq_inv_comp, prod_iso_prod]

@[simp, reassoc] lemma prod_iso_prod_hom_snd (X Y : Top.{u}) :
  (prod_iso_prod X Y).hom ≫ prod_snd = limits.prod.snd :=
by simpa [← iso.eq_inv_comp, prod_iso_prod]

@[simp] lemma prod_iso_prod_hom_apply {X Y : Top.{u}} (x : X ⨯ Y) :
  (prod_iso_prod X Y).hom x =
    ((limits.prod.fst : X ⨯ Y ⟶ _) x, (limits.prod.snd : X ⨯ Y ⟶ _) x) :=
begin
  ext,
  { exact concrete_category.congr_hom (prod_iso_prod_hom_fst X Y) x },
  { exact concrete_category.congr_hom (prod_iso_prod_hom_snd X Y) x }
end

@[simp, reassoc, elementwise] lemma prod_iso_prod_inv_fst (X Y : Top.{u}) :
  (prod_iso_prod X Y).inv ≫ limits.prod.fst = prod_fst :=
by simp [iso.inv_comp_eq]

@[simp, reassoc, elementwise] lemma prod_iso_prod_inv_snd (X Y : Top.{u}) :
  (prod_iso_prod X Y).inv ≫ limits.prod.snd = prod_snd :=
by simp [iso.inv_comp_eq]

lemma prod_topology {X Y : Top} :
  (X ⨯ Y).topological_space =
    induced (limits.prod.fst : X ⨯ Y ⟶ _) X.topological_space ⊓
      induced (limits.prod.snd : X ⨯ Y ⟶ _) Y.topological_space :=
begin
  let homeo := homeo_of_iso (prod_iso_prod X Y),
  refine homeo.inducing.induced.trans _,
  change induced homeo (_ ⊓ _) = _,
  simpa [induced_compose]
end

lemma range_prod_map {W X Y Z : Top.{u}} (f : W ⟶ Y) (g : X ⟶ Z) :
  set.range (limits.prod.map f g) =
    (limits.prod.fst : Y ⨯ Z ⟶ _) ⁻¹' (set.range f) ∩
      (limits.prod.snd : Y ⨯ Z ⟶ _) ⁻¹' (set.range g) :=
begin
  ext,
  split,
  { rintros ⟨y, rfl⟩,
    simp only [set.mem_preimage, set.mem_range, set.mem_inter_eq, ←comp_apply],
    simp only [limits.prod.map_fst, limits.prod.map_snd,
      exists_apply_eq_apply, comp_apply, and_self] },
  { rintros ⟨⟨x₁, hx₁⟩, ⟨x₂, hx₂⟩⟩,
    use (prod_iso_prod W X).inv (x₁, x₂),
    apply concrete.limit_ext,
    rintro ⟨⟩,
    { simp only [← comp_apply, category.assoc], erw limits.prod.map_fst, simp [hx₁] },
    { simp only [← comp_apply, category.assoc], erw limits.prod.map_snd, simp [hx₂] } }
end

lemma inducing_prod_map {W X Y Z : Top} {f : W ⟶ X} {g : Y ⟶ Z}
  (hf : inducing f) (hg : inducing g) : inducing (limits.prod.map f g) :=
begin
  constructor,
  simp only [prod_topology, induced_compose, ←coe_comp, limits.prod.map_fst, limits.prod.map_snd,
    induced_inf],
  simp only [coe_comp],
  rw [← @induced_compose _ _ _ _ _ f, ← @induced_compose _ _ _ _ _ g, ← hf.induced, ← hg.induced]
end

lemma embedding_prod_map {W X Y Z : Top} {f : W ⟶ X} {g : Y ⟶ Z}
  (hf : embedding f) (hg : embedding g) : embedding (limits.prod.map f g) :=
⟨inducing_prod_map hf.to_inducing hg.to_inducing,
begin
  haveI := (Top.mono_iff_injective _).mpr hf.inj,
  haveI := (Top.mono_iff_injective _).mpr hg.inj,
  exact (Top.mono_iff_injective _).mp infer_instance
end⟩

end prod

section pullback

variables {X Y Z : Top.{u}}

/-- The first projection from the pullback. -/
abbreviation pullback_fst (f : X ⟶ Z) (g : Y ⟶ Z) : Top.of { p : X × Y // f p.1 = g p.2 } ⟶ X :=
⟨prod.fst ∘ subtype.val⟩

/-- The second projection from the pullback. -/
abbreviation pullback_snd (f : X ⟶ Z) (g : Y ⟶ Z) : Top.of { p : X × Y // f p.1 = g p.2 } ⟶ Y :=
⟨prod.snd ∘ subtype.val⟩

/-- The explicit pullback cone of `X, Y` given by `{ p : X × Y // f p.1 = g p.2 }`. -/
def pullback_cone (f : X ⟶ Z) (g : Y ⟶ Z) : pullback_cone f g :=
pullback_cone.mk (pullback_fst f g) (pullback_snd f g) (by { ext ⟨x, h⟩, simp [h] })

/-- The constructed cone is a limit. -/
def pullback_cone_is_limit (f : X ⟶ Z) (g : Y ⟶ Z) :
  is_limit (pullback_cone f g) := pullback_cone.is_limit_aux' _
begin
  intro s,
  split, swap,
  exact { to_fun := λ x, ⟨⟨s.fst x, s.snd x⟩,
    by simpa using concrete_category.congr_hom s.condition x⟩ },
  refine ⟨_,_,_⟩,
  { ext, delta pullback_cone, simp },
  { ext, delta pullback_cone, simp },
  { intros m h₁ h₂,
    ext x,
    { simpa using concrete_category.congr_hom h₁ x },
    { simpa using concrete_category.congr_hom h₂ x } }
end

/-- The pullback of two maps can be identified as a subspace of `X × Y`. -/
def pullback_iso_prod_subtype (f : X ⟶ Z) (g : Y ⟶ Z) :
  pullback f g ≅ Top.of { p : X × Y // f p.1 = g p.2 } :=
(limit.is_limit _).cone_point_unique_up_to_iso (pullback_cone_is_limit f g)

@[simp, reassoc] lemma pullback_iso_prod_subtype_inv_fst (f : X ⟶ Z) (g : Y ⟶ Z) :
  (pullback_iso_prod_subtype f g).inv ≫ pullback.fst = pullback_fst f g :=
by simpa [pullback_iso_prod_subtype]

@[simp] lemma pullback_iso_prod_subtype_inv_fst_apply (f : X ⟶ Z) (g : Y ⟶ Z)
  (x : { p : X × Y // f p.1 = g p.2 }) :
  (pullback.fst : pullback f g ⟶ _) ((pullback_iso_prod_subtype f g).inv x) = (x : X × Y).fst :=
concrete_category.congr_hom (pullback_iso_prod_subtype_inv_fst f g) x

@[simp, reassoc] lemma pullback_iso_prod_subtype_inv_snd (f : X ⟶ Z) (g : Y ⟶ Z) :
  (pullback_iso_prod_subtype f g).inv ≫ pullback.snd = pullback_snd f g :=
by simpa [pullback_iso_prod_subtype]

@[simp] lemma pullback_iso_prod_subtype_inv_snd_apply (f : X ⟶ Z) (g : Y ⟶ Z)
  (x : { p : X × Y // f p.1 = g p.2 }) :
  (pullback.snd : pullback f g ⟶ _) ((pullback_iso_prod_subtype f g).inv x) = (x : X × Y).snd :=
concrete_category.congr_hom (pullback_iso_prod_subtype_inv_snd f g) x

lemma pullback_iso_prod_subtype_hom_fst (f : X ⟶ Z) (g : Y ⟶ Z) :
  (pullback_iso_prod_subtype f g).hom ≫ pullback_fst f g = pullback.fst :=
by rw [←iso.eq_inv_comp, pullback_iso_prod_subtype_inv_fst]

lemma pullback_iso_prod_subtype_hom_snd (f : X ⟶ Z) (g : Y ⟶ Z) :
  (pullback_iso_prod_subtype f g).hom ≫ pullback_snd f g = pullback.snd :=
by rw [←iso.eq_inv_comp, pullback_iso_prod_subtype_inv_snd]

@[simp] lemma pullback_iso_prod_subtype_hom_apply {f : X ⟶ Z} {g : Y ⟶ Z}
  (x : pullback f g) : (pullback_iso_prod_subtype f g).hom x =
    ⟨⟨(pullback.fst : pullback f g ⟶ _) x, (pullback.snd : pullback f g ⟶ _) x⟩,
      by simpa using concrete_category.congr_hom pullback.condition x⟩ :=
begin
  ext,
  exacts [concrete_category.congr_hom (pullback_iso_prod_subtype_hom_fst f g) x,
    concrete_category.congr_hom (pullback_iso_prod_subtype_hom_snd f g) x]
end

lemma pullback_topology {X Y Z : Top.{u}} (f : X ⟶ Z) (g : Y ⟶ Z) :
  (pullback f g).topological_space =
    induced (pullback.fst : pullback f g ⟶ _) X.topological_space ⊓
      induced (pullback.snd : pullback f g ⟶ _) Y.topological_space :=
begin
  let homeo := homeo_of_iso (pullback_iso_prod_subtype f g),
  refine homeo.inducing.induced.trans _,
  change induced homeo (induced _ (_ ⊓ _)) = _,
  simpa [induced_compose]
end

lemma range_pullback_to_prod {X Y Z : Top} (f : X ⟶ Z) (g : Y ⟶ Z) :
  set.range (prod.lift pullback.fst pullback.snd : pullback f g ⟶ X ⨯ Y) =
  { x | (limits.prod.fst ≫ f) x = (limits.prod.snd ≫ g) x } :=
begin
  ext x,
  split,
  { rintros ⟨y, rfl⟩,
    simp only [←comp_apply, set.mem_set_of_eq],
    congr' 1,
    simp [pullback.condition] },
  { intro h,
    use (pullback_iso_prod_subtype f g).inv ⟨⟨_, _⟩, h⟩,
    apply concrete.limit_ext,
    rintro ⟨⟩; simp }
end

lemma inducing_pullback_to_prod {X Y Z : Top} (f : X ⟶ Z) (g : Y ⟶ Z) :
  inducing ⇑(prod.lift pullback.fst pullback.snd : pullback f g ⟶ X ⨯ Y) :=
⟨by simp [prod_topology, pullback_topology, induced_compose, ←coe_comp]⟩

lemma embedding_pullback_to_prod {X Y Z : Top} (f : X ⟶ Z) (g : Y ⟶ Z) :
  embedding ⇑(prod.lift pullback.fst pullback.snd : pullback f g ⟶ X ⨯ Y) :=
⟨inducing_pullback_to_prod f g, (Top.mono_iff_injective _).mp infer_instance⟩

/-- If the map `S ⟶ T` is mono, then there is a description of the image of `W ×ₛ X ⟶ Y ×ₜ Z`. -/
lemma range_pullback_map {W X Y Z S T : Top} (f₁ : W ⟶ S) (f₂ : X ⟶ S)
  (g₁ : Y ⟶ T) (g₂ : Z ⟶ T) (i₁ : W ⟶ Y) (i₂ : X ⟶ Z) (i₃ : S ⟶ T) [H₃ : mono i₃]
  (eq₁ : f₁ ≫ i₃ = i₁ ≫ g₁) (eq₂ : f₂ ≫ i₃ = i₂ ≫ g₂) :
  set.range (pullback.map f₁ f₂ g₁ g₂ i₁ i₂ i₃ eq₁ eq₂) =
    (pullback.fst : pullback g₁ g₂ ⟶ _) ⁻¹' (set.range i₁) ∩
      (pullback.snd : pullback g₁ g₂ ⟶ _) ⁻¹' (set.range i₂) :=
begin
  ext,
  split,
  { rintro ⟨y, rfl⟩, simp, },
  rintros ⟨⟨x₁, hx₁⟩, ⟨x₂, hx₂⟩⟩,
  have : f₁ x₁ = f₂ x₂,
  { apply (Top.mono_iff_injective _).mp H₃,
    simp only [←comp_apply, eq₁, eq₂],
    simp only [comp_apply, hx₁, hx₂],
    simp only [←comp_apply, pullback.condition] },
  use (pullback_iso_prod_subtype f₁ f₂).inv ⟨⟨x₁, x₂⟩, this⟩,
  apply concrete.limit_ext,
  rintros (_|_|_),
  { simp only [Top.comp_app, limit.lift_π_apply, category.assoc, pullback_cone.mk_π_app_one,
      hx₁, pullback_iso_prod_subtype_inv_fst_apply, subtype.coe_mk],
    simp only [← comp_apply],
    congr,
    apply limit.w _ walking_cospan.hom.inl },
  { simp [hx₁] },
  { simp [hx₂] },
end

lemma pullback_fst_range {X Y S : Top} (f : X ⟶ S) (g : Y ⟶ S) :
  set.range (pullback.fst : pullback f g ⟶ _) = { x : X | ∃ y : Y, f x = g y} :=
begin
  ext x,
  split,
  { rintro ⟨y, rfl⟩,
    use (pullback.snd : pullback f g ⟶ _) y,
    exact concrete_category.congr_hom pullback.condition y },
  { rintro ⟨y, eq⟩,
    use (Top.pullback_iso_prod_subtype f g).inv ⟨⟨x, y⟩, eq⟩,
    simp },
end

lemma pullback_snd_range {X Y S : Top} (f : X ⟶ S) (g : Y ⟶ S) :
  set.range (pullback.snd : pullback f g ⟶ _) = { y : Y | ∃ x : X, f x = g y} :=
begin
  ext y,
  split,
  { rintro ⟨x, rfl⟩,
    use (pullback.fst : pullback f g ⟶ _) x,
    exact concrete_category.congr_hom pullback.condition x },
  { rintro ⟨x, eq⟩,
    use (Top.pullback_iso_prod_subtype f g).inv ⟨⟨x, y⟩, eq⟩,
    simp },
end

/--
If there is a diagram where the morphisms `W ⟶ Y` and `X ⟶ Z` are embeddings,
then the induced morphism `W ×ₛ X ⟶ Y ×ₜ Z` is also an embedding.

  W  ⟶  Y
    ↘      ↘
      S  ⟶  T
    ↗      ↗
  X  ⟶  Z
-/
lemma pullback_map_embedding_of_embeddings {W X Y Z S T : Top}
  (f₁ : W ⟶ S) (f₂ : X ⟶ S) (g₁ : Y ⟶ T) (g₂ : Z ⟶ T) {i₁ : W ⟶ Y} {i₂ : X ⟶ Z}
  (H₁ : embedding i₁) (H₂ : embedding i₂) (i₃ : S ⟶ T)
  (eq₁ : f₁ ≫ i₃ = i₁ ≫ g₁) (eq₂ : f₂ ≫ i₃ = i₂ ≫ g₂) :
  embedding (pullback.map f₁ f₂ g₁ g₂ i₁ i₂ i₃ eq₁ eq₂) :=
begin
  refine embedding_of_embedding_compose (continuous_map.continuous_to_fun _)
    (show continuous (prod.lift pullback.fst pullback.snd : pullback g₁ g₂ ⟶ Y ⨯ Z), from
      continuous_map.continuous_to_fun _) _,
  suffices : embedding
    (prod.lift pullback.fst pullback.snd ≫ limits.prod.map i₁ i₂ : pullback f₁ f₂ ⟶ _),
  { simpa [←coe_comp] using this },
  rw coe_comp,
  refine embedding.comp (embedding_prod_map H₁ H₂)
    (embedding_pullback_to_prod _ _)
end

/--
If there is a diagram where the morphisms `W ⟶ Y` and `X ⟶ Z` are open embeddings, and `S ⟶ T`
is mono, then the induced morphism `W ×ₛ X ⟶ Y ×ₜ Z` is also an open embedding.
  W  ⟶  Y
    ↘      ↘
      S  ⟶  T
    ↗       ↗
  X  ⟶  Z
-/
lemma pullback_map_open_embedding_of_open_embeddings {W X Y Z S T : Top}
  (f₁ : W ⟶ S) (f₂ : X ⟶ S) (g₁ : Y ⟶ T) (g₂ : Z ⟶ T) {i₁ : W ⟶ Y} {i₂ : X ⟶ Z}
  (H₁ : open_embedding i₁) (H₂ : open_embedding i₂) (i₃ : S ⟶ T) [H₃ : mono i₃]
  (eq₁ : f₁ ≫ i₃ = i₁ ≫ g₁) (eq₂ : f₂ ≫ i₃ = i₂ ≫ g₂) :
  open_embedding (pullback.map f₁ f₂ g₁ g₂ i₁ i₂ i₃ eq₁ eq₂) :=
begin
  split,
  { apply pullback_map_embedding_of_embeddings
      f₁ f₂ g₁ g₂ H₁.to_embedding H₂.to_embedding i₃ eq₁ eq₂ },
  { rw range_pullback_map,
    apply is_open.inter; apply continuous.is_open_preimage,
    continuity,
    exacts [H₁.open_range, H₂.open_range] }
end

lemma snd_embedding_of_left_embedding {X Y S : Top}
  {f : X ⟶ S} (H : embedding f) (g : Y ⟶ S) :
  embedding ⇑(pullback.snd : pullback f g ⟶ Y) :=
begin
  convert (homeo_of_iso (as_iso (pullback.snd : pullback (𝟙 S) g ⟶ _))).embedding.comp
    (pullback_map_embedding_of_embeddings f g (𝟙 _) g H
      (homeo_of_iso (iso.refl _)).embedding (𝟙 _) rfl (by simp)),
  erw ←coe_comp,
  simp
end

lemma fst_embedding_of_right_embedding {X Y S : Top}
  (f : X ⟶ S) {g : Y ⟶ S} (H : embedding g) :
  embedding ⇑(pullback.fst : pullback f g ⟶ X) :=
begin
  convert (homeo_of_iso (as_iso (pullback.fst : pullback f (𝟙 S) ⟶ _))).embedding.comp
    (pullback_map_embedding_of_embeddings f g f (𝟙 _)
      (homeo_of_iso (iso.refl _)).embedding H (𝟙 _) rfl (by simp)),
  erw ←coe_comp,
  simp
end

lemma embedding_of_pullback_embeddings {X Y S : Top}
  {f : X ⟶ S} {g : Y ⟶ S} (H₁ : embedding f) (H₂ : embedding g) :
  embedding (limit.π (cospan f g) walking_cospan.one) :=
begin
  convert H₂.comp (snd_embedding_of_left_embedding H₁ g),
  erw ←coe_comp,
  congr,
  exact (limit.w _ walking_cospan.hom.inr).symm
end

lemma snd_open_embedding_of_left_open_embedding {X Y S : Top}
  {f : X ⟶ S} (H : open_embedding f) (g : Y ⟶ S) :
  open_embedding ⇑(pullback.snd : pullback f g ⟶ Y) :=
begin
  convert (homeo_of_iso (as_iso (pullback.snd : pullback (𝟙 S) g ⟶ _))).open_embedding.comp
    (pullback_map_open_embedding_of_open_embeddings f g (𝟙 _) g H
      (homeo_of_iso (iso.refl _)).open_embedding (𝟙 _) rfl (by simp)),
  erw ←coe_comp,
  simp
end

lemma fst_open_embedding_of_right_open_embedding {X Y S : Top}
  (f : X ⟶ S) {g : Y ⟶ S} (H : open_embedding g) :
  open_embedding ⇑(pullback.fst : pullback f g ⟶ X) :=
begin
  convert (homeo_of_iso (as_iso (pullback.fst : pullback f (𝟙 S) ⟶ _))).open_embedding.comp
    (pullback_map_open_embedding_of_open_embeddings f g f (𝟙 _)
      (homeo_of_iso (iso.refl _)).open_embedding H (𝟙 _) rfl (by simp)),
  erw ←coe_comp,
  simp
end

/-- If `X ⟶ S`, `Y ⟶ S` are open embeddings, then so is `X ×ₛ Y ⟶ S`. -/
lemma open_embedding_of_pullback_open_embeddings {X Y S : Top}
  {f : X ⟶ S} {g : Y ⟶ S} (H₁ : open_embedding f) (H₂ : open_embedding g) :
  open_embedding (limit.π (cospan f g) walking_cospan.one) :=
begin
  convert H₂.comp (snd_open_embedding_of_left_open_embedding H₁ g),
  erw ←coe_comp,
  congr,
  exact (limit.w _ walking_cospan.hom.inr).symm
end

lemma fst_iso_of_right_embedding_range_subset {X Y S : Top} (f : X ⟶ S) {g : Y ⟶ S}
  (hg : embedding g) (H : set.range f ⊆ set.range g) : is_iso (pullback.fst : pullback f g ⟶ X) :=
begin
  let : (pullback f g : Top) ≃ₜ X :=
    (homeomorph.of_embedding _ (fst_embedding_of_right_embedding f hg)).trans
    { to_fun := coe,
      inv_fun := (λ x, ⟨x,
        by { rw pullback_fst_range, exact ⟨_, (H (set.mem_range_self x)).some_spec.symm⟩ }⟩),
      left_inv := λ ⟨_,_⟩, rfl,
      right_inv := λ x, rfl },
  convert is_iso.of_iso (iso_of_homeo this),
  ext,
  refl
end

lemma snd_iso_of_left_embedding_range_subset {X Y S : Top} {f : X ⟶ S} (hf : embedding f)
  (g : Y ⟶ S) (H : set.range g ⊆ set.range f) : is_iso (pullback.snd : pullback f g ⟶ Y) :=
begin
  let : (pullback f g : Top) ≃ₜ Y :=
    (homeomorph.of_embedding _ (snd_embedding_of_left_embedding hf g)).trans
    { to_fun := coe,
      inv_fun := (λ x, ⟨x,
        by { rw pullback_snd_range, exact ⟨_, (H (set.mem_range_self x)).some_spec⟩ }⟩),
      left_inv := λ ⟨_,_⟩, rfl,
      right_inv := λ x, rfl },
  convert is_iso.of_iso (iso_of_homeo this),
  ext,
  refl
end

end pullback

--TODO: Add analogous constructions for `coprod` and `pushout`.

lemma coinduced_of_is_colimit {F : J ⥤ Top.{u}} (c : cocone F) (hc : is_colimit c) :
  c.X.topological_space = ⨆ j, (F.obj j).topological_space.coinduced (c.ι.app j) :=
begin
  let homeo := homeo_of_iso (hc.cocone_point_unique_up_to_iso (colimit_cocone_is_colimit F)),
  ext,
  refine homeo.symm.is_open_preimage.symm.trans (iff.trans _ is_open_supr_iff.symm),
  exact is_open_supr_iff
end

lemma colimit_topology (F : J ⥤ Top.{u}) :
  (colimit F).topological_space = ⨆ j, (F.obj j).topological_space.coinduced (colimit.ι F j) :=
coinduced_of_is_colimit _ (colimit.is_colimit F)

lemma colimit_is_open_iff (F : J ⥤ Top.{u}) (U : set ((colimit F : _) : Type u)) :
  is_open U ↔ ∀ j, is_open (colimit.ι F j ⁻¹' U) :=
begin
  conv_lhs { rw colimit_topology F },
  exact is_open_supr_iff
end

lemma coequalizer_is_open_iff (F : walking_parallel_pair.{u} ⥤ Top.{u})
  (U : set ((colimit F : _) : Type u)) :
  is_open U ↔ is_open (colimit.ι F walking_parallel_pair.one ⁻¹' U) :=
begin
  rw colimit_is_open_iff,
  split,
  { intro H, exact H _ },
  { intros H j,
    cases j,
    { rw ←colimit.w F walking_parallel_pair_hom.left,
      exact (F.map walking_parallel_pair_hom.left).continuous_to_fun.is_open_preimage _ H },
    { exact H } }
end

end Top

namespace Top

section cofiltered_limit

variables {J : Type u} [small_category J] [is_cofiltered J] (F : J ⥤ Top.{u})
  (C : cone F) (hC : is_limit C)

include hC

/--
Given a *compatible* collection of topological bases for the factors in a cofiltered limit
which contain `set.univ` and are closed under intersections, the induced *naive* collection
of sets in the limit is, in fact, a topological basis.
-/
theorem is_topological_basis_cofiltered_limit
  (T : Π j, set (set (F.obj j))) (hT : ∀ j, is_topological_basis (T j))
  (univ : ∀ (i : J), set.univ ∈ T i)
  (inter : ∀ i (U1 U2 : set (F.obj i)), U1 ∈ T i → U2 ∈ T i → U1 ∩ U2 ∈ T i)
  (compat : ∀ (i j : J) (f : i ⟶ j) (V : set (F.obj j)) (hV : V ∈ T j), (F.map f) ⁻¹' V ∈ T i) :
  is_topological_basis { U : set C.X | ∃ j (V : set (F.obj j)), V ∈ T j ∧ U = C.π.app j ⁻¹' V } :=
begin
  classical,
  -- The limit cone for `F` whose topology is defined as an infimum.
  let D := limit_cone_infi F,
  -- The isomorphism between the cone point of `C` and the cone point of `D`.
  let E : C.X ≅ D.X := hC.cone_point_unique_up_to_iso (limit_cone_infi_is_limit _),
  have hE : inducing E.hom := (Top.homeo_of_iso E).inducing,
  -- Reduce to the assertion of the theorem with `D` instead of `C`.
  suffices : is_topological_basis
    { U : set D.X | ∃ j (V : set (F.obj j)), V ∈ T j ∧ U = D.π.app j ⁻¹' V },
  { convert this.inducing hE,
    ext U0,
    split,
    { rintro ⟨j, V, hV, rfl⟩,
      refine ⟨D.π.app j ⁻¹' V, ⟨j, V, hV, rfl⟩, rfl⟩ },
    { rintro ⟨W, ⟨j, V, hV, rfl⟩, rfl⟩,
      refine ⟨j, V, hV, rfl⟩ } },
  -- Using `D`, we can apply the characterization of the topological basis of a
  -- topology defined as an infimum...
  convert is_topological_basis_infi hT (λ j (x : D.X), D.π.app j x),
  ext U0,
  split,
  { rintros  ⟨j, V, hV, rfl⟩,
    let U : Π i, set (F.obj i) := λ i, if h : i = j then (by {rw h, exact V}) else set.univ,
    refine ⟨U,{j},_,_⟩,
    { rintro i h,
      rw finset.mem_singleton at h,
      dsimp [U],
      rw dif_pos h,
      subst h,
      exact hV },
    { dsimp [U],
      simp } },
  { rintros ⟨U, G, h1, h2⟩,
    obtain ⟨j, hj⟩ := is_cofiltered.inf_objs_exists G,
    let g : ∀ e (he : e ∈ G), j ⟶ e := λ _ he, (hj he).some,
    let Vs : J → set (F.obj j) := λ e, if h : e ∈ G then F.map (g e h) ⁻¹' (U e) else set.univ,
    let V : set (F.obj j) := ⋂ (e : J) (he : e ∈ G), Vs e,
    refine ⟨j, V, _, _⟩,
    { -- An intermediate claim used to apply induction along `G : finset J` later on.
      have : ∀ (S : set (set (F.obj j))) (E : finset J) (P : J → set (F.obj j))
        (univ : set.univ ∈ S)
        (inter : ∀ A B : set (F.obj j), A ∈ S → B ∈ S → A ∩ B ∈ S)
        (cond : ∀ (e : J) (he : e ∈ E), P e ∈ S), (⋂ e (he : e ∈ E), P e) ∈ S,
      { intros S E,
        apply E.induction_on,
        { intros P he hh,
          simpa },
        { intros a E ha hh1 hh2 hh3 hh4 hh5,
          rw finset.set_bInter_insert,
          refine hh4 _ _ (hh5 _ (finset.mem_insert_self _ _)) (hh1 _ hh3 hh4 _),
          intros e he,
          exact hh5 e (finset.mem_insert_of_mem he) } },
      -- use the intermediate claim to finish off the goal using `univ` and `inter`.
      refine this _ _ _ (univ _) (inter _) _,
      intros e he,
      dsimp [Vs],
      rw dif_pos he,
      exact compat j e (g e he) (U e) (h1 e he), },
    { -- conclude...
      rw h2,
      dsimp [V],
      rw set.preimage_Inter,
      congr' 1,
      ext1 e,
      rw set.preimage_Inter,
      congr' 1,
      ext1 he,
      dsimp [Vs],
      rw [dif_pos he, ← set.preimage_comp],
      congr' 1,
      change _ = ⇑(D.π.app j ≫ F.map (g e he)),
      rw D.w } }
end

end cofiltered_limit

section topological_konig

/-!
## Topological Kőnig's lemma

A topological version of Kőnig's lemma is that the inverse limit of nonempty compact Hausdorff
spaces is nonempty.  (Note: this can be generalized further to inverse limits of nonempty compact
T0 spaces, where all the maps are closed maps; see [Stone1979] --- however there is an erratum
for Theorem 4 that the element in the inverse limit can have cofinally many components that are
not closed points.)

We give this in a more general form, which is that cofiltered limits
of nonempty compact Hausdorff spaces are nonempty
(`nonempty_limit_cone_of_compact_t2_cofiltered_system`).

This also applies to inverse limits, where `{J : Type u} [directed_order J]` and `F : Jᵒᵖ ⥤ Top`.

The theorem is specialized to nonempty finite types (which are compact Hausdorff with the
discrete topology) in `nonempty_sections_of_fintype_cofiltered_system` and
`nonempty_sections_of_fintype_inverse_system`.

(See https://stacks.math.columbia.edu/tag/086J for the Set version.)
-/

variables {J : Type u} [small_category J]
variables (F : J ⥤ Top.{u})

private abbreviation finite_diagram_arrow {J : Type u} [small_category J] (G : finset J) :=
Σ' (X Y : J) (mX : X ∈ G) (mY : Y ∈ G), X ⟶ Y
private abbreviation finite_diagram (J : Type u) [small_category J] :=
Σ (G : finset J), finset (finite_diagram_arrow G)

/--
Partial sections of a cofiltered limit are sections when restricted to
a finite subset of objects and morphisms of `J`.
-/
def partial_sections {J : Type u} [small_category J] (F : J ⥤ Top.{u})
  {G : finset J} (H : finset (finite_diagram_arrow G)) : set (Π j, F.obj j) :=
{ u | ∀ {f : finite_diagram_arrow G} (hf : f ∈ H), F.map f.2.2.2.2 (u f.1) = u f.2.1 }

lemma partial_sections.nonempty [is_cofiltered J] [h : Π (j : J), nonempty (F.obj j)]
  {G : finset J} (H : finset (finite_diagram_arrow G)) :
  (partial_sections F H).nonempty :=
begin
  classical,
  use λ (j : J), if hj : j ∈ G
                 then F.map (is_cofiltered.inf_to G H hj) (h (is_cofiltered.inf G H)).some
                 else (h _).some,
  rintros ⟨X, Y, hX, hY, f⟩ hf,
  dsimp only,
  rwa [dif_pos hX, dif_pos hY, ←comp_app, ←F.map_comp,
       @is_cofiltered.inf_to_commutes _ _ _ G H],
end

lemma partial_sections.directed :
  directed superset (λ (G : finite_diagram J), partial_sections F G.2) :=
begin
  classical,
  intros A B,
  let ιA : finite_diagram_arrow A.1 → finite_diagram_arrow (A.1 ⊔ B.1) :=
    λ f, ⟨f.1, f.2.1, finset.mem_union_left _ f.2.2.1, finset.mem_union_left _ f.2.2.2.1,
          f.2.2.2.2⟩,
  let ιB : finite_diagram_arrow B.1 → finite_diagram_arrow (A.1 ⊔ B.1) :=
    λ f, ⟨f.1, f.2.1, finset.mem_union_right _ f.2.2.1, finset.mem_union_right _ f.2.2.2.1,
          f.2.2.2.2⟩,
  refine ⟨⟨A.1 ⊔ B.1, A.2.image ιA ⊔ B.2.image ιB⟩, _, _⟩,
  { rintro u hu f hf,
    have : ιA f ∈ A.2.image ιA ⊔ B.2.image ιB,
    { apply finset.mem_union_left,
      rw finset.mem_image,
      refine ⟨f, hf, rfl⟩ },
    exact hu this },
  { rintro u hu f hf,
    have : ιB f ∈ A.2.image ιA ⊔ B.2.image ιB,
    { apply finset.mem_union_right,
      rw finset.mem_image,
      refine ⟨f, hf, rfl⟩ },
    exact hu this }
end

lemma partial_sections.closed [Π (j : J), t2_space (F.obj j)]
  {G : finset J} (H : finset (finite_diagram_arrow G)) :
  is_closed (partial_sections F H) :=
begin
  have : partial_sections F H =
    ⋂ {f : finite_diagram_arrow G} (hf : f ∈ H), { u | F.map f.2.2.2.2 (u f.1) = u f.2.1 },
  { ext1,
    simp only [set.mem_Inter, set.mem_set_of_eq],
    refl, },
  rw this,
  apply is_closed_bInter,
  intros f hf,
  apply is_closed_eq,
  continuity,
end

/--
Cofiltered limits of nonempty compact Hausdorff spaces are nonempty topological spaces.
--/
lemma nonempty_limit_cone_of_compact_t2_cofiltered_system
  [is_cofiltered J]
  [Π (j : J), nonempty (F.obj j)]
  [Π (j : J), compact_space (F.obj j)]
  [Π (j : J), t2_space (F.obj j)] :
  nonempty (Top.limit_cone F).X :=
begin
  classical,
  obtain ⟨u, hu⟩ := is_compact.nonempty_Inter_of_directed_nonempty_compact_closed
    (λ G, partial_sections F _)
    (partial_sections.directed F)
    (λ G, partial_sections.nonempty F _)
    (λ G, is_closed.is_compact (partial_sections.closed F _))
    (λ G, partial_sections.closed F _),
  use u,
  intros X Y f,
  let G : finite_diagram J :=
    ⟨{X, Y},
     {⟨X, Y,
      by simp only [true_or, eq_self_iff_true, finset.mem_insert],
      by simp only [eq_self_iff_true, or_true, finset.mem_insert, finset.mem_singleton],
      f⟩}⟩,
  exact hu _ ⟨G, rfl⟩ (finset.mem_singleton_self _),
end

end topological_konig

end Top

section fintype_konig

/-- This bootstraps `nonempty_sections_of_fintype_inverse_system`. In this version,
the `F` functor is between categories of the same universe, and it is an easy
corollary to `Top.nonempty_limit_cone_of_compact_t2_inverse_system`. -/
lemma nonempty_sections_of_fintype_cofiltered_system.init
  {J : Type u} [small_category J] [is_cofiltered J] (F : J ⥤ Type u)
  [hf : Π (j : J), fintype (F.obj j)] [hne : Π (j : J), nonempty (F.obj j)] :
  F.sections.nonempty :=
begin
  let F' : J ⥤ Top := F ⋙ Top.discrete,
  haveI : Π (j : J), fintype (F'.obj j) := hf,
  haveI : Π (j : J), nonempty (F'.obj j) := hne,
  obtain ⟨⟨u, hu⟩⟩ := Top.nonempty_limit_cone_of_compact_t2_cofiltered_system F',
  exact ⟨u, λ _ _ f, hu f⟩,
end

/-- The cofiltered limit of nonempty finite types is nonempty.

See `nonempty_sections_of_fintype_inverse_system` for a specialization to inverse limits. -/
theorem nonempty_sections_of_fintype_cofiltered_system
  {J : Type u} [category.{w} J] [is_cofiltered J] (F : J ⥤ Type v)
  [Π (j : J), fintype (F.obj j)] [Π (j : J), nonempty (F.obj j)] :
  F.sections.nonempty :=
begin
  -- Step 1: lift everything to the `max u v w` universe.
  let J' : Type (max w v u) := as_small.{max w v} J,
  let down : J' ⥤ J := as_small.down,
  let F' : J' ⥤ Type (max u v w) := down ⋙ F ⋙ ulift_functor.{(max u w) v},
  haveI : ∀ i, nonempty (F'.obj i) := λ i, ⟨⟨classical.arbitrary (F.obj (down.obj i))⟩⟩,
  haveI : ∀ i, fintype (F'.obj i) := λ i, fintype.of_equiv (F.obj (down.obj i)) equiv.ulift.symm,
  -- Step 2: apply the bootstrap theorem
  obtain ⟨u, hu⟩ := nonempty_sections_of_fintype_cofiltered_system.init F',
  -- Step 3: interpret the results
  use λ j, (u ⟨j⟩).down,
  intros j j' f,
  have h := @hu (⟨j⟩ : J') (⟨j'⟩ : J') (ulift.up f),
  simp only [as_small.down, functor.comp_map, ulift_functor_map, functor.op_map] at h,
  simp_rw [←h],
  refl,
end

/-- The inverse limit of nonempty finite types is nonempty.

See `nonempty_sections_of_fintype_cofiltered_system` for a generalization to cofiltered limits.
That version applies in almost all cases, and the only difference is that this version
allows `J` to be empty.

This may be regarded as a generalization of Kőnig's lemma.
To specialize: given a locally finite connected graph, take `Jᵒᵖ` to be `ℕ` and
`F j` to be length-`j` paths that start from an arbitrary fixed vertex.
Elements of `F.sections` can be read off as infinite rays in the graph. -/
theorem nonempty_sections_of_fintype_inverse_system
  {J : Type u} [directed_order J] (F : Jᵒᵖ ⥤ Type v)
  [Π (j : Jᵒᵖ), fintype (F.obj j)] [Π (j : Jᵒᵖ), nonempty (F.obj j)] :
  F.sections.nonempty :=
begin
  tactic.unfreeze_local_instances,
  by_cases h : nonempty J,
  { apply nonempty_sections_of_fintype_cofiltered_system, },
  { rw not_nonempty_iff_imp_false at h,
    exact ⟨λ j, false.elim (h j.unop), λ j, false.elim (h j.unop)⟩, },
end

end fintype_konig


import
  tactic.induction
  tactic.linarith
  ...compiler
  ...semantics

open vm_big_step env_big_step

-- convert from environment-preserving to regular big_step
lemma env_vm_big_step {env env' P S R} :
    (env, P, S) ⟹ₙᵥ (env', R)
  → (env, P, S) ⟹ᵥₘ R :=
begin
  assume hnv,
  induction' hnv,
  case ERunEmpty {
    apply RunEmpty
  },
  case ERunPush {
    apply RunPush,
    exact ih
  },
  case ERunOpInstr {
    apply RunOpInstr,
    exact ih
  },
  case ERunTBranch {
    apply RunTBranch,
    exact ih
  },
  case ERunFBranch {
    apply RunFBranch,
    { exact _x },
    { exact ih }
  },
  case ERunJump {
    apply RunJump,
    { exact _x },
    { exact ih }
  },
  case ERunLookup {
    apply RunLookup,
    { exact _x },
    { exact ih }
  },
  case ERunOpenScope {
    apply RunOpenScope,
    exact ih
  },
  case ERunCloseScope {
    apply RunCloseScope,
    exact ih
  }
end

theorem from_interm_results
  {E₁ E₂ Eᵢ P₁ P₂ S S' I R} :
    (E₁, P₁, S) ⟹ₙᵥ (Eᵢ, I)
  → (Eᵢ, P₂, I ++ S') ⟹ₙᵥ (E₂, R)
  → (E₁, P₁ ++ P₂, S ++ S') ⟹ₙᵥ (E₂, R) :=
begin
  assume h1 h2,
  induction' h1,
  { exact h2 },
  { apply ERunPush,
    rw ←list.cons_append,
    apply ih h2 },
  case ERunOpInstr {
    rw list.cons_append,
    apply ERunOpInstr,
    apply ih h2
  },
  case ERunTBranch {
    rw list.cons_append,
    apply ERunTBranch,
    apply ih h2
  },
  case ERunFBranch {
    rw list.cons_append,
    apply ERunFBranch,
    { rw [at_least, list.length_append],
      rw [at_least] at _x,
      linarith },
    rw [list.drop_append_of_le_length],
    apply ih h2,
    exact _x
  },
  case ERunJump {
    rw list.cons_append,
    apply ERunJump,
    { rw [at_least, list.length_append],
      rw [at_least] at _x,
      linarith },
    rw [list.drop_append_of_le_length],
    apply ih h2,
    exact _x
  },
  case ERunLookup {
    apply ERunLookup _x,
    rw ←list.cons_append,
    apply ih h2
  },
  case ERunOpenScope {
    rw list.cons_append,
    apply ERunOpenScope,
    apply ih h2
  },
  case ERunCloseScope {
    rw list.cons_append,
    apply ERunCloseScope,
    apply ih h2
  }
end

lemma from_interm_results'
  {E₁ E₂ Eᵢ P₁ P₂ S I R} :
    (E₁, P₁, S) ⟹ₙᵥ (Eᵢ, I)
  → (Eᵢ, P₂, I) ⟹ₙᵥ (E₂, R)
  → (E₁, P₁ ++ P₂, S) ⟹ₙᵥ (E₂, R) :=
begin
  assume h1 h2,
  rw ←list.append_nil I at h2,
  rw ←list.append_nil S,
  exact from_interm_results h1 h2
end

theorem to_interm_results {E₁ E₂ e P S S' r} :
  (E₁, compile e ++ P, S) ⟹ₙᵥ (E₂, r :: S')
  → ∃ v, (E₁, compile e, S) ⟹ₙᵥ (E₁, v :: S) ∧
         (E₁, P, v :: S) ⟹ₙᵥ (E₂, r :: S') :=
begin
  assume hnv,
  induction' e,
  case EVal {
    rw compile at hnv ⊢,
    cases' hnv,
    use v,
    apply and.intro,
    { apply ERunPush,
      exact ERunEmpty },
    { exact hnv }
  },
  case EOp {
    rw compile at hnv ⊢,
    simp at hnv ⊢,
    cases' ih_e_1 hnv,
    cases' h with he_1 h,
    cases' ih_e h with u h',
    cases' h' with he h',
    cases' h',
    use eval n m op,
    apply and.intro,
    { apply from_interm_results' he_1,
      apply from_interm_results' he,
      apply ERunOpInstr,
      exact ERunEmpty },
    { exact h' }
  },
  case EIf {
    rw compile at hnv ⊢,
    simp at hnv ⊢,
    cases' ih_e hnv, clear hnv,
    cases' h with he h,
    cases' h,
    case ERunTBranch {
      cases' ih_e_1 h with w h',
      cases' h' with he_1 h',
      cases' h',
      rw [list.drop_append_of_le_length,
          list.drop_length,
          list.nil_append] at h',
      use w,
      apply and.intro,
      { apply from_interm_results' he,
        apply ERunTBranch,
        apply from_interm_results' he_1,
        apply ERunJump,
        exact at_least_refl,
        rw list.drop_length,
        exact ERunEmpty },
      { exact h' },
      refl
    },
    case ERunFBranch {
      rw [nat.add_comm,
          list.drop_add,
          list.drop_one,
          list.drop_append_of_le_length,
          list.drop_length,
          list.nil_append,
          list.tail] at h,
      cases' ih_e_2 h with w h',
      cases' h' with he_2 h',
      use w,
      apply and.intro,
      { apply from_interm_results' he,
        apply ERunFBranch,
        { rw [at_least,
              list.length_append,
              list.length_cons],
          linarith },
        rw [nat.add_comm,
            list.drop_add,
            list.drop_one,
            list.drop_append_of_le_length,
            list.drop_length,
            list.nil_append,
            list.tail],
        exact he_2,
        refl },
      { exact h' },
      refl
    }
  },
  case EVar {
    rw compile at hnv ⊢,
    cases' hnv,
    use v,
    apply and.intro,
    { apply ERunLookup _x,
      exact ERunEmpty },
    { exact hnv }
  },
  case ELet {
    rw compile at hnv ⊢,
    simp at hnv ⊢,
    cases' ih_e hnv,
    cases' h with he h,
    cases' h,
    cases' ih_e_1 h with u h',
    cases' h' with he_1 h',
    cases' h',
    use u,
    apply and.intro,
    { apply from_interm_results' he,
      apply ERunOpenScope,
      apply from_interm_results' he_1,
      apply ERunCloseScope,
      exact ERunEmpty },
    { exact h' }
  }
end


import data.option.basic

example (α : Type*) (a : α) [subsingleton α] : option.choice α = some a :=
begin
  delta option.choice,
  rw dif_pos,
  congr,
  use a,
end


import category_theory.limits.shapes
import category_theory.limits.preserves.limits
import category_theory.limits.shapes.reflexive

import subobject_classifier

/-!
# Pullbacks inside a topos

Lemmas to work with pullbacks in topos
-/
/-
  Convention (compatible with mathlib)

  pullback_cone f g
  pullback_cone.mk fst snd

  X -snd-> Y
  |        |
 fst       g
  |        |
  Z --f--> W
-/

open category_theory category_theory.category category_theory.limits classifier

noncomputable theory
universes u v
variables {C : Type u} [category.{v} C] [has_finite_limits C] [has_subobject_classifier C]

lemma pb_classifier_condition {X Y : C} (m : X ⟶ Y) [mono m] :
  m ≫ classifier_of m = lift_truth X :=
begin
  rw (classifies m).comm,
end

/- Useful lemmas about pb -/
variables {X Y : C} (m : X ⟶ Y) [mono m]

def monic_to_pb_cone : pullback_cone (truth C) (classifier_of m) :=
pullback_cone.mk (terminal.from _) m (classifier.comm _).symm

def sub_iso_cano : X ≅ s{ classifier_of m }s :=
  (limit.iso_limit_cone (limit_cone.mk _ (classifies m).is_pb)).symm

/- Given
       X ---> ⊤
       |      |
  W -> Y ---> Ω
    h
  and the appropriate commutation, we lift it to a map W -> X,
  and we prove the commutativity of the triangle W X Y, and the uniqueness

-/
def pb_lift_from_monic {W X Y : C} (m : X ⟶ Y) [mono m] (h : W ⟶ Y)
  (w : h ≫ (classifier_of m) = lift_truth _) :=
pullback_cone.is_limit.lift' (classifies m).is_pb h (terminal.from W) w

def pb_lift_from_monic.map {W X Y : C} (m : X ⟶ Y) [mono m] (h : W ⟶ Y)
  (w : h ≫ (classifier_of m) = lift_truth _) :
  W ⟶ X :=
(pb_lift_from_monic m h w).1

lemma pb_lift_from_monic.comm {W X Y : C} (m : X ⟶ Y) [mono m] (h : W ⟶ Y)
  (w : h ≫ (classifier_of m) = lift_truth _) :
  (pb_lift_from_monic.map m h w) ≫ m = h :=
(pb_lift_from_monic m h w).2.left

lemma pb_lift_from_monic.unique {W X Y : C} (m : X ⟶ Y) [mono m] (h : W ⟶ Y)
  (w : h ≫ (classifier_of m) = lift_truth _) :
  ∀ u : W ⟶ X, u ≫ m = h → u = pb_lift_from_monic.map m h w :=
begin
  intros u h1,
  have h :=
  calc
  u ≫ m = h                                   : by assumption
  ...    = (pb_lift_from_monic.map m h w) ≫ m : by symmetry; apply pb_lift_from_monic.comm,
  rw ←cancel_mono m, assumption
end

-- The product of two pullback square is a pullback square,
-- already in mathlib in a more abstract way (i.e. limits commutes)
-- but redoing it here is probably easier

open category_theory.limits.prod

variables {U V W Z : C} {f : X ⟶ Z} {g : Y ⟶ Z}
  {s : pullback_cone f g} {h : U ⟶ W} {k : V ⟶ W}
  {t : pullback_cone h k}

def map_lift (s_lim : is_limit s) (t_lim : is_limit t) (u : pullback_cone (map f h) (map g k)) :
  {l // l ≫ s.fst = u.fst ≫ fst ∧ l ≫ s.snd = u.snd ≫ fst}
× {l // l ≫ t.fst = u.fst ≫ snd ∧ l ≫ t.snd = u.snd ≫ snd} :=
begin
  let u_fst := eq_whisker u.condition fst,
  let u_snd := eq_whisker u.condition snd,
  rw [assoc, assoc] at u_fst u_snd,
  rw [map_fst, map_fst, ←assoc, ←assoc] at u_fst,
  rw [map_snd, map_snd, ←assoc, ←assoc] at u_snd,
  exact (pullback_cone.is_limit.lift' s_lim (u.fst ≫ fst) (u.snd ≫ fst) u_fst,
         pullback_cone.is_limit.lift' t_lim (u.fst ≫ snd) (u.snd ≫ snd) u_snd)
end

lemma is_pullback_of_prod_pullback (s_lim : is_limit s) (t_lim : is_limit t) :
  is_limit (pullback_cone.mk (map s.fst t.fst) (map s.snd t.snd)
           (by { rw [map_map, s.condition, t.condition, ←map_map] })) :=
begin
  apply pullback_cone.is_limit.mk _
    (λ u, lift (map_lift s_lim t_lim u).1.val (map_lift s_lim t_lim u).2.val);
  simp only; intro u,
  { rw lift_map,
    erw [(map_lift s_lim t_lim u).1.prop.left, (map_lift s_lim t_lim u).2.prop.left],
    rw [←comp_lift, lift_fst_snd, comp_id] },
  { rw lift_map,
    erw [(map_lift s_lim t_lim u).1.prop.right, (map_lift s_lim t_lim u).2.prop.right],
    rw [←comp_lift, lift_fst_snd, comp_id] },
  { intros l' hfst hsnd,
    apply hom_ext,
    { apply pullback_cone.is_limit.hom_ext s_lim,
        rw [lift_fst, assoc, ←map_fst s.fst t.fst, ←assoc, hfst],
        erw [(map_lift s_lim t_lim u).1.prop.left],

        rw [lift_fst, assoc, ←map_fst s.snd t.snd, ←assoc, hsnd],
        erw [(map_lift s_lim t_lim u).1.prop.right] },
    { apply pullback_cone.is_limit.hom_ext t_lim,
        rw [lift_snd, assoc, ←map_snd s.fst t.fst, ←assoc, hfst],
        erw [(map_lift s_lim t_lim u).2.prop.left],

        rw [lift_snd, assoc, ←map_snd s.snd t.snd, ←assoc, hsnd],
        erw [(map_lift s_lim t_lim u).2.prop.right] } }
end

lemma is_pullback_square_ids_fst{c d : C} (f : c ⟶ d) :
  is_limit (pullback_cone.mk f (𝟙 c) (by simp) : pullback_cone (𝟙 d) f) :=
begin
  apply pullback_cone.is_limit.mk _ (λ s, s.snd); simp only,
  exact (λ s, by { rw [←s.condition, comp_id] }),
  exact (λ s, by rw comp_id s.snd),
  exact (λ s t h1 h2, by { rw [←h2, comp_id] })
end

lemma is_pullback_square_ids_snd {c d : C} (f : c ⟶ d) :
  is_limit (pullback_cone.mk (𝟙 c) f (by simp) : pullback_cone f (𝟙 d)) :=
begin
  apply pullback_cone.is_limit.mk _ (λ s, s.fst); simp only,
  exact (λ s, by rw comp_id s.fst),
  exact (λ s, by { rw [s.condition, comp_id] }),
  exact (λ s t h1 h2, by { rw [←h1, comp_id] })
end

def lift_pullback_of_equalizer_coreflexive_pair {c d : C} {h k : c ⟶ d} {u : fork k h}
  [is_coreflexive_pair h k] (u_lim : is_limit u) (s : pullback_cone h k) :
  {l // l ≫ u.ι = s.fst ∧ l ≫ u.ι = s.snd} :=
begin
  have cond := eq_whisker s.condition (common_retraction h k),
  rw [assoc, assoc, right_comp_retraction, left_comp_retraction, comp_id, comp_id] at cond,
  rw ←cond, simp only [and_self],
  refine fork.is_limit.lift' u_lim s.fst _,
  nth_rewrite 0 cond,
  exact s.condition.symm
end

def is_pullback_of_equalizer_coreflexive_pair {c d : C} {h k : c ⟶ d} {u : fork k h}
  (u_lim : is_limit u) [is_coreflexive_pair h k] :
  is_limit (pullback_cone.mk u.ι u.ι (by rw u.condition) : pullback_cone h k) :=
begin
  apply pullback_cone.is_limit.mk _
  (λ s, (lift_pullback_of_equalizer_coreflexive_pair u_lim s).val);
  intro s; simp only,
    exact (lift_pullback_of_equalizer_coreflexive_pair u_lim s).prop.left,
    exact (lift_pullback_of_equalizer_coreflexive_pair u_lim s).prop.right,
    intros m hfst hsnd, apply fork.is_limit.hom_ext u_lim,
    erw [hfst, (lift_pullback_of_equalizer_coreflexive_pair u_lim s).prop.left]
end

lemma is_pullback_id_cone_of_monic {c d : C} (k : c ⟶ d) [mono k] :
  is_limit (pullback_cone.mk (𝟙 c) (𝟙 c) (by rw id_comp) : pullback_cone k k) :=
begin
  apply pullback_cone.is_limit.mk _ (λ s, s.fst); intro s; simp only,
  { rw comp_id },
  { rw [comp_id, ←cancel_mono k, s.condition] },
  { intros u hf hs, rw ←hf, rw comp_id }
end


inductive Con : Type
| nil : Con
| foo : Con

inductive Conw : Con → Prop
| nilw : Conw Con.nil

example (x : Conw Con.nil) : x = Conw.nilw := by
  cases x
  traceState
  rfl


import data.serial

open serial serializer

structure point :=
(x y z : ℕ)

instance : serial point :=
by mk_serializer (point.mk <$> ser_field point.x <*> ser_field point.y <*> ser_field point.z)

example : serial point :=
begin
  apply of_serializer (point.mk <$> ser_field point.x <*> ser_field point.y <*> ser_field point.z),
  intro w, cases w,
  apply there_and_back_again_seq,
  apply there_and_back_again_seq,
  apply there_and_back_again_map,
  { simp },
  { refl },
  { simp },
  { refl },
  { simp },
end

@[derive serial]
inductive my_sum
| first : my_sum
| second : ℕ → my_sum
| third (n : ℕ) (xs : list ℕ) : n ≤ xs.length → my_sum

@[derive serial]
structure my_struct :=
(x : ℕ)
(xs : list ℕ)
(bounded : xs.length ≤ x)

@[derive [serial, decidable_eq]]
inductive tree' (α : Type)
| leaf {} : tree'
| node2 : α → tree' → tree' → tree'
| node3 : α → tree' → tree' → tree' → tree'

open tree'

meta def tree'.repr {α} [has_repr α] : tree' α → string
| leaf := "leaf"
| (node2 x t₀ t₁) := to_string $ format!"(node2 {repr x} {tree'.repr t₀} {tree'.repr t₁})"
| (node3 x t₀ t₁ t₂) := to_string $ format!"(node3 {repr x} {tree'.repr t₀} {tree'.repr t₁} {tree'.repr t₂})"

meta instance {α} [has_repr α] : has_repr (tree' α) := ⟨ tree'.repr ⟩

def x := node2 2 (node3 77777777777777 leaf leaf (node2 1 leaf leaf)) leaf

#eval serialize x
-- [17, 1, 5, 2, 430029026, 72437, 0, 0, 1, 3, 0, 0, 0]
#eval deserialize (tree' ℕ) [17, 1, 5, 2, 430029026, 72437, 0, 0, 1, 3, 0, 0, 0]
-- (some (node2 2 (node3 77777777777777 leaf leaf (node2 1 leaf leaf)) leaf))
#eval (deserialize _ (serialize x) = some x : bool)
-- tt

open medium

example (x : tree' ℕ) : deserialize _ (serialize x) = some x :=
by { dsimp [serialize,deserialize],
     rw [eval_eval,serial.correctness],
     refl }


inductive Con : Type
| nil : Con
| foo : Con

inductive Conw : Con → Prop
| nilw : Conw Con.nil

example (x : Conw Con.nil) : x = Conw.nilw := by
  cases x
  trace_state
  rfl