import ..type_system
import .syntax_directed
import .phrase_partial_order
import ..phrase
import ..expr

namespace flow_analysis

/- Lemma 6.3 (Simple Security)
 - If (Λ, γ) ⊢ e : base τ, then for every x in e, γ(x) ≤ τ
 -/
open program_typing_eq
lemma simple_security {Λ : location} {γ : identifier}
    {e : base_expr} {τ : security_class} :
  (Λ, γ) ⊢ₑ e : phrase.base τ → ∀x, x ∈ base_expr.fl e → map.lookup x Λ ≤ τ
:= begin
  intros h x h_dom,
  have h_sd := program_typing_eq.expr.1 h, clear h,
  rename h_sd h,
  simp at h,

  induction e,
  repeat { simp[base_expr.fl] at h_dom, },
  repeat { cc, },
  rw h_dom,
  cases h, rename h_τ a, rename h_a he, rename h_a_1 haτ,
  cases he,
  case base_expr.bin_op : e b e' ihe ihe' {
    cases h, rename h_a he, rename h_a_1 he',
    cases h_dom,
    exact ihe h_dom he,
    exact ihe' h_dom he',
    rename h_a h_var,
    cases h_var,
  },
end

lemma confinement.generalizing {Λ : location} {γ : identifier}
      {l : location} {c : program} {τ : security_class} :
    (Λ, γ) ⊢ₜ c : phrase.cmd τ
  → ∀x, program.assigned_to_in x c → map.lookup x Λ ≥ τ
:= begin
  simp only[prod.fst, prod.snd],
  intros ht x hx,
  have h := program_typing_eq.1 ht, simp at h, clear ht,
  apply ge_iff_le.2,

  induction hx generalizing γ,
  case program.assigned_to_in.update : v e {
    cases h,
    cases h_a,
  },
  case program.assigned_to_in.seq_left : v c c' hv ih {
    cases h,
    apply ih,
    assumption,
  },
  case program.assigned_to_in.seq_right : v c c' hv ih {
    cases h,
    apply ih,
    assumption,
  },
  case program.assigned_to_in.branch_true : v e c c' hv ih {
    cases h,
    apply ih (syntax_directed_subtyping (
      and.intro h_a_1 (
        phrase.ss.cmd (
          phrase.ss.base h_a_3)))),
  },
  case program.assigned_to_in.branch_false : v e c c' hv ih {
    cases h,
    apply ih (syntax_directed_subtyping (
      and.intro h_a_2 (
        phrase.ss.cmd (
          phrase.ss.base h_a_3)))),
  },
  case program.assigned_to_in.loop : v e c hv ih {
    cases h,
    apply ih (syntax_directed_subtyping (
      and.intro h_a_1 (
        phrase.ss.cmd (
          phrase.ss.base h_a_2)))),
  },
  case program.assigned_to_in.bind_var : v x e c h_neq hv ih {
    cases h,
    apply ih,
    assumption,
  },
end

lemma confinement.type_to_syntax {Λ : location} {c : program}
    {τ : security_class} :
  (∃x, (Λ, x) ⊢ₜ c : phrase.cmd τ) → (∃x, (Λ, x) ⊢ₛ c : phrase.cmd τ)
:= begin
  intro ht,
  cases ht with x hx,
  apply exists.intro x,
  have h := program_typing_eq.1 hx,
  assumption,
end

lemma confinement.exists_variant {Λ : location}
      {c : program} {τ : security_class} :
    (∃x, (Λ, x) ⊢ₜ c : phrase.cmd τ)
  → ∀x, program.assigned_to_in x c → map.lookup x Λ ≥ τ
:= begin
  simp only[prod.fst, prod.snd],
  intros ht x hx,
  have h := confinement.type_to_syntax ht, simp at h, clear ht,
  apply ge_iff_le.2,

  induction hx,
  case program.assigned_to_in.update : v e {
    cases h with γ h,
    cases h, rename h_a ih,
    cases ih,
  },
  case program.assigned_to_in.seq_left : v c c' hv ih {
    cases h with γ h,
    cases h,
    apply ih,
    apply exists.intro γ,
    assumption,
  },
  case program.assigned_to_in.seq_right : v c c' hv ih {
    cases h with γ h,
    cases h,
    apply ih,
    apply exists.intro γ,
    assumption,
  },
  case program.assigned_to_in.branch_true : v e c c' hv ih {
    cases h with γ h,
    cases h, rename h_τ τ', rename h_a_1 hc, rename h_a_3 hττ',
    apply ih,
    apply exists.intro γ,
    exact syntax_directed_subtyping (
      and.intro hc (
        phrase.ss.cmd (
          phrase.ss.base hττ'))),
  },
  case program.assigned_to_in.branch_false : v e c c' hv ih {
    cases h with γ h,
    cases h, rename h_τ τ', rename h_a_2 hc', rename h_a_3 hττ',
    apply ih,
    apply exists.intro γ,
    exact syntax_directed_subtyping (
      and.intro hc' (
        phrase.ss.cmd (
          phrase.ss.base hττ'))),
  },
  case program.assigned_to_in.loop : v e c hv ih {
    cases h with γ h,
    cases h, rename h_τ τ', rename h_a_1 hc, rename h_a_2 hττ',
    apply ih,
    apply exists.intro γ,
    exact syntax_directed_subtyping (
      and.intro hc (
        phrase.ss.cmd (
          phrase.ss.base hττ'))),
  },
  case program.assigned_to_in.bind_var : v x e c h_neq hv ih {
    cases h with γ h,
    cases h, rename h_τ τ', rename h_a_1 hc,
    apply ih,
    apply exists.intro (γ[ₗ x : phrase.var τ']), -- main point
    assumption,
  },
end

/- Lemma 6.4 (Confinement)
 - If (Λ, γ) ⊢ c : cmd τ, then for every x assigned to in c, γ(x) ≥ τ
 -/
lemma confinement {Λ : location} {γ : identifier}
      {l : location} {c : program} {τ : security_class} :
    (Λ, γ) ⊢ₜ c : phrase.cmd τ
  → ∀x, program.assigned_to_in x c → map.lookup x Λ ≥ τ
:= begin
  intros h x hx,
  apply confinement.exists_variant,
  apply exists.intro γ,
  repeat { assumption },
end

/- Lemma 6.5 (Substitution)
 - If (Λ, γ) ⊢ l : τ var and (Λ, γ[x  : τ var]) ⊢ c : τ' cmd,
 - then (Λ, γ) ⊢ [l/x]c : τ' cmd.
 -/
lemma substitution {Λ : location} {γ : identifier}
    {c : program} {l x : vname} {τ τ': security_class} :
  ((Λ, γ) ⊢ₑ base_expr.loc l : phrase.var τ)
∧ ((Λ, γ[ᵢx  : phrase.var τ]) ⊢ₜ c : phrase.cmd τ')
→ ((Λ, γ) ⊢ₜ program.substitution l x c : phrase.cmd τ')
:= begin
  sorry,
end

/- Lemma 6.6
 - If μ ⊢ c ⟹ μ', then dom(μ) = dom(μ')
 -/
lemma dom_equality {μ μ': state} {c : program} :
  (c, μ) ⟹ μ' → map.dom μ = map.dom μ'
:= begin
  sorry,
end

/- Lemma 6.7
 - If μ ⊢ c ⟹ μ', l ∈ dom(μ), and l is not assigned to in c, then μ(l) = μ'(l)
 -/
lemma eq_if_not_used {μ μ': state} {c : program} {l : vname} :
    (c, μ) ⟹ μ' ∧ l ∈ map.dom μ ∧ program.not_assigned_to_in l c
  → map.lookup l μ = map.lookup l μ'
:= begin
  sorry,
end

/- Theorem 6.8 (Type Soundness), Suppose
 - λ ⊢ c : ρ,
 - μ ⊢ c ⟹ μ',
 - ν ⊢ c ⟹ ν',
 - dom(μ) = dom(ν) = dom(λ), and
 - ν(l) = μ(l) for all l such that λ(l) ≤ τ
 - Then ν'(l) = μ'(l) for all l such that λ(l) ≤ τ
 -/

end flow_analysis


set_option trace.Meta.debug true

example (hv : v < n) (ih: ∀ v : Fin n, ∃ v', v' ≤ v):
  True := by
  have ⟨w, hw⟩ := ih ⟨v, ‹_›⟩
  trivial


#check (λ (A : Type) (x : A), x : Π {A : Type}, A → A)
#check (λ {A : Type} (x : A), x : Π (A : Type), A → A)
#check expr
#exit

axiom A : Type
axiom B : Type 1
axioms x y : A

#check A → B
#check B → A
#check (B → (A : Type))
#check (B → A : Type 1)
#check (λ x, x : A → A)
#check (λ x, x : A → A)

#check λ x y x
#exit

-- Parse:
#check λ y : A, (λ x y : A, x) y
-- Eval:
#check λ y : A, (λ x y : A, x) y
#check λ y : A, (λ y : A, y)
-- Beaufity:
#check λ y : A, (λ y_1 : A, y)
-- Print:
#reduce λ y : A, (λ x y : A, x) y
#check λ y y_1 : A, y
example : (λ y : A, (λ x y : A, x) y) = (λ y y_1 : A, y) := rfl

-- Parse:
#check λ y : A, (λ x y : A, y) y -- Note, the body of the inner lambda is `y`.
-- Eval:
#check λ y : A, (λ x y : A, y) y
#check λ y : A, (λ y : A, y)
-- Beaufity:
#check λ y : A, (λ y : A, y)
-- Print:
#check λ y y : A, y
#reduce λ y : A, (λ x y : A, y) y
example : (λ y y : A, y) = (λ y : A, (λ x y : A, y) y) := rfl

-- Parse:
#check (λ x y : A, x) y
-- Eval:
#check (λ y : A, y)
-- Beaufity:
#check (λ y_1 : A, y)
-- Print:
#check λ y_1 : A, y
#reduce (λ x y : A, x) y
example : (λ y_1 : A, y) = ((λ x y : A, x) y) := rfl

-- Parse:
#check λ (y : A → B), (λ (f : A → B) (y : A), (λ (x y : A), f x) y) y
-- Eval:
#check λ (y : A → B), (λ (f : A → B) (y : A), (λ (x y : A), f x) y) y
#check λ (y : A → B), (λ (f : A → B) (y : A), (λ (y : A), f y)) y
-- Beautify:
#check λ (y : A → B), (λ (y_1 : A), (λ (y_2 : A), y y_1))
-- Print:
#check λ (y : A → B) (y_1 y_2 : A), y y_1
#reduce λ (y : A → B), (λ (f : A → B) (y : A), (λ (x y : A), f x) y) y
example : (λ (y : A → B) (y_1 y_2 : A), y y_1) = (λ (y : A → B), (λ (f : A → B) (y : A), (λ (x y : A), f x) y) y) := rfl

-- Parse:
#check λ (y : A → B), (λ (f : A → B) (y y : A), f y) y
-- Eval:
#check λ (y : A → B), (λ (f : A → B) (y y : A), f y) y
-- Beautify:
#check λ (y : A → B), (λ (y_1 y_1 : A), y y_1)
-- Print:
#check λ (y : A → B) (y_1 y_1 : A), y y_1
#reduce λ (y : A → B), (λ (f : A → B) (y y : A), f y) y
example : (λ (y : A → B) (y_1 y_1 : A), y y_1) = (λ (y : A → B), (λ (f : A → B) (y y : A), f y) y) := rfl

-- Variable shadowing
#reduce λ y : A, (λ x y : A, x) y
#reduce λ y : A, (λ x y y_1 : A, x) y
#reduce λ y : A, (λ (x y : A) (y_1 : A → A), y_1 x) y
#reduce λ y : A, (λ (x : A) (y_1 y : A → A), y_1 x) y
#reduce λ y : A, (λ (x : A) (y_1 : A → A) (y : A) , y_1 x) y
#reduce λ y : A, (λ (x : A) (y_1 y : A → A) (y : A) , y_1 x) y
-- Normalization
axiom F : A → A → Type
#check λ (x : A) (y : (λ A : Type, A) A), x
#check Π (x : A) (y : (λ A : Type, A) A), A
#check Π (x : A) (y : (λ A : Type, A) A), F x y
#check Π (A : Type) (B : (λ A : Type 1, A) Type), A × B
#reduce λ (x : A) (y : (λ A : Type, A) A), x
#reduce Π (x : A) (y : (λ A : Type, A) A), A
#reduce Π (x : A) (y : (λ A : Type, A) A), F x y
#reduce Π (A : Type) (B : (λ A : Type 1, A) Type), A × B
-- Long lines
axioms B C D E : Type
#check λ(a:A)(b:B),a
#check λ(a1 a2 a3 a4:A)(b1 b2 b3 b4:B),a1
#check λ(a1 a2 a3 a4:A)(b1 b2 b3 b4:B)(c1 c2 c3 c4:C),a1
#check λ(a1 a2 a3 a4:A)(b1 b2 b3 b4:B)(c1 c2 c3 c4:C)(d1 d2 d3 d4:D),a1
#check λ(a1 a2 a3 a4:A)(b1 b2 b3 b4:B)(c1 c2 c3 c4:C)(d1 d2 d3 d4:D)(e1 e2 e3 e4:E),a1
axiom F1 : A → B → Type
#check Π(a:A)(b:B),F1 a b
axiom F2 (a1 a2 a3 a4:A)(b1 b2 b3 b4:B):Type
#check Π(a1 a2 a3 a4:A)(b1 b2 b3 b4:B),F2 a1 a2 a3 a4 b1 b2 b3 b4
/-
#check Π(a1 a2 a3 a4:A)(b1 b2 b3 b4:B)(c1 c2 c3 c4:C),a1
#check Π(a1 a2 a3 a4:A)(b1 b2 b3 b4:B)(c1 c2 c3 c4:C)(d1 d2 d3 d4:D),a1
#check f a
#check f a1 a2 a3 a4 a5
#check f a1 a2 a3 a4 a5 a6 a7 a8 a9 a10
#check f a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15
#check f a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20
#check f a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20 a21 a22 a23 a24 a25
#check f (g a1 a2 a3 a4 a5)
#check f (g a1 a2 a3 a4 a5) (g a1 a2 a3 a4 a5)
#check f (g a1 a2 a3 a4 a5) (g a1 a2 a3 a4 a5) (g a1 a2 a3 a4 a5)
#check f (g a1 a2 a3 a4 a5) (g a1 a2 a3 a4 a5) (g a1 a2 a3 a4 a5) (g a1 a2 a3 a4 a5)
#check f (g a1 a2 a3 a4 a5) (g a1 a2 a3 a4 a5) (g a1 a2 a3 a4 a5) (g a1 a2 a3 a4 a5) (g a1 a2 a3 a4 a5)
#check A -> B
#check (A -> B) -> B
#check (A -> B) -> (A -> B)
#check A1 -> A2 -> A3 -> A4 -> A5 -> B
#check A1 -> A2 -> A3 -> A4 -> A5 -> A6 -> A7 -> A8 -> A9 -> A10 -> B
#check A1 -> A2 -> A3 -> A4 -> A5 -> A6 -> A7 -> A8 -> A9 -> A10 -> A11 -> A12 -> A13 -> A14 -> A15 -> B
#check A1 -> A2 -> A3 -> A4 -> A5 -> A6 -> A7 -> A8 -> A9 -> A10 -> A11 -> A12 -> A13 -> A14 -> A15 -> A16 -> A17 -> A18 -> A19 -> A20 -> B
#check A1 -> A2 -> A3 -> A4 -> A5 -> A6 -> A7 -> A8 -> A9 -> A10 -> A11 -> A12 -> A13 -> A14 -> A15 -> A16 -> A17 -> A18 -> A19 -> A20 -> A21 -> A22 -> A23 -> A24 -> A25 -> B
#check (A1 -> A2 -> A3 -> A4 -> A5) -> B
#check (A1 -> A2 -> A3 -> A4 -> A5) -> (A1 -> A2 -> A3 -> A4 -> A5) -> B
#check (A1 -> A2 -> A3 -> A4 -> A5) -> (A1 -> A2 -> A3 -> A4 -> A5) -> (A1 -> A2 -> A3 -> A4 -> A5) -> B
#check (A1 -> A2 -> A3 -> A4 -> A5) -> (A1 -> A2 -> A3 -> A4 -> A5) -> (A1 -> A2 -> A3 -> A4 -> A5) -> (A1 -> A2 -> A3 -> A4 -> A5) -> B
#check (A1 -> A2 -> A3 -> A4 -> A5) -> (A1 -> A2 -> A3 -> A4 -> A5) -> (A1 -> A2 -> A3 -> A4 -> A5) -> (A1 -> A2 -> A3 -> A4 -> A5) -> (A1 -> A2 -> A3 -> A4 -> A5) -> B

-/
#exit
import data.W.basic

-- The following is based on the book Homotopy Type Theory: Univalent
-- Foundations of Mathematics.

universes u v w

section

parameters {α : Type u} (r : α → α → Prop) (a : α)

-- Definition 10.3.1. Accessibility.
inductive acc' : α → Type u
| intro (x : α) (h : Π y, r y x → acc' y) : acc' x

-- Lemma 10.3.2. Accessibility is a mere property.
instance : subsingleton (acc' a) :=
begin
  refine ⟨λ s₁ s₂, _⟩,
  induction s₁ with _ _ ih,
  induction s₂ with _ h _,
  congr,
  ext a ha,
  exact ih a ha (h a ha)
end

-- Definition 10.3.3. Well-foundedness.
inductive wf : Type u
| intro (apply : Π a, acc' a) : wf

def wf.apply : wf → Π a, acc' a
| (wf.intro h) := h

-- Lemma 10.3.4. Well-foundedness is a mere property.
instance : subsingleton wf :=
⟨λ s₁ s₂, by { cases s₁, cases s₂, congr }⟩

-- Example 10.3.5. The usual strict ordering on `ℕ` is well-founded.
example {p : ℕ → Type u} (h : ∀ n, (∀ m, m < n → p m) → p n) : ∀ n, p n :=
begin
  suffices h : ∀ n m, m < n → p m,
  { exact λ n, h n.succ n (nat.lt_succ_self n) },
  intro n,
  induction n with n ih,
  { intros m h', exfalso, cases h' },
  { intros m h',
    apply or.by_cases (decidable.lt_or_eq_of_le (nat.le_of_lt_succ h')),
    { exact ih m },
    { rintro rfl, exact h m ih } }
end

section

parameters {β : α → Type v}

def W : Type (max u v) := W_type β

def lt : W → W → Prop
| w ⟨a, f⟩ := ∃ b, w = f b

-- Example 10.3.6. A well-founded relation on W-types.
example : well_founded lt :=
begin
  refine ⟨λ w, _⟩,
  induction w with a f ih,
  refine ⟨⟨a, f⟩, λ w h, _⟩,
  rcases h with ⟨b, rfl⟩,
  exact ih b
end

end

parameters {β : Type u} (g : set β → β) (h : wf)

def f_aux : Π a, acc' a → β :=
@acc'.rec (λ a ha, β) (λ a f ih, g (λ b, ∃ a' h, b = ih a' h))

def f (a : α) : β := f_aux a (wf.apply h a)

-- Lemma 10.3.7. Suppose we have a function `g : set β → β`, then there a
-- function `f : α → β` such that for all `a : α` we have
-- `f a = g {f a′ | a′ < a}`.
example : f a = g (λ b, ∃ a', r a' a ∧ b = f a') :=
begin
  simp only [f, f_aux],
  cases wf.apply h a with a ha,
  simp only,
  congr,
  ext b,
  rw ←f_aux,
  split; rintro ⟨a', h', rfl⟩; exact ⟨a', h', by congr⟩
end

-- Lemma 10.3.8. Assuming excluded middle, `<` is well-founded if and only if
-- every nonempty set `s : set α` merely has a minimal element.
example (h : wf) (s : set α) (hs : set.nonempty s) :
  ∃ a ∈ s, ∀ a' ∈ s, ¬ r a' a :=
begin
  cases hs with a ha,
  by_contra h',
  push_neg at h',
  suffices : ∀ a, acc' a → a ∉ s,
  { exact this a (wf.apply h a) ha },
  clear ha a,
  intros a ha,
  induction ha with a' f ih, clear a, rename a' a,
  dsimp only at ih,
  intro ha,
  specialize h' a ha,
  rcases h' with ⟨a', h₁, h₂⟩,
  exact ih a' h₂ h₁
end

noncomputable def strong_not_not {α : Type u} : ((α → false) → false) → α :=
begin
  classical,
  intro h,
  by_cases h' : nonempty α,
  { exact classical.choice h' },
  { exact false.elim (h (λ a, h' ⟨a⟩)) }
end

noncomputable example (h : ∀ s : set α, set.nonempty s → ∃ a ∈ s, ∀ a' ∈ s, ¬ r a' a) :
  wf :=
begin
  let s : set α := {a | acc' a → false},
  by_cases hs : set.nonempty s,
  { specialize h s hs,
    simp only [exists_prop] at h,
    let a := classical.some h,
    obtain ⟨ha₁, ha₂⟩ : a ∈ s ∧ ∀ a', a' ∈ s → ¬ r a' a := classical.some_spec h,
    change acc' a → false at ha₁,
    change ∀ a', (acc' a' → false) → ¬ r a' a at ha₂,
    replace ha₂ : Π a', r a' a → acc' a' := λ a' ha', strong_not_not (λ h, ha₂ a' h ha'),
    exact false.elim (ha₁ ⟨a, ha₂⟩) },
  { refine ⟨λ a, _⟩,
    simp [s, set.nonempty] at hs,
    exact classical.some (hs a) }
end

-- Definition 10.3.9. Extensional well-founded relation.
def ext (rα : α → α → Prop) : Prop :=
∀ ⦃a₁ a₂⦄, (∀ a, rα a a₁ ↔ rα a a₂) → a₁ = a₂

-- Theorem 10.3.10. The type of extensional well-founded relations is a set.
example (h₁ : ext r) (h₂ : wf) {f f' : α → α} :
  (∀ a₁ a₂, r a₁ a₂ ↔ r (f a₁) (f a₂)) → function.right_inverse f' f → f = id :=
begin
  intros hf₁ hf₂,
  ext a,
  change f a = a,
  have ha := wf.apply h₂ a, clear h₂,
  induction ha with a' f' ih, clear a, rename a' a,
  dsimp only at ih, clear f',
  apply h₁, clear h₁,
  intro a',
  refine ⟨λ ha', _, λ ha', _⟩,
  { suffices : r (f' a') a,
    { specialize ih (f' a') this,
      specialize hf₁ (f' a') a,
      rwa [←hf₂ a', ih, hf₁, hf₂ a'] },
    specialize hf₁ (f' a') a,
    specialize hf₂ a',
    rwa [hf₁, hf₂] },
  { specialize hf₁ a' a,
    rw ih a' ha' at hf₁,
    rwa ←hf₁ }
end

end

section

parameters {α : Type u} {rα : α → α → Prop}
parameters {β : Type v} {rβ : β → β → Prop}
parameters {f g : α → β}

-- Definition 10.3.11. Simulation.
def simulation (rα : α → α → Prop) (rβ : β → β → Prop) (f : α → β) : Prop :=
(∀ a₁ a₂, rα a₁ a₂ → rβ (f a₁) (f a₂)) ∧
 ∀ a b, rβ b (f a) → ∃ a', rα a' a ∧ b = f a'

-- Lemma 10.3.12. Any simulation is injective.
theorem simulation.injective (h₁ : ext rα) (h₂ : well_founded rα) :
  simulation rα rβ f → function.injective f :=
begin
  intro hf,
  refine λ x, h₂.induction x (λ a ih₁, _),
  refine λ x, h₂.induction x (λ b ih₂, _),
  refine λ h, h₁ (λ c, _), clear h₁ h₂,
  cases hf with hf₁ hf₂,
  split; intro hc,
  { rcases hf₂ b (f c) (h ▸ hf₁ c a hc) with ⟨c', _, hc'⟩,
    rwa ih₁ c hc hc' },
  { rcases hf₂ a (f c) (h.symm ▸ hf₁ c b hc) with ⟨c', hc, hc'⟩,
    rwa ←ih₁ c' hc hc'.symm }
end

def is_initial_seg (C : set β) :=
∀ c b, c ∈ C → rβ b c → b ∈ C

example (hf : simulation rα rβ f) : is_initial_seg (set.range f) :=
begin
  unfold set.range,
  intros c b hc hb,
  change ∃ a, f a = c at hc,
  rcases hc with ⟨a, rfl⟩,
  change ∃ a, f a = b,
  cases hf with hf' hf, clear hf',
  specialize hf a b hb, clear hb rβ,
  rcases hf with ⟨a', ha', rfl⟩, clear ha' rα a, rename a' a,
  exact ⟨a, rfl⟩
end

end

variables {α : Type u} {rα : α → α → Prop}
variables {β : Type v} {rβ : β → β → Prop}
variables {γ : Type w} {rγ : γ → γ → Prop}

-- Theorem 10.3.14. For a set `α`, let `p α` be the type of extensional
-- well-founded relations on `α`. If `rα : p α` and `rβ : p β` and `f : α → β`,
-- let `h rα rβ f` be the mere proposition that `f` is a simulation. Then
-- `⟨p, h⟩` is a standard notion of structure over Set in the sense of §9.8.
example {rα₁ : α → α → Prop} {rα₂ : α → α → Prop} :
  simulation rα₁ rα₂ id → simulation rα₂ rα₁ id → rα₁ = rα₂ :=
begin
  rintros ⟨h₁, h⟩ ⟨h₂, h⟩, clear h h,
  ext a₁ a₂,
  exact ⟨h₁ a₁ a₂, h₂ a₁ a₂⟩
end

-- Corollary 10.3.15. There is a category whose objects are sets equipped with
-- extensional well-founded relations, and whose morphisms are simulations.
theorem simulation.id : simulation rα rα id :=
begin
  split,
  { exact λ a₁ a₂ h, h },
  { exact λ a₁ a₂ h, ⟨a₂, h, rfl⟩ }
end

theorem simulation.comp {g : β → γ} {f : α → β} :
  simulation rβ rγ g → simulation rα rβ f → simulation rα rγ (g ∘ f) :=
begin
  rintros ⟨hg₁, hg₂⟩ ⟨hf₁, hf₂⟩,
  split,
  { clear hf₂ hg₂, rename hf₁ hf, rename hg₁ hg,
    intros a₁ a₂ h,
    replace h := hf a₁ a₂ h, clear hf,
    replace h := hg (f a₁) (f a₂) h, clear hg,
    exact h },
  { clear hf₁ hg₁, rename hf₂ hf, rename hg₂ hg,
    intros a c h,
    replace h := hg (f a) c h, clear hg,
    rcases h with ⟨b, h, rfl⟩,
    replace h := hf a b h, clear hf,
    rcases h with ⟨a', h, rfl⟩,
    exact ⟨a', h, rfl⟩ }
end

-- Lemma 10.3.16. There is at most one simulation `f : α → β`.
theorem simulation.unique {f₁ f₂ : α → β} (hα : well_founded rα) (hβ : ext rβ) :
  simulation rα rβ f₁ → simulation rα rβ f₂ → f₁ = f₂ :=
begin
  intros hf₁ hf₂,
  ext x,
  refine hα.induction x (λ a ih, _), clear hα x,
  change ∀ a', rα a' a → f₁ a' = f₂ a' at ih,
  refine hβ (λ b, _), clear hβ,
  cases hf₁ with hf₁₁ hf₁₂,
  cases hf₂ with hf₂₁ hf₂₂,
  split; intro h,
  { clear hf₁₁ hf₂₂, rename hf₁₂ hf₁, rename hf₂₁ hf₂,
    specialize hf₁ a b h, clear h,
    rcases hf₁ with ⟨a', ha', rfl⟩,
    specialize hf₂ a' a ha',
    specialize ih a' ha', clear ha' rα,
    rwa ih },
  { clear hf₁₂ hf₂₁, rename hf₁₁ hf₁, rename hf₂₂ hf₂,
    specialize hf₂ a b h, clear h,
    rcases hf₂ with ⟨a', ha', rfl⟩,
    specialize hf₁ a' a ha',
    specialize ih a' ha', clear ha' rα,
    rwa ←ih }
end

theorem simulation.left_inverse {f : α → β} {g : β → α}
  (hα₁ : ext rα) (hα₂ : well_founded rα) :
  simulation rβ rα g → simulation rα rβ f → function.left_inverse g f :=
begin
  intros hg hf a,
  change g (f a) = id a,
  rw ←simulation.unique hα₂ hα₁ (hg.comp hf) simulation.id
end

def well_order (rα : α → α → Prop) :=
ext rα ∧ well_founded rα ∧ transitive rα

def well_order.ext : well_order rα → ext rα
| ⟨hα₁, hα₂, hα₃⟩ := hα₁

def well_order.wf : well_order rα → well_founded rα
| ⟨hα₁, hα₂, hα₃⟩ := hα₂

def well_order.trans : well_order rα → transitive rα
| ⟨hα₁, hα₂, hα₃⟩ := hα₃

inductive ordinal' : Type (u+1)
| mk {α : Type u} {rα : α → α → Prop} : well_order rα → ordinal'

namespace ordinal'

def r : ordinal'.{u} → ordinal'.{u} → Prop
| (@ordinal'.mk α rα hα) (@ordinal'.mk β rβ hβ) :=
  (∃ f, simulation rα rβ f) ∧ ∃ g, simulation rβ rα g

theorem r.reflexive : reflexive r :=
begin
  rintro ⟨α, rα, hα⟩,
  refine ⟨⟨id, simulation.id⟩, ⟨id, simulation.id⟩⟩,
end

theorem r.symmetric : symmetric r :=
begin
  rintros ⟨α, rα, hα⟩ ⟨β, rβ, hβ⟩ ⟨hf, hg⟩,
  exact ⟨hg, hf⟩
end

theorem r.trans : transitive r :=
begin
  rintros ⟨α, rα, hα⟩ ⟨β, rβ, hβ⟩ ⟨γ, rγ, hγ⟩ ⟨⟨f₁, hf₁⟩, ⟨g₁, hg₁⟩⟩ ⟨⟨f₂, hf₂⟩, ⟨g₂, hg₂⟩⟩,
  exact ⟨⟨f₂ ∘ f₁, hf₂.comp hf₁⟩, ⟨g₁ ∘ g₂, hg₁.comp hg₂⟩⟩
end

theorem r.equivalence : equivalence r :=
⟨r.reflexive, r.symmetric, r.trans⟩

instance setoid : setoid ordinal' :=
{ r := r, iseqv := r.equivalence }

end ordinal'

def ordinal : Type (u+1) := quotient ordinal'.setoid.{u}

namespace ordinal

def mk (hα : well_order rα) : ordinal := quotient.mk ⟨hα⟩

namespace ω

def r : ulift.{u} ℕ → ulift.{u} ℕ → Prop
| ⟨n⟩ ⟨m⟩ := n < m

theorem r.ext : ext r :=
begin
  rintros ⟨n₁⟩ ⟨n₂⟩ h,
  replace h : ∀ m, m < n₁ ↔ m < n₂ := λ m, h ⟨m⟩,
  congr,
  by_contra h',
  cases ne.lt_or_lt h' with h' h',
  { rw ←h at h', exact nat.lt_asymm h' h' },
  { rw h at h', exact nat.lt_asymm h' h' }
end

theorem r.wf : well_founded r :=
begin
  suffices h : ∀ n m, r m n → acc r m,
  { exact ⟨λ ⟨n⟩, h ⟨n + 1⟩ ⟨n⟩ (nat.lt_succ_self n)⟩ },
  rintro ⟨n⟩,
  induction n with n ih,
  { rintros ⟨m⟩ h', exfalso, cases h' },
  { rintros ⟨m⟩ h',
    cases decidable.lt_or_eq_of_le (nat.le_of_lt_succ h'),
    { exact ih ⟨m⟩ h },
    { subst h, exact ⟨⟨m⟩, λ n h, ih n h⟩ } }
end

theorem r.trans : transitive r :=
λ ⟨n₁⟩ ⟨n₂⟩ ⟨n₃⟩ h₁ h₂, lt_trans h₁ h₂

theorem r.well_order : well_order r :=
⟨r.ext, r.wf, r.trans⟩

end ω

-- Example 10.3.18. The least transfinite ordinal `ω`.
def ω : ordinal.{u} :=
ordinal.mk ω.r.well_order

namespace initial_seg

def carrier (rα : α → α → Prop) (a : α) : Type u :=
{b // rα b a}

def r (rα : α → α → Prop) (a : α) (b₁ b₂ : carrier rα a) : Prop :=
rα b₁.val b₂.val

theorem r.ext (hα₁ : ext rα) (hα₂ : transitive rα) (a : α) : ext (r rα a) :=
begin
  rintros ⟨b₁, hb₁⟩ ⟨b₂, hb₂⟩ h,
  congr,
  refine hα₁ (λ b, ⟨λ hb, _, λ hb, _⟩),
  { specialize hα₂ hb hb₁,
    specialize h ⟨b, hα₂⟩,
    unfold r at h,
    rwa ←h },
  { specialize hα₂ hb hb₂,
    specialize h ⟨b, hα₂⟩,
    unfold r at h,
    rwa h }
end

theorem r.wf (hα : well_founded rα) (a : α) : well_founded (r rα a) :=
begin
  refine ⟨_⟩,
  rintro ⟨b, hb⟩,
  suffices h : ∀ hb, acc (r rα a) ⟨b, hb⟩,
  { exact h hb },
  refine hα.induction b _, clear hb b,
  intros b ih hb,
  refine ⟨⟨b, hb⟩, _⟩,
  rintro ⟨b', hb'⟩ h,
  exact ih b' h hb'
end

theorem r.trans (hα : transitive rα) (a : α) : transitive (r rα a) :=
begin
  rintros ⟨b₁, hb₁⟩ ⟨b₂, hb₂⟩ ⟨b₃, hb₃⟩ h₁ h₂,
  exact hα h₁ h₂
end

theorem r.well_order (hα : well_order rα) (a : α) : well_order (r rα a) :=
begin
  rcases hα with ⟨hα₁, hα₂, hα₃⟩,
  exact ⟨r.ext hα₁ hα₃ a, r.wf hα₂ a, r.trans hα₃ a⟩
end

end initial_seg

def initial_seg (hα : well_order rα) (a : α) : ordinal :=
mk (initial_seg.r.well_order hα a)

namespace initial_seg

theorem injective {hα : well_order rα} :
  function.injective (initial_seg hα) :=
begin
  intros a₁ a₂ h,
  refine hα.ext (λ b, _),
  let i₁ : carrier rα a₁ → α := subtype.val,
  let i₂ : carrier rα a₂ → α := subtype.val,
  suffices h : b ∈ set.range i₁ ↔ b ∈ set.range i₂,
  { split; intro hb,
    { replace hb : b ∈ set.range i₂,
      { rw ←h, exact ⟨⟨b, hb⟩, rfl⟩ },
      rcases hb with ⟨⟨b, hb⟩, rfl⟩,
      exact hb },
    { replace hb : b ∈ set.range i₁,
      { rw h, exact ⟨⟨b, hb⟩, rfl⟩ },
      rcases hb with ⟨⟨b, hb⟩, rfl⟩,
      exact hb } },
  unfold initial_seg mk at h,
  rw quotient.eq at h,
  rcases h with ⟨⟨f, hf⟩, ⟨g, hg⟩⟩,
  have h : function.right_inverse g f,
  { exact simulation.left_inverse (r.ext hα.ext hα.trans a₂) (r.wf hα.wf a₂) hf hg },
  rw ←h.surjective.range_comp i₂, clear h,
  have hi₁ : simulation (r rα a₁) rα i₁,
  { refine ⟨λ b₁ b₂ h, h, λ ⟨b₁, hb₁⟩ b₂ hb₂, ⟨⟨b₂, hα.trans hb₂ hb₁⟩, hb₂, rfl⟩⟩ },
  have hi₂ : simulation (r rα a₂) rα i₂,
  { refine ⟨λ b₁ b₂ h, h, λ ⟨b₁, hb₁⟩ b₂ hb₂, ⟨⟨b₂, hα.trans hb₂ hb₁⟩, hb₂, rfl⟩⟩ },
  rw simulation.unique (r.wf hα.wf a₁) hα.ext hi₁ (hi₂.comp hf)
end

end initial_seg

def lt' (α : ordinal) : ordinal' → Prop
| (@ordinal'.mk β rβ hβ) := ∃ b, α = initial_seg hβ b

-- Definition 10.3.19. For ordinals `α` and `β`, a simulation `f : α → β` is
-- said to be bounded if there exists `b : β` such that `α = initial_seg b`.
def lt (α β : ordinal) : Prop :=
begin
  refine quotient.lift (lt' α) _ β, clear β,
  rintros ⟨β₁, rβ₁, hβ₁⟩ ⟨β₂, rβ₂, hβ₂⟩ h,
  rcases h with ⟨⟨f, hf⟩, ⟨g, hg⟩⟩,
  have hf₃ : function.left_inverse g f := hg.left_inverse hβ₁.ext hβ₁.wf hf,
  have hg₃ : function.left_inverse f g := hf.left_inverse hβ₂.ext hβ₂.wf hg,
  cases hf with hf₁ hf₂,
  cases hg with hg₁ hg₂,
  ext,
  split,
  { rintro ⟨b, rfl⟩,
    refine ⟨f b, quotient.sound ⟨⟨_, _, _⟩, ⟨_, _, _⟩⟩⟩,
    { exact λ c, ⟨f c.val, hf₁ c.val b c.property⟩ },
    { exact λ ⟨c₁, hc₁⟩ ⟨c₂, hc₂⟩, hf₁ c₁ c₂ },
    { rintros ⟨c₁, hc₁⟩ ⟨c₂, hc₂⟩ h,
      simp only [subtype.mk_eq_mk],
      change rβ₂ c₂ (f c₁) at h,
      specialize hf₂ b c₂ hc₂, clear hc₂,
      rcases hf₂ with ⟨c₂, hc₂, rfl⟩,
      refine ⟨⟨c₂, hc₂⟩, _, rfl⟩,
      change rβ₁ c₂ c₁,
      specialize hg₁ (f c₂) (f c₁) h,
      rwa [hf₃, hf₃] at hg₁ },
    { refine λ c, ⟨g c.val, _⟩,
      specialize hg₁ c.val (f b) c.property,
      rwa hf₃ at hg₁ },
    { exact λ ⟨c₁, hc₁⟩ ⟨c₂, hc₂⟩, hg₁ c₁ c₂ },
    { rintros ⟨c₁, hc₁⟩ ⟨c₂, hc₂⟩ h,
      simp only [subtype.mk_eq_mk],
      change ∃ c, rβ₂ _ c₁ ∧ _,
      change rβ₁ c₂ (g c₁) at h,
      specialize hg₂ c₁ c₂ h, clear hc₁ h,
      rcases hg₂ with ⟨c₂, hc₁, rfl⟩,
      replace hc₂ := hf₁ (g c₂) b hc₂,
      rw hg₃ at hc₂,
      exact ⟨⟨c₂, hc₂⟩, hc₁, rfl⟩ } },
  { rintro ⟨b, rfl⟩,
    refine ⟨g b, quotient.sound ⟨⟨_, _, _⟩, ⟨_, _, _⟩⟩⟩,
    { exact λ c, ⟨g c.val, hg₁ c.val b c.property⟩ },
    { exact λ ⟨c₁, hc₁⟩ ⟨c₂, hc₂⟩, hg₁ c₁ c₂ },
    { rintros ⟨c₁, hc₁⟩ ⟨c₂, hc₂⟩ h,
      simp only [subtype.mk_eq_mk],
      change rβ₁ c₂ (g c₁) at h,
      specialize hg₂ b c₂ hc₂, clear hc₂,
      rcases hg₂ with ⟨c₂, hc₂, rfl⟩,
      refine ⟨⟨c₂, hc₂⟩, _, rfl⟩,
      change rβ₂ c₂ c₁,
      specialize hf₁ (g c₂) (g c₁) h,
      rwa [hg₃, hg₃] at hf₁ },
    { refine λ c, ⟨f c.val, _⟩,
      specialize hf₁ c.val (g b) c.property,
      rwa hg₃ at hf₁ },
    { exact λ ⟨c₁, hc₁⟩ ⟨c₂, hc₂⟩, hf₁ c₁ c₂ },
    { rintros ⟨c₁, hc₁⟩ ⟨c₂, hc₂⟩ h,
      simp only [subtype.mk_eq_mk],
      change ∃ c, rβ₁ _ c₁ ∧ _,
      change rβ₂ c₂ (f c₁) at h,
      specialize hf₂ c₁ c₂ h, clear hc₁ h,
      rcases hf₂ with ⟨c₂, hc₁, rfl⟩,
      replace hc₂ := hg₁ (f c₂) b hc₂,
      rw hf₃ at hc₂,
      exact ⟨⟨c₂, hc₂⟩, hc₁, rfl⟩ } }
end

theorem initial_seg.lt (hα : well_order rα) (a : α) :
  lt (initial_seg hα a) (mk hα) :=
⟨a, rfl⟩

-- XXX: there is probably a way of proving this using choice instead of
-- univalence.
theorem lt.ext : ext lt :=
begin
  rintros ⟨α, rα, hα⟩ ⟨β, rβ, hβ⟩ h,
  change ∀ γ, (∃ a, _) ↔ ∃ a, _ at h,
  change mk hα = mk hβ,
  suffices h : α = β,
  { subst h,
    congr,
    ext a₁ a₂,
    split; intro ha,
    { specialize h (initial_seg hα a₂),
      replace h : ∃ a, initial_seg hα a₂ = initial_seg hβ a := h.mp ⟨a₂, rfl⟩,
      cases h with a h,
      unfold initial_seg at h,
      generalize_proofs h₁ h₂ at h,
      sorry
    },
    sorry
  },
  sorry

  -- XXX: incomplete proof using choice instead of univalence
  /-
  rintros ⟨α, rα, hα⟩ ⟨β, rβ, hβ⟩ h,
  change ∀ γ, lt γ (mk hα) ↔ lt γ (mk hβ) at h,
  change mk hα = mk hβ,
  refine quotient.sound ⟨⟨_, _, _⟩, ⟨_, _, _⟩⟩,
  { intro a,
    specialize h (initial_seg hα a),
    replace h : lt (initial_seg hα a) (mk hβ) := h.mp (initial_seg.lt hα a),
    -- In a homotopy type theory proof assistant, I would use univalence
    -- elsewhere to avoid using choice here.
    exact classical.some h },
  { intros a₁ a₂ ha,
    let α₁ : ordinal := initial_seg hα a₁,
    let α₂ : ordinal := initial_seg hα a₂,
    have h₁ : ∃ b₁, α₁ = initial_seg hβ b₁ := (h α₁).mp (initial_seg.lt hα a₁),
    have h₂ : ∃ b₂, α₂ = initial_seg hβ b₂ := (h α₂).mp (initial_seg.lt hα a₂),
    let b₁ : β := classical.some h₁,
    let β₁ : ordinal := initial_seg hβ b₁,
    have hb₁ : α₁ = β₁ := classical.some_spec h₁,
    let b₂ : β := classical.some h₂,
    let β₂ : ordinal := initial_seg hβ b₂,
    have hb₂ : α₂ = β₂ := classical.some_spec h₂,
    change rβ b₁ b₂,
    clear_value b₁ b₂,
    clear h₁ h₂,
    sorry
  }
  -/
end

theorem lt.wf : well_founded lt :=
begin
  refine ⟨_⟩,
  rintro ⟨α, rα, hα⟩,
  suffices h : ∀ a, acc lt (initial_seg hα a),
  { refine ⟨mk hα, λ β hβ, _⟩,
    rcases hβ with ⟨b, rfl⟩,
    exact h b },
  intro a,
  refine hα.wf.induction a _, clear a,
  intros a ih,
  refine ⟨initial_seg hα a, λ β hβ, _⟩,
  rcases hβ with ⟨⟨b, hb⟩, rfl⟩,
  specialize ih b hb,
  rename hb hb,
  unfold initial_seg at ⊢ ih,
  generalize_proofs hβ hαβ at ⊢ ih,
  suffices h : mk hαβ = mk hβ,
  { rw h, exact ih },
  clear ih,
  refine quotient.sound ⟨⟨_, _, _⟩, ⟨_, _, _⟩⟩,
  { exact λ c, ⟨c.val.val, c.property⟩ },
  { exact λ c₁ c₂ h, h },
  { rintros ⟨⟨c₁, hc₁₁⟩, hc₁₂⟩ ⟨c₂, hc₂⟩ h,
    exact ⟨⟨⟨c₂, hα.trans hc₂ hb⟩, hc₂⟩, h, rfl⟩ },
  { exact λ c, ⟨⟨c.val, hα.trans c.property hb⟩, c.property⟩ },
  { exact λ c₁ c₂ h, h },
  { rintro ⟨c₁, hc₁⟩ ⟨⟨c₂, hc₂₁⟩, hc₂₂⟩ h,
    exact ⟨⟨c₂, hc₂₂⟩, h, rfl⟩ }
end

theorem lt.trans : transitive lt :=
sorry

theorem lt.well_order : well_order lt :=
⟨lt.ext, lt.wf, lt.trans⟩

-- Theorem 10.3.20. `(ordinal, <)` is an ordinal.
def ordinal : ordinal :=
mk lt.well_order

end ordinal


example (f : Nat → Nat → Nat) (h₁ : x = 0) (h₂ : y = 0) (h₃ : f 0 0 = 0) : f x y = x := by
  subst_vars
  assumption


import Smt

theorem modus_ponens' (p q : Bool) (hp : p) (hpq : p → q) : q := by
  smt [hp, hpq]
  simp_all


namespace Dec2

universe u

def parse : IO (List String) := do
  let text <- IO.FS.readFile "data/dec2.txt"
  let lines := String.split text (· = '\n')
  pure lines

inductive Move where
| rock : Move
| paper : Move
| scissors : Move
deriving BEq, Repr

def fromStr (input : String) : Option Move :=
  match input with
  | "A" | "X" => Move.rock
  | "B" | "Y" => Move.paper
  | "C" | "Z" => Move.scissors
  | _ => none

def prodMap {α β : Type} (e : (α × α)) (f : (α → β)) : (β × β) :=
  let (x, y) := e
  (f x, f y)

structure UniProd (α : Type u) where
  fst : α
  snd : α

instance (α : Type) : Coe (α × α) (UniProd α) where
  coe x := UniProd.mk x.1 x.2

instance [ToString α] : ToString (UniProd α) where
  toString x := s!"({x.fst}, {x.snd})"

-- the type of uniform products
instance : Functor UniProd where
  map f e := (f e.fst, f e.snd)

def liftOption {α : Type} (x y : Option α) : Option (α × α) :=
  match x, y with
  | some x, some y => (x, y)
  | _, _ => none

inductive Outcome where
| win : Outcome
| lose : Outcome
| tie : Outcome
deriving Repr, BEq

instance : ToString Outcome where
  toString x := match x with
                | Outcome.win => "win"
                | Outcome.lose => "lose"
                | Outcome.tie => "tie"

def outcomeVal (o : Outcome) : Nat :=
  match o with
  | Outcome.win => 6
  | Outcome.lose => 0
  | Outcome.tie => 3

def choiceVal (m : Move) : Nat :=
  match m with
  | Move.rock => 1
  | Move.paper => 2
  | Move.scissors => 3

def score (me : Move) (opp : Move) : Outcome :=
  if me == opp then
    Outcome.tie
  else match me, opp with
    | Move.rock, Move.scissors => Outcome.win
    | Move.paper, Move.rock => Outcome.win
    | Move.scissors, Move.paper => Outcome.win
    | _, _ => Outcome.lose

def chooseOption (m : Move) (outcome : Outcome) : Move :=
  match outcome, m with
  | Outcome.win, Move.rock => Move.paper
  | Outcome.win, Move.paper => Move.scissors
  | Outcome.win, Move.scissors => Move.rock
  | Outcome.lose, Move.rock => Move.scissors
  | Outcome.lose, Move.paper => Move.rock
  | Outcome.lose, Move.scissors => Move.paper
  | Outcome.tie, move => move

def moveToOutcome (m : Move) : Outcome :=
  match m with
  | Move.rock => Outcome.lose
  | Move.paper => Outcome.tie
  | Move.scissors => Outcome.win

theorem chooseOptionCorrect (m : Move) (o : Outcome) : score (chooseOption m o) m = o :=
  by
    match m with
    | Move.rock => match o with
                   | Outcome.win => rfl
                   | Outcome.lose => rfl
                   | Outcome.tie => rfl
    | Move.paper => match o with
                   | Outcome.win => rfl
                   | Outcome.lose => rfl
                   | Outcome.tie => rfl
    | Move.scissors => match o with
                       | Outcome.win => rfl
                       | Outcome.lose => rfl
                       | Outcome.tie => rfl

def run : IO Unit := do

  let lines <- parse

  let parsed : List (Move × Move) :=
    lines |> List.map (String.split · (· = ' '))
          |> List.map (λ x => (x[0]?, x[1]?))
          |> List.filterMap (λ x => liftOption x.fst x.snd)
          |> List.map (λ (m1, m2) => (fromStr m1, fromStr m2))
          |> List.filterMap (λ x => liftOption x.fst x.snd)

  let part1 :=
    parsed |> List.map (λ x => outcomeVal (score x.2 x.1) + choiceVal x.2)
           |> List.foldl (· + ·) 0

  let part2 :=
    parsed |> List.map (λ (e, h) => (e, moveToOutcome h))
           |> List.map (λ (e, o) => (e, chooseOption e o))
           |> List.map (λ (e, h) => outcomeVal (score h e) + choiceVal h)
           |> List.foldl (· + ·) 0

  let stdout <- IO.getStdout
  stdout.putStrLn s!"Part 1: {part1}"
  stdout.putStrLn s!"Part 2: {part2}"

end Dec2


meta def my_tac : tactic unit :=
  `[ repeat { { left, assumption } <|> right <|> assumption } ]

example (p q r : Prop) (hp : p) : p ∨ q ∨ r :=
  by my_tac

example (p q r : Prop) (hq : q) : p ∨ q ∨ r :=
  by my_tac

example (p q r : Prop) (hr : r) : p ∨ q ∨ r :=
  by my_tac


/-
Copyright (c) 2021 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta
-/
import category_theory.limits.preserves.shapes.binary_products
import category_theory.limits.constructions.finite_products_of_binary_products
import category_theory.monad.limits
import category_theory.adjunction.fully_faithful
import category_theory.adjunction.reflective
import category_theory.closed.cartesian
import category_theory.subterminal

/-!
# Exponential ideals

An exponential ideal of a cartesian closed category `C` is a subcategory `D ⊆ C` such that for any
`B : D` and `A : C`, the exponential `A ⟹ B` is in `D`: resembling ring theoretic ideals. We
define the notion here for inclusion functors `i : D ⥤ C` rather than explicit subcategories to
preserve the principle of equivalence.

We additionally show that if `C` is cartesian closed and `i : D ⥤ C` is a reflective functor, the
following are equivalent.
* The left adjoint to `i` preserves binary (equivalently, finite) products.
* `i` is an exponential ideal.
-/
universes v₁ v₂ u₁ u₂

noncomputable theory

namespace category_theory

open limits category

section ideal

variables {C : Type u₁} {D : Type u₂} [category.{v₁} C] [category.{v₁} D] {i : D ⥤ C}

variables (i) [has_finite_products C] [cartesian_closed C]

/--
The subcategory `D` of `C` expressed as an inclusion functor is an *exponential ideal* if
`B ∈ D` implies `A ⟹ B ∈ D` for all `A`.
-/
class exponential_ideal : Prop :=
(exp_closed : ∀ {B}, B ∈ i.ess_image → ∀ A, (A ⟹ B) ∈ i.ess_image)

/--
To show `i` is an exponential ideal it suffices to show that `A ⟹ iB` is "in" `D` for any `A` in
`C` and `B` in `D`.
-/
lemma exponential_ideal.mk' (h : ∀ (B : D) (A : C), (A ⟹ i.obj B) ∈ i.ess_image) :
  exponential_ideal i :=
⟨λ B hB A,
begin
  rcases hB with ⟨B', ⟨iB'⟩⟩,
  exact functor.ess_image.of_iso ((exp A).map_iso iB') (h B' A),
end⟩

/-- The entire category viewed as a subcategory is an exponential ideal. -/
instance : exponential_ideal (𝟭 C) :=
exponential_ideal.mk' _ (λ B A, ⟨_, ⟨iso.refl _⟩⟩)

open cartesian_closed

/-- The subcategory of subterminal objects is an exponential ideal. -/
instance : exponential_ideal (subterminal_inclusion C) :=
begin
  apply exponential_ideal.mk',
  intros B A,
  refine ⟨⟨A ⟹ B.1, λ Z g h, _⟩, ⟨iso.refl _⟩⟩,
  exact uncurry_injective (B.2 (cartesian_closed.uncurry g) (cartesian_closed.uncurry h))
end

/--
If `D` is a reflective subcategory, the property of being an exponential ideal is equivalent to
the presence of a natural isomorphism `i ⋙ exp A ⋙ left_adjoint i ⋙ i ≅ i ⋙ exp A`, that is:
`(A ⟹ iB) ≅ i L (A ⟹ iB)`, naturally in `B`.
The converse is given in `exponential_ideal.mk_of_iso`.
-/
def exponential_ideal_reflective (A : C) [reflective i] [exponential_ideal i] :
  i ⋙ exp A ⋙ left_adjoint i ⋙ i ≅ i ⋙ exp A :=
begin
  symmetry,
  apply nat_iso.of_components _ _,
  { intro X,
    haveI := (exponential_ideal.exp_closed (i.obj_mem_ess_image X) A).unit_is_iso,
    apply as_iso ((adjunction.of_right_adjoint i).unit.app (A ⟹ i.obj X)) },
  { simp }
end

/--
Given a natural isomorphism `i ⋙ exp A ⋙ left_adjoint i ⋙ i ≅ i ⋙ exp A`, we can show `i`
is an exponential ideal.
-/
lemma exponential_ideal.mk_of_iso [reflective i]
  (h : Π (A : C), i ⋙ exp A ⋙ left_adjoint i ⋙ i ≅ i ⋙ exp A) :
  exponential_ideal i :=
begin
  apply exponential_ideal.mk',
  intros B A,
  exact ⟨_, ⟨(h A).app B⟩⟩,
end

end ideal

section

variables {C : Type u₁} {D : Type u₂} [category.{v₁} C] [category.{v₁} D]
variables (i : D ⥤ C)

lemma reflective_products [has_finite_products C] [reflective i] : has_finite_products D :=
⟨λ n, has_limits_of_shape_of_reflective i⟩

local attribute [instance, priority 10] reflective_products

open cartesian_closed

variables [has_finite_products C] [reflective i] [cartesian_closed C]

/--
If the reflector preserves binary products, the subcategory is an exponential ideal.
This is the converse of `preserves_binary_products_of_exponential_ideal`.
-/
@[priority 10]
instance exponential_ideal_of_preserves_binary_products
  [preserves_limits_of_shape (discrete walking_pair) (left_adjoint i)] :
  exponential_ideal i :=
begin
  let ir := adjunction.of_right_adjoint i,
  let L : C ⥤ D := left_adjoint i,
  let η : 𝟭 C ⟶ L ⋙ i := ir.unit,
  let ε : i ⋙ L ⟶ 𝟭 D := ir.counit,
  apply exponential_ideal.mk',
  intros B A,
  let q : i.obj (L.obj (A ⟹ i.obj B)) ⟶ A ⟹ i.obj B,
    apply cartesian_closed.curry (ir.hom_equiv _ _ _),
    apply _ ≫ (ir.hom_equiv _ _).symm ((exp.ev A).app (i.obj B)),
    refine prod_comparison L A _ ≫ limits.prod.map (𝟙 _) (ε.app _) ≫ inv (prod_comparison _ _ _),
  have : η.app (A ⟹ i.obj B) ≫ q = 𝟙 (A ⟹ i.obj B),
  { dsimp,
    rw [← curry_natural_left, curry_eq_iff, uncurry_id_eq_ev, ← ir.hom_equiv_naturality_left,
        ir.hom_equiv_apply_eq, assoc, assoc, prod_comparison_natural_assoc, L.map_id,
        ← prod.map_id_comp_assoc, ir.left_triangle_components, prod.map_id_id, id_comp],
    apply is_iso.hom_inv_id_assoc },
  haveI : is_split_mono (η.app (A ⟹ i.obj B)) := is_split_mono.mk' ⟨_, this⟩,
  apply mem_ess_image_of_unit_is_split_mono,
end

variables [exponential_ideal i]

/--
If `i` witnesses that `D` is a reflective subcategory and an exponential ideal, then `D` is
itself cartesian closed.
-/
def cartesian_closed_of_reflective : cartesian_closed D :=
{ closed' := λ B,
  { is_adj :=
    { right := i ⋙ exp (i.obj B) ⋙ left_adjoint i,
      adj :=
      begin
        apply adjunction.restrict_fully_faithful i i (exp.adjunction (i.obj B)),
        { symmetry,
          apply nat_iso.of_components _ _,
          { intro X,
            haveI :=
              adjunction.right_adjoint_preserves_limits.{0 0} (adjunction.of_right_adjoint i),
            apply as_iso (prod_comparison i B X) },
          { intros X Y f,
            dsimp,
            rw prod_comparison_natural,
            simp, } },
        { apply (exponential_ideal_reflective i _).symm }
      end } } }

-- It's annoying that I need to do this.
local attribute [-instance]
  category_theory.preserves_limit_of_creates_limit_and_has_limit
  category_theory.preserves_limit_of_shape_of_creates_limits_of_shape_and_has_limits_of_shape

/--
We construct a bijection between morphisms `L(A ⨯ B) ⟶ X` and morphisms `LA ⨯ LB ⟶ X`.
This bijection has two key properties:
* It is natural in `X`: See `bijection_natural`.
* When `X = LA ⨯ LB`, then the backwards direction sends the identity morphism to the product
  comparison morphism: See `bijection_symm_apply_id`.

Together these help show that `L` preserves binary products. This should be considered
*internal implementation* towards `preserves_binary_products_of_exponential_ideal`.
-/
noncomputable def bijection (A B : C) (X : D) :
  ((left_adjoint i).obj (A ⨯ B) ⟶ X) ≃ ((left_adjoint i).obj A ⨯ (left_adjoint i).obj B ⟶ X) :=
calc _ ≃ (A ⨯ B ⟶ i.obj X) :
              (adjunction.of_right_adjoint i).hom_equiv _ _
   ... ≃ (B ⨯ A ⟶ i.obj X) :
              (limits.prod.braiding _ _).hom_congr (iso.refl _)
   ... ≃ (A ⟶ B ⟹ i.obj X) :
              (exp.adjunction _).hom_equiv _ _
   ... ≃ (i.obj ((left_adjoint i).obj A) ⟶ B ⟹ i.obj X) :
              unit_comp_partial_bijective _ (exponential_ideal.exp_closed (i.obj_mem_ess_image _) _)
   ... ≃ (B ⨯ i.obj ((left_adjoint i).obj A) ⟶ i.obj X) :
              ((exp.adjunction _).hom_equiv _ _).symm
   ... ≃ (i.obj ((left_adjoint i).obj A) ⨯ B ⟶ i.obj X) :
              (limits.prod.braiding _ _).hom_congr (iso.refl _)
   ... ≃ (B ⟶ i.obj ((left_adjoint i).obj A) ⟹ i.obj X) :
              (exp.adjunction _).hom_equiv _ _
   ... ≃ (i.obj ((left_adjoint i).obj B) ⟶ i.obj ((left_adjoint i).obj A) ⟹ i.obj X) :
              unit_comp_partial_bijective _ (exponential_ideal.exp_closed (i.obj_mem_ess_image _) _)
   ... ≃ (i.obj ((left_adjoint i).obj A) ⨯ i.obj ((left_adjoint i).obj B) ⟶ i.obj X) :
              ((exp.adjunction _).hom_equiv _ _).symm
   ... ≃ (i.obj ((left_adjoint i).obj A ⨯ (left_adjoint i).obj B) ⟶ i.obj X) :
     begin
       apply iso.hom_congr _ (iso.refl _),
       haveI : preserves_limits i := (adjunction.of_right_adjoint i).right_adjoint_preserves_limits,
       haveI := preserves_smallest_limits_of_preserves_limits i,
       exact (preserves_limit_pair.iso _ _ _).symm,
     end
   ... ≃ ((left_adjoint i).obj A ⨯ (left_adjoint i).obj B ⟶ X) :
              (equiv_of_fully_faithful _).symm

lemma bijection_symm_apply_id (A B : C) :
  (bijection i A B _).symm (𝟙 _) = prod_comparison _ _ _ :=
begin
  dsimp [bijection],
  rw [comp_id, comp_id, comp_id, i.map_id, comp_id, unit_comp_partial_bijective_symm_apply,
      unit_comp_partial_bijective_symm_apply, uncurry_natural_left, uncurry_curry,
      uncurry_natural_left, uncurry_curry, prod.lift_map_assoc, comp_id, prod.lift_map_assoc,
      comp_id, prod.comp_lift_assoc, prod.lift_snd, prod.lift_fst_assoc,
      prod.lift_fst_comp_snd_comp, ←adjunction.eq_hom_equiv_apply, adjunction.hom_equiv_unit,
      iso.comp_inv_eq, assoc, preserves_limit_pair.iso_hom],
  apply prod.hom_ext,
  { rw [limits.prod.map_fst, assoc, assoc, prod_comparison_fst, ←i.map_comp, prod_comparison_fst],
    apply (adjunction.of_right_adjoint i).unit.naturality },
  { rw [limits.prod.map_snd, assoc, assoc, prod_comparison_snd, ←i.map_comp, prod_comparison_snd],
    apply (adjunction.of_right_adjoint i).unit.naturality },
end

lemma bijection_natural
  (A B : C) (X X' : D) (f : ((left_adjoint i).obj (A ⨯ B) ⟶ X)) (g : X ⟶ X') :
  bijection i _ _ _ (f ≫ g) = bijection i _ _ _ f ≫ g :=
begin
  dsimp [bijection],
  apply i.map_injective,
  rw [i.image_preimage, i.map_comp, i.image_preimage, comp_id, comp_id, comp_id, comp_id, comp_id,
      comp_id, adjunction.hom_equiv_naturality_right, ← assoc, curry_natural_right _ (i.map g),
      unit_comp_partial_bijective_natural, uncurry_natural_right, ← assoc, curry_natural_right,
      unit_comp_partial_bijective_natural, uncurry_natural_right, assoc],
end

/--
The bijection allows us to show that `prod_comparison L A B` is an isomorphism, where the inverse
is the forward map of the identity morphism.
-/
lemma prod_comparison_iso (A B : C) :
  is_iso (prod_comparison (left_adjoint i) A B) :=
⟨⟨bijection i _ _ _ (𝟙 _),
  by rw [←(bijection i _ _ _).injective.eq_iff, bijection_natural, ← bijection_symm_apply_id,
         equiv.apply_symm_apply, id_comp],
  by rw [←bijection_natural, id_comp, ←bijection_symm_apply_id, equiv.apply_symm_apply]⟩⟩

local attribute [instance] prod_comparison_iso

/--
If a reflective subcategory is an exponential ideal, then the reflector preserves binary products.
This is the converse of `exponential_ideal_of_preserves_binary_products`.
-/
noncomputable def preserves_binary_products_of_exponential_ideal :
  preserves_limits_of_shape (discrete walking_pair) (left_adjoint i) :=
{ preserves_limit := λ K,
  begin
    apply limits.preserves_limit_of_iso_diagram _ (diagram_iso_pair K).symm,
    apply preserves_limit_pair.of_iso_prod_comparison,
  end }

/--
If a reflective subcategory is an exponential ideal, then the reflector preserves finite products.
-/
noncomputable def preserves_finite_products_of_exponential_ideal (J : Type) [fintype J] :
  preserves_limits_of_shape (discrete J) (left_adjoint i) :=
begin
  letI := preserves_binary_products_of_exponential_ideal i,
  letI := left_adjoint_preserves_terminal_of_reflective.{0} i,
  apply preserves_finite_products_of_preserves_binary_and_terminal (left_adjoint i) J,
end

end

end category_theory


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.int.basic
import Mathlib.category_theory.graded_object
import Mathlib.category_theory.differential_object
import Mathlib.PostPort

universes v u u_1

namespace Mathlib

/-!
# Chain complexes

We define a chain complex in `V` as a differential `ℤ`-graded object in `V`.

This is fancy language for the obvious definition,
and it seems we can use it straightforwardly:

```
example (C : chain_complex V) : C.X 5 ⟶ C.X 6 := C.d 5
```

-/

/--
A `homological_complex V b` for `b : β` is a (co)chain complex graded by `β`,
with differential in grading `b`.

(We use the somewhat cumbersome `homological_complex` to avoid the name conflict with `ℂ`.)
-/
def homological_complex (V : Type u) [category_theory.category V] [category_theory.limits.has_zero_morphisms V] {β : Type} [add_comm_group β] (b : β) :=
  category_theory.differential_object (category_theory.graded_object_with_shift b V)

/--
A chain complex in `V` is "just" a differential `ℤ`-graded object in `V`,
with differential graded `-1`.
-/
def chain_complex (V : Type u) [category_theory.category V] [category_theory.limits.has_zero_morphisms V] :=
  homological_complex V (-1)

/--
A cochain complex in `V` is "just" a differential `ℤ`-graded object in `V`,
with differential graded `+1`.
-/
def cochain_complex (V : Type u) [category_theory.category V] [category_theory.limits.has_zero_morphisms V] :=
  homological_complex V 1

-- The chain groups of a chain complex `C` are accessed as `C.X i`,

-- and the differentials as `C.d i : C.X i ⟶ C.X (i-1)`.

namespace homological_complex

@[simp] theorem d_squared {V : Type u} [category_theory.category V] [category_theory.limits.has_zero_morphisms V] {β : Type} [add_comm_group β] {b : β} (C : homological_complex V b) (i : β) : category_theory.differential_object.d C i ≫ category_theory.differential_object.d C (i + b) = 0 := sorry

/--
A convenience lemma for morphisms of cochain complexes,
picking out one component of the commutation relation.
-/
-- I haven't been able to get this to work with projection notation: `f.comm_at i`

@[simp] theorem comm_at {V : Type u} [category_theory.category V] [category_theory.limits.has_zero_morphisms V] {β : Type} [add_comm_group β] {b : β} {C : homological_complex V b} {D : homological_complex V b} (f : C ⟶ D) (i : β) : category_theory.differential_object.d C i ≫ category_theory.differential_object.hom.f f (i + b) =
  category_theory.differential_object.hom.f f i ≫ category_theory.differential_object.d D i := sorry

@[simp] theorem comm {V : Type u} [category_theory.category V] [category_theory.limits.has_zero_morphisms V] {β : Type} [add_comm_group β] {b : β} {C : homological_complex V b} {D : homological_complex V b} (f : C ⟶ D) : category_theory.differential_object.d C ≫
    category_theory.functor.map
      (category_theory.equivalence.functor (category_theory.shift (category_theory.graded_object_with_shift b V) ^ 1))
      (category_theory.differential_object.hom.f f) =
  category_theory.differential_object.hom.f f ≫ category_theory.differential_object.d D :=
  category_theory.differential_object.hom.comm (category_theory.graded_object_with_shift b V)
    (category_theory.graded_object.category_of_graded_objects β) (category_theory.graded_object.has_zero_morphisms β)
    (category_theory.graded_object.has_shift b) C D f

/-- The forgetful functor from cochain complexes to graded objects, forgetting the differential. -/
def forget (V : Type u) [category_theory.category V] [category_theory.limits.has_zero_morphisms V] {β : Type} [add_comm_group β] {b : β} : homological_complex V b ⥤ category_theory.graded_object β V :=
  category_theory.differential_object.forget (category_theory.graded_object_with_shift b V)

protected instance inhabited {β : Type} [add_comm_group β] {b : β} : Inhabited (homological_complex (category_theory.discrete PUnit) b) :=
  { default := 0 }


import Runtime.Time

@[simp]
theorem Array.getElem?_nil {i : Nat} : (#[] : Array α)[i]? = none := by
  simp [getElem?]; split <;> simp; contradiction

@[simp]
theorem Array.getElem?_zero_singleton : (#[a] : Array α)[0]? = a := rfl

theorem Array.getElem?_zero_isSome_iff_not_isEmpty {as : Array α} : as[0]?.isSome ↔ ¬as.isEmpty := by
  simp [Array.isEmpty, Option.isSome_iff_exists, getElem?]
  constructor
  case mp =>
    intro ⟨_, h⟩
    split at h
    case inl hs => exact Nat.not_eq_zero_of_lt hs
    case inr => contradiction
  case mpr =>
    intro h
    split
    case inl => exists as[0]
    case inr hs => exact absurd (Nat.zero_lt_of_ne_zero h) hs

theorem Array.isEmpty_iff_data_eq_nil {as : Array α} : as.isEmpty ↔ as.data = [] := by
  simp [isEmpty, size]
  exact List.length_eq_zero

theorem Array.any_iff_mem_where {as : Array α} : (as.any p) ↔ (∃ a, (a ∈ as.data) ∧ p a) := sorry

@[reducible]
instance [DecidableEq α] {β : α → Type _} [∀ a, DecidableEq (β a)] : DecidableEq (Σ a : α, β a) :=
  fun ⟨a₁, b₁⟩ ⟨a₂, b₂⟩ =>
    if h : a₁ = a₂ then
      if h' : (h ▸ b₁) = b₂ then
        .isTrue (by subst h h'; rfl)
      else
        .isFalse (by
          subst h
          intro hc
          injection hc
          contradiction
        )
    else
      .isFalse (by
        intro hc
        injection hc
        contradiction
      )

def Array.merge (s₁ s₂ : Array α) (le : α → α → Bool) : Array α :=
  (s₁ ++ s₂).insertionSort le

def Array.unique (as : Array α) (f : α → β) [DecidableEq β] : (Array α) × (Array α) := Id.run do
  let mut included : Array α := #[]
  let mut excluded : Array α := #[]
  for a in as do
    if included.any (f a = f ·)
    then excluded := excluded.push a
    else included := included.push a
  return (included, excluded)

def Array.uniqueMergeMap [BEq α] (as : Array α) (f : α → Array β) (le : β → β → Bool) :
  Array β := Id.run do
  let mut processed : Array α := #[]
  let mut result : Array β := #[]
  for a in as do
    if ¬ processed.contains a then
      processed := processed.push a
      result := result.merge (f a) le
  return result

-- `Array.find?` isn't universe polymorphic.
def Array.findP? (as : Array α) (p : α → Bool) : Option α := do
  loop 0 as p
where
  loop (idx : Nat) (as : Array α) (p : α → Bool) : Option α :=
  if h : idx < as.size then
    let a := as[idx]
    if p a then a else loop (idx + 1) as p
  else
    none
termination_by _ => as.size - idx

theorem Array.findP?_property {as : Array α} : (Array.findP? as p = some a) → (p a) :=
  let rec go {idx} : (Array.findP?.loop idx as p = some a) → (p a) := by
    intro h
    unfold findP?.loop at h
    split at h <;> simp at h
    case inl hi =>
      split at h
      case inl => simp_all
      case inr => exact go h
  go
termination_by _ => as.size - idx

def UInt32.clipping (n : Nat) : UInt32 :=
  UInt32.ofNatCore (min n (UInt32.size - 1)) (by
    rw [Nat.min_def]
    split
    case inr => simp
    case inl h => exact Nat.lt_succ_of_le h
  )

def IO.sleepUntil (time : Time) : IO Unit := do
  let offset := time - (← Time.now)
  sleep <| UInt32.clipping <| offset.to .ms


/-
Copyright (c) 2022 Joël Riou. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Joël Riou
-/

import for_mathlib.dold_kan.equivalence_additive
import for_mathlib.idempotents.homological_complex

noncomputable theory

open category_theory
open category_theory.category
open category_theory.limits
open category_theory.idempotents
open algebraic_topology

open algebraic_topology.dold_kan

namespace category_theory

namespace simplicial_object

@[simps]
def karoubi_whiskering (C D : Type*) [category C] [category D] :=
simplicial_object.whiskering C D ⋙ functor_extension₂ _ _

end simplicial_object

namespace preadditive

namespace dold_kan

variables {C : Type*} [category C] [preadditive C] [has_finite_coproducts C]
variables {D : Type*} [category D] [preadditive D] [has_finite_coproducts D]
variables (F : C ⥤ D) [functor.additive F]

lemma functoriality_N₁ : (simplicial_object.whiskering C D).obj F ⋙ N₁ =
  N₁ ⋙ F.map_karoubi_homological_complex _ :=
begin
  apply functor.ext,
  { intros X Y f,
    ext n,
    simp only [karoubi.comp_f, homological_complex.comp_f, karoubi.eq_to_hom_f,
      homological_complex.eq_to_hom_f, eq_to_hom_refl, comp_id],
    dsimp,
    simp only [map_P_infty_f, ← F.map_comp],
    congr' 1,
    rw [assoc, P_infty_f_naturality],
    simp only [← assoc, P_infty_f_idem], },
  { intro X,
    ext n,
    { dsimp,
      erw [homological_complex.eq_to_hom_f, ← algebraic_topology.dold_kan.map_P_infty_f,
      comp_id, id_comp], },
    { exact functor.congr_obj (map_alternating_face_map_complex F).symm X, }, },
end

lemma functoriality_N :
  (simplicial_object.karoubi_whiskering _ _).obj F ⋙ dold_kan.equivalence.functor =
  dold_kan.equivalence.functor ⋙ F.map_karoubi_homological_complex _ :=
begin
  dsimp [functor.map_karoubi_homological_complex,
    simplicial_object.karoubi_whiskering],
  simp only [functor_extension₂, functor.comp_obj, N, N₂],
  erw ← functor_extension₁_comp _ _ _ N₁ (F.map_homological_complex _ ⋙ to_karoubi _),
  erw ← functor_extension₁_comp _ _ _
    ((simplicial_object.whiskering C D).obj F ⋙ to_karoubi _) N₁,
  congr' 1,
  have h := functor.congr_obj (functor_extension₁_comp_whiskering_left_to_karoubi _ _)
    (N₁ : simplicial_object D ⥤ _),
  simp only [functor.comp_obj, whiskering_left, functor.id] at h,
  erw [functor.assoc_eq, h],
  apply functoriality_N₁,
end

end dold_kan

end preadditive

end category_theory


/-
Copyright (c) 2019 Patrick Massot. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Patrick Massot
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.real.cau_seq
import Mathlib.topology.uniform_space.basic
import Mathlib.PostPort

universes u_1 u_2

namespace Mathlib

/-!
# Uniform structure induced by an absolute value

We build a uniform space structure on a commutative ring `R` equipped with an absolute value into
a linear ordered field `𝕜`. Of course in the case `R` is `ℚ`, `ℝ` or `ℂ` and
`𝕜 = ℝ`, we get the same thing as the metric space construction, and the general construction
follows exactly the same path.

## Implementation details

Note that we import `data.real.cau_seq` because this is where absolute values are defined, but
the current file does not depend on real numbers. TODO: extract absolute values from that
`data.real` folder.

## References

* [N. Bourbaki, *Topologie générale*][bourbaki1966]

## Tags

absolute value, uniform spaces
-/

namespace is_absolute_value

/-- The uniformity coming from an absolute value. -/
def uniform_space_core {𝕜 : Type u_1} [linear_ordered_field 𝕜] {R : Type u_2} [comm_ring R] (abv : R → 𝕜) [is_absolute_value abv] : uniform_space.core R :=
  uniform_space.core.mk
    (infi
      fun (ε : 𝕜) =>
        infi fun (H : ε > 0) => filter.principal (set_of fun (p : R × R) => abv (prod.snd p - prod.fst p) < ε))
    sorry sorry sorry

/-- The uniform structure coming from an absolute value. -/
def uniform_space {𝕜 : Type u_1} [linear_ordered_field 𝕜] {R : Type u_2} [comm_ring R] (abv : R → 𝕜) [is_absolute_value abv] : uniform_space R :=
  uniform_space.of_core (uniform_space_core abv)

theorem mem_uniformity {𝕜 : Type u_1} [linear_ordered_field 𝕜] {R : Type u_2} [comm_ring R] (abv : R → 𝕜) [is_absolute_value abv] {s : set (R × R)} : s ∈ uniform_space.core.uniformity (uniform_space_core abv) ↔
  ∃ (ε : 𝕜), ∃ (H : ε > 0), ∀ {a b : R}, abv (b - a) < ε → (a, b) ∈ s := sorry


/-
Copyright (c) 2021 Andrew Yang. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Andrew Yang
-/
import category_theory.sites.limits
import category_theory.functor.flat
import category_theory.limits.preserves.filtered
import category_theory.sites.left_exact

/-!
# Cover-preserving functors between sites.

We define cover-preserving functors between sites as functors that push covering sieves to
covering sieves. A cover-preserving and compatible-preserving functor `G : C ⥤ D` then pulls
sheaves on `D` back to sheaves on `C` via `G.op ⋙ -`.

## Main definitions

* `category_theory.cover_preserving`: a functor between sites is cover-preserving if it
pushes covering sieves to covering sieves
* `category_theory.compatible_preserving`: a functor between sites is compatible-preserving
if it pushes compatible families of elements to compatible families.
* `category_theory.pullback_sheaf`: the pullback of a sheaf along a cover-preserving and
compatible-preserving functor.
* `category_theory.sites.pullback`: the induced functor `Sheaf K A ⥤ Sheaf J A` for a
cover-preserving and compatible-preserving functor `G : (C, J) ⥤ (D, K)`.
* `category_theory.sites.pushforward`: the induced functor `Sheaf J A ⥤ Sheaf K A` for a
cover-preserving and compatible-preserving functor `G : (C, J) ⥤ (D, K)`.
* `category_theory.sites.pushforward`: the induced functor `Sheaf J A ⥤ Sheaf K A` for a
cover-preserving and compatible-preserving functor `G : (C, J) ⥤ (D, K)`.

## Main results

- `category_theory.sites.whiskering_left_is_sheaf_of_cover_preserving`: If `G : C ⥤ D` is
cover-preserving and compatible-preserving, then `G ⋙ -` (`uᵖ`) as a functor
`(Dᵒᵖ ⥤ A) ⥤ (Cᵒᵖ ⥤ A)` of presheaves maps sheaves to sheaves.

## References

* [Elephant]: *Sketches of an Elephant*, P. T. Johnstone: C2.3.
* https://stacks.math.columbia.edu/tag/00WW

-/

universes w v₁ v₂ v₃ u₁ u₂ u₃
noncomputable theory

open category_theory
open opposite
open category_theory.presieve.family_of_elements
open category_theory.presieve
open category_theory.limits

namespace category_theory
variables {C : Type u₁} [category.{v₁} C] {D : Type u₂} [category.{v₂} D]
variables {A : Type u₃} [category.{v₃} A]
variables (J : grothendieck_topology C) (K : grothendieck_topology D)
variables {L : grothendieck_topology A}

/--
A functor `G : (C, J) ⥤ (D, K)` between sites is *cover-preserving*
if for all covering sieves `R` in `C`, `R.pushforward_functor G` is a covering sieve in `D`.
-/
@[nolint has_inhabited_instance]
structure cover_preserving (G : C ⥤ D) : Prop :=
(cover_preserve : ∀ {U : C} {S : sieve U} (hS : S ∈ J U), S.functor_pushforward G ∈ K (G.obj U))

/-- The identity functor on a site is cover-preserving. -/
lemma id_cover_preserving : cover_preserving J J (𝟭 _) := ⟨λ U S hS, by simpa using hS⟩

variables (J) (K)

/-- The composition of two cover-preserving functors is cover-preserving. -/
lemma cover_preserving.comp {F} (hF : cover_preserving J K F) {G} (hG : cover_preserving K L G) :
  cover_preserving J L (F ⋙ G) := ⟨λ U S hS,
begin
  rw sieve.functor_pushforward_comp,
  exact hG.cover_preserve (hF.cover_preserve hS)
end⟩

/--
A functor `G : (C, J) ⥤ (D, K)` between sites is called compatible preserving if for each
compatible family of elements at `C` and valued in `G.op ⋙ ℱ`, and each commuting diagram
`f₁ ≫ G.map g₁ = f₂ ≫ G.map g₂`, `x g₁` and `x g₂` coincide when restricted via `fᵢ`.
This is actually stronger than merely preserving compatible families because of the definition of
`functor_pushforward` used.
-/
@[nolint has_inhabited_instance]
structure compatible_preserving (K : grothendieck_topology D) (G : C ⥤ D) : Prop :=
(compatible :
  ∀ (ℱ : SheafOfTypes.{w} K) {Z} {T : presieve Z}
    {x : family_of_elements (G.op ⋙ ℱ.val) T} (h : x.compatible)
    {Y₁ Y₂} {X} (f₁ : X ⟶ G.obj Y₁) (f₂ : X ⟶ G.obj Y₂) {g₁ : Y₁ ⟶ Z} {g₂ : Y₂ ⟶ Z}
    (hg₁ : T g₁) (hg₂ : T g₂) (eq : f₁ ≫ G.map g₁ = f₂ ≫ G.map g₂),
      ℱ.val.map f₁.op (x g₁ hg₁) = ℱ.val.map f₂.op (x g₂ hg₂))

variables {J K} {G : C ⥤ D} (hG : compatible_preserving.{w} K G) (ℱ : SheafOfTypes.{w} K) {Z : C}
variables {T : presieve Z} {x : family_of_elements (G.op ⋙ ℱ.val) T} (h : x.compatible)

include h hG

/-- `compatible_preserving` functors indeed preserve compatible families. -/
lemma presieve.family_of_elements.compatible.functor_pushforward :
  (x.functor_pushforward G).compatible :=
begin
  rintros Z₁ Z₂ W g₁ g₂ f₁' f₂' H₁ H₂ eq,
  unfold family_of_elements.functor_pushforward,
  rcases get_functor_pushforward_structure H₁ with ⟨X₁, f₁, h₁, hf₁, rfl⟩,
  rcases get_functor_pushforward_structure H₂ with ⟨X₂, f₂, h₂, hf₂, rfl⟩,
  suffices : ℱ.val.map (g₁ ≫ h₁).op (x f₁ hf₁) = ℱ.val.map (g₂ ≫ h₂).op (x f₂ hf₂),
    simpa using this,
  apply hG.compatible ℱ h _ _ hf₁ hf₂,
  simpa using eq
end

@[simp] lemma compatible_preserving.apply_map {Y : C} {f : Y ⟶ Z} (hf : T f) :
  x.functor_pushforward G (G.map f) (image_mem_functor_pushforward G T hf) = x f hf :=
begin
  unfold family_of_elements.functor_pushforward,
  rcases e₁ : get_functor_pushforward_structure (image_mem_functor_pushforward G T hf) with
    ⟨X, g, f', hg, eq⟩,
  simpa using hG.compatible ℱ h f' (𝟙 _) hg hf (by simp[eq])
end

omit h hG

open limits.walking_cospan

lemma compatible_preserving_of_flat {C : Type u₁} [category.{v₁} C] {D : Type u₁} [category.{v₁} D]
  (K : grothendieck_topology D) (G : C ⥤ D) [representably_flat G] : compatible_preserving K G :=
begin
  constructor,
  intros ℱ Z T x hx Y₁ Y₂ X f₁ f₂ g₁ g₂ hg₁ hg₂ e,

  /- First, `f₁` and `f₂` form a cone over `cospan g₁ g₂ ⋙ u`. -/
  let c : cone (cospan g₁ g₂ ⋙ G) :=
    (cones.postcompose (diagram_iso_cospan (cospan g₁ g₂ ⋙ G)).inv).obj
      (pullback_cone.mk f₁ f₂ e),

  /-
  This can then be viewed as a cospan of structured arrows, and we may obtain an arbitrary cone
  over it since `structured_arrow W u` is cofiltered.
  Then, it suffices to prove that it is compatible when restricted onto `u(c'.X.right)`.
  -/
  let c' := is_cofiltered.cone (structured_arrow_cone.to_diagram c ⋙ structured_arrow.pre _ _ _),
  have eq₁ : f₁ = (c'.X.hom ≫ G.map (c'.π.app left).right) ≫ eq_to_hom (by simp),
  { erw ← (c'.π.app left).w, dsimp, simp },
  have eq₂ : f₂ = (c'.X.hom ≫ G.map (c'.π.app right).right) ≫ eq_to_hom (by simp),
  { erw ← (c'.π.app right).w, dsimp, simp },
  conv_lhs { rw eq₁ },
  conv_rhs { rw eq₂ },
  simp only [op_comp, functor.map_comp, types_comp_apply, eq_to_hom_op, eq_to_hom_map],
  congr' 1,

  /-
  Since everything now falls in the image of `u`,
  the result follows from the compatibility of `x` in the image of `u`.
  -/
  injection c'.π.naturality walking_cospan.hom.inl with _ e₁,
  injection c'.π.naturality walking_cospan.hom.inr with _ e₂,
  exact hx (c'.π.app left).right (c'.π.app right).right hg₁ hg₂ (e₁.symm.trans e₂)
end

/--
If `G` is cover-preserving and compatible-preserving,
then `G.op ⋙ _` pulls sheaves back to sheaves.

This result is basically https://stacks.math.columbia.edu/tag/00WW.
-/
theorem pullback_is_sheaf_of_cover_preserving {G : C ⥤ D} (hG₁ : compatible_preserving.{v₃} K G)
  (hG₂ : cover_preserving J K G) (ℱ : Sheaf K A) :
  presheaf.is_sheaf J (G.op ⋙ ℱ.val) :=
begin
  intros X U S hS x hx,
  change family_of_elements (G.op ⋙ ℱ.val ⋙ coyoneda.obj (op X)) _ at x,
  let H := ℱ.2 X _ (hG₂.cover_preserve hS),
  let hx' := hx.functor_pushforward hG₁ (sheaf_over ℱ X),
  split, swap,
  { apply H.amalgamate (x.functor_pushforward G),
    exact hx' },
  split,
  { intros V f hf,
    convert H.is_amalgamation hx' (G.map f) (image_mem_functor_pushforward G S hf),
    rw hG₁.apply_map (sheaf_over ℱ X) hx },
  { intros y hy,
    refine H.is_separated_for _ y _ _
      (H.is_amalgamation (hx.functor_pushforward hG₁ (sheaf_over ℱ X))),
    rintros V f ⟨Z, f', g', h, rfl⟩,
    erw family_of_elements.comp_of_compatible (S.functor_pushforward G)
      hx' (image_mem_functor_pushforward G S h) g',
    dsimp,
    simp [hG₁.apply_map (sheaf_over ℱ X) hx h, ←hy f' h] }
end

/-- The pullback of a sheaf along a cover-preserving and compatible-preserving functor. -/
def pullback_sheaf {G : C ⥤ D} (hG₁ : compatible_preserving K G)
  (hG₂ : cover_preserving J K G) (ℱ : Sheaf K A) : Sheaf J A :=
⟨G.op ⋙ ℱ.val, pullback_is_sheaf_of_cover_preserving hG₁ hG₂ ℱ⟩

variable (A)

/--
The induced functor from `Sheaf K A ⥤ Sheaf J A` given by `G.op ⋙ _`
if `G` is cover-preserving and compatible-preserving.
-/
@[simps] def sites.pullback {G : C ⥤ D} (hG₁ : compatible_preserving K G)
  (hG₂ : cover_preserving J K G) : Sheaf K A ⥤ Sheaf J A :=
{ obj := λ ℱ, pullback_sheaf hG₁ hG₂ ℱ,
  map := λ _ _ f, ⟨(((whiskering_left _ _ _).obj G.op)).map f.val⟩,
  map_id' := λ ℱ, by { ext1, apply (((whiskering_left _ _ _).obj G.op)).map_id },
  map_comp' := λ _ _ _ f g, by { ext1, apply (((whiskering_left _ _ _).obj G.op)).map_comp } }

end category_theory

namespace category_theory

variables {C : Type v₁} [small_category C] {D : Type v₁} [small_category D]
variables (A : Type u₂) [category.{v₁} A]
variables (J : grothendieck_topology C) (K : grothendieck_topology D)

instance [has_limits A] : creates_limits (Sheaf_to_presheaf J A) :=
category_theory.Sheaf.category_theory.Sheaf_to_presheaf.category_theory.creates_limits.{u₂ v₁ v₁}

-- The assumptions so that we have sheafification
variables [concrete_category.{v₁} A] [preserves_limits (forget A)] [has_colimits A] [has_limits A]
variables [preserves_filtered_colimits (forget A)] [reflects_isomorphisms (forget A)]

local attribute [instance] reflects_limits_of_reflects_isomorphisms

instance {X : C} : is_cofiltered (J.cover X) := infer_instance

/-- The pushforward functor `Sheaf J A ⥤ Sheaf K A` associated to a functor `G : C ⥤ D` in the
same direction as `G`. -/
@[simps] def sites.pushforward (G : C ⥤ D) : Sheaf J A ⥤ Sheaf K A :=
Sheaf_to_presheaf J A ⋙ Lan G.op ⋙ presheaf_to_Sheaf K A

instance (G : C ⥤ D) [representably_flat G] :
  preserves_finite_limits (sites.pushforward A J K G) :=
begin
  apply_with comp_preserves_finite_limits { instances := ff },
  { apply_instance },
  apply_with comp_preserves_finite_limits { instances := ff },
  { apply category_theory.Lan_preserves_finite_limits_of_flat },
  { apply category_theory.presheaf_to_Sheaf.limits.preserves_finite_limits.{u₂ v₁ v₁},
    apply_instance }
end

/-- The pushforward functor is left adjoint to the pullback functor. -/
def sites.pullback_pushforward_adjunction {G : C ⥤ D} (hG₁ : compatible_preserving K G)
  (hG₂ : cover_preserving J K G) : sites.pushforward A J K G ⊣ sites.pullback A hG₁ hG₂ :=
((Lan.adjunction A G.op).comp _ _ (sheafification_adjunction K A)).restrict_fully_faithful
  (Sheaf_to_presheaf J A) (𝟭 _)
  (nat_iso.of_components (λ _, iso.refl _)
    (λ _ _ _,(category.comp_id _).trans (category.id_comp _).symm))
  (nat_iso.of_components (λ _, iso.refl _)
    (λ _ _ _,(category.comp_id _).trans (category.id_comp _).symm))

end category_theory


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

Additional equiv and encodable instances for lists, finsets, and fintypes.
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.equiv.denumerable
import Mathlib.data.finset.sort
import Mathlib.PostPort

universes u_1 u_2

namespace Mathlib

namespace encodable

def encode_list {α : Type u_1} [encodable α] : List α → ℕ := sorry

def decode_list {α : Type u_1} [encodable α] : ℕ → Option (List α) := sorry

protected instance list {α : Type u_1} [encodable α] : encodable (List α) :=
  mk encode_list decode_list sorry

@[simp] theorem encode_list_nil {α : Type u_1} [encodable α] : encode [] = 0 := rfl

@[simp] theorem encode_list_cons {α : Type u_1} [encodable α] (a : α) (l : List α) :
    encode (a :: l) = Nat.succ (nat.mkpair (encode a) (encode l)) :=
  rfl

@[simp] theorem decode_list_zero {α : Type u_1} [encodable α] : decode (List α) 0 = some [] := rfl

@[simp] theorem decode_list_succ {α : Type u_1} [encodable α] (v : ℕ) :
    decode (List α) (Nat.succ v) =
        (fun (_x : α) (_y : List α) => _x :: _y) <$> decode α (prod.fst (nat.unpair v)) <*>
          decode (List α) (prod.snd (nat.unpair v)) :=
  sorry

theorem length_le_encode {α : Type u_1} [encodable α] (l : List α) : list.length l ≤ encode l :=
  sorry

def encode_multiset {α : Type u_1} [encodable α] (s : multiset α) : ℕ :=
  encode (multiset.sort enle s)

def decode_multiset {α : Type u_1} [encodable α] (n : ℕ) : Option (multiset α) :=
  coe <$> decode (List α) n

protected instance multiset {α : Type u_1} [encodable α] : encodable (multiset α) :=
  mk encode_multiset decode_multiset sorry

def encodable_of_list {α : Type u_1} [DecidableEq α] (l : List α) (H : ∀ (x : α), x ∈ l) :
    encodable α :=
  mk (fun (a : α) => list.index_of a l) (list.nth l) sorry

def trunc_encodable_of_fintype (α : Type u_1) [DecidableEq α] [fintype α] : trunc (encodable α) :=
  quot.rec_on_subsingleton (finset.val finset.univ)
    (fun (l : List α) (H : ∀ (x : α), x ∈ Quot.mk setoid.r l) => trunc.mk (encodable_of_list l H))
    finset.mem_univ

/-- A noncomputable way to arbitrarily choose an ordering on a finite type.
  It is not made into a global instance, since it involves an arbitrary choice.
  This can be locally made into an instance with `local attribute [instance] fintype.encodable`. -/
def fintype.encodable (α : Type u_1) [fintype α] : encodable α :=
  trunc.out (trunc_encodable_of_fintype α)

protected instance vector {α : Type u_1} [encodable α] {n : ℕ} : encodable (vector α n) :=
  encodable.subtype

protected instance fin_arrow {α : Type u_1} [encodable α] {n : ℕ} : encodable (fin n → α) :=
  of_equiv (vector α n) (equiv.symm (equiv.vector_equiv_fin α n))

protected instance fin_pi (n : ℕ) (π : fin n → Type u_1) [(i : fin n) → encodable (π i)] :
    encodable ((i : fin n) → π i) :=
  of_equiv
    (↥(set_of fun (f : fin n → sigma fun (i : fin n) => π i) => ∀ (i : fin n), sigma.fst (f i) = i))
    (equiv.pi_equiv_subtype_sigma (fin n) π)

protected instance array {α : Type u_1} [encodable α] {n : ℕ} : encodable (array n α) :=
  of_equiv (fin n → α) (equiv.array_equiv_fin n α)

protected instance finset {α : Type u_1} [encodable α] : encodable (finset α) :=
  of_equiv (Subtype fun (s : multiset α) => multiset.nodup s)
    (equiv.mk (fun (_x : finset α) => sorry)
      (fun (_x : Subtype fun (s : multiset α) => multiset.nodup s) => sorry) sorry sorry)

def fintype_arrow (α : Type u_1) (β : Type u_2) [DecidableEq α] [fintype α] [encodable β] :
    trunc (encodable (α → β)) :=
  trunc.map
    (fun (f : α ≃ fin (fintype.card α)) =>
      of_equiv (fin (fintype.card α) → β) (equiv.arrow_congr f (equiv.refl β)))
    (fintype.equiv_fin α)

def fintype_pi (α : Type u_1) (π : α → Type u_2) [DecidableEq α] [fintype α]
    [(a : α) → encodable (π a)] : trunc (encodable ((a : α) → π a)) :=
  trunc.bind (trunc_encodable_of_fintype α)
    fun (a : encodable α) =>
      trunc.bind (fintype_arrow α (sigma fun (a : α) => π a))
        fun (f : encodable (α → sigma fun (a : α) => π a)) =>
          trunc.mk
            (of_equiv
              (Subtype
                fun (a : α → sigma fun (a : α) => π a) =>
                  a ∈
                    set_of fun (f : α → sigma fun (a : α) => π a) => ∀ (i : α), sigma.fst (f i) = i)
              (equiv.pi_equiv_subtype_sigma α π))

/-- The elements of a `fintype` as a sorted list. -/
def sorted_univ (α : Type u_1) [fintype α] [encodable α] : List α :=
  finset.sort (⇑(encode' α) ⁻¹'o LessEq) finset.univ

theorem mem_sorted_univ {α : Type u_1} [fintype α] [encodable α] (x : α) : x ∈ sorted_univ α :=
  iff.mpr (finset.mem_sort (⇑(encode' α) ⁻¹'o LessEq)) (finset.mem_univ x)

theorem length_sorted_univ {α : Type u_1} [fintype α] [encodable α] :
    list.length (sorted_univ α) = fintype.card α :=
  finset.length_sort (⇑(encode' α) ⁻¹'o LessEq)

theorem sorted_univ_nodup {α : Type u_1} [fintype α] [encodable α] : list.nodup (sorted_univ α) :=
  finset.sort_nodup (⇑(encode' α) ⁻¹'o LessEq) finset.univ

/-- An encodable `fintype` is equivalent a `fin`.-/
def fintype_equiv_fin {α : Type u_1} [fintype α] [encodable α] : α ≃ fin (fintype.card α) :=
  equiv.trans (fintype.equiv_fin_of_forall_mem_list mem_sorted_univ sorted_univ_nodup)
    (equiv.cast sorry)

protected instance fintype_arrow_of_encodable {α : Type u_1} {β : Type u_2} [encodable α]
    [fintype α] [encodable β] : encodable (α → β) :=
  of_equiv (fin (fintype.card α) → β) (equiv.arrow_congr fintype_equiv_fin (equiv.refl β))

end encodable

namespace denumerable

theorem denumerable_list_aux {α : Type u_1} [denumerable α] (n : ℕ) :
    ∃ (a : List α), ∃ (H : a ∈ encodable.decode_list n), encodable.encode_list a = n :=
  sorry

protected instance denumerable_list {α : Type u_1} [denumerable α] : denumerable (List α) :=
  mk denumerable_list_aux

@[simp] theorem list_of_nat_zero {α : Type u_1} [denumerable α] : of_nat (List α) 0 = [] := rfl

@[simp] theorem list_of_nat_succ {α : Type u_1} [denumerable α] (v : ℕ) :
    of_nat (List α) (Nat.succ v) =
        of_nat α (prod.fst (nat.unpair v)) :: of_nat (List α) (prod.snd (nat.unpair v)) :=
  sorry

def lower : List ℕ → ℕ → List ℕ := sorry

def raise : List ℕ → ℕ → List ℕ := sorry

theorem lower_raise (l : List ℕ) (n : ℕ) : lower (raise l n) n = l := sorry

theorem raise_lower {l : List ℕ} {n : ℕ} : list.sorted LessEq (n :: l) → raise (lower l n) n = l :=
  sorry

theorem raise_chain (l : List ℕ) (n : ℕ) : list.chain LessEq n (raise l n) := sorry

theorem raise_sorted (l : List ℕ) (n : ℕ) : list.sorted LessEq (raise l n) := sorry

/- Warning: this is not the same encoding as used in `encodable` -/

protected instance multiset {α : Type u_1} [denumerable α] : denumerable (multiset α) :=
  mk'
    (equiv.mk
      (fun (s : multiset α) =>
        encodable.encode (lower (multiset.sort LessEq (multiset.map encodable.encode s)) 0))
      (fun (n : ℕ) => multiset.map (of_nat α) ↑(raise (of_nat (List ℕ) n) 0)) sorry sorry)

def lower' : List ℕ → ℕ → List ℕ := sorry

def raise' : List ℕ → ℕ → List ℕ := sorry

theorem lower_raise' (l : List ℕ) (n : ℕ) : lower' (raise' l n) n = l := sorry

theorem raise_lower' {l : List ℕ} {n : ℕ} :
    (∀ (m : ℕ), m ∈ l → n ≤ m) → list.sorted Less l → raise' (lower' l n) n = l :=
  sorry

theorem raise'_chain (l : List ℕ) {m : ℕ} {n : ℕ} : m < n → list.chain Less m (raise' l n) := sorry

theorem raise'_sorted (l : List ℕ) (n : ℕ) : list.sorted Less (raise' l n) := sorry

def raise'_finset (l : List ℕ) (n : ℕ) : finset ℕ := finset.mk ↑(raise' l n) sorry

/- Warning: this is not the same encoding as used in `encodable` -/

protected instance finset {α : Type u_1} [denumerable α] : denumerable (finset α) :=
  mk'
    (equiv.mk
      (fun (s : finset α) =>
        encodable.encode
          (lower' (finset.sort LessEq (finset.map (equiv.to_embedding (eqv α)) s)) 0))
      (fun (n : ℕ) =>
        finset.map (equiv.to_embedding (equiv.symm (eqv α))) (raise'_finset (of_nat (List ℕ) n) 0))
      sorry sorry)

end denumerable

namespace equiv

/-- The type lists on unit is canonically equivalent to the natural numbers. -/
def list_unit_equiv : List Unit ≃ ℕ := mk list.length (list.repeat Unit.unit) sorry sorry

def list_nat_equiv_nat : List ℕ ≃ ℕ := denumerable.eqv (List ℕ)

def list_equiv_self_of_equiv_nat {α : Type} (e : α ≃ ℕ) : List α ≃ α :=
  equiv.trans (equiv.trans (list_equiv_of_equiv e) list_nat_equiv_nat) (equiv.symm e)

end Mathlib


import category_theory.shift

noncomputable theory

namespace category_theory

open category

namespace monoidal_functor

variables {C D : Type*} [category C] [monoidal_category C]
  [category D] [monoidal_category D]
  (F : monoidal_functor C D) (comm : ∀ (X Y : C), X ⊗ Y ≅ Y ⊗ X)
  (commσ : ∀ (X Y Z : C), comm Z (X ⊗ Y) ≪≫ α_ X Y Z =
    (α_ Z X Y).symm ≪≫ (comm Z X ⊗ (iso.refl Y)) ≪≫ α_ X Z Y ≪≫ (iso.refl X ⊗ comm Z Y))

def associativity_iso_eq (X Y Z : C) :
  (F.μ_iso X Y ⊗ (iso.refl (F.obj Z))) ≪≫ F.μ_iso (X ⊗ Y) Z ≪≫
  F.map_iso (α_ X Y Z) =
    α_ (F.obj X) (F.obj Y) (F.obj Z) ≪≫
   (iso.refl (F.obj X) ⊗ (F.μ_iso Y Z)) ≪≫ F.μ_iso X (Y ⊗ Z) :=
begin
  ext,
  apply F.associativity
end

lemma apply_α (X Y Z : C) : F.map (α_ X Y Z).hom =
  (F.μ_iso (X ⊗ Y) Z).inv ≫ ((F.μ_iso X Y).inv ⊗ 𝟙 (F.obj Z)) ≫
  (α_ (F.obj X) (F.obj Y) (F.obj Z)).hom ≫
  (𝟙 (F.obj X) ⊗ (F.μ_iso Y Z).hom) ≫ (F.μ_iso X (Y ⊗ Z)).hom :=
by simpa only [← cancel_epi ((F.μ_iso (X ⊗ Y) Z).hom),
    ← cancel_epi ((F.μ_iso X Y).hom ⊗ 𝟙 (F.obj Z)),
    iso.hom_inv_id_assoc, assoc, ← monoidal_category.tensor_comp_assoc,
    iso.hom_inv_id, id_comp, monoidal_category.tensor_id]
    using F.associativity X Y Z

lemma apply_α_inv (X Y Z : C) : F.map (α_ X Y Z).inv =
  (F.μ_iso X (Y ⊗ Z)).inv ≫ (𝟙 (F.obj X) ⊗ (F.μ_iso Y Z).inv) ≫
  (α_ (F.obj X) (F.obj Y) (F.obj Z)).inv ≫
  ((F.μ_iso X Y).hom ⊗ 𝟙 (F.obj Z)) ≫
  (F.μ_iso (X ⊗ Y) Z).hom :=
begin
  rw [← cancel_mono (F.map (α_ X Y Z).hom), ← F.map_comp, iso.inv_hom_id, F.map_id, apply_α],
  simp only [assoc, iso.hom_inv_id_assoc, ← monoidal_category.tensor_comp_assoc,
      iso.hom_inv_id, comp_id, monoidal_category.tensor_id, id_comp,
      iso.inv_hom_id_assoc, iso.inv_hom_id],
end

def comm' (X Y : C) : F.obj X ⊗ F.obj Y ≅ F.obj Y ⊗ F.obj X :=
F.μ_iso X Y ≪≫ F.map_iso (comm X Y) ≪≫ (F.μ_iso Y X).symm

include commσ

lemma compatibility (X Y Z : C) :
  F.comm' comm Z (X ⊗ Y) ≪≫
    ((F.μ_iso X Y).symm ⊗ (iso.refl (F.obj Z))) ≪≫ α_ _ _ _ =
    (iso.refl (F.obj Z) ⊗ (F.μ_iso X Y).symm) ≪≫
    (α_ _ _ _).symm ≪≫
    (F.comm' comm Z X ⊗ iso.refl (F.obj Y)) ≪≫ α_ _ _ _ ≪≫
    (iso.refl (F.obj X) ⊗ F.comm' comm Z Y) :=
begin
  ext,
  have eq := (F.μ_iso Z (X ⊗ Y)).hom ≫=
    F.congr_map (congr_arg iso.hom (commσ X Y Z)),
  dsimp only [iso.trans, iso.symm, iso.refl, comm', functor.map_iso,
    tensor_iso_hom] at ⊢ eq,
  simp only [F.map_comp, assoc] at eq ⊢,
  simp only [F.apply_α X Y Z, ← cancel_mono ((F.μ_iso X (Y ⊗ Z)).inv), assoc,
    iso.hom_inv_id, comp_id,
    ← cancel_mono ((𝟙 (F.to_lax_monoidal_functor.to_functor.obj X) ⊗ (F.μ_iso Y Z).inv)),
    ← monoidal_category.tensor_comp, monoidal_category.tensor_id] at eq,
  rw eq, clear eq,
  rw F.apply_α_inv,
  simp only [assoc],
  erw iso.hom_inv_id_assoc,
  congr' 2,
  simp only [monoidal_category.comp_tensor_id, monoidal_category.id_tensor_comp, assoc],
  congr' 1,
  rw F.apply_α,
  simp only [← assoc],
  congr' 1,
  simp only [assoc],
  conv_lhs { rw [← assoc, ← assoc, ← assoc], },
  conv_rhs { rw ← assoc, },
  congr' 3,
  { simp only [μ_iso_hom, assoc, ← F.μ_natural_assoc, functor.map_id, μ_hom_inv_id, comp_id], },
  { simp only [μ_iso_hom, ← F.μ_natural_assoc, functor.map_id, μ_hom_inv_id, comp_id], },
end

end monoidal_functor

section

variables (C : Type*) [category C] {A : Type*} [add_comm_monoid A]
  [has_shift C A]

def shift_functor_add_comm (a₁ a₂ : A) :
  shift_functor C a₁ ⋙ shift_functor C a₂ ≅
  shift_functor C a₂ ⋙ shift_functor C a₁ :=
(shift_functor_add C a₁ a₂).symm ≪≫ eq_to_iso (by rw add_comm a₁ a₂) ≪≫ (shift_functor_add C a₂ a₁)

@[simp]
lemma shift_functor_add_comm_hom_app (a₁ a₂ : A) (X : C) :
  (shift_functor_add_comm C a₁ a₂).hom.app X  = (shift_functor_add C a₁ a₂).inv.app X ≫
  eq_to_hom (by rw add_comm a₁ a₂) ≫ (shift_functor_add C a₂ a₁).hom.app X :=
begin
  dsimp only [shift_functor_add_comm, iso.trans, eq_to_iso],
  simp only [iso.symm_hom, nat_trans.comp_app, eq_to_hom_app],
end

@[simp]
lemma shift_functor_add_comm_eq_refl (a : A) :
  shift_functor_add_comm C a a = iso.refl _ :=
begin
  ext X,
  dsimp only [shift_functor_add_comm, iso.trans, eq_to_iso, iso.symm, iso.refl],
  rw [eq_to_hom_refl, id_comp, iso.inv_hom_id],
end

local attribute [instance, reducible] endofunctor_monoidal_category
local attribute [reducible] discrete.add_monoidal

lemma shift_compatibility (a₁ a₂ a₃ : A) (X : C) :
  (shift_functor_add_comm C a₃ (a₁ + a₂)).hom.app X ≫
  (shift_functor C a₃).map ((shift_functor_add C a₁ a₂).app X).hom =
  (shift_functor_add C a₁ a₂).hom.app ((shift_functor C a₃).obj X) ≫
  (shift_functor C a₂).map ((shift_functor_add_comm C a₃ a₁).hom.app X) ≫
  (shift_functor_add_comm C a₃ a₂).hom.app ((shift_functor C a₁).obj X) :=
begin
  let Acomm : Π (a₁ a₂ : discrete A), a₁ ⊗ a₂ ≅ a₂ ⊗ a₁,
  { rintros ⟨a₁⟩ ⟨a₂⟩,
    refine eq_to_iso _,
    dsimp,
    rw add_comm, },
  have Acommeq : Π (a₁ a₂ : A) (X' : C),
    ((shift_monoidal_functor C A).comm' Acomm ⟨a₁⟩ ⟨a₂⟩).hom.app X' =
     (shift_functor_add_comm C a₁ a₂).hom.app X',
  { intros a₁ a₂ X',
    dsimp [shift_functor_add_comm, monoidal_functor.comm'],
    rw eq_to_hom_map, },
  have h₁ := (shift_monoidal_functor C A).compatibility
    Acomm (by tidy) ⟨a₁⟩ ⟨a₂⟩ ⟨a₃⟩, swap,
  have h₂ := congr_arg (λ (e : _ ≅ _), e.hom) h₁,
  have h₃ := congr_app h₂ X,
  clear h₁ h₂,
  dsimp [iso.trans] at h₃,
  simpa only [Acommeq, id_comp, comp_id, functor.map_id, assoc] using h₃,
end

end

end category_theory


import pseudo_normed_group.Tinv
import rescale.CLC

open_locale classical nnreal
noncomputable theory
local attribute [instance] type_pow
open opposite ProFiltPseuNormGrpWithTinv category_theory

universe variable u
variables (r : ℝ≥0) (V : SemiNormedGroup) [normed_with_aut r V] [fact (0 < r)]
variables (r' : ℝ≥0) [fact (0 < r')] [fact (r' ≤ 1)]
variables (M : ProFiltPseuNormGrpWithTinv.{u} r')
variables (c c₁ c₂ c₃ c₄ : ℝ≥0) {m n : ℕ}

namespace breen_deligne

open CLCFPTinv

namespace universal_map

variables (ϕ : universal_map m n)

local attribute [semireducible] CLCFPTinv₂ CLCFPTinv₂.res
  breen_deligne.universal_map.eval_CLCFPTinv₂

theorem eval_CLCFPTinv₂_rescale
  [fact (c₂ ≤ r' * c₁)] [fact (c₄ ≤ r' * c₃)] [ϕ.suitable c₃ c₁] [ϕ.suitable c₄ c₂]
  (N : ℝ≥0) [fact (c₂ * N⁻¹ ≤ r' * (c₁ * N⁻¹))] [fact (c₄ * N⁻¹ ≤ r' * (c₃ * N⁻¹))]
  (M : ProFiltPseuNormGrpWithTinv r') :
  arrow.mk ((eval_CLCFPTinv₂ r V r' c₁ c₂ c₃ c₄ ϕ).app (op (of r' (rescale N M)))) =
  arrow.mk ((eval_CLCFPTinv₂ r V r' (c₁ * N⁻¹) (c₂ * N⁻¹) (c₃ * N⁻¹) (c₄ * N⁻¹) ϕ).app (op M)) :=
begin
  dsimp only [universal_map.eval_CLCFPTinv₂, _root_.id, SemiNormedGroup.equalizer.map_nat_app],
  refine SemiNormedGroup.equalizer.map_congr _ _ rfl rfl rfl rfl;
  { exact universal_map.eval_CLCFP_rescale V r' _ _ _ _ _ N M },
end

end universal_map
end breen_deligne


open tactic expr

set_option pp.all true

example (a b c x y : nat) (H : nat.add (nat.add x y) y = 0) : true :=
by do
  a ← get_local `a, b ← get_local `b, c ← get_local `c,
  nat_add : expr ← mk_const `nat.add,
  p : pattern    ← mk_pattern [] [a, b] (app_of_list nat_add [a, b]) [] [app_of_list nat_add [b, a], a, b],
  trace (pattern.moutput p),
  H ← get_local `H >>= infer_type,
  lhs_rhs ← match_eq H,
  r     ← match_pattern p (prod.fst lhs_rhs),
  trace r,
  constructor