-- WIP stuff. see Metamath.Verify for the verifier

import Lean
import Metamath.Verify

open Or in
theorem or_assoc {a b c} : (a ∨ b) ∨ c ↔ a ∨ (b ∨ c) :=
⟨fun | inl (inl h) => inl h
     | inl (inr h) => inr (inl h)
     | inr h => inr (inr h),
 fun | inl h => inl (inl h)
     | inr (inl h) => inl (inr h)
     | inr (inr h) => inr h⟩

theorem Or.symm : a ∨ b → b ∨ a
| Or.inl h => Or.inr h
| Or.inr h => Or.inl h

theorem Or.imp_right (h : b → c) : a ∨ b → a ∨ c
| Or.inl h => Or.inl h
| Or.inr h' => Or.inr (h h')

namespace List

def mem (a : α) : List α → Prop
| [] => False
| (b :: l) => a = b ∨ mem a l

infix:50 " ∈ " => mem

theorem mem_append {a} : ∀ {l₁ l₂ : List α}, a ∈ l₁ ++ l₂ ↔ a ∈ l₁ ∨ a ∈ l₂
| [], _ => by simp [mem]
| b :: l₁, l₂ => by simp only [List.cons_append, mem, or_assoc, mem_append]; exact Iff.rfl

theorem mem_map {f : α → β} {b} : ∀ {l}, b ∈ l.map f ↔ ∃ a, a ∈ l ∧ b = f a
| [] => by simp [mem]; intro ⟨_, e⟩; exact e
| b :: l => by
  simp only [join, mem, mem_map]
  exact ⟨fun | Or.inl h => ⟨_, Or.inl rfl, h⟩
             | Or.inr ⟨l, h₁, h₂⟩ => ⟨l, Or.inr h₁, h₂⟩,
         fun | ⟨_, Or.inl rfl, h⟩ => Or.inl h
             | ⟨l, Or.inr h₁, h₂⟩ => Or.inr ⟨l, h₁, h₂⟩⟩

theorem mem_join {a} : ∀ {L : List (List α)}, a ∈ L.join ↔ ∃ l, l ∈ L ∧ a ∈ l
| [] => by simp [mem]; intro ⟨_, e⟩; exact e
| b :: l => by
  simp only [join, mem, mem_append, mem_join]
  exact ⟨fun | Or.inl h => ⟨_, Or.inl rfl, h⟩
             | Or.inr ⟨l, h₁, h₂⟩ => ⟨l, Or.inr h₁, h₂⟩,
         fun | ⟨_, Or.inl rfl, h⟩ => Or.inl h
             | ⟨l, Or.inr h₁, h₂⟩ => Or.inr ⟨l, h₁, h₂⟩⟩

theorem mem_bind {f : α → List β} {b} {l} : b ∈ l.bind f ↔ ∃ a, a ∈ l ∧ b ∈ f a := by
  simp [List.bind, mem_map, mem_join]
  exact ⟨fun ⟨_, ⟨a, h₁, rfl⟩, h₂⟩ => ⟨a, h₁, h₂⟩, fun ⟨a, h₁, h₂⟩ => ⟨_, ⟨a, h₁, rfl⟩, h₂⟩⟩

end List

namespace Metamath
open Lean Elab
open Verify in
partial def foo : TermElabM Unit := do
  let mut s : ParserState := Inhabited.default
  s := s.withDB fun db => { db with interrupt := true }
  let h ← IO.FS.Handle.mk "/home/mario/Documents/metamath/mm/iset.mm" IO.FS.Mode.read true
  let rec loop (s : ParserState) (base : Nat) : IO (Except ParserState DB) := do
    if ← h.isEof then
      pure $ Except.ok $ s.done base
    else
      let buf ← h.read 1024
      let s := s.feedAll base buf
      if s.db.error?.isSome then pure $ Except.error s
      else loop s (base + buf.size)
  match ← loop Inhabited.default 0 with
  | Except.ok _ => ()
  | Except.error s => match s.db.error? with
    | some ⟨Error.ax pos l f fr, i⟩ =>
      IO.println s!"axiom {l}: {fr} |- {f}"
    | some ⟨Error.thm pos l f fr, i⟩ =>
      IO.println s!"theorem {l}: {fr} |- {f}"
    | some ⟨Error.error pos msg, _⟩ =>
      IO.println s!"at {pos}: {msg}"
    | _ => ()

-- #eval foo

def CN := String
instance : Inhabited CN := inferInstanceAs (Inhabited String)
instance : DecidableEq CN := inferInstanceAs (DecidableEq String)

structure VR := (type : CN) (i : Nat)
deriving DecidableEq

inductive Sym
| const (c : CN)
| var (n : VR)
deriving Inhabited, DecidableEq
open Sym

instance : Coe String Sym := ⟨const⟩
def Sym.isVar : Sym → Bool
| const _ => false
| var _ => true

def Expr := List Sym
def VR.expr (v : VR) : Expr := [var v]

instance : Append Expr := inferInstanceAs (Append (List Sym))
def Expr.sn (s : Sym) : Expr := [s]
instance : Coe String Expr := ⟨fun c => Expr.sn c⟩
instance : Coe VR Expr := ⟨fun v => Expr.sn (var v)⟩
def Expr.cons (c : String) : Expr → Expr := List.cons c
def Expr.mem (e : Expr) (v : VR) : Prop := var v ∈ e

scoped notation:50 a:51 " ∈' " b:51 => Expr.mem b a

def Expr.vars : Expr → List VR
| [] => []
| const c :: e => vars e
| var v :: e => v :: vars e

def Expr.subst (σ : VR → Expr) : Expr → Expr
| [] => []
| const c :: e => const c :: subst σ e
| var v :: e => σ v ++ subst σ e

theorem Expr.subst_id : (e : Expr) → Expr.subst VR.expr e = e
| [] => rfl
| const c :: e => congrArg (const c :: .) (subst_id e)
| var v :: e => congrArg (var v :: .) (subst_id e)

theorem Expr.subst_append (σ) : (e₁ e₂ : Expr) → Expr.subst σ (e₁ ++ e₂) = e₁.subst σ ++ e₂.subst σ
| [], _ => rfl
| const c :: (e₁ : Expr), e₂ => by
  simp only [Expr.subst]; rw [List.cons_append, List.cons_append, ← subst_append]; rfl
| var v :: e, e₂ => by
  rw [List.cons_append]; simp only [Expr.subst]; rw [List.append_assoc, subst_append]

theorem Expr.mem_subst {σ a} : {e : Expr} → a ∈' Expr.subst σ e → ∃ b, b ∈' e ∧ a ∈' σ b
| const c :: (e : Expr), Or.inr h => let ⟨b, h₁, h₂⟩ := mem_subst h; ⟨b, Or.inr h₁, h₂⟩
| var v :: e, h =>
  match List.mem_append.1 h with
  | Or.inl h => ⟨v, Or.inl rfl, h⟩
  | Or.inr h => let ⟨b, h₁, h₂⟩ := mem_subst h; ⟨b, Or.inr h₁, h₂⟩

def subst.trans (σ σ' : VR → Expr) (v : VR) : Expr := (σ v).subst σ'

theorem Expr.subst_tr (σ σ' : VR → Expr) : (e : Expr) →
  e.subst (subst.trans σ σ') = (e.subst σ).subst σ'
| [] => rfl
| const c :: e => congrArg (const c :: .) (subst_tr _ _ e)
| var v :: e => by simp only [subst]; rw [subst_append, subst_tr]; rfl

def Formula := CN × Expr

def Formula.subst (σ : VR → Expr) : Formula → Formula
| (c, e) => (c, e.subst σ)

theorem Formula.subst_id : (e : Formula) → Formula.subst VR.expr e = e
| (c, e) => congrArg (c, .) e.subst_id

theorem Formula.subst_tr (σ σ' : VR → Expr) : (e : Formula) →
  e.subst (subst.trans σ σ') = (e.subst σ).subst σ'
| (c, e) => congrArg (c, .) (e.subst_tr _ _)

def VR.vhyp (v : VR) : Formula := (v.type, [var v])
instance : Coe VR Formula := ⟨VR.vhyp⟩

def Expr.δ (a b : Expr) : Bool :=
a.all fun
| const _ => true
| var a => b.all fun
  | const _ => true
  | var b => a != b

structure DJ :=
  disj : VR → VR → Prop
  irr : ¬ disj x x
  symm : disj x y → disj y x

instance : CoeFun DJ (fun _ => VR → VR → Prop) := ⟨DJ.disj⟩
instance : LE DJ := ⟨fun dj dj' => ∀ a b, dj a b → dj' a b⟩

theorem DJ.refl (dj : DJ) : dj ≤ dj := fun _ _ => id

theorem DJ.ne (dj : DJ) {a b} (h : dj a b) : a ≠ b :=
  fun e => by cases e; exact dj.irr h

theorem DJ.ext : {dj₁ dj₂ : DJ} → (∀ a b, dj₁ a b ↔ dj₂ a b) → dj₁ = dj₂
| ⟨dj₁, _, _⟩, ⟨dj₂, _, _⟩, h =>
  have dj₁ = dj₂ from funext fun a => funext fun b => propext (h a b)
  by cases this; rfl

theorem DJ.le_antisymm {dj₁ dj₂ : DJ} (H₁ : dj₁ ≤ dj₂) (H₂ : dj₂ ≤ dj₁) : dj₁ = dj₂ :=
  DJ.ext fun a b => ⟨H₁ _ _, H₂ _ _⟩

def DJ.mk' (disj : List (VR × VR)) : DJ :=
{ disj := fun a b => a ≠ b ∧ ((a, b) ∈ disj ∨ (b, a) ∈ disj)
  irr := fun h => h.1 rfl
  symm := fun ⟨h, h'⟩ => ⟨h.symm, h'.symm⟩ }

def Expr.disjoint (dj : DJ) (e₁ e₂ : Expr) : Prop :=
  ∀ a b, a ∈' e₁ → b ∈' e₂ → dj a b

theorem Expr.disjoint.mono {dj₁ dj₂ : DJ} (h : dj₁ ≤ dj₂) {e₁ e₂}
  (H : Expr.disjoint dj₁ e₁ e₂) : Expr.disjoint dj₂ e₁ e₂ :=
  fun a b ha hb => h _ _ (H a b ha hb)

def DJ.subst (σ : VR → Expr) (dj dj' : DJ) :=
  ∀ a b, dj a b → (σ a).disjoint dj' (σ b)

theorem DJ.subst.mono {σ : VR → Expr} {dj₁ dj₂ dj₁' dj₂' : DJ}
  (h : dj₂ ≤ dj₁) (h' : dj₁' ≤ dj₂') (H : dj₁.subst σ dj₁') : dj₂.subst σ dj₂' :=
  fun a b d => Expr.disjoint.mono h' (H _ _ (h _ _ d))

def DJ.trim (dj : DJ) (P : VR → Prop) : DJ :=
{ disj := fun x y => dj x y ∧ P x ∧ P y
  irr := fun x => dj.irr x.1
  symm := fun ⟨h₁, h₂, h₃⟩ => ⟨dj.symm h₁, h₃, h₂⟩ }

theorem DJ.trim.mono {dj₁ dj₂ : DJ} (hdj : dj₁ ≤ dj₂) {P Q : VR → Prop}
  (pq : ∀ x, P x → Q x) : dj₁.trim P ≤ dj₂.trim Q :=
  fun a b ⟨h, ha, hb⟩ => ⟨hdj _ _ h, pq _ ha, pq _ hb⟩

def DJ.trimmed (dj : DJ) (P : VR → Prop) : Prop :=
  ∀ a b, dj a b → P a ∧ P b

theorem DJ.trimmed.mono (dj : DJ) {P Q : VR → Prop}
  (h : ∀ x, P x → Q x) (H : dj.trimmed P) : dj.trimmed Q
| a, b, d => let ⟨h₁, h₂⟩ := H a b d; ⟨h _ h₁, h _ h₂⟩

theorem DJ.trim_le_self (dj : DJ) (P : VR → Prop) : dj.trim P ≤ dj := fun a b d => d.1

theorem DJ.trim.trimmed (dj : DJ) (P : VR → Prop) : (dj.trim P).trimmed P := fun a b h => h.2

theorem DJ.trimmed.trim_eq {dj : DJ} {P} (h : dj.trimmed P) : dj.trim P = dj :=
  DJ.ext fun a b => ⟨fun h => h.1, fun h' => ⟨h', h _ _ h'⟩⟩

def DJ.untrim (dj : DJ) (P : VR → Prop) : DJ :=
{ disj := fun x y => x ≠ y ∧ (P x → P y → dj x y)
  irr := fun x => x.1 rfl
  symm := fun ⟨h₁, h₂⟩ => ⟨h₁.symm, fun x y => dj.symm (h₂ y x)⟩ }

theorem DJ.untrim.mono {dj₁ dj₂ : DJ} (hdj : dj₁ ≤ dj₂) {P Q : VR → Prop}
  (qp : ∀ x, Q x → P x) : dj₁.untrim P ≤ dj₂.untrim Q :=
  fun a b ⟨h₁, h₂⟩ => ⟨h₁, fun ha hb => hdj _ _ (h₂ (qp _ ha) (qp _ hb))⟩

theorem DJ.trim_le {dj₁ dj₂ : DJ} {P} : dj₁.trim P ≤ dj₂ ↔ dj₁ ≤ dj₂.untrim P :=
  ⟨fun H a b h => ⟨dj₁.ne h, fun ha hb => H _ _ ⟨h, ha, hb⟩⟩,
   fun H a b ⟨h, ha, hb⟩ => (H _ _ h).2 ha hb⟩

theorem DJ.self_le_untrim (dj : DJ) (P : VR → Prop) : dj ≤ dj.untrim P :=
  DJ.trim_le.1 $ DJ.trim_le_self _ _

theorem DJ.trim_untrim (dj : DJ) (P : VR → Prop) : (dj.untrim P).trim P = dj.trim P :=
  DJ.le_antisymm (fun a b ⟨h, ha, hb⟩ => ⟨h.2 ha hb, ha, hb⟩)
    (DJ.trim.mono (DJ.self_le_untrim _ _) (fun _ => id))

theorem DJ.untrim_trim (dj : DJ) (P : VR → Prop) : (dj.trim P).untrim P = dj.untrim P :=
  DJ.le_antisymm (DJ.untrim.mono (DJ.trim_le_self _ _) (fun _ => id))
    fun a b ⟨h, H⟩ => ⟨h, fun ha hb => ⟨H ha hb, ha, hb⟩⟩

structure Context :=
  hyps : List Formula
  dj : DJ

def Context.mk' (disj : List (VR × VR)) (hyps : List Formula) : Context :=
  ⟨hyps, DJ.mk' disj⟩

instance : LE Context := ⟨fun Γ Γ' => (∀ a, a ∈ Γ.hyps → a ∈ Γ'.hyps) ∧ Γ.dj ≤ Γ'.dj⟩

theorem Context.refl (Γ : Context) : Γ ≤ Γ := ⟨fun _ => id, DJ.refl _⟩

structure Statement :=
  ctx : Context
  fmla : Formula

instance : LE Statement := ⟨fun s s' => s.ctx ≤ s'.ctx ∧ s.fmla = s'.fmla⟩

theorem Statement.refl (s : Statement) : s ≤ s := ⟨Context.refl _, rfl⟩

def Statement.vars (s : Statement) : List VR :=
  (s.fmla :: s.ctx.hyps).bind fun e => e.2.vars

theorem Statement.vars.mono' {s₁ s₂ : Statement}
  (H : ∀ a, a ∈ s₁.ctx.hyps → a ∈ s₂.ctx.hyps) (H₂ : s₁.fmla = s₂.fmla)
  (v) : v ∈ s₁.vars → v ∈ s₂.vars := by
  simp only [vars, List.mem_bind, List.mem, H₂]
  exact fun ⟨a, b, c⟩ => ⟨a, b.imp_right (H _), c⟩

theorem Statement.vars.mono {s₁ s₂ : Statement} (H : s₁ ≤ s₂) : ∀ v, v ∈ s₁.vars → v ∈ s₂.vars :=
  Statement.vars.mono' H.1.1 H.2

def Statement.trim (s : Statement) : Statement :=
  ⟨⟨s.ctx.hyps, s.ctx.dj.trim fun v => v ∈ s.vars⟩, s.fmla⟩

def Statement.untrim' (s : Statement) (P : VR → Prop): Statement :=
  ⟨⟨s.ctx.hyps, s.ctx.dj.untrim P⟩, s.fmla⟩
def Statement.untrim (s : Statement) : Statement := s.untrim' fun v => v ∈ s.vars

theorem Statement.trim_le_self (s : Statement) : s.trim ≤ s :=
  ⟨⟨fun _ => id, DJ.trim_le_self _ _⟩, rfl⟩

theorem Statement.self_le_untrim' (s : Statement) (P) : s ≤ s.untrim' P :=
  ⟨⟨fun _ => id, DJ.self_le_untrim _ _⟩, rfl⟩
theorem Statement.self_le_untrim (s : Statement) : s ≤ s.untrim := s.self_le_untrim' _

theorem Statement.trim.mono {s₁ s₂ : Statement} (h : s₁ ≤ s₂) : s₁.trim ≤ s₂.trim :=
  ⟨⟨h.1.1, DJ.trim.mono h.1.2 (Statement.vars.mono h)⟩, h.2⟩

theorem Statement.untrim'.mono {s₁ s₂ : Statement} {P Q}
  (H : ∀ x, Q x → P x) (h : s₁ ≤ s₂) : s₁.untrim' P ≤ s₂.untrim' Q :=
  ⟨⟨h.1.1, DJ.untrim.mono h.1.2 H⟩, h.2⟩
theorem Statement.untrim.mono {s₁ s₂ : Statement}
  (H : s₁.ctx.hyps = s₂.ctx.hyps) (h : s₁ ≤ s₂) : s₁.untrim ≤ s₂.untrim :=
  Statement.untrim'.mono (Statement.vars.mono' (by rw [H]; exact fun _ => id) h.2.symm) h

theorem Statement.trim_vars (s : Statement) : s.trim.vars = s.vars := rfl
theorem Statement.untrim'_vars (s : Statement) (P) : (s.untrim' P).vars = s.vars := rfl
theorem Statement.untrim_vars (s : Statement) : s.untrim.vars = s.vars := rfl

theorem Statement.trim_untrim (s : Statement) : s.untrim.trim = s.trim := by
  simp only [trim, untrim_vars]; simp only [untrim, untrim', DJ.trim_untrim]; rfl

theorem Statement.untrim_trim (s : Statement) : s.trim.untrim = s.untrim := by
  simp only [untrim, untrim', trim_vars]; simp only [trim, DJ.untrim_trim]; rfl

theorem Statement.trim_le {s₁ s₂ : Statement} (e : s₁.vars = s₂.vars) :
  s₁.trim.ctx ≤ s₂.ctx ↔ s₁.ctx ≤ s₂.untrim.ctx :=
  ⟨fun ⟨h₁, h₂⟩ => ⟨h₁, DJ.trim_le.1 $ by rw [← e]; exact h₂⟩,
   fun ⟨h₁, h₂⟩ => ⟨h₁, DJ.trim_le.2 $ by rw [e]; exact h₂⟩⟩

def Statement.trimmed (s : Statement) : Prop := s.ctx.dj.trimmed fun v => v ∈ s.vars

theorem Statement.trim.trimmed (s : Statement) : s.trim.trimmed := DJ.trim.trimmed _ _

theorem Statement.trimmed.trim_eq : {s : Statement} → s.trimmed → s.trim = s
| ⟨⟨a, b⟩, c⟩, h => by simp only [trim]; rw [DJ.trimmed.trim_eq h]

inductive Provable (axs : Statement → Prop) (Γ : Context) : Formula → Prop
| hyp (h) : h ∈ Γ.hyps → Provable axs Γ h
| var (v:VR) : Provable axs Γ v
| ax (σ) {ax} : axs ax → ax.ctx.dj.subst σ Γ.dj →
  (∀ h, h ∈ ax.ctx.hyps ∨ (∃ v:VR, h = v) → Provable axs Γ (h.subst σ)) →
  Provable axs Γ (ax.fmla.subst σ)

theorem Provable.mono {axs₁ axs₂} (haxs : ∀ a, axs₁ a → axs₂ a)
  {Γ₁ Γ₂} (hΓ : Γ₁ ≤ Γ₂) {e} (pr : Provable axs₁ Γ₁ e) : Provable axs₂ Γ₂ e := by
  induction pr with
  | hyp e h => exact hyp e (hΓ.1 _ h)
  | var v => exact var v
  | ax σ ha h₁ h₂ IH =>
    exact ax σ (haxs _ ha) (h₁.mono (DJ.refl _) hΓ.2) fun e h => IH _ h

def Statement.provable' (axs : Statement → Prop) (s : Statement) : Prop :=
  Provable axs s.ctx s.fmla

theorem Statement.provable'.mono {axs₁ axs₂} (haxs : ∀ a, axs₁ a → axs₂ a) :
  {s₁ s₂ : Statement} → s₁ ≤ s₂ → s₁.provable' axs₁ → s₂.provable' axs₂
| ⟨Γ₁, e⟩, ⟨Γ₂, _⟩, ⟨hΓ, rfl⟩ => Provable.mono haxs hΓ

def Statement.provable (axs : Statement → Prop) (s : Statement) : Prop :=
  s.untrim.provable' axs

-- theorem Statement.provable.mono {axs₁ axs₂} (haxs : ∀ a, axs₁ a → axs₂ a) :
--   {s₁ s₂ : Statement} → s₁ ≤ s₂ → s₁.provable axs₁ → s₂.provable axs₂
-- | s₁, s₂, h, hs, pr =>
--   Statement.provable'.mono haxs (untrim'.mono (fun _ => id) hs) $
--   Statement.provable'.mono (fun _ => id) _ pr

theorem Statement.provable'.of {axs} {s : Statement} (h : s.provable' axs) : s.provable axs :=
  h.mono (fun _ => id) (self_le_untrim _)

theorem Statement.provable.trim {axs} {s : Statement} : s.trim.provable axs ↔ s.provable axs :=
  by simp only [provable, untrim_trim]; exact Iff.rfl

theorem Provable.ax_self (axs : Statement → Prop) {ax} (H : axs ax) : ax.provable' axs := by
  have _ from Provable.ax (Γ := ax.ctx) VR.expr H ?disj ?hyp
  rw [Formula.subst_id] at this; exact this
  case disj =>
    intro a b h a' b' h₁ h₂
    match a', b', h₁, h₂ with | _, _, Or.inl rfl, Or.inl rfl => ?_
    exact h
  case hyp =>
    intro fmla h
    match fmla, h with
    | fmla, Or.inl h => rw [Formula.subst_id]; exact Provable.hyp _ h
    | _, Or.inr ⟨v, rfl⟩ => exact Provable.var v

theorem Provable.trans' {axs Γ} (σ) {Γ' fmla} (pr : Provable axs Γ' fmla)
  (dj : Γ'.dj.subst σ Γ.dj)
  (hh : ∀ h, h ∈ Γ'.hyps ∨ (∃ v:VR, h = v) → Provable axs Γ (h.subst σ)) :
  Provable axs Γ (fmla.subst σ) := by
  induction pr with
  | hyp f h => exact hh _ (Or.inl h)
  | var v => exact hh _ (Or.inr ⟨v, rfl⟩)
  | @ax σ' a ha dj' hh' IH =>
    rw [← Formula.subst_tr]
    apply ax (subst.trans σ' σ) ha
    focus
      intros a b ab c d hc hd
      let ⟨e, ea, ce⟩ := Expr.mem_subst hc
      let ⟨f, fb, df⟩ := Expr.mem_subst hd
      refine dj _ _ ?_ _ _ ce df
      exact dj' _ _ ab _ _ ea fb
    focus { intros f; rw [Formula.subst_tr]; refine IH _ }

theorem Provable.trans'' {axs Γ σ} (s : Statement) : s.provable' axs →
  s.ctx.dj.subst σ Γ.dj →
  (∀ h, h ∈ s.ctx.hyps ∨ (∃ v:VR, h = v) → Provable axs Γ (h.subst σ)) →
  Provable axs Γ (s.fmla.subst σ) :=
  Provable.trans' (axs := axs) σ

def subst_of : List (VR × Expr) → VR → Expr
| [], v => v
| (a, e)::l, v => if a = v then e else subst_of l v

class Subst (σ : VR → Expr) (e : Expr) (e' : outParam Expr) := (out : e.subst σ = e')

instance [Subst σ e₁ e₁'] [Subst σ e₂ e₂'] : Subst σ (e₁ ++ e₂) (e₁' ++ e₂') :=
  ⟨by rw [Expr.subst_append, Subst.out, Subst.out]⟩

instance (s : String) : Subst σ s s := ⟨rfl⟩

instance (s : String) [Subst σ e e'] : Subst σ (s ++ e) (s ++ e') :=
  inferInstanceAs (Subst σ (Expr.sn _ ++ e) _)
instance (s : String) [Subst σ e e'] : Subst σ (e ++ s) (e' ++ s) :=
  inferInstanceAs (Subst σ (e ++ Expr.sn _) _)

def subst.ok (axs Γ) (σ : VR → Expr) := ∀ v, Provable axs Γ (v.type, σ v)

theorem subst.ok.nil {axs Γ} : subst.ok axs Γ (subst_of []) := Provable.var
theorem subst.ok.cons {axs Γ e σ} (x) (h₁ : Provable axs Γ (x.type, e))
  (h₂ : subst.ok axs Γ (subst_of σ)) : subst.ok axs Γ (subst_of ((x, e)::σ)) := by
  intro v
  simp only [subst_of]
  cases Decidable.em (x = v) with simp [h]
  | inl h => cases h; exact h₁
  | inr h => exact h₂ v

theorem Provable.thm {axs} {Γ : Context}
  {σ : VR → Expr} {dj hyps c s} (pr : Provable axs (Context.mk' dj hyps) (c, s))
  (hv : subst.ok axs Γ σ)
  (dj : (DJ.mk' dj).subst σ Γ.dj)
  (hh : ∀ h, h ∈ hyps → Provable axs Γ (h.subst σ))
  {e} [inst : Subst σ s e] : Provable axs Γ (c, e) := by
  rw [← inst.out]
  exact Metamath.Provable.trans' σ pr dj fun
    | f, Or.inl h => hh _ h
    | _, Or.inr ⟨v, rfl⟩ =>
      show Provable axs Γ (v.type, σ v ++ show Expr from []) by
      rw [List.append_nil]; exact hv v

theorem DJ_nil {σ dj'} : (DJ.mk' []).subst σ dj' | _, _, h => nomatch h
theorem DJ_cons {a b l σ dj'}
  (h₁ : (σ a).disjoint dj' (σ b))
  (h₂ : (DJ.mk' l).subst σ dj') : (DJ.mk' ((a, b) :: l)).subst σ dj'
| _, _, ⟨_, Or.inl (Or.inl rfl)⟩ => h₁
| _, _, ⟨_, Or.inr (Or.inl rfl)⟩ => fun x y hx hy => dj'.symm (h₁ y x hy hx)
| _, _, ⟨h, Or.inl (Or.inr h')⟩ => h₂ _ _ ⟨h, Or.inl h'⟩
| _, _, ⟨h, Or.inr (Or.inr h')⟩ => h₂ _ _ ⟨h, Or.inr h'⟩

theorem HH_nil {axs Γ σ} : ∀ h:Formula, h ∈ [] → Provable axs Γ (h.subst σ)
| _, h => nomatch h

theorem HH_cons {axs Γ σ c f hyps}
  {e} [Subst σ f e] (h₁ : Provable axs Γ (c, e))
  (h₂ : ∀ h:Formula, h ∈ hyps → Provable axs Γ (h.subst σ)) :
  ∀ h:Formula, h ∈ (c, f)::hyps → Provable axs Γ (h.subst σ)
| _, Or.inl rfl => by rw [← @Subst.out σ f e] at h₁; exact h₁
| _, Or.inr h => h₂ _ h

class Typed (axs : outParam _) (c : outParam CN) (e : Expr) :=
  type (Γ) : Provable axs Γ (c, e)

def Expr.ty (e) {axs c} [Typed axs c e] {Γ} : Provable axs Γ (c, e) := Typed.type Γ

-- This is a by hand translation of demo0.mm, ideally the tactic will write this

namespace Demo

def ze : Expr := "0"
instance : Subst σ ze ze := inferInstanceAs (Subst σ "0" _)

def pl (t r : Expr) : Expr := "(" ++ t ++ "+" ++ r ++ ")"
instance [Subst σ t t'] [Subst σ r r'] : Subst σ (pl t r) (pl t' r') :=
  inferInstanceAs (Subst σ (_++_) _)

def eq (t r : Expr) : Expr := t ++ "=" ++ r
instance [Subst σ t t'] [Subst σ r r'] : Subst σ (eq t r) (eq t' r') :=
  inferInstanceAs (Subst σ (_++_) _)

def im (P Q : Expr) : Expr := "(" ++ P ++ "->" ++ Q ++ ")"
instance {P Q P' Q'} [Subst σ P P'] [Subst σ Q Q'] : Subst σ (im P Q) (im P' Q') :=
  inferInstanceAs (Subst σ (_++_) _)

def al (x P : Expr) : Expr := "A." ++ x ++ P
instance {x P x' P'} [Subst σ x x'] [Subst σ P P'] : Subst σ (al x P) (al x' P') :=
  inferInstanceAs (Subst σ (_++_) _)

def vt : VR := ⟨"term", 0⟩
def vr : VR := ⟨"term", 1⟩
def vs : VR := ⟨"term", 2⟩
def vP : VR := ⟨"wff", 0⟩
def vQ : VR := ⟨"wff", 1⟩
def vx : VR := ⟨"set", 0⟩

def axs (s : Statement) : Prop := s ∈ [
  ⟨Context.mk' [] [], ("term", ze)⟩,
  ⟨Context.mk' [] [], ("term", pl vt vr)⟩,
  ⟨Context.mk' [] [], ("wff", eq vt vr)⟩,
  ⟨Context.mk' [] [], ("wff", im vP vQ)⟩,
  ⟨Context.mk' [] [], ("wff", al vx vP)⟩,
  ⟨Context.mk' [] [], ("|-", im (eq vt vr) (im (eq vt vs) (eq vr vs)))⟩,
  ⟨Context.mk' [] [], ("|-", eq (pl vt ze) vt)⟩,
  ⟨Context.mk' [] [("|-", vP), ("|-", im vP vQ)], ("|-", vQ)⟩,
  ⟨Context.mk' [(vx, vP)] [], ("|-", im vP (al vx vP))⟩
]

abbrev Provable := Metamath.Provable axs
abbrev Typed := Metamath.Typed axs

instance tze : Typed "term" ze :=
⟨fun Γ =>
  (Provable.ax_self axs (Or.inl rfl)).thm subst.ok.nil DJ_nil HH_nil⟩

instance tpl {t r} [Typed "term" t] [Typed "term" r] :
  Typed "term" (pl t r) :=
⟨fun Γ =>
  have Subst (subst_of [(vt, t), (vr, r)]) vt t from ⟨List.append_nil _⟩
  have Subst (subst_of [(vt, t), (vr, r)]) vr r from ⟨List.append_nil _⟩
  (Provable.ax_self axs (Or.inr $ Or.inl rfl)).thm
    (subst.ok.cons vt t.ty $ subst.ok.cons vr r.ty subst.ok.nil)
    DJ_nil HH_nil⟩

instance weq {t r} [Typed "term" t] [Typed "term" r] :
  Typed "wff" (eq t r) :=
⟨fun Γ =>
  have Subst (subst_of [(vt, t), (vr, r)]) vt t from ⟨List.append_nil _⟩
  have Subst (subst_of [(vt, t), (vr, r)]) vr r from ⟨List.append_nil _⟩
  (Provable.ax_self axs (Or.inr $ Or.inr $ Or.inl rfl)).thm
    (subst.ok.cons vt t.ty $ subst.ok.cons vr r.ty subst.ok.nil)
    DJ_nil HH_nil⟩

instance wim {P Q} [Typed "wff" P] [Typed "wff" Q] :
  Typed "wff" (im P Q) :=
⟨fun Γ =>
  have Subst (subst_of [(vP, P), (vQ, Q)]) vP P from ⟨List.append_nil _⟩
  have Subst (subst_of [(vP, P), (vQ, Q)]) vQ Q from ⟨List.append_nil _⟩
  (Provable.ax_self axs (Or.inr $ Or.inr $ Or.inr $ Or.inl rfl)).thm
    (subst.ok.cons vP P.ty $ subst.ok.cons vQ Q.ty subst.ok.nil)
    DJ_nil HH_nil⟩

instance wal {x P} [Typed "set" x] [Typed "wff" P] :
  Typed "wff" (al x P) :=
⟨fun Γ =>
  have Subst (subst_of [(vx, x), (vP, P)]) vx x from ⟨List.append_nil _⟩
  have Subst (subst_of [(vx, x), (vP, P)]) vP P from ⟨List.append_nil _⟩
  (Provable.ax_self axs (Or.inr $ Or.inr $ Or.inr $ Or.inr $ Or.inl rfl)).thm
    (subst.ok.cons vx x.ty $ subst.ok.cons vP P.ty subst.ok.nil)
    DJ_nil HH_nil⟩

theorem a1 {Γ t r s} [Typed "term" t] [Typed "term" r] [Typed "term" s] :
  Provable Γ ("|-", im (eq t r) (im (eq t s) (eq r s))) :=
  have Subst (subst_of [(vt, t), (vr, r), (vs, s)]) vt t from ⟨List.append_nil _⟩
  have Subst (subst_of [(vt, t), (vr, r), (vs, s)]) vr r from ⟨List.append_nil _⟩
  have Subst (subst_of [(vt, t), (vr, r), (vs, s)]) vs s from ⟨List.append_nil _⟩
  (Provable.ax_self axs (Or.inr $ Or.inr $ Or.inr $ Or.inr $ Or.inr $ Or.inl rfl)).thm
    (subst.ok.cons vt t.ty $ subst.ok.cons vr r.ty $ subst.ok.cons vs s.ty subst.ok.nil)
    DJ_nil HH_nil

theorem a2 {Γ t} [Typed "term" t] :
  Provable Γ ("|-", eq (pl t ze) t) :=
  have Subst (subst_of [(vt, t)]) vt t from ⟨List.append_nil _⟩
  (Provable.ax_self axs (Or.inr $ Or.inr $ Or.inr $ Or.inr $ Or.inr $ Or.inr $ Or.inl rfl)).thm
    (subst.ok.cons vt t.ty subst.ok.nil)
    DJ_nil HH_nil

theorem mp {Γ P Q} [Typed "wff" P] [Typed "wff" Q]
  (min : Provable Γ ("|-", P))
  (maj : Provable Γ ("|-", im P Q)) :
  Provable Γ ("|-", Q) :=
  have Subst (subst_of [(vP, P), (vQ, Q)]) vP P from ⟨List.append_nil _⟩
  have Subst (subst_of [(vP, P), (vQ, Q)]) vQ Q from ⟨List.append_nil _⟩
  (Provable.ax_self axs (Or.inr $ Or.inr $ Or.inr $ Or.inr $ Or.inr $ Or.inr $ Or.inr $ Or.inl rfl)).thm
    (subst.ok.cons vP P.ty $ subst.ok.cons vQ Q.ty subst.ok.nil)
    DJ_nil (HH_cons min $ HH_cons maj HH_nil)

theorem ax5 {Γ x P} [Typed "set" x] [Typed "wff" P]
  (xp : x.disjoint Γ.dj P) :
  Provable Γ ("|-", im P (al x P)) :=
  have Subst (subst_of [(vx, x), (vP, P)]) vx x from ⟨List.append_nil _⟩
  have Subst (subst_of [(vx, x), (vP, P)]) vP P from ⟨List.append_nil _⟩
  (Provable.ax_self axs (Or.inr $ Or.inr $ Or.inr $ Or.inr $ Or.inr $ Or.inr $ Or.inr $ Or.inr $ Or.inl rfl)).thm
    (subst.ok.cons vx x.ty $ subst.ok.cons vP P.ty subst.ok.nil)
    (DJ_cons xp DJ_nil) HH_nil

theorem th1 {Γ t} [Typed "term" t] :
  Provable Γ ("|-", eq t t) := mp a2 (mp a2 a1)

end Demo
end Metamath


import GMLInit.Data.Array.Basic
import GMLInit.Data.Array.KeyedArray

structure AssocArray (α β : Type _) [BEq α] extends KeyedArray (α × β) Prod.fst

namespace AssocArray
variable {α β} [BEq α] [EquivBEq α] (a : AssocArray α β)

@[inline] def find? (key : α) : Option β :=
  match a.toKeyedArray.find? key with
  | some (_, value) => some value
  | none => none

@[inline] def insert (key : α) (value : β) : AssocArray α β where
  toKeyedArray := a.toKeyedArray.insert (key, value)

theorem find?_insert (key : α) (value : β) : (a.insert key value).find? key = some value := by
  unfold find? insert; rw [a.toKeyedArray.find?_insert (key, value)]

theorem find?_insert_bne {key : α} {value : β} {k : α} : k != key → (a.insert key value).find? k = a.find? k := by
  intro h; unfold find? insert; rw [a.toKeyedArray.find?_insert_bne h]

@[inline] def erase (key : α) : AssocArray α β where
  toKeyedArray := a.toKeyedArray.erase key

theorem find?_erase (key : α) : (a.erase key).find? key = none := by
  unfold find? erase; rw [a.toKeyedArray.find?_erase key]

theorem find?_erase_bne {key : α} {k : α} : k != key → (a.erase key).find? k = a.find? k := by
  intro h; unfold find? erase; rw [a.toKeyedArray.find?_erase_bne h]

end AssocArray


-- Boilerplate:
import data.nat.basic
import group_theory.congruence
namespace examples

section unbundled

/-
This example concerns product type instances of an unbundled class such as the following modification to the `comm_monoid` class:
-/
class semigroup (G : Type*) [has_mul G] := (mul_assoc : ∀ (x y z : G), (x * y) * z = x * (y * z))
class mul_one_class (M : Type*) [has_one M] [has_mul M].
class comm_semigroup (G : Type*) [has_mul G] [semigroup G].
class monoid (M : Type*) [has_mul M] [has_one M] [semigroup M] [mul_one_class M].
class comm_monoid (M : Type*) [has_mul M] [has_one M] [semigroup M] [mul_one_class M] [monoid M] [comm_semigroup M].

/-
Providing an instance for the natural numbers is straightforward, although it now involves instantiating each step in the hierarchy separately:
-/
instance : semigroup ℕ := ⟨mul_assoc⟩
instance : mul_one_class ℕ := ⟨⟩
instance : comm_semigroup ℕ := ⟨⟩
instance : monoid ℕ := ⟨⟩
instance : comm_monoid ℕ := ⟨⟩
/-
When we want to instantiate the commutative monoid structure on the product of two commutative monoids, we see that the length of types starts to grow noticeably:
-/
variables {G H M N : Type*}
instance prod.has_mul [has_mul G] [has_mul H] : has_mul (G × H) :=
{ mul := λ a b, (a.1 * b.1, a.2 * b.2) }
@[simp] lemma prod.mul_def [has_mul G] [has_mul H]
  (a b : G) (c d : H) : (a, c) * (b, d) = (a * b, c * d) := rfl

instance prod.has_one [has_one G] [has_one H] : has_one (G × H) :=
{ one := (1, 1) }
@[simp] lemma prod.one_def [has_one G] [has_one H] :
  (1 : G × H) = (1, 1) := rfl

instance prod.semigroup [has_mul G] [has_mul H]
  [semigroup G] [semigroup H] : semigroup (G × H) :=
⟨λ x y z, by { cases x, cases y, cases z, simp only [prod.mul_def, semigroup.mul_assoc] }⟩
instance prod.comm_semigroup [has_mul G] [has_mul H]
  [semigroup G] [semigroup H] [comm_semigroup G] [comm_semigroup H] :
  comm_semigroup (G × H) :=
⟨⟩
instance prod.mul_one_class [has_mul G] [has_mul H] [has_one G] [has_one H]
  [mul_one_class G] [mul_one_class H] : mul_one_class (G × H) :=
⟨⟩
instance prod.monoid [has_mul M] [has_mul N] [has_one M] [has_one N]
  [semigroup M] [semigroup N] [mul_one_class M] [mul_one_class N] :
  monoid (M × N) :=
⟨⟩
instance prod.comm_monoid
  [has_one M] [has_one N] [has_mul M] [has_mul N]
  [semigroup M] [semigroup N] [mul_one_class M] [mul_one_class N]
  [monoid M] [monoid N] [comm_semigroup M] [comm_semigroup N]
  [comm_monoid M] [comm_monoid N] :
  comm_monoid (M × N) :=
⟨⟩
/-
The linear growth in the types translates to an exponential growth in the term size of concrete instances,
since each instance parameter implicit in `comm_monoid (ℕ × ⋯ × ℕ)` is filled with a term that has itself the same number of instance arguments.
-/

set_option pp.implicit true
#check (by apply_instance : comm_monoid ℕ)
#check (by apply_instance : comm_monoid (ℕ × ℕ))
#check (by apply_instance : comm_monoid (ℕ × ℕ × ℕ))
#check (by apply_instance : comm_monoid (ℕ × ℕ × ℕ × ℕ))
#check (by apply_instance : comm_monoid (ℕ × ℕ × ℕ × ℕ × ℕ))
-- and so on

end unbundled

section fails_quickly

/-
The `fails_quickly` linter can also detect timeouts caused by looping or diverging synthesis,
for example the loop `nonempty → has_bot → nonempty` in the following code:
-/

-- Adapted from `order/bounded_order.lean:54`
-- `has_bot.bot` is notation for the minimum element of `α`
class has_bot (α : Type*) := (bot : α)

-- Adapted from `order/bounded_order.lean:60`
instance has_bot_nonempty (α : Type*) [has_bot α] : nonempty α :=
⟨has_bot.bot⟩

-- The natural numbers are well-ordered so each nonempty subtype has a bottom element.
-- Adapted from `data/nat/basic.lean:106`
instance nat.subtype.has_bot (s : set ℕ) [decidable_pred (∈ s)] [h : nonempty s] :
  has_bot s :=
{ bot := ⟨nat.find (nonempty_subtype.1 h), nat.find_spec (nonempty_subtype.1 h)⟩ }

#lint only fails_quickly

end fails_quickly

section priority

-- Adapted from `group_theory/congruence.lean:209`
@[priority 500] -- Reduce the priority from 1000 to 500 since it's slow to apply.
instance con.quotient.decidable_eq {M : Type*} [has_mul M] (c : con M)
  [d : ∀ (a b : M), decidable (c a b)] : decidable_eq (con.quotient c) :=
@quotient.decidable_eq M c.to_setoid d

end priority

end examples


/-
Copyright (c) 2020 Markus Himmel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Markus Himmel
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.comma
import Mathlib.PostPort

universes v u l u₁ u₂ v₁ v₂

namespace Mathlib

/-!
# The category of arrows

The category of arrows, with morphisms commutative squares.
We set this up as a specialization of the comma category `comma L R`,
where `L` and `R` are both the identity functor.

We also define the typeclass `has_lift`, representing a choice of a lift
of a commutative square (that is, a diagonal morphism making the two triangles commute).

## Tags

comma, arrow
-/

namespace category_theory

/-- The arrow category of `T` has as objects all morphisms in `T` and as morphisms commutative
     squares in `T`. -/
def arrow (T : Type u) [category T] := comma 𝟭 𝟭

-- Satisfying the inhabited linter

protected instance arrow.inhabited (T : Type u) [category T] [Inhabited T] : Inhabited (arrow T) :=
  { default := (fun (this : comma 𝟭 𝟭) => this) Inhabited.default }

namespace arrow

@[simp] theorem id_left {T : Type u} [category T] (f : arrow T) : comma_morphism.left 𝟙 = 𝟙 := rfl

@[simp] theorem id_right {T : Type u} [category T] (f : arrow T) : comma_morphism.right 𝟙 = 𝟙 := rfl

/-- An object in the arrow category is simply a morphism in `T`. -/
@[simp] theorem mk_left {T : Type u} [category T] {X : T} {Y : T} (f : X ⟶ Y) :
    comma.left (mk f) = X :=
  Eq.refl (comma.left (mk f))

/-- A morphism in the arrow category is a commutative square connecting two objects of the arrow
    category. -/
def hom_mk {T : Type u} [category T] {f : arrow T} {g : arrow T} {u : comma.left f ⟶ comma.left g}
    {v : comma.right f ⟶ comma.right g} (w : u ≫ comma.hom g = comma.hom f ≫ v) : f ⟶ g :=
  comma_morphism.mk

/-- We can also build a morphism in the arrow category out of any commutative square in `T`. -/
@[simp] theorem hom_mk'_right {T : Type u} [category T] {X : T} {Y : T} {f : X ⟶ Y} {P : T} {Q : T}
    {g : P ⟶ Q} {u : X ⟶ P} {v : Y ⟶ Q} (w : u ≫ g = f ≫ v) :
    comma_morphism.right (hom_mk' w) = v :=
  Eq.refl (comma_morphism.right (hom_mk' w))

@[simp] theorem w_assoc {T : Type u} [category T] {f : arrow T} {g : arrow T} (sq : f ⟶ g)
    {X' :
      autoParam T
        (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.obviously")
          (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "obviously") [])}
    (f' : functor.obj 𝟭 (comma.right g) ⟶ X') :
    comma_morphism.left sq ≫ comma.hom g ≫ f' = comma.hom f ≫ comma_morphism.right sq ≫ f' :=
  sorry

/-- A lift of a commutative square is a diagonal morphism making the two triangles commute. -/
structure lift_struct {T : Type u} [category T] {f : arrow T} {g : arrow T} (sq : f ⟶ g) where
  lift : comma.right f ⟶ comma.left g
  fac_left : comma.hom f ≫ lift = comma_morphism.left sq
  fac_right : lift ≫ comma.hom g = comma_morphism.right sq

protected instance lift_struct_inhabited {T : Type u} [category T] {X : T} :
    Inhabited (lift_struct 𝟙) :=
  { default := lift_struct.mk 𝟙 sorry sorry }

/-- `has_lift sq` says that there is some `lift_struct sq`, i.e., that it is possible to find a
    diagonal morphism making the two triangles commute. -/
class has_lift {T : Type u} [category T] {f : arrow T} {g : arrow T} (sq : f ⟶ g) where
  mk' :: (exists_lift : Nonempty (lift_struct sq))

theorem has_lift.mk {T : Type u} [category T] {f : arrow T} {g : arrow T} {sq : f ⟶ g}
    (s : lift_struct sq) : has_lift sq :=
  has_lift.mk' (Nonempty.intro s)

@[simp] theorem lift_struct.fac_right_assoc {T : Type u} [category T] {f : arrow T} {g : arrow T}
    {sq : f ⟶ g} (c : lift_struct sq)
    {X' :
      autoParam T
        (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.obviously")
          (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "obviously") [])}
    (f' : functor.obj 𝟭 (comma.right g) ⟶ X') :
    lift_struct.lift c ≫ comma.hom g ≫ f' = comma_morphism.right sq ≫ f' :=
  sorry

/-- Given `has_lift sq`, obtain a lift. -/
def has_lift.struct {T : Type u} [category T] {f : arrow T} {g : arrow T} (sq : f ⟶ g)
    [has_lift sq] : lift_struct sq :=
  Classical.choice has_lift.exists_lift

/-- If there is a lift of a commutative square `sq`, we can access it by saying `lift sq`. -/
def lift {T : Type u} [category T] {f : arrow T} {g : arrow T} (sq : f ⟶ g) [has_lift sq] :
    comma.right f ⟶ comma.left g :=
  lift_struct.lift (has_lift.struct sq)

theorem lift.fac_left {T : Type u} [category T] {f : arrow T} {g : arrow T} (sq : f ⟶ g)
    [has_lift sq] : comma.hom f ≫ lift sq = comma_morphism.left sq :=
  sorry

theorem lift.fac_right {T : Type u} [category T] {f : arrow T} {g : arrow T} (sq : f ⟶ g)
    [has_lift sq] : lift sq ≫ comma.hom g = comma_morphism.right sq :=
  sorry

@[simp] theorem lift_mk'_left {T : Type u} [category T] {X : T} {Y : T} {P : T} {Q : T} {f : X ⟶ Y}
    {g : P ⟶ Q} {u : X ⟶ P} {v : Y ⟶ Q} (h : u ≫ g = f ≫ v) [has_lift (hom_mk' h)] :
    f ≫ lift (hom_mk' h) = u :=
  sorry

@[simp] theorem lift_mk'_right_assoc {T : Type u} [category T] {X : T} {Y : T} {P : T} {Q : T}
    {f : X ⟶ Y} {g : P ⟶ Q} {u : X ⟶ P} {v : Y ⟶ Q} (h : u ≫ g = f ≫ v) [has_lift (hom_mk' h)]
    {X' :
      autoParam T
        (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.obviously")
          (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "obviously") [])}
    (f' : Q ⟶ X') : lift (hom_mk' h) ≫ g ≫ f' = v ≫ f' :=
  sorry

protected instance subsingleton_lift_struct_of_epi {T : Type u} [category T] {f : arrow T}
    {g : arrow T} (sq : f ⟶ g) [epi (comma.hom f)] : subsingleton (lift_struct sq) :=
  subsingleton.intro
    fun (a b : lift_struct sq) =>
      lift_struct.ext a b
        (iff.mp (cancel_epi (comma.hom f))
          (eq.mpr
            (id
              (Eq.trans
                ((fun (a a_1 : functor.obj 𝟭 (comma.left f) ⟶ comma.left g) (e_1 : a = a_1)
                    (ᾰ ᾰ_1 : functor.obj 𝟭 (comma.left f) ⟶ comma.left g) (e_2 : ᾰ = ᾰ_1) =>
                    congr (congr_arg Eq e_1) e_2)
                  (comma.hom f ≫ lift_struct.lift a) (comma_morphism.left sq)
                  (lift_struct.fac_left a) (comma.hom f ≫ lift_struct.lift b)
                  (comma_morphism.left sq) (lift_struct.fac_left b))
                (propext (eq_self_iff_true (comma_morphism.left sq)))))
            trivial))

protected instance subsingleton_lift_struct_of_mono {T : Type u} [category T] {f : arrow T}
    {g : arrow T} (sq : f ⟶ g) [mono (comma.hom g)] : subsingleton (lift_struct sq) :=
  subsingleton.intro
    fun (a b : lift_struct sq) =>
      lift_struct.ext a b
        (iff.mp (cancel_mono (comma.hom g))
          (eq.mpr
            (id
              (Eq.trans
                ((fun (a a_1 : comma.right f ⟶ functor.obj 𝟭 (comma.right g)) (e_1 : a = a_1)
                    (ᾰ ᾰ_1 : comma.right f ⟶ functor.obj 𝟭 (comma.right g)) (e_2 : ᾰ = ᾰ_1) =>
                    congr (congr_arg Eq e_1) e_2)
                  (lift_struct.lift a ≫ comma.hom g) (comma_morphism.right sq)
                  (lift_struct.fac_right a) (lift_struct.lift b ≫ comma.hom g)
                  (comma_morphism.right sq) (lift_struct.fac_right b))
                (propext (eq_self_iff_true (comma_morphism.right sq)))))
            trivial))

end arrow

namespace functor

/-- A functor `C ⥤ D` induces a functor between the corresponding arrow categories. -/
@[simp] theorem map_arrow_map_right {C : Type u₁} [category C] {D : Type u₂} [category D]
    (F : C ⥤ D) (a : arrow C) (b : arrow C) (f : a ⟶ b) :
    comma_morphism.right (map (map_arrow F) f) = map F (comma_morphism.right f) :=
  Eq.refl (comma_morphism.right (map (map_arrow F) f))

end Mathlib


/-
Copyright (c) 2017 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Mario Carneiro

Parallel computation of a computable sequence of computations by
a diagonal enumeration.
The important theorems of this operation are proven as
terminates_parallel and exists_of_mem_parallel.
(This operation is nondeterministic in the sense that it does not
honor sequence equivalence (irrelevance of computation time).)
-/
import data.seq.wseq
universes u v

namespace computation
open wseq
variables {α : Type u} {β : Type v}

def parallel.aux2 : list (computation α) → α ⊕ list (computation α) :=
list.foldr (λc o, match o with
| sum.inl a  := sum.inl a
| sum.inr ls := rmap (λ c', c' :: ls) (destruct c)
end) (sum.inr [])

def parallel.aux1 : list (computation α) × wseq (computation α) →
  α ⊕ list (computation α) × wseq (computation α)
| (l, S) := rmap (λ l', match seq.destruct S with
  | none := (l', nil)
  | some (none, S') := (l', S')
  | some (some c, S') := (c::l', S')
  end) (parallel.aux2 l)

/-- Parallel computation of an infinite stream of computations,
  taking the first result -/
def parallel (S : wseq (computation α)) : computation α :=
corec parallel.aux1 ([], S)

theorem terminates_parallel.aux : ∀ {l : list (computation α)} {S c},
  c ∈ l → terminates c → terminates (corec parallel.aux1 (l, S)) :=
begin
  have lem1 : ∀ l S, (∃ (a : α), parallel.aux2 l = sum.inl a) →
    terminates (corec parallel.aux1 (l, S)),
  { intros l S e, cases e with a e,
    have this : corec parallel.aux1 (l, S) = return a,
    { apply destruct_eq_ret, simp [parallel.aux1], rw e, simp [rmap] },
    rw this, apply_instance },
  intros l S c m T, revert l S,
  apply @terminates_rec_on _ _ c T _ _,
  { intros a l S m, apply lem1,
    induction l with c l IH generalizing m; simp at m, { contradiction },
    cases m with e m,
    { rw ←e, simp [parallel.aux2],
      cases list.foldr parallel.aux2._match_1 (sum.inr list.nil) l with a' ls,
      exacts [⟨a', rfl⟩, ⟨a, rfl⟩] },
    { cases IH m with a' e,
      simp [parallel.aux2], simp [parallel.aux2] at e,
      rw e, exact ⟨a', rfl⟩ } },
  { intros s IH l S m,
    have H1 : ∀ l', parallel.aux2 l = sum.inr l' → s ∈ l',
    { induction l with c l IH' generalizing m;
      intros l' e'; simp at m, { contradiction },
      cases m with e m; simp [parallel.aux2] at e',
      { rw ←e at e',
        cases list.foldr parallel.aux2._match_1 (sum.inr list.nil) l with a' ls;
        injection e' with e', rw ←e', simp },
      { induction e : list.foldr parallel.aux2._match_1 (sum.inr list.nil) l with a' ls;
        rw e at e', { contradiction },
        have := IH' m _ e,
        simp [parallel.aux2] at e',
        cases destruct c; injection e' with h',
        rw ←h', simp [this] } },
    induction h : parallel.aux2 l with a l',
    { exact lem1 _ _ ⟨a, h⟩ },
    { have H2 : corec parallel.aux1 (l, S) = think _,
      { apply destruct_eq_think,
        simp [parallel.aux1],
        rw h, simp [rmap] },
      rw H2, apply @computation.think_terminates _ _ _,
      have := H1 _ h,
      rcases seq.destruct S with _ | ⟨_|c, S'⟩;
      simp [parallel.aux1]; apply IH; simp [this] } }
end

theorem terminates_parallel {S : wseq (computation α)}
   {c} (h : c ∈ S) [T : terminates c] : terminates (parallel S) :=
suffices ∀ n (l : list (computation α)) S c,
  c ∈ l ∨ some (some c) = seq.nth S n →
  terminates c → terminates (corec parallel.aux1 (l, S)),
from let ⟨n, h⟩ := h in this n [] S c (or.inr h) T,
begin
  intro n, induction n with n IH; intros l S c o T,
  { cases o with a a, { exact terminates_parallel.aux a T },
    have H : seq.destruct S = some (some c, _),
    { unfold seq.destruct functor.map, rw ← a, simp },
    induction h : parallel.aux2 l with a l';
    have C : corec parallel.aux1 (l, S) = _,
    { apply destruct_eq_ret, simp [parallel.aux1], rw [h], simp [rmap] },
    { rw C, resetI, apply_instance },
    { apply destruct_eq_think, simp [parallel.aux1], rw [h, H], simp [rmap] },
    { rw C, apply @computation.think_terminates _ _ _,
      apply terminates_parallel.aux _ T, simp } },
  { cases o with a a, { exact terminates_parallel.aux a T },
    induction h : parallel.aux2 l with a l';
    have C : corec parallel.aux1 (l, S) = _,
    { apply destruct_eq_ret, simp [parallel.aux1], rw [h], simp [rmap] },
    { rw C, resetI, apply_instance },
    { apply destruct_eq_think, simp [parallel.aux1], rw [h], simp [rmap] },
    { rw C, apply @computation.think_terminates _ _ _,
      have TT : ∀ l', terminates (corec parallel.aux1 (l', S.tail)),
      { intro, apply IH _ _ _ (or.inr _) T, rw a, cases S with f al, refl },
      induction e : seq.nth S 0 with o,
      { have D : seq.destruct S = none,
        { dsimp [seq.destruct], rw e, refl },
        rw D, simp [parallel.aux1], have TT := TT l',
        rwa [seq.destruct_eq_nil D, seq.tail_nil] at TT },
      { have D : seq.destruct S = some (o, S.tail),
        { dsimp [seq.destruct], rw e, refl },
        rw D, cases o with c; simp [parallel.aux1, TT] } } }
end

theorem exists_of_mem_parallel {S : wseq (computation α)}
   {a} (h : a ∈ parallel S) : ∃ c ∈ S, a ∈ c :=
suffices ∀ C, a ∈ C → ∀ (l : list (computation α)) S,
  corec parallel.aux1 (l, S) = C → ∃ c, (c ∈ l ∨ c ∈ S) ∧ a ∈ c,
from let ⟨c, h1, h2⟩ := this _ h [] S rfl in ⟨c, h1.resolve_left id, h2⟩,
begin
  let F : list (computation α) → α ⊕ list (computation α) → Prop,
  { intros l a, cases a with a l',
    exact ∃ c ∈ l, a ∈ c,
    exact ∀ a', (∃ c ∈ l', a' ∈ c) → (∃ c ∈ l, a' ∈ c) },
  have lem1 : ∀ (l : list (computation α)), F l (parallel.aux2 l),
  { intro l, induction l with c l IH; simp [parallel.aux2],
    { intros a h, rcases h with ⟨c, hn, _⟩,
      exact false.elim hn },
    { simp [parallel.aux2] at IH,
      cases list.foldr parallel.aux2._match_1 (sum.inr list.nil) l with a ls;
      simp [parallel.aux2],
      { rcases IH with ⟨c', cl, ac⟩,
        refine ⟨c', or.inr cl, ac⟩ },
      { induction h : destruct c with a c'; simp [rmap],
        { refine ⟨c, list.mem_cons_self _ _, _⟩,
          rw destruct_eq_ret h,
          apply ret_mem },
        { intros a' h, rcases h with ⟨d, dm, ad⟩,
          simp at dm, cases dm with e dl,
          { rw e at ad, refine ⟨c, list.mem_cons_self _ _, _⟩,
            rw destruct_eq_think h,
            exact think_mem ad },
          { cases IH a' ⟨d, dl, ad⟩ with d dm, cases dm with dm ad,
            exact ⟨d, or.inr dm, ad⟩ } } } } },
  intros C aC, refine mem_rec_on aC _ (λ C' IH, _);
  intros l S e; have e' := congr_arg destruct e; have := lem1 l;
  simp [parallel.aux1] at e'; cases parallel.aux2 l with a' l'; injection e' with h',
  { rw h' at this, rcases this with ⟨c, cl, ac⟩,
    exact ⟨c, or.inl cl, ac⟩ },
  { induction e : seq.destruct S with a; rw e at h',
    { exact let ⟨d, o, ad⟩ := IH _ _ h',
        ⟨c, cl, ac⟩ := this a ⟨d, o.resolve_right (not_mem_nil _), ad⟩ in
      ⟨c, or.inl cl, ac⟩ },
    { cases a with o S', cases o with c; simp [parallel.aux1] at h';
      rcases IH _ _ h' with ⟨d, dl | dS', ad⟩,
      { exact let ⟨c, cl, ac⟩ := this a ⟨d, dl, ad⟩ in ⟨c, or.inl cl, ac⟩ },
      { refine ⟨d, or.inr _, ad⟩,
        rw seq.destruct_eq_cons e,
        exact seq.mem_cons_of_mem _ dS' },
      { simp at dl, cases dl with dc dl,
        { rw dc at ad, refine ⟨c, or.inr _, ad⟩,
          rw seq.destruct_eq_cons e,
          apply seq.mem_cons },
        { exact let ⟨c, cl, ac⟩ := this a ⟨d, dl, ad⟩ in ⟨c, or.inl cl, ac⟩ } },
      { refine ⟨d, or.inr _, ad⟩,
        rw seq.destruct_eq_cons e,
        exact seq.mem_cons_of_mem _ dS' } } }
end

theorem map_parallel (f : α → β) (S) : map f (parallel S) = parallel (S.map (map f)) :=
begin
  refine eq_of_bisim (λ c1 c2, ∃ l S,
    c1 = map f (corec parallel.aux1 (l, S)) ∧
    c2 = corec parallel.aux1 (l.map (map f), S.map (map f))) _ ⟨[], S, rfl, rfl⟩,
  intros c1 c2 h, exact match c1, c2, h with ._, ._, ⟨l, S, rfl, rfl⟩ := begin
    clear _match,
    have : parallel.aux2 (l.map (map f)) = lmap f (rmap (list.map (map f)) (parallel.aux2 l)),
    { simp [parallel.aux2],
      induction l with c l IH; simp, rw [IH],
      cases list.foldr parallel.aux2._match_1 (sum.inr list.nil) l; simp [parallel.aux2],
      cases destruct c; simp },
    simp [parallel.aux1], rw this, cases parallel.aux2 l with a l'; simp,
    apply S.cases_on _ (λ c S, _) (λ S, _); simp; simp [parallel.aux1];
    exact ⟨_, _, rfl, rfl⟩
  end end
end

theorem parallel_empty (S : wseq (computation α)) (h : S.head ~> none) :
parallel S = empty _ :=
eq_empty_of_not_terminates $ λ ⟨a, m⟩,
let ⟨c, cs, ac⟩ := exists_of_mem_parallel m,
    ⟨n, nm⟩ := exists_nth_of_mem cs,
    ⟨c', h'⟩ := head_some_of_nth_some nm in by injection h h'

-- The reason this isn't trivial from exists_of_mem_parallel is because it eliminates to Sort
def parallel_rec {S : wseq (computation α)} (C : α → Sort v)
  (H : ∀ s ∈ S, ∀ a ∈ s, C a) {a} (h : a ∈ parallel S) : C a :=
begin
  let T : wseq (computation (α × computation α)) :=
    S.map (λc, c.map (λ a, (a, c))),
  have : S = T.map (map (λ c, c.1)),
  { rw [←wseq.map_comp], refine (wseq.map_id _).symm.trans (congr_arg (λ f, wseq.map f S) _),
    funext c, dsimp [id, function.comp], rw [←map_comp], exact (map_id _).symm },
  have pe := congr_arg parallel this, rw ←map_parallel at pe,
  have h' := h, rw pe at h',
  haveI : terminates (parallel T) := (terminates_map_iff _ _).1 ⟨_, h'⟩,
  induction e : get (parallel T) with a' c,
  have : a ∈ c ∧ c ∈ S,
  { rcases exists_of_mem_map h' with ⟨d, dT, cd⟩,
    rw get_eq_of_mem _ dT at e, cases e, dsimp at cd, cases cd,
    rcases exists_of_mem_parallel dT with ⟨d', dT', ad'⟩,
    rcases wseq.exists_of_mem_map dT' with ⟨c', cs', e'⟩,
    rw ←e' at ad',
    rcases exists_of_mem_map ad' with ⟨a', ac', e'⟩, injection e' with i1 i2,
    constructor, rwa [i1, i2] at ac', rwa i2 at cs' },
  cases this with ac cs, apply H _ cs _ ac
end

theorem parallel_promises {S : wseq (computation α)} {a}
  (H : ∀ s ∈ S, s ~> a) : parallel S ~> a :=
λ a' ma', let ⟨c, cs, ac⟩ := exists_of_mem_parallel ma' in H _ cs ac

theorem mem_parallel {S : wseq (computation α)} {a}
  (H : ∀ s ∈ S, s ~> a) {c} (cs : c ∈ S) (ac : a ∈ c) : a ∈ parallel S :=
by haveI := terminates_of_mem ac; have := terminates_parallel cs;
   exact mem_of_promises _ (parallel_promises H)

theorem parallel_congr_lem {S T : wseq (computation α)} {a}
  (H : S.lift_rel equiv T) : (∀ s ∈ S, s ~> a) ↔ (∀ t ∈ T, t ~> a) :=
⟨λ h1 t tT, let ⟨s, sS, se⟩ := wseq.exists_of_lift_rel_right H tT in
  (promises_congr se _).1 (h1 _ sS),
λ h2 s sS, let ⟨t, tT, se⟩ := wseq.exists_of_lift_rel_left H sS in
  (promises_congr se _).2 (h2 _ tT)⟩

-- The parallel operation is only deterministic when all computation paths lead to the same value
theorem parallel_congr_left {S T : wseq (computation α)} {a}
  (h1 : ∀ s ∈ S, s ~> a) (H : S.lift_rel equiv T) : parallel S ~ parallel T :=
let h2 := (parallel_congr_lem H).1 h1 in
λ a', ⟨λh, by have aa := parallel_promises h1 h; rw ←aa; rw ←aa at h; exact
  let ⟨s, sS, as⟩ := exists_of_mem_parallel h,
      ⟨t, tT, st⟩ := wseq.exists_of_lift_rel_left H sS,
      aT := (st _).1 as in mem_parallel h2 tT aT,
λh, by have aa := parallel_promises h2 h; rw ←aa; rw ←aa at h; exact
  let ⟨s, sS, as⟩ := exists_of_mem_parallel h,
      ⟨t, tT, st⟩ := wseq.exists_of_lift_rel_right H sS,
      aT := (st _).2 as in mem_parallel h1 tT aT⟩

theorem parallel_congr_right {S T : wseq (computation α)} {a}
  (h2 : ∀ t ∈ T, t ~> a) (H : S.lift_rel equiv T) : parallel S ~ parallel T :=
parallel_congr_left ((parallel_congr_lem H).2 h2) H

end computation


example (P Q : Prop) : P → (Q → P) :=
begin
intro p,
intro q,
exact p,
end


/-
Copyright (c) 2018 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon

Transferring `traversable` instances using isomorphisms.
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.equiv.basic
import Mathlib.control.traversable.lemmas
import Mathlib.PostPort

universes u

namespace Mathlib

namespace equiv

/-- Given a functor `t`, a function `t' : Type u → Type u`, and
equivalences `t α ≃ t' α` for all `α`, then every function `α → β` can
be mapped to a function `t' α → t' β` functorially (see
`equiv.functor`). -/
protected def map {t : Type u → Type u} {t' : Type u → Type u} (eqv : (α : Type u) → t α ≃ t' α) [Functor t] {α : Type u} {β : Type u} (f : α → β) (x : t' α) : t' β :=
  coe_fn (eqv β) (f <$> coe_fn (equiv.symm (eqv α)) x)

/-- The function `equiv.map` transfers the functoriality of `t` to
`t'` using the equivalences `eqv`.  -/
protected def functor {t : Type u → Type u} {t' : Type u → Type u} (eqv : (α : Type u) → t α ≃ t' α) [Functor t] : Functor t' :=
  { map := equiv.map eqv, mapConst := fun (α β : Type u) => equiv.map eqv ∘ function.const β }

protected theorem id_map {t : Type u → Type u} {t' : Type u → Type u} (eqv : (α : Type u) → t α ≃ t' α) [Functor t] [is_lawful_functor t] {α : Type u} (x : t' α) : equiv.map eqv id x = x := sorry

protected theorem comp_map {t : Type u → Type u} {t' : Type u → Type u} (eqv : (α : Type u) → t α ≃ t' α) [Functor t] [is_lawful_functor t] {α : Type u} {β : Type u} {γ : Type u} (g : α → β) (h : β → γ) (x : t' α) : equiv.map eqv (h ∘ g) x = equiv.map eqv h (equiv.map eqv g x) := sorry

protected theorem is_lawful_functor {t : Type u → Type u} {t' : Type u → Type u} (eqv : (α : Type u) → t α ≃ t' α) [Functor t] [is_lawful_functor t] : is_lawful_functor t' :=
  is_lawful_functor.mk (equiv.id_map eqv) (equiv.comp_map eqv)

protected theorem is_lawful_functor' {t : Type u → Type u} {t' : Type u → Type u} (eqv : (α : Type u) → t α ≃ t' α) [Functor t] [is_lawful_functor t] [F : Functor t'] (h₀ : ∀ {α β : Type u} (f : α → β), Functor.map f = equiv.map eqv f) (h₁ : ∀ {α β : Type u} (f : β), Functor.mapConst f = function.comp (equiv.map eqv) (function.const α) f) : is_lawful_functor t' := sorry

/-- Like `equiv.map`, a function `t' : Type u → Type u` can be given
the structure of a traversable functor using a traversable functor
`t'` and equivalences `t α ≃ t' α` for all α.  See `equiv.traversable`. -/
protected def traverse {t : Type u → Type u} {t' : Type u → Type u} (eqv : (α : Type u) → t α ≃ t' α) [traversable t] {m : Type u → Type u} [Applicative m] {α : Type u} {β : Type u} (f : α → m β) (x : t' α) : m (t' β) :=
  ⇑(eqv β) <$> traverse f (coe_fn (equiv.symm (eqv α)) x)

/-- The function `equiv.tranverse` transfers a traversable functor
instance across the equivalences `eqv`. -/
protected def traversable {t : Type u → Type u} {t' : Type u → Type u} (eqv : (α : Type u) → t α ≃ t' α) [traversable t] : traversable t' :=
  traversable.mk (equiv.traverse eqv)

protected theorem id_traverse {t : Type u → Type u} {t' : Type u → Type u} (eqv : (α : Type u) → t α ≃ t' α) [traversable t] [is_lawful_traversable t] {α : Type u} (x : t' α) : equiv.traverse eqv id.mk x = x := sorry

protected theorem traverse_eq_map_id {t : Type u → Type u} {t' : Type u → Type u} (eqv : (α : Type u) → t α ≃ t' α) [traversable t] [is_lawful_traversable t] {α : Type u} {β : Type u} (f : α → β) (x : t' α) : equiv.traverse eqv (id.mk ∘ f) x = id.mk (equiv.map eqv f x) := sorry

protected theorem comp_traverse {t : Type u → Type u} {t' : Type u → Type u} (eqv : (α : Type u) → t α ≃ t' α) [traversable t] [is_lawful_traversable t] {F : Type u → Type u} {G : Type u → Type u} [Applicative F] [Applicative G] [is_lawful_applicative F] [is_lawful_applicative G] {α : Type u} {β : Type u} {γ : Type u} (f : β → F γ) (g : α → G β) (x : t' α) : equiv.traverse eqv (functor.comp.mk ∘ Functor.map f ∘ g) x =
  functor.comp.mk (equiv.traverse eqv f <$> equiv.traverse eqv g x) := sorry

protected theorem naturality {t : Type u → Type u} {t' : Type u → Type u} (eqv : (α : Type u) → t α ≃ t' α) [traversable t] [is_lawful_traversable t] {F : Type u → Type u} {G : Type u → Type u} [Applicative F] [Applicative G] [is_lawful_applicative F] [is_lawful_applicative G] (η : applicative_transformation F G) {α : Type u} {β : Type u} (f : α → F β) (x : t' α) : coe_fn η (t' β) (equiv.traverse eqv f x) = equiv.traverse eqv (coe_fn η β ∘ f) x := sorry

/-- The fact that `t` is a lawful traversable functor carries over the
equivalences to `t'`, with the traversable functor structure given by
`equiv.traversable`. -/
protected def is_lawful_traversable {t : Type u → Type u} {t' : Type u → Type u} (eqv : (α : Type u) → t α ≃ t' α) [traversable t] [is_lawful_traversable t] : is_lawful_traversable t' :=
  is_lawful_traversable.mk (equiv.id_traverse eqv) (equiv.comp_traverse eqv) (equiv.traverse_eq_map_id eqv)
    (equiv.naturality eqv)

/-- If the `traversable t'` instance has the properties that `map`,
`map_const`, and `traverse` are equal to the ones that come from
carrying the traversable functor structure from `t` over the
equivalences, then the the fact `t` is a lawful traversable functor
carries over as well. -/
protected def is_lawful_traversable' {t : Type u → Type u} {t' : Type u → Type u} (eqv : (α : Type u) → t α ≃ t' α) [traversable t] [is_lawful_traversable t] [traversable t'] (h₀ : ∀ {α β : Type u} (f : α → β), Functor.map f = equiv.map eqv f) (h₁ : ∀ {α β : Type u} (f : β), Functor.mapConst f = function.comp (equiv.map eqv) (function.const α) f) (h₂ : ∀ {F : Type u → Type u} [_inst_7 : Applicative F] [_inst_8 : is_lawful_applicative F] {α β : Type u} (f : α → F β),
  traverse f = equiv.traverse eqv f) : is_lawful_traversable t' :=
  is_lawful_traversable.mk sorry sorry sorry sorry


import data.hash_map .lib

namespace maps

def prev_append : pos_num → pos_num → pos_num
| pos_num.one j := j
| (pos_num.bit1 i') j := prev_append i' (pos_num.bit1 j)
| (pos_num.bit0 i') j := prev_append i' (pos_num.bit0 j)

def prev (i : pos_num) : pos_num :=
prev_append i pos_num.one

inductive PTree (A : Type) : Type
| leaf {} : PTree
| node    : PTree → option A → PTree → PTree
open PTree

namespace PTree

instance {A} : has_emptyc (PTree A) := ⟨leaf⟩

def get {A : Type} : pos_num → PTree A → option A :=
by { intros i m, revert i,
     induction m with l o r Il Ir; intro i, exact none,
     cases i with i' i',
     exact o,
     exact Il i', exact Ir i' }

def get_or {A : Type} (n : pos_num) (t : PTree A) (dfl : A) : A :=
(t.get n).get_or_else dfl

def set {A : Type} : pos_num → A → PTree A → PTree A
| pos_num.one       v leaf         := node leaf (some v) leaf
| (pos_num.bit0 i') v leaf         := node (set i' v leaf) none leaf
| (pos_num.bit1 i') v leaf         := node leaf none (set i' v leaf)
| pos_num.one       v (node l o r) := node l (some v) r
| (pos_num.bit0 i') v (node l o r) := node (set i' v l) o r
| (pos_num.bit1 i') v (node l o r) := node l o (set i' v r)

lemma gleaf {A} (i) : get i (leaf : PTree A) = none :=
by induction i; simp [get]

theorem gempty {A} (i) : get i (∅ : PTree A) = none := gleaf i

theorem gss {A} (i x) (m : PTree A) : get i (set i x m) = some x := sorry

theorem gso {A i j} (x : A) (m : PTree A) : i ≠ j → get i (set j x m) = get i m := sorry

theorem gsspec {A} (i j) (x : A) (m : PTree A) :
  get i (set j x m) = if i = j then some x else get i m :=
by { by_cases (i = j); simp [h], rw gss, rw gso _ _ h }

theorem gsident {A} (i : pos_num) (m : PTree A) (v : A) :
  get i m = some v → set i v m = m := sorry

theorem set2 {A} (i : pos_num) (m : PTree A) (v1 v2 : A) :
  set i v2 (set i v1 m) = set i v2 m := sorry

def of_list {A} (l : list (pos_num × A)) : PTree A :=
l.foldl (λ m ⟨k, v⟩, set k v m) ∅

def node' {A} : PTree A → option A → PTree A → PTree A
| leaf none leaf := leaf
| l x r := node l x r

section combine

variables {A B C : Type} (f : option A → option B → option C)

def xcombine_l : PTree A → PTree C
| leaf := leaf
| (node l o r) := node' (xcombine_l l) (f o none) (xcombine_l r)

def xcombine_r : PTree B → PTree C
| leaf := leaf
| (node l o r) := node' (xcombine_r l) (f none o) (xcombine_r r)

def combine : PTree A → PTree B → PTree C
| leaf m2 := xcombine_r f m2
| m1 leaf := xcombine_l f m1
| (node l1 o1 r1) (node l2 o2 r2) := node' (combine l1 l2) (f o1 o2) (combine r1 r2)

theorem combine_commut (f g : option A → option A → option B) :
(∀ i j, f i j = g j i) →
∀ m1 m2, combine f m1 m2 = combine g m2 m1 := sorry

end combine

def xelements {A} : PTree A → pos_num → list (pos_num × A) → list (pos_num × A)
| leaf i k := k
| (node l none r) i k :=
    xelements l (pos_num.bit0 i) (xelements r (pos_num.bit1 i) k)
| (node l (some x) r) i k :=
    xelements l (pos_num.bit0 i)
    ((prev i, x) :: xelements r (pos_num.bit1 i) k)

def elements {A} (m : PTree A) := xelements m pos_num.one []

def xfold {A B} (f : B → pos_num → A → B) : pos_num → PTree A → B → B
| i leaf v := v
| i (node l none r) v :=
  let v1 := xfold (pos_num.bit0 i) l v in
  xfold (pos_num.bit1 i) r v1
| i (node l (some x) r) v :=
  let v1 := xfold (pos_num.bit0 i) l v in
  let v2 := f v1 (pos_num.pred i) x in
  xfold (pos_num.bit1 i) r v2

def fold {A B} (f : B → pos_num → A → B) (m : PTree A) (v : B) :=
xfold f pos_num.one m v

def for_all {A} (m : PTree A) (f : pos_num → A → bool) : bool :=
fold (λ b x a, b && f x a) m tt

notation a `^!` b := get b a

end PTree

end maps


namespace Foo

def x := 10

end Foo

#check Foo.x

open Foo

#check x

theorem ex1 : x = Foo.x := rfl

namespace Foo

def f x y := x + y + 1

scoped infix:70 "^^" => f

#check 1 ^^ 2

theorem ex1 : x ^^ y = f x y := rfl

end Foo

#check 1 ^^ 2 -- works because we have an `open Foo` above

theorem ex2 : x ^^ y = f x y := rfl
theorem ex3 : x ^^ y = Foo.f x y := rfl


import data.sign

namespace int

@[elab_as_eliminator] protected lemma induction_on_iff {p : ℤ → Prop}
  (i : ℤ) (hz : p 0) (h : ∀ i : ℤ, p i ↔ p (i + 1)) : p i :=
begin
  induction i using int.induction_on with i IH i IH,
  { exact hz },
  { rwa ← h },
  { rwa [h, sub_add_cancel], }
end

@[simp] lemma sign_eq_sign (n : ℤ) : n.sign = _root_.sign n :=
begin
  obtain ((_ | _) | _) := n,
  { exact congr_arg coe sign_zero.symm },
  { exact congr_arg coe (sign_pos $ int.succ_coe_nat_pos _).symm },
  { exact congr_arg coe (_root_.sign_neg $ neg_succ_lt_zero _).symm }
end

end int


import data.list.func
import .helpers
import .list2d
import .find_indexes2d

def bset1d := list bool
def bset2d := list2d bool

instance : inhabited bset1d := ⟨[]⟩
instance : inhabited bset2d := ⟨[]⟩

instance : has_mem ℕ bset1d :=
⟨λ n l, list.func.get n l = tt⟩
instance : has_mem (ℕ×ℕ) bset2d :=
⟨λ xy l, list2d.get2d xy l = tt⟩
lemma bset1d.has_mem.unfold {n : ℕ} {l : bset1d}
  : n ∈ l = (list.func.get n l = tt) := rfl
lemma bset2d.has_mem.unfold {xy : ℕ×ℕ} {l : bset2d}
  : xy ∈ l = (list2d.get2d xy l = tt) := rfl

instance : has_sdiff bset2d
:= ⟨list2d.pointwise2d (λ a b, (cond b ff a))⟩
instance : has_inter bset2d
:= ⟨list2d.pointwise2d band⟩
instance : has_union bset2d
:= ⟨list2d.pointwise2d bor⟩

def pic_str1d (l : bset1d) : string :=
  string.push (list.as_string (l.map (λb, cond b '*' '.'))) '\n'
def pic_str2d (l : bset2d) : string :=
  string.join (l.map pic_str1d)
instance : has_repr bset1d := ⟨pic_str1d⟩
instance : has_repr bset2d := ⟨pic_str2d⟩

--             _              _
--   ___ _   _| |__  ___  ___| |_
--  / __| | | | '_ \/ __|/ _ \ __|
--  \__ \ |_| | |_) \__ \  __/ |_
--  |___/\__,_|_.__/|___/\___|\__|
--

def bset1d.subset (l1 : bset1d) (l2 : bset1d) : Prop
  := ∀ x : ℕ, x ∈ l1 → x ∈ l2
def bset2d.subset (l1 : bset2d) (l2 : bset2d) : Prop
  := ∀ xy : ℕ×ℕ, xy ∈ l1 → xy ∈ l2
instance : has_subset bset1d := ⟨bset1d.subset⟩
instance : has_subset bset2d := ⟨bset2d.subset⟩

def bset2d.disjoint (l1 : bset2d) (l2 : bset2d) : Prop
  := ∀ xy : ℕ×ℕ, xy ∈ l1 → xy ∈ l2 → false

theorem bset2d.subset.refl : ∀ {l1 : bset2d}, l1 ⊆ l1
:= assume l1 xy H, H
theorem bset2d.subset.trans : ∀ {l1 l2 l3 : bset2d},
  l1 ⊆ l2 → l2 ⊆ l3 → l1 ⊆ l3
:= assume l1 l2 l3 H12 H23 xy H1, H23 xy (H12 xy H1)

theorem bset2d.subset_of_equiv : ∀ {l1 l2 : bset2d},
  list2d.equiv l1 l2 → l1 ⊆ l2 :=
begin
  intros l1 l2 Heq xy Hget,
  unfold has_mem.mem at Hget,
  rw Heq xy at Hget, exact Hget,
end

--                         _   _
--    ___ ___  _   _ _ __ | |_(_)_ __   __ _
--   / __/ _ \| | | | '_ \| __| | '_ \ / _` |
--  | (_| (_) | |_| | | | | |_| | | | | (_| |
--   \___\___/ \__,_|_| |_|\__|_|_| |_|\__, |
--                                     |___/

def bset1d.count (l : bset1d) : ℕ := list.sum (list.map bool.to_nat l)
def bset2d.count (l : bset2d) : ℕ := list.sum (list.map bset1d.count l)

@[simp] theorem bset1d.count_nil : bset1d.count [] = 0 := rfl
@[simp] theorem bset2d.count_nil : bset2d.count [] = 0 := rfl
@[simp] theorem bset1d.count_cons : ∀ (h : bool) (t : bset1d),
  bset1d.count (h::t) = (bool.to_nat h) + t.count := by simp [bset1d.count]
@[simp] theorem bset2d.count_cons : ∀ (h : bset1d) (t : bset2d),
  bset2d.count (h::t) = h.count + t.count := by simp [bset2d.count]

--                         _                       _              _
--    ___ ___  _   _ _ __ | |_     _     ___ _   _| |__  ___  ___| |_
--   / __/ _ \| | | | '_ \| __|  _| |_  / __| | | | '_ \/ __|/ _ \ __|
--  | (_| (_) | |_| | | | | |_  |_   _| \__ \ |_| | |_) \__ \  __/ |_
--   \___\___/ \__,_|_| |_|\__|   |_|   |___/\__,_|_.__/|___/\___|\__|
--

theorem bool_to_nat_le {b1 b2 : bool} :
  (b1.to_nat ≤ b2.to_nat) ↔ (b1 = tt → b2 = tt) :=
begin
  intros, split, {
    intro H, cases b1, simp,
    cases b2, simp [bool.to_nat] at H, contradiction,
    simp,
  }, {
    intro H, cases b1, simp [bool.to_nat],
    cases b2, simp at H, contradiction,
    apply le_rfl,
  }
end

theorem bset1d.subset_cons : ∀ (h1 h2 : bool) (t1 t2 : bset1d),
  bset1d.subset (h1::t1) (h2::t2) = (h1.to_nat ≤ h2.to_nat ∧ t1 ⊆ t2) :=
begin
  intros, apply propext, split, {
    intro H, split, exact bool_to_nat_le.2 (H 0),
    intro n, exact H n.succ
  }, {
    intro H, cases H with H1 H2,
    intro n, cases n, exact bool_to_nat_le.1 H1,
    exact H2 n,
  }
end
theorem bset2d.subset_cons : ∀ (h1 h2 : bset1d) (t1 t2 : bset2d),
  bset2d.subset (h1::t1) (h2::t2) = (h1 ⊆ h2 ∧ t1 ⊆ t2) :=
begin
  intros, apply propext, split, {
    intro H, split, intro x, exact H (x,0),
    intro xy, cases xy with x y, exact H (x,y+1)
  }, {
    intro H, cases H with H1 H2,
    intro xy, cases xy with x y, cases y, apply H1,
    exact H2 (x, y),
  }
end

theorem bset1d.count_0_of_subset_nil : ∀ l : bset1d,
  bset1d.subset l list.nil → l.count = 0
| [] := by simp
| (h::t) := begin
  intro H, simp, split, {
    have := H 0, simp [has_mem.mem] at this,
    rw bool_eq_false this, refl,
  }, {
    apply bset1d.count_0_of_subset_nil,
    intros n H2, specialize H (n+1), simp [has_mem.mem] at H, contradiction,
  }
end
theorem bset2d.count_0_of_subset_nil : ∀ l : bset2d,
  bset2d.subset l list.nil → l.count = 0
| [] := by simp
| (h::t) := begin
  intro H, simp, split, {
    apply bset1d.count_0_of_subset_nil,
    intro x, exact H (x,0),
  }, {
    apply bset2d.count_0_of_subset_nil,
    intros xy H2, cases xy with x y,
    specialize H (x,y+1), simp [has_mem.mem] at H, contradiction,
  }
end

theorem bset1d.count_le_of_subset : ∀ l1 l2 : bset1d,
  l1 ⊆ l2 → l1.count ≤ l2.count
| [] _ := by simp
| _ [] := begin
  intros H, have H := bset1d.count_0_of_subset_nil _ H, rewrite H,
  apply zero_le,
end
| (h1::t1) (h2::t2) := begin
  simp [has_subset.subset, bset1d.subset_cons], intros Hh Ht, apply add_le_add,
  exact Hh,
  exact bset1d.count_le_of_subset _ _ Ht,
end

theorem bset2d.count_le_of_subset : ∀ l1 l2 : bset2d,
  l1 ⊆ l2 → l1.count ≤ l2.count
| [] _ := by simp
| _ [] := begin
  intros H, have H := bset2d.count_0_of_subset_nil _ H, rewrite H,
  apply zero_le,
end
| (h1::t1) (h2::t2) := begin
  simp [has_subset.subset, bset2d.subset_cons], intros Hh Ht, apply add_le_add,
  exact bset1d.count_le_of_subset _ _ Hh,
  exact bset2d.count_le_of_subset _ _ Ht,
end

lemma leq_sum_equal {a b c d : ℕ} :
  a ≤ b → c ≤ d → a+c = b+d → a=b ∧ c=d := by omega

theorem bset1d.subset_nil_of_count_0 : ∀ l : bset1d,
  l.count = 0 → bset1d.subset l list.nil
| [] := λ _ _ H, H
| (h::t) := begin
  simp, intros Hh Ht n, cases n, {
    cases h, intro H, simp at H, contradiction,
    simp [bool.to_nat] at Hh, contradiction,
  }, {
    have := bset1d.subset_nil_of_count_0 t Ht n,
    simp [has_mem.mem], simp [has_mem.mem] at this, exact this,
  }
end
theorem bset2d.subset_nil_of_count_0 : ∀ l : bset2d,
  l.count = 0 → bset2d.subset l list.nil
| [] := λ _ _ H, H
| (h::t) := begin
  simp, intros Hh Ht xy, cases xy with x y, cases y, {
    exact bset1d.subset_nil_of_count_0 h Hh x,
  }, {
    have := bset2d.subset_nil_of_count_0 t Ht (x,y),
    simp [has_mem.mem], simp [has_mem.mem] at this, exact this,
  }
end

theorem bset1d.subset_eq_of_count_eq : ∀ l1 l2 : bset1d,
  l1 ⊆ l2 → l1.count = l2.count → l2 ⊆ l1
| _ [] := begin simp [has_mem.mem, has_subset.subset, bset1d.subset], end
| [] l2 := begin
  intros Hh Hc, simp at Hc,
  apply bset1d.subset_nil_of_count_0 l2 (eq.symm Hc),
end
| (h1::t1) (h2::t2) := begin
  simp [has_subset.subset, bset1d.subset_cons], intros Hh Ht Hc,
  have Ht_le := bset1d.count_le_of_subset t1 t2 Ht,
  cases leq_sum_equal Hh Ht_le Hc with Eh Et,
  split, simp! [Eh],
  exact bset1d.subset_eq_of_count_eq t1 t2 Ht Et,
end

theorem bset2d.subset_eq_of_count_eq : ∀ l1 l2 : bset2d,
  l1 ⊆ l2 → l1.count = l2.count → l2 ⊆ l1
| _ [] := by simp [has_mem.mem, has_subset.subset, bset2d.subset]
| [] l2 := begin
  intros Hh Hc, simp at Hc,
  apply bset2d.subset_nil_of_count_0 l2 (eq.symm Hc),
end
| (h1::t1) (h2::t2) := begin
  simp [has_subset.subset, bset1d.subset_cons, bset2d.subset_cons],
  intros Hh Ht Hc,
  have Hh_le := bset1d.count_le_of_subset h1 h2 Hh,
  have Ht_le := bset2d.count_le_of_subset t1 t2 Ht,
  cases leq_sum_equal Hh_le Ht_le Hc with Eh Et,
  split, apply bset1d.subset_eq_of_count_eq h1 h2 Hh Eh,
  exact bset2d.subset_eq_of_count_eq t1 t2 Ht Et,
end

--             _     _
--    __ _  __| | __| |    _     _ __ ___ _ __ ___   _____   _____
--   / _` |/ _` |/ _` |  _| |_  | '__/ _ \ '_ ` _ \ / _ \ \ / / _ \
--  | (_| | (_| | (_| | |_   _| | | |  __/ | | | | | (_) \ V /  __/
--   \__,_|\__,_|\__,_|   |_|   |_|  \___|_| |_| |_|\___/ \_/ \___|
--

def bset2d.add (xy : ℕ×ℕ) (l : bset2d) : bset2d := list2d.set2d tt l xy
def bset2d.remove (xy : ℕ×ℕ) (l : bset2d) : bset2d := list2d.set2d ff l xy

lemma bset2d.mem_add {xy : ℕ×ℕ} {l : bset2d}
  : xy ∈ (l.add xy) := list2d.get2d_set2d
lemma bset2d.mem_add_of_mem {xy xy' : ℕ×ℕ} {l : bset2d}
  : xy ∈ l → xy ∈ (l.add xy') := begin
  assume H, by_cases C : xy = xy', rw C, exact list2d.get2d_set2d,
  exact eq.trans (list2d.get2d_set2d_eq_of_ne C) H,
end
lemma bset2d.nmem_add_of_neq_nmem {xy xy' : ℕ×ℕ} {l : bset2d}
  : xy ≠ xy' → xy ∉ l → xy ∉ (l.add xy')
:= λ Hn Hl Hadd, Hl (eq.trans (list2d.get2d_set2d_eq_of_ne Hn).symm Hadd)
lemma bset2d.nmem_remove {xy : ℕ×ℕ} {l : bset2d}
  : xy ∉ (l.remove xy)
:= by simp [has_mem.mem, bset2d.remove, list2d.get2d_set2d]
lemma bset2d.nmem_remove_of_nmem {xy xy' : ℕ×ℕ} {l : bset2d}
  : xy ∉ l → xy ∉ (l.remove xy') := begin
  assume H, by_cases C : xy = xy', rw C, exact bset2d.nmem_remove,
  assume Hrem, exact H (eq.trans (list2d.get2d_set2d_eq_of_ne C).symm Hrem),
end
lemma bset2d.mem_remove_of_neq_mem {xy xy' : ℕ×ℕ} {l : bset2d}
  : xy ≠ xy' → xy ∈ l → xy ∈ (l.remove xy')
:= λ Hn Hl, eq.trans (list2d.get2d_set2d_eq_of_ne Hn) Hl

lemma bset2d.of_mem_add {xy xy' : ℕ×ℕ} {l : bset2d}
  : xy ∈ (l.add xy') → xy = xy' ∨ xy ∈ l := begin
  intro H, by_cases C : xy = xy', left, exact C,
  right, by_contradiction Hnl,
  exact bset2d.nmem_add_of_neq_nmem C Hnl H,
end
lemma bset2d.nmem_of_nmem_add {xy xy' : ℕ×ℕ} {l : bset2d}
  : xy ∉ (l.add xy') → xy ∉ l :=
begin
  intros Hnadd, by_contradiction Hl,
  exact Hnadd (bset2d.mem_add_of_mem Hl),
end
lemma bset2d.neq_of_nmem_add {xy xy' : ℕ×ℕ} {l : bset2d}
  : xy ∉ (l.add xy') → xy ≠ xy' :=
begin
  intros Hnadd Heq, rw Heq at Hnadd,
  exact Hnadd (bset2d.mem_add),
end
lemma bset2d.of_nmem_remove {xy xy' : ℕ×ℕ} {l : bset2d}
  : xy ∉ (l.remove xy') → xy = xy' ∨ xy ∉ l := begin
  intro H, by_cases C : xy = xy', left, exact C,
  right, by_contradiction Hl,
  refine H (bset2d.mem_remove_of_neq_mem _ Hl),
  assume Cn, exact C Cn,
end
lemma bset2d.mem_of_mem_remove {xy xy' : ℕ×ℕ} {l : bset2d}
  : xy ∈ (l.remove xy') → xy ∈ l := begin
  intro Hrem, by_contradiction Hnl,
  exact bset2d.nmem_remove_of_nmem Hnl Hrem,
end
lemma bset2d.neq_of_mem_remove {xy xy' : ℕ×ℕ} {l : bset2d}
  : xy ∈ (l.remove xy') → xy ≠ xy' := begin
  intros Hrem Heq, rw Heq at Hrem,
  exact bset2d.nmem_remove Hrem,
end
lemma bset2d.subset_add_same {l1 l2 : bset2d} {xy : ℕ×ℕ}
  : l1 ⊆ l2 → l1.add xy ⊆ l2.add xy
:= begin
  intros Hsub xy' Hin, cases bset2d.of_mem_add Hin,
  rw h, exact bset2d.mem_add,
  apply bset2d.mem_add_of_mem, exact Hsub xy' h,
end

lemma bset2d.subset_remove_same {l1 l2 : bset2d} {xy : ℕ×ℕ}
  : l1 ⊆ l2 → l1.remove xy ⊆ l2.remove xy
:= begin
  intros Hsub xy' Hin, apply bset2d.mem_remove_of_neq_mem,
  exact bset2d.neq_of_mem_remove Hin,
  apply Hsub,
  exact bset2d.mem_of_mem_remove Hin,
end

--                         _                             _       _
--    ___ ___  _   _ _ __ | |_     _     _   _ _ __   __| | __ _| |_ ___
--   / __/ _ \| | | | '_ \| __|  _| |_  | | | | '_ \ / _` |/ _` | __/ _ \
--  | (_| (_) | |_| | | | | |_  |_   _| | |_| | |_) | (_| | (_| | ||  __/
--   \___\___/ \__,_|_| |_|\__|   |_|    \__,_| .__/ \__,_|\__,_|\__\___|
--                                            |_|

lemma bset1d.count_update : ∀ (b : bool) (l : bset1d) (n : ℕ),
∃ c, bset1d.count l = c + (list.func.get n l).to_nat
∧ bset1d.count (list.func.set b l n) = c + b.to_nat
:=
list.sum_map_update bool.to_nat rfl

lemma bset2d.count_update : ∀ (b : bool) (l : bset2d) (xy : ℕ×ℕ),
∃ c, bset2d.count l = c + (list2d.get2d xy l).to_nat
∧ bset2d.count (list2d.set2d b l xy) = c + b.to_nat
:=
begin
  intros, cases xy with x y,
  rcases list.sum_map_update bset1d.count rfl
    (list.func.set b (list.func.get y l) x) l y
  with ⟨c1, H1old, H1new⟩,
  rcases bset1d.count_update b (list.func.get y l) x
  with ⟨c2, H2old, H2new⟩,
  existsi c1 + c2,
  split, {
    unfold bset2d.count, rw H1old, rw H2old,
    rw ←add_assoc, refl,
  }, {
    unfold bset2d.count, unfold list2d.set2d,
    rw H1new, rw H2new, rw ←add_assoc,
  }
end

lemma bset2d.count_add {xy : ℕ×ℕ} {l : bset2d}
: xy ∉ l → (l.add xy).count = l.count+1
:=
begin
  rcases bset2d.count_update tt l xy with ⟨c,Hold,Hnew⟩,
  assume Hnin : xy ∉ l,
    rw bool_eq_false Hnin at Hold, clear Hnin,
  unfold bset2d.add, rw Hnew, rw Hold,
  simp [bool.to_nat],
end

lemma bset2d.count_remove {xy : ℕ×ℕ} {l : bset2d}
: xy ∈ l → (l.remove xy).count+1 = l.count
:=
begin
  rcases bset2d.count_update ff l xy with ⟨c,Hold,Hnew⟩,
  assume Hin : xy ∈ l,
    rw bset2d.has_mem.unfold at Hin, rw Hin at Hold, clear Hin,
  unfold bset2d.remove, rw Hnew, rw Hold,
  simp [bool.to_nat],
end

--           _ _  __  __
--   ___  __| (_)/ _|/ _|
--  / __|/ _` | | |_| |_
--  \__ \ (_| | |  _|  _|
--  |___/\__,_|_|_| |_|
--

lemma bset2d.mem_sdiff_of_mem_nmem {xy : ℕ×ℕ} {l1 l2 : bset2d}
  : xy ∈ l1 → xy ∉ l2 → xy ∈ l1 \ l2 :=
begin
  simp [has_sdiff.sdiff, has_mem.mem, list2d.get2d_pointwise],
  intros H1 H2, simp! [H1, H2],
end
lemma bset2d.mem_of_mem_sdiff {xy : ℕ×ℕ} {l1 l2 : bset2d}
  : xy ∈ l1 \ l2 → xy ∈ l1 :=
begin
  simp [has_sdiff.sdiff, has_mem.mem, list2d.get2d_pointwise],
  assume H, cases (list2d.get2d xy l2), exact H, exact bool.no_confusion H,
end
lemma bset2d.nmem_of_mem_sdiff {xy : ℕ×ℕ} {l1 l2 : bset2d}
  : xy ∈ l1 \ l2 → xy ∉ l2 :=
begin
  simp [has_sdiff.sdiff, has_mem.mem, list2d.get2d_pointwise],
  assume H, cases (list2d.get2d xy l2), refl, exact bool.no_confusion H,
end
lemma bset2d.sdiff_subset {l1 l2 : bset2d} : l1 \ l2 ⊆ l1
:= assume xy, bset2d.mem_of_mem_sdiff

--   _       _                                  _
--  (_)_ __ | |_ ___ _ __     _     _   _ _ __ (_) ___  _ __
--  | | '_ \| __/ _ \ '__|  _| |_  | | | | '_ \| |/ _ \| '_ \
--  | | | | | ||  __/ |    |_   _| | |_| | | | | | (_) | | | |
--  |_|_| |_|\__\___|_|      |_|    \__,_|_| |_|_|\___/|_| |_|
--

lemma bset2d.inter_subset_left {l1 l2 : bset2d} : l1 ∩ l2 ⊆ l1
:=
  assume xy,
  assume H,
  have this : list2d.get2d xy l1 && list2d.get2d xy l2 = tt
    := eq.trans (eq.symm (list2d.get2d_pointwise rfl _ _ _)) H,
  show xy ∈ l1, from ((band_coe_iff _ _).mp this).1

lemma bset2d.inter_subset_right {l1 l2 : bset2d} : l1 ∩ l2 ⊆ l2
:=
  assume xy,
  assume H,
  have this : list2d.get2d xy l1 && list2d.get2d xy l2 = tt
    := eq.trans (eq.symm (list2d.get2d_pointwise rfl _ _ _)) H,
  show xy ∈ l2, from ((band_coe_iff _ _).mp this).2

lemma bset2d.union_subset {l1 l2 l3 : bset2d} : l1 ⊆ l3 → l2 ⊆ l3 → l1 ∪ l2 ⊆ l3
:=
begin
  assume H1 H2 xy Hin,
  have this : list2d.get2d xy l1 || list2d.get2d xy l2 = tt
    := eq.trans (eq.symm (list2d.get2d_pointwise rfl _ _ _)) Hin,
  cases (bor_coe_iff _ _).mp this with Hin1 Hin2,
  exact H1 xy Hin1,
  exact H2 xy Hin2,
end
lemma bset2d.union_supset_left {l1 l2 : bset2d} : l1 ⊆ l1 ∪ l2
:=
begin
  assume xy,
  assume H,
  refine eq.trans (list2d.get2d_pointwise rfl _ _ _) _,
  exact (congr_arg (λ a, a || list2d.get2d xy l2) H).trans (tt_bor _),
end
lemma bset2d.union_supset_right {l1 l2 : bset2d} : l2 ⊆ l1 ∪ l2
:=
begin
  assume xy,
  assume H,
  refine eq.trans (list2d.get2d_pointwise rfl _ _ _) _,
  exact (congr_arg (bor _) H).trans (bor_tt _),
end

--   _           _
--  (_)_ __   __| | _____  _____  ___
--  | | '_ \ / _` |/ _ \ \/ / _ \/ __|
--  | | | | | (_| |  __/>  <  __/\__ \
--  |_|_| |_|\__,_|\___/_/\_\___||___/
--

def bset2d.from_index (xy : ℕ×ℕ) : bset2d := list2d.set2d tt [] xy
def bset2d.from_indexes (xys : list (ℕ × ℕ)) : bset2d
:= list.foldr (λ (xy : ℕ×ℕ) (l : bset2d), l.set2d tt xy) [] xys
def bset2d.to_indexes (s : bset2d) : list (ℕ × ℕ)
:= s.find_indexes2d (eq tt)

theorem bset2d.from_index_iff (xy : ℕ×ℕ)
  : ∀ xy' : ℕ×ℕ, xy' ∈ bset2d.from_index xy ↔ xy' = xy :=
begin
  intro xy', split, {
    intro H, by_contradiction C,
    unfold has_mem.mem at H, unfold bset2d.from_index at H,
    rw list2d.get2d_set2d_eq_of_ne at H, simp at H, exact H, exact C,
  }, {
    intro H, rw H, unfold bset2d.from_index, unfold has_mem.mem,
    exact list2d.get2d_set2d,
  }
end

theorem bset2d.from_indexes_iff (xys : list (ℕ×ℕ))
  : ∀ xy : ℕ×ℕ, xy ∈ bset2d.from_indexes xys ↔ xy ∈ xys :=
begin
  intro xy, induction xys with xy' t IH, {
    simp! [bset2d.from_indexes, has_mem.mem],
  }, {
    by_cases C : xy = xy',
    { rw ←C, simp! [has_mem.mem, bset2d.from_indexes, list2d.get2d_set2d], },
    simp [bset2d.from_indexes], unfold has_mem.mem,
    rw list2d.get2d_set2d_eq_of_ne C,
    split,
    { intro H, right, exact IH.mp H, },
    { intro H, cases H, exact false.elim (C H),
      exact IH.mpr H, },
  },
end

theorem bset2d.to_indexes_iff (s : bset2d)
  : ∀ xy : ℕ×ℕ, xy ∈ bset2d.to_indexes s ↔ xy ∈ s :=
begin
  intro xy,
  unfold bset2d.to_indexes, rw bset2d.has_mem.unfold,
  rw ←list2d.find_indexes2d_iff, exact eq_comm, simp!,
end


/-
Copyright (c) 2022 Yaël Dillies. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies
-/
import group_theory.group_action.defs

/-!
# Option instances for additive and multiplicative actions

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

This file defines instances for additive and multiplicative actions on `option` type. Scalar
multiplication is defined by `a • some b = some (a • b)` and `a • none = none`.

## See also

* `group_theory.group_action.pi`
* `group_theory.group_action.prod`
* `group_theory.group_action.sigma`
* `group_theory.group_action.sum`
-/

variables {M N α : Type*}

namespace option

section has_smul
variables [has_smul M α] [has_smul N α] (a : M) (b : α) (x : option α)

@[to_additive option.has_vadd] instance : has_smul M (option α) := ⟨λ a, option.map $ (•) a⟩

@[to_additive] lemma smul_def : a • x = x.map ((•) a) := rfl
@[simp, to_additive] lemma smul_none : a • (none : option α) = none := rfl
@[simp, to_additive] lemma smul_some : a • some b = some (a • b) := rfl

@[to_additive] instance [has_smul M N] [is_scalar_tower M N α] : is_scalar_tower M N (option α) :=
⟨λ a b x, by { cases x, exacts [rfl, congr_arg some (smul_assoc _ _ _)] }⟩

@[to_additive] instance [smul_comm_class M N α] : smul_comm_class M N (option α) :=
⟨λ a b, function.commute.option_map $ smul_comm _ _⟩

@[to_additive]
instance [has_smul Mᵐᵒᵖ α] [is_central_scalar M α] : is_central_scalar M (option α) :=
⟨λ a x, by { cases x, exacts [rfl, congr_arg some (op_smul_eq_smul _ _)] }⟩

@[to_additive] instance [has_faithful_smul M α] : has_faithful_smul M (option α) :=
⟨λ x y h, eq_of_smul_eq_smul $ λ b : α, by injection h (some b)⟩

end has_smul

instance [monoid M] [mul_action M α] : mul_action M (option α) :=
{ smul := (•),
  one_smul := λ b, by { cases b, exacts [rfl, congr_arg some (one_smul _ _)] },
  mul_smul := λ a₁ a₂ b, by { cases b, exacts [rfl, congr_arg some (mul_smul _ _ _)] } }

end option


/-
Copyright (c) 2018 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/

/-!
# Extra definitions on `option`

This file defines more operations involving `option α`. Lemmas about them are located in other
files under `data.option.`.
Other basic operations on `option` are defined in the core library.
-/

namespace option
variables {α : Type*} {β : Type*}

attribute [inline] option.is_some option.is_none

/-- An elimination principle for `option`. It is a nondependent version of `option.rec_on`. -/
@[simp] protected def elim : option α → β → (α → β) → β
| (some x) y f := f x
| none     y f := y

instance has_mem : has_mem α (option α) := ⟨λ a b, b = some a⟩

@[simp] theorem mem_def {a : α} {b : option α} : a ∈ b ↔ b = some a :=
iff.rfl

lemma mem_iff {a : α} {b : option α} : a ∈ b ↔ b = a := iff.rfl

theorem is_none_iff_eq_none {o : option α} : o.is_none = tt ↔ o = none :=
⟨option.eq_none_of_is_none, λ e, e.symm ▸ rfl⟩

theorem some_inj {a b : α} : some a = some b ↔ a = b := by simp

/--
`o = none` is decidable even if the wrapped type does not have decidable equality.

This is not an instance because it is not definitionally equal to `option.decidable_eq`.
Try to use `o.is_none` or `o.is_some` instead.
-/
@[inline]
def decidable_eq_none {o : option α} : decidable (o = none) :=
decidable_of_decidable_of_iff (bool.decidable_eq _ _) is_none_iff_eq_none

instance decidable_forall_mem {p : α → Prop} [decidable_pred p] :
  ∀ o : option α, decidable (∀ a ∈ o, p a)
| none     := is_true (by simp [false_implies_iff])
| (some a) := if h : p a
  then is_true $ λ o e, some_inj.1 e ▸ h
  else is_false $ mt (λ H, H _ rfl) h

instance decidable_exists_mem {p : α → Prop} [decidable_pred p] :
  ∀ o : option α, decidable (∃ a ∈ o, p a)
| none     := is_false (λ ⟨a, ⟨h, _⟩⟩, by cases h)
| (some a) := if h : p a
  then is_true $ ⟨_, rfl, h⟩
  else is_false $ λ ⟨_, ⟨rfl, hn⟩⟩, h hn

/-- Inhabited `get` function. Returns `a` if the input is `some a`, otherwise returns `default`. -/
@[reducible] def iget [inhabited α] : option α → α
| (some x) := x
| none     := default α

@[simp] theorem iget_some [inhabited α] {a : α} : (some a).iget = a := rfl

/-- `guard p a` returns `some a` if `p a` holds, otherwise `none`. -/
def guard (p : α → Prop) [decidable_pred p] (a : α) : option α :=
if p a then some a else none

/-- `filter p o` returns `some a` if `o` is `some a` and `p a` holds, otherwise `none`. -/
def filter (p : α → Prop) [decidable_pred p] (o : option α) : option α :=
o.bind (guard p)

/-- Cast of `option` to `list `. Returns `[a]` if the input is `some a`, and `[]` if it is
`none`. -/
def to_list : option α → list α
| none     := []
| (some a) := [a]

@[simp] theorem mem_to_list {a : α} {o : option α} : a ∈ to_list o ↔ a ∈ o :=
by cases o; simp [to_list, eq_comm]

/-- Two arguments failsafe function. Returns `f a b` if the inputs are `some a` and `some b`, and
"does nothing" otherwise. -/
def lift_or_get (f : α → α → α) : option α → option α → option α
| none     none     := none
| (some a) none     := some a       -- get a
| none     (some b) := some b       -- get b
| (some a) (some b) := some (f a b) -- lift f

instance lift_or_get_comm (f : α → α → α) [h : is_commutative α f] :
  is_commutative (option α) (lift_or_get f) :=
⟨λ a b, by cases a; cases b; simp [lift_or_get, h.comm]⟩

instance lift_or_get_assoc (f : α → α → α) [h : is_associative α f] :
  is_associative (option α) (lift_or_get f) :=
⟨λ a b c, by cases a; cases b; cases c; simp [lift_or_get, h.assoc]⟩

instance lift_or_get_idem (f : α → α → α) [h : is_idempotent α f] :
  is_idempotent (option α) (lift_or_get f) :=
⟨λ a, by cases a; simp [lift_or_get, h.idempotent]⟩

instance lift_or_get_is_left_id (f : α → α → α) :
  is_left_id (option α) (lift_or_get f) none :=
⟨λ a, by cases a; simp [lift_or_get]⟩

instance lift_or_get_is_right_id (f : α → α → α) :
  is_right_id (option α) (lift_or_get f) none :=
⟨λ a, by cases a; simp [lift_or_get]⟩

/-- Lifts a relation `α → β → Prop` to a relation `option α → option β → Prop` by just adding
`none ~ none`. -/
inductive rel (r : α → β → Prop) : option α → option β → Prop
/-- If `a ~ b`, then `some a ~ some b` -/
| some {a b} : r a b → rel (some a) (some b)
/-- `none ~ none` -/
| none       : rel none none

/-- Partial bind. If for some `x : option α`, `f : Π (a : α), a ∈ x → option β` is a
  partial function defined on `a : α` giving an `option β`, where `some a = x`,
  then `pbind x f h` is essentially the same as `bind x f`
  but is defined only when all `x = some a`, using the proof to apply `f`. -/
@[simp] def pbind : Π (x : option α), (Π (a : α), a ∈ x → option β) → option β
| none     _ := none
| (some a) f := f a rfl

/-- Partial map. If `f : Π a, p a → β` is a partial function defined on `a : α` satisfying `p`,
then `pmap f x h` is essentially the same as `map f x` but is defined only when all members of `x`
satisfy `p`, using the proof to apply `f`. -/
@[simp] def pmap {p : α → Prop} (f : Π (a : α), p a → β) :
  Π x : option α, (∀ a ∈ x, p a) → option β
| none     _ := none
| (some a) H := some (f a (H a (mem_def.mpr rfl)))

/-- Flatten an `option` of `option`, a specialization of `mjoin`. -/
@[simp] def join : option (option α) → option α :=
λ x, bind x id

protected def {u v} traverse {F : Type u → Type v} [applicative F] {α β : Type*} (f : α → F β) :
  option α → F (option β)
| none     := pure none
| (some x) := some <$> f x

/- By analogy with `monad.sequence` in `init/category/combinators.lean`. -/

/-- If you maybe have a monadic computation in a `[monad m]` which produces a term of type `α`, then
there is a naturally associated way to always perform a computation in `m` which maybe produces a
result. -/
def {u v} maybe {m : Type u → Type v} [monad m] {α : Type u} : option (m α) → m (option α)
| none      := return none
| (some fn) := some <$> fn

/-- Map a monadic function `f : α → m β` over an `o : option α`, maybe producing a result. -/
def {u v w} mmap {m : Type u → Type v} [monad m] {α : Type w} {β : Type u} (f : α → m β)
  (o : option α) : m (option β) := (o.map f).maybe

/-- A monadic analogue of `option.elim`. -/
def melim {α β : Type*} {m : Type* → Type*} [monad m] (x : m (option α)) (y : m β) (z : α → m β) :
  m β :=
x >>= λ o, option.elim o y z

/-- A monadic analogue of `option.get_or_else`. -/
def mget_or_else {α : Type*} {m : Type* → Type*} [monad m] (x : m (option α)) (y : m α) : m α :=
melim x y pure

end option


/-
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 category_theory.concrete_category.basic
import category_theory.full_subcategory
import category_theory.skeletal
import category_theory.elementwise
import data.fin.basic
import data.fintype.basic

/-!
# 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`.
-/

open_locale classical
open category_theory

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

namespace Fintype

instance : has_coe_to_sort Fintype Type* := bundled.has_coe_to_sort

/-- Construct a bundled `Fintype` from the underlying type and typeclass. -/
def of (X : Type*) [fintype X] : Fintype := bundled.of X
instance : inhabited Fintype := ⟨⟨pempty⟩⟩
instance {X : Fintype} : fintype X := X.2

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

/-- The fully faithful embedding of `Fintype` into the category of types. -/
@[derive [full, faithful], simps]
def incl : Fintype ⥤ Type* := induced_functor _

instance concrete_category_Fintype : concrete_category Fintype := ⟨incl⟩

@[simp] lemma id_apply (X : Fintype) (x : X) : (𝟙 X : X → X) x = x := rfl
@[simp] lemma comp_apply {X Y Z : Fintype} (f : X ⟶ Y) (g : Y ⟶ Z) (x : X) :
  (f ≫ g) x = g (f x) := rfl

/-- Equivalences between finite types are the same as isomorphisms in `Fintype`. -/
-- See `equiv_equiv_iso` in the root namespace for the analogue in `Type`.
@[simps]
def equiv_equiv_iso {A B : Fintype} : (A ≃ B) ≃ (A ≅ B) :=
{ to_fun := λ e,
  { hom := e,
    inv := e.symm, },
  inv_fun := λ i,
  { to_fun := i.hom,
    inv_fun := i.inv,
    left_inv := iso.hom_inv_id_apply i,
    right_inv := iso.inv_hom_id_apply i, },
  left_inv := by tidy,
  right_inv := by tidy, }

universe u
/--
The "standard" skeleton for `Fintype`. This is the full subcategory of `Fintype` spanned by objects
of the form `ulift (fin n)` for `n : ℕ`. We parameterize the objects of `Fintype.skeleton`
directly as `ulift ℕ`, as the type `ulift (fin m) ≃ ulift (fin n)` is
nonempty if and only if `n = m`. Specifying universes, `skeleton : Type u` is a small
skeletal category equivalent to `Fintype.{u}`.
-/
def skeleton : Type u := ulift ℕ

namespace skeleton

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

instance : inhabited skeleton := ⟨mk 0⟩

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

@[ext]
lemma ext (X Y : skeleton) : X.len = Y.len → X = Y := ulift.ext _ _

instance : small_category skeleton.{u} :=
{ hom := λ X Y, ulift.{u} (fin X.len) → ulift.{u} (fin Y.len),
  id := λ _, id,
  comp := λ _ _ _ f g, g ∘ f }

lemma is_skeletal : skeletal skeleton.{u} := λ X Y ⟨h⟩, ext _ _ $ fin.equiv_iff_eq.mp $
  nonempty.intro $
{ to_fun := λ x, (h.hom ⟨x⟩).down,
  inv_fun := λ x, (h.inv ⟨x⟩).down,
  left_inv := begin
    intro a,
    change ulift.down _ = _,
    rw ulift.up_down,
    change ((h.hom ≫ h.inv) _).down = _,
    simpa,
  end,
  right_inv := begin
    intro a,
    change ulift.down _ = _,
    rw ulift.up_down,
    change ((h.inv ≫ h.hom) _).down = _,
    simpa,
  end }

/-- The canonical fully faithful embedding of `Fintype.skeleton` into `Fintype`. -/
def incl : skeleton.{u} ⥤ Fintype.{u} :=
{ obj := λ X, Fintype.of (ulift (fin X.len)),
  map := λ _ _ f, f }

instance : full incl := { preimage := λ _ _ f, f }
instance : faithful incl := {}
instance : ess_surj incl :=
ess_surj.mk $ λ X, let F := fintype.equiv_fin X in ⟨mk (fintype.card X), nonempty.intro
  { hom := F.symm ∘ ulift.down,
    inv := ulift.up ∘ F }⟩

noncomputable instance : is_equivalence incl :=
equivalence.of_fully_faithfully_ess_surj _

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

@[simp] lemma incl_mk_nat_card (n : ℕ) : fintype.card (incl.obj (mk n)) = n :=
begin
  convert finset.card_fin n,
  apply fintype.of_equiv_card,
end

end skeleton

/-- `Fintype.skeleton` is a skeleton of `Fintype`. -/
noncomputable def is_skeleton : is_skeleton_of Fintype skeleton skeleton.incl :=
{ skel := skeleton.is_skeletal,
  eqv := by apply_instance }

end Fintype


/-
Copyright (c) 2018 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon, Patrick Massot
-/
import algebra.module.basic
import algebra.ring.pi

/-!
# Pi instances for module and multiplicative actions

This file defines instances for module, mul_action and related structures on Pi Types
-/

namespace pi
universes u v w
variable {I : Type u}     -- The indexing type
variable {f : I → Type v} -- The family of types already equipped with instances
variables (x y : Π i, f i) (i : I)

instance has_scalar {α : Type*} [Π i, has_scalar α $ f i] :
  has_scalar α (Π i : I, f i) :=
⟨λ s x, λ i, s • (x i)⟩

@[simp] lemma smul_apply {α : Type*} [Π i, has_scalar α $ f i] (s : α) : (s • x) i = s • x i := rfl

instance has_scalar' {g : I → Type*} [Π i, has_scalar (f i) (g i)] :
  has_scalar (Π i, f i) (Π i : I, g i) :=
⟨λ s x, λ i, (s i) • (x i)⟩

@[simp]
lemma smul_apply' {g : I → Type*} [∀ i, has_scalar (f i) (g i)] (s : Π i, f i) (x : Π i, g i) :
  (s • x) i = s i • x i :=
rfl

instance is_scalar_tower {α β : Type*}
  [has_scalar α β] [Π i, has_scalar β $ f i] [Π i, has_scalar α $ f i]
  [Π i, is_scalar_tower α β (f i)] : is_scalar_tower α β (Π i : I, f i) :=
⟨λ x y z, funext $ λ i, smul_assoc x y (z i)⟩

instance is_scalar_tower' {g : I → Type*} {α : Type*}
  [Π i, has_scalar α $ f i] [Π i, has_scalar (f i) (g i)] [Π i, has_scalar α $ g i]
  [Π i, is_scalar_tower α (f i) (g i)] : is_scalar_tower α (Π i : I, f i) (Π i : I, g i) :=
⟨λ x y z, funext $ λ i, smul_assoc x (y i) (z i)⟩

instance is_scalar_tower'' {g : I → Type*} {h : I → Type*}
  [Π i, has_scalar (f i) (g i)] [Π i, has_scalar (g i) (h i)] [Π i, has_scalar (f i) (h i)]
  [Π i, is_scalar_tower (f i) (g i) (h i)] : is_scalar_tower (Π i, f i) (Π i, g i) (Π i, h i) :=
⟨λ x y z, funext $ λ i, smul_assoc (x i) (y i) (z i)⟩

instance smul_comm_class {α β : Type*}
  [Π i, has_scalar α $ f i] [Π i, has_scalar β $ f i] [∀ i, smul_comm_class α β (f i)] :
  smul_comm_class α β (Π i : I, f i) :=
⟨λ x y z, funext $ λ i, smul_comm x y (z i)⟩

instance smul_comm_class' {g : I → Type*} {α : Type*}
  [Π i, has_scalar α $ g i] [Π i, has_scalar (f i) (g i)] [∀ i, smul_comm_class α (f i) (g i)] :
  smul_comm_class α (Π i : I, f i) (Π i : I, g i) :=
⟨λ x y z, funext $ λ i, smul_comm x (y i) (z i)⟩

instance smul_comm_class'' {g : I → Type*} {h : I → Type*}
  [Π i, has_scalar (g i) (h i)] [Π i, has_scalar (f i) (h i)]
  [∀ i, smul_comm_class (f i) (g i) (h i)] : smul_comm_class (Π i, f i) (Π i, g i) (Π i, h i) :=
⟨λ x y z, funext $ λ i, smul_comm (x i) (y i) (z i)⟩

instance mul_action (α) {m : monoid α} [Π i, mul_action α $ f i] :
  @mul_action α (Π i : I, f i) m :=
{ smul := (•),
  mul_smul := λ r s f, funext $ λ i, mul_smul _ _ _,
  one_smul := λ f, funext $ λ i, one_smul α _ }

instance mul_action' {g : I → Type*} {m : Π i, monoid (f i)} [Π i, mul_action (f i) (g i)] :
  @mul_action (Π i, f i) (Π i : I, g i) (@pi.monoid I f m) :=
{ smul := (•),
  mul_smul := λ r s f, funext $ λ i, mul_smul _ _ _,
  one_smul := λ f, funext $ λ i, one_smul _ _ }

instance distrib_mul_action (α) {m : monoid α} {n : ∀ i, add_monoid $ f i}
  [∀ i, distrib_mul_action α $ f i] :
  @distrib_mul_action α (Π i : I, f i) m (@pi.add_monoid I f n) :=
{ smul_zero := λ c, funext $ λ i, smul_zero _,
  smul_add := λ c f g, funext $ λ i, smul_add _ _ _,
  ..pi.mul_action _ }

instance distrib_mul_action' {g : I → Type*} {m : Π i, monoid (f i)} {n : Π i, add_monoid $ g i}
  [Π i, distrib_mul_action (f i) (g i)] :
  @distrib_mul_action (Π i, f i) (Π i : I, g i) (@pi.monoid I f m) (@pi.add_monoid I g n) :=
{ smul_add := by { intros, ext x, apply smul_add },
  smul_zero := by { intros, ext x, apply smul_zero } }

lemma single_smul {α} [monoid α] [Π i, add_monoid $ f i]
  [Π i, distrib_mul_action α $ f i] [decidable_eq I] (i : I) (r : α) (x : f i) :
  single i (r • x) = r • single i x :=
single_op (λ i : I, ((•) r : f i → f i)) (λ j, smul_zero _) _ _

lemma single_smul' {g : I → Type*} [Π i, monoid_with_zero (f i)] [Π i, add_monoid (g i)]
  [Π i, distrib_mul_action (f i) (g i)] [decidable_eq I] (i : I) (r : f i) (x : g i) :
  single i (r • x) = single i r • single i x :=
single_op₂ (λ i : I, ((•) : f i → g i → g i)) (λ j, smul_zero _) _ _ _

variables (I f)

instance module (α) {r : semiring α} {m : ∀ i, add_comm_monoid $ f i}
  [∀ i, module α $ f i] :
  @module α (Π i : I, f i) r (@pi.add_comm_monoid I f m) :=
{ add_smul := λ c f g, funext $ λ i, add_smul _ _ _,
  zero_smul := λ f, funext $ λ i, zero_smul α _,
  ..pi.distrib_mul_action _ }

variables {I f}

instance module' {g : I → Type*} {r : Π i, semiring (f i)} {m : Π i, add_comm_monoid (g i)}
  [Π i, module (f i) (g i)] :
  module (Π i, f i) (Π i, g i) :=
{ add_smul := by { intros, ext1, apply add_smul },
  zero_smul := by { intros, ext1, apply zero_smul } }

instance (α) {r : semiring α} {m : Π i, add_comm_monoid $ f i}
  [Π i, module α $ f i] [∀ i, no_zero_smul_divisors α $ f i] :
  no_zero_smul_divisors α (Π i : I, f i) :=
⟨λ c x h, or_iff_not_imp_left.mpr (λ hc, funext
  (λ i, (smul_eq_zero.mp (congr_fun h i)).resolve_left hc))⟩

end pi


-- Copyright (c) 2017 Scott Morrison. All rights reserved.
-- Released under Apache 2.0 license as described in the file LICENSE.
-- Authors: Tim Baumann, Stephen Morgan, Scott Morrison

import category_theory.isomorphism
import category_theory.functor_category

open category_theory

namespace category_theory.nat_iso

universes v₁ v₂ u₁ u₂ -- declare the `v`'s first; see `category_theory.category` for an explanation

variables {C : Type u₁} [𝒞 : category.{v₁} C] {D : Type u₂} [𝒟 : category.{v₂} D]
include 𝒞 𝒟

def app {F G : C ⥤ D} (α : F ≅ G) (X : C) : F.obj X ≅ G.obj X :=
{ hom := α.hom.app X,
  inv := α.inv.app X,
  hom_inv_id' := begin rw [← functor.category.comp_app, iso.hom_inv_id], refl, end,
  inv_hom_id' := begin rw [← functor.category.comp_app, iso.inv_hom_id], refl, end }

@[simp] lemma comp_app {F G H : C ⥤ D} (α : F ≅ G) (β : G ≅ H) (X : C) :
  app (α ≪≫ β) X = app α X ≪≫ app β X := rfl

@[simp] lemma app_hom {F G : C ⥤ D} (α : F ≅ G) (X : C) : (app α X).hom = α.hom.app X := rfl
@[simp] lemma app_inv {F G : C ⥤ D} (α : F ≅ G) (X : C) : (app α X).inv = α.inv.app X := rfl

variables {F G : C ⥤ D}

instance hom_app_is_iso (α : F ≅ G) (X : C) : is_iso (α.hom.app X) :=
{ inv := α.inv.app X,
  hom_inv_id' := begin rw [←functor.category.comp_app, iso.hom_inv_id, ←functor.category.id_app] end,
  inv_hom_id' := begin rw [←functor.category.comp_app, iso.inv_hom_id, ←functor.category.id_app] end }
instance inv_app_is_iso (α : F ≅ G) (X : C) : is_iso (α.inv.app X) :=
{ inv := α.hom.app X,
  hom_inv_id' := begin rw [←functor.category.comp_app, iso.inv_hom_id, ←functor.category.id_app] end,
  inv_hom_id' := begin rw [←functor.category.comp_app, iso.hom_inv_id, ←functor.category.id_app] end }

@[simp] lemma hom_vcomp_inv (α : F ≅ G) : (α.hom ⊟ α.inv) = nat_trans.id _ :=
begin
  have h : (α.hom ⊟ α.inv) = α.hom ≫ α.inv := rfl,
  rw h,
  rw iso.hom_inv_id,
  refl
end
@[simp] lemma inv_vcomp_hom (α : F ≅ G) : (α.inv ⊟ α.hom) = nat_trans.id _ :=
begin
  have h : (α.inv ⊟ α.hom) = α.inv ≫ α.hom := rfl,
  rw h,
  rw iso.inv_hom_id,
  refl
end

@[simp] lemma hom_app_inv_app_id (α : F ≅ G) (X : C) : α.hom.app X ≫ α.inv.app X = 𝟙 _ :=
begin
  rw ←nat_trans.vcomp_app,
  simp,
end
@[simp] lemma inv_app_hom_app_id (α : F ≅ G) (X : C) : α.inv.app X ≫ α.hom.app X = 𝟙 _ :=
begin
  rw ←nat_trans.vcomp_app,
  simp,
end

variables {X Y : C}
@[simp] lemma naturality_1 (α : F ≅ G) (f : X ⟶ Y) :
  (α.inv.app X) ≫ (F.map f) ≫ (α.hom.app Y) = G.map f :=
begin erw [nat_trans.naturality, ←category.assoc, is_iso.hom_inv_id, category.id_comp] end
@[simp] lemma naturality_2 (α : F ≅ G) (f : X ⟶ Y) :
  (α.hom.app X) ≫ (G.map f) ≫ (α.inv.app Y) = F.map f :=
begin erw [nat_trans.naturality, ←category.assoc, is_iso.hom_inv_id, category.id_comp] end

instance is_iso_of_is_iso_app (α : F ⟶ G) [∀ X : C, is_iso (α.app X)] : is_iso α :=
{ inv :=
  { app := λ X, inv (α.app X),
    naturality' := λ X Y f,
    by simpa using congr_arg (λ f, inv (α.app X) ≫ (f ≫ inv (α.app Y))) (α.naturality f).symm } }

def of_components (app : ∀ X : C, (F.obj X) ≅ (G.obj X))
  (naturality : ∀ {X Y : C} (f : X ⟶ Y), (F.map f) ≫ ((app Y).hom) = ((app X).hom) ≫ (G.map f)) :
  F ≅ G :=
as_iso { app := λ X, (app X).hom }

@[simp] def of_components.app (app' : ∀ X : C, (F.obj X) ≅ (G.obj X)) (naturality) (X) :
  app (of_components app' naturality) X = app' X :=
by tidy
@[simp] def of_components.hom_app (app : ∀ X : C, (F.obj X) ≅ (G.obj X)) (naturality) (X) :
  (of_components app naturality).hom.app X = (app X).hom := rfl
@[simp] def of_components.inv_app (app : ∀ X : C, (F.obj X) ≅ (G.obj X)) (naturality) (X) :
  (of_components app naturality).inv.app X = (app X).inv := rfl

end category_theory.nat_iso

namespace category_theory.functor

universes u₁ u₂ v₁ v₂

section
variables {C : Type u₁} [𝒞 : category.{v₁} C]
          {D : Type u₂} [𝒟 : category.{v₂} D]
include 𝒞 𝒟

@[simp] protected def id_comp (F : C ⥤ D) : functor.id C ⋙ F ≅ F :=
{ hom := { app := λ X, 𝟙 (F.obj X) },
  inv := { app := λ X, 𝟙 (F.obj X) } }
@[simp] protected def comp_id (F : C ⥤ D) : F ⋙ functor.id D ≅ F :=
{ hom := { app := λ X, 𝟙 (F.obj X) },
  inv := { app := λ X, 𝟙 (F.obj X) } }

universes u₃ v₃ u₄ v₄

variables {A : Type u₃} [𝒜 : category.{v₃} A]
          {B : Type u₄} [ℬ : category.{v₄} B]
include 𝒜 ℬ
variables (F : A ⥤ B) (G : B ⥤ C) (H : C ⥤ D)

@[simp] protected def assoc : (F ⋙ G) ⋙ H ≅ F ⋙ (G ⋙ H ):=
{ hom := { app := λ X, 𝟙 (H.obj (G.obj (F.obj X))) },
  inv := { app := λ X, 𝟙 (H.obj (G.obj (F.obj X))) } }

-- When it's time to define monoidal categories and 2-categories,
-- we'll need to add lemmas relating these natural isomorphisms,
-- in particular the pentagon for the associator.
end

section
variables {C : Type u₁} [𝒞 : category.{v₁} C]
include 𝒞

def ulift_down_up : ulift_down.{v₁} C ⋙ ulift_up C ≅ functor.id (ulift.{u₂} C) :=
{ hom := { app := λ X, @category_struct.id (ulift.{u₂} C) _ X },
  inv := { app := λ X, @category_struct.id (ulift.{u₂} C) _ X } }

def ulift_up_down : ulift_up.{v₁} C ⋙ ulift_down C ≅ functor.id C :=
{ hom := { app := λ X, 𝟙 X },
  inv := { app := λ X, 𝟙 X } }

end

end category_theory.functor