/-
Copyright (c) 2018-2019 Minchao Wu. All rights reserved.
Released under MIT license as described in the file LICENSE.
Author: Minchao Wu
-/

import defs
open nnf tactic

meta def frame_restriction : tactic unit :=
do intro `a >> `[simp]

structure KT (states : Type) extends kripke states :=
(refl : reflexive rel . frame_restriction)

instance inhabited_KT : inhabited (KT ℕ) :=
⟨{ val := λ a b, tt, rel := λ a b, tt }⟩

@[simp] def force {states : Type} (k : KT states) : states → nnf → Prop
| s (var n)    := k.val n s
| s (neg n)    := ¬ k.val n s
| s (and φ ψ)  := force s φ ∧ force s ψ
| s (or φ ψ)   := force s φ ∨ force s ψ
| s (box φ)    := ∀ s', k.rel s s' → force s' φ
| s (dia φ)    := ∃ s', k.rel s s' ∧ force s' φ

def sat {st} (k : KT st) (s) (Γ : list nnf) : Prop :=
∀ φ ∈ Γ, force k s φ

def unsatisfiable (Γ : list nnf) : Prop :=
∀ (st) (k : KT st) s, ¬ sat k s Γ

theorem unsat_singleton {φ} : unsatisfiable [φ] → ∀ (st) (k : KT st) s, ¬ force k s φ
 :=
begin
  intro h, intros, intro hf,
  apply h, intros ψ hψ, rw list.mem_singleton at hψ, rw hψ, exact hf
end

theorem sat_of_empty {st} (k : KT st) (s) : sat k s [] :=
λ φ h, absurd h $ list.not_mem_nil _

theorem ne_empty_of_unsat {Γ} (h : unsatisfiable Γ): Γ ≠ [] :=
begin
  intro heq, rw heq at h,
  apply h, apply sat_of_empty, exact nat,
  apply inhabited_KT.1, exact 0
end

inductive model
| cons : list ℕ → list model → model

instance : decidable_eq model := by tactic.mk_dec_eq_instance

open model

@[simp] def mval : ℕ → model → bool
| p (cons v r) := p ∈ v

@[simp] def mrel : model → model → bool
| m₁@(cons v r) m₂ := m₂ ∈ r ∨ m₁ = m₂

theorem refl_mrel (s : model) : mrel s s := by cases s with v r; simp

theorem mem_of_mrel_tt : Π {v r m}, mrel (cons v r) m = tt → m ∈ r ∨ cons v r = m :=
begin
  intros v r m h, by_cases hc : cons v r = m,
  {right, exact hc},{left, by_contradiction hn,
  have : mrel (cons v r) m = ff, { simp [hc, hn] },
  rw h at this, contradiction}
end

-- TODO : make this neater. Currently it's just a copy-paste
theorem mem_of_mrel_empty : Π {v m}, mrel (cons v []) m = tt → cons v [] = m :=
begin
  intros v m h, by_cases hc : cons v [] = m,
  {exact hc},
  {by_contradiction hn,
  have : mrel (cons v []) m = ff, { simp [hc, hn] },
  rw h at this, contradiction}
end

@[simp] def builder : KT model :=
{val := λ n s, mval n s, rel := λ s₁ s₂, mrel s₁ s₂, refl := refl_mrel}

theorem force_box_of_leaf {v φ} (h : force builder (cons v []) φ):
force builder (cons v []) (box φ) :=
begin
  dsimp, intros s' hs',
  have : cons v [] = s', {apply mem_of_mrel_empty, exact hs'},
  rw ←this, assumption
end

def srefl (m h : list nnf) :=
∀ {v l φ}, sat builder (cons v l) m →
box φ ∈ h →
(∀ ψ, box ψ ∈ h → ∀ m ∈ l, force builder m ψ) →
force builder (cons v l) φ

structure seqt : Type :=
(main : list nnf)
(hdld : list nnf)
-- srefl main hdld says that sequent hdld | main satisfies theorem 3.7(2)
(pmain : srefl main hdld)
-- box_only says there are only boxed formulas in hdld
(phdld : box_only hdld)

class val_constructible (Γ : seqt) :=
(satu : saturated Γ.main)
(no_box_main : ∀ {φ}, box φ ∉ Γ.main)
(no_contra_main : ∀ {n}, var n ∈ Γ.main → neg n ∉ Γ.main)
(v : list ℕ)
(hv : ∀ n, var n ∈ Γ.main ↔ n ∈ v)

class modal_applicable (Γ : seqt) extends val_constructible Γ :=
(φ : nnf)
(ex : dia φ ∈ Γ.main)

class model_constructible (Γ : seqt) extends val_constructible Γ :=
(no_dia : ∀ {φ}, nnf.dia φ ∉ Γ.main)

theorem build_model : Π Γ (h : model_constructible Γ),
sat builder (cons h.v []) Γ.main :=
begin
  intros, intro, intro hmem,
  cases heq : φ,
  case nnf.var : n {dsimp, have := h.hv, rw heq at hmem, rw this at hmem, simp [hmem]},
  case nnf.neg : n {dsimp, have h₁ := h.hv, rw heq at hmem, have := h.no_contra_main, simp, rw ←h₁, intro hvar, apply this, swap, exact hmem, exact hvar},
  case nnf.box : ψ {dsimp, intros, have := h.no_box_main, exfalso, rw heq at hmem, exact this hmem},
  case nnf.and : φ ψ { rw heq at hmem, have := h.satu.no_and, have := @this φ ψ, contradiction},
  case nnf.or : φ ψ { rw heq at hmem, have := h.satu.no_or, have := @this φ ψ, contradiction},
  case nnf.dia : φ { rw heq at hmem, have := h.no_dia, have := @this φ, contradiction},
end

/- Regular lemmas for the propositional part. -/

section
variables (φ ψ : nnf) (Γ₁ Γ₂ Δ Λ: list nnf) {st : Type}
variables (k : KT st) (s : st)
open list

theorem sat_subset (h₁ : Γ₁ ⊆ Γ₂) (h₂ : sat k s Γ₂) : sat k s Γ₁ :=
λ x hx, h₂ _ (h₁ hx)

theorem sat_sublist (h₁ : Γ₁ <+ Γ₂) (h₂ :sat k s Γ₂) : sat k s Γ₁ :=
sat_subset _ _ _ _ (sublist.subset h₁) h₂

theorem sat_append (h₁ : sat k s Γ₁) (h₂ : sat k s Γ₂) : sat k s (Γ₁ ++ Γ₂) :=
begin
  intros φ h, rw mem_append at h, cases h,
  apply h₁ _ h, apply h₂ _ h
end

theorem unsat_contra  {Δ n} : var n ∈ Δ →  neg n ∈ Δ →  unsatisfiable Δ:=
begin
  intros h₁ h₂, intros v hsat, intros s hsat,
  have := hsat _ h₁, have := hsat _ h₂, simpa
end

theorem unsat_contra_seqt {Δ : seqt} {n} : var n ∈ Δ.main →  neg n ∈ Δ.main →  unsatisfiable (Δ.main ++ Δ.hdld):=
begin
  intros h₁ h₂, intros st m, intros s hsat,
  have := unsat_contra h₁ h₂,
  have := this _ m s,
  apply this,
  apply sat_subset _ _ _ _ _ hsat,
  simp
end

theorem sat_of_and : force k s (and φ ψ) ↔ (force k s φ) ∧ (force k s ψ) :=
by split; {intro, simpa}

theorem sat_of_sat_erase (h₁ : sat k s $ Δ.erase φ) (h₂ : force k s φ) : sat k s Δ :=
begin
  intro ψ, intro h,
  by_cases (ψ = φ),
  {rw h, assumption},
  {have : ψ ∈ Δ.erase φ,
   rw mem_erase_of_ne, assumption, exact h,
   apply h₁, assumption}
end

theorem unsat_and_of_unsat_split
        (h₁ : and φ ψ ∈ Δ)
        (h₂ : unsatisfiable $ φ :: ψ :: Δ.erase (and φ ψ)) :
        unsatisfiable Δ :=
begin
  intro st, intros, intro h,
  apply h₂, swap 3, exact k, swap, exact s,
  intro e, intro he,
  cases he,
  {rw he, have := h _ h₁, rw sat_of_and at this, exact this.1},
  {cases he,
    {rw he, have := h _ h₁, rw sat_of_and at this, exact this.2},
    {have := h _ h₁, apply h, apply mem_of_mem_erase he} }
end

theorem unsat_and_of_unsat_split_seqt {Γ}
        (h₁ : and φ ψ ∈ Δ)
        (h₂ : unsatisfiable $ (φ :: ψ :: Δ.erase (and φ ψ)++Γ)) :
        unsatisfiable (Δ++Γ) :=
begin
  intro st, intros, intro h,
  apply h₂, swap 3, exact k, swap, exact s,
  intro e, intro he,
  cases he,
  {rw he, have := h _ (mem_append_left _ h₁), rw sat_of_and at this, exact this.1},
  {cases he,
    {rw he, have := h _ (mem_append_left _ h₁), rw sat_of_and at this, exact this.2},
    {have := h _ (mem_append_left _ h₁), apply h, apply mem_of_mem_erase, rw erase_append_left, exact he, exact h₁} }
end

theorem sat_and_of_sat_split
        (h₁ : and φ ψ ∈ Δ)
        (h₂ : sat k s $ φ :: ψ :: Δ.erase (and φ ψ)) :
        sat k s Δ :=
begin
  intro e, intro he,
  by_cases (e = and φ ψ),
  { rw h, dsimp, split, repeat {apply h₂, simp} },
  { have : e ∈ Δ.erase (and φ ψ),
      { rw mem_erase_of_ne, repeat { assumption } },
    apply h₂, simp [this] }
end

theorem sat_and_of_sat_split_seqt {Γ}
        (h₁ : and φ ψ ∈ Δ)
        (h₂ : sat k s $ (φ :: ψ :: Δ.erase (and φ ψ)++Γ)) :
        sat k s (Δ++Γ) :=
begin
  intro e, intro he,
  by_cases (e = and φ ψ),
  { rw h, dsimp, split, repeat {apply h₂, simp} },
  { have : e ∈ Δ.erase (and φ ψ) ++ Γ,
      { rw ←erase_append_left, rw mem_erase_of_ne, repeat {assumption} },
    apply h₂, simp [this] }
end

theorem sat_split_of_sat_and_seqt {Γ}
        (h₁ : and φ ψ ∈ Δ)
        (h₂ : sat k s (Δ++Γ)) :
        sat k s $ (φ :: ψ :: Δ.erase (and φ ψ)++Γ) :=
begin
  intros e he, rw mem_append at he, cases he,
  have : force k s (and φ ψ), {apply h₂, simp [h₁]}, rw sat_of_and at this,
  {cases he,
  {rw he, exact this.left},
  {cases he, rw he, exact this.right, apply h₂, rw mem_append, left, apply mem_of_mem_erase he}
  },
  {apply h₂, rw mem_append, right, exact he}
end

theorem unsat_or_of_unsat_split_seqt {Γ}
        (h : or φ ψ ∈ Δ)
        (h₁ : unsatisfiable $ (φ :: Δ.erase (nnf.or φ ψ)++Γ))
        (h₂ : unsatisfiable $ (ψ :: Δ.erase (nnf.or φ ψ)++Γ)) :
        unsatisfiable $ (Δ++Γ) :=
begin
  intro, intros, intro hsat,
  have := hsat _ (mem_append_left _ h),
  dsimp at this,
  cases this,
  {apply h₁, swap 3, exact k, swap, exact s, intro e, intro he,
   cases he, rw he, exact this, apply hsat,
apply mem_of_mem_erase, rw erase_append_left, exact he, exact h},
  {apply h₂, swap 3, exact k, swap, exact s, intro e, intro he,
   cases he, rw he, exact this, apply hsat, apply mem_of_mem_erase, rw erase_append_left, exact he, exact h}
end

theorem sat_or_of_sat_split_left
        (h : or φ ψ ∈ Δ)
        (hl : sat k s $ φ :: Δ.erase (nnf.or φ ψ)) :
        sat k s Δ :=
begin
  intros e he,
  by_cases (e = or φ ψ),
  { rw h, dsimp, left, apply hl, simp},
  {have : e ∈ Δ.erase (or φ ψ),
     { rw mem_erase_of_ne, repeat { assumption } },
   apply hl, simp [this]}
end

theorem sat_or_of_sat_split_right
        (h : or φ ψ ∈ Δ)
        (hl : sat k s $ ψ :: Δ.erase (nnf.or φ ψ)) :
        sat k s Δ :=
begin
  intros e he,
  by_cases (e = or φ ψ),
  { rw h, dsimp, right, apply hl, simp},
  { have : e ∈ Δ.erase (or φ ψ),
      { rw mem_erase_of_ne, repeat { assumption } },
    apply hl, simp [this] }
end

/- KT-specific lemmas -/

theorem force_of_force_box (h : force k s $ box φ) : force k s φ
:= begin dsimp at h, apply h, apply k.refl end

theorem unsat_copy_of_unsat_box
        (h₁ : box φ ∈ Δ)
        (h₂ : unsatisfiable $ (φ :: Δ.erase (box φ)) ++ box φ :: Λ) :
        unsatisfiable (Δ ++ Λ) :=
begin
  intros st k s h,
  apply h₂, swap 3, exact k, swap, exact s,
  intros e he,
  rw [mem_append] at he,
  cases he,
  {cases he,
    {rw he, apply force_of_force_box, apply h (box φ), simp [h₁]},
    {apply h, rw mem_append, left, apply mem_of_mem_erase he }},
  {cases he,
    {rw ←he at h₁, apply h, rw mem_append, left, exact h₁},
    {apply h, rw mem_append, right, assumption}}
end

theorem sat_copy_of_sat_box
        (h₁ : box φ ∈ Δ)
        (h₂ : sat k s $ (φ :: Δ.erase (box φ)) ++ box φ :: Λ) :
        sat k s (Δ ++ Λ) :=
begin
  intros ψ hφ,
  rw mem_append at hφ,
  cases hφ,
  {by_cases heq : ψ = box φ,
    {rw heq, apply h₂ (box φ), simp},
    {have := mem_erase_of_ne heq, rw ←this at hφ, apply h₂, simp, right, left, exact hφ}},
  {apply h₂, simp, repeat {right}, exact hφ}
end

theorem sat_box_of_sat_copy
        (h₁ : box φ ∈ Δ)
        (h₂ : sat k s (Δ ++ Λ)) :
        sat k s $ (φ :: Δ.erase (box φ)) ++ box φ :: Λ :=
begin
  apply sat_append,
  {intros ψ h, cases h, have : sat k s Δ, {apply sat_subset Δ (Δ++Λ), simp, assumption}, have := this _ h₁, apply force_of_force_box, rw h, exact this, apply h₂, have := mem_of_mem_erase h, simp [this]},
  {intros ψ h, cases h, rw h, have := h₂ (box φ), apply this, simp [h₁], apply h₂, rw mem_append, right, exact h}
end

end

def and_child {φ ψ} (Γ : seqt) (h : nnf.and φ ψ ∈ Γ.main) : seqt :=
⟨φ :: ψ :: Γ.main.erase (and φ ψ), Γ.hdld,
begin
  intros k s γ hsat hin hall,
  by_cases heq : γ = and φ ψ,
  {rw heq, split, apply hsat, simp, apply hsat, simp},
  {apply Γ.pmain _ hin hall, apply sat_and_of_sat_split _ _ _ _ _ h hsat}
end,
Γ.phdld⟩

inductive and_instance_seqt (Γ : seqt) : seqt → Type
| cons : Π {φ ψ} (h : nnf.and φ ψ ∈ Γ.main),
         and_instance_seqt $ and_child Γ h

def or_child_left {φ ψ} (Γ : seqt) (h : nnf.or φ ψ ∈ Γ.main) : seqt :=
⟨φ :: Γ.main.erase (or φ ψ), Γ.hdld,
begin
  intros k s γ hsat hin hall,
  by_cases heq : γ = or φ ψ,
  {rw heq, dsimp, left, apply hsat, simp},
  {apply Γ.pmain, apply sat_or_of_sat_split_left, exact h, exact hsat, exact hin, exact hall}
end,
Γ.phdld⟩

def or_child_right {φ ψ} (Γ : seqt) (h : nnf.or φ ψ ∈ Γ.main) : seqt :=
⟨ψ :: Γ.main.erase (or φ ψ), Γ.hdld,
begin
  intros k s γ hsat hin hall,
  by_cases heq : γ = or φ ψ,
  {rw heq, dsimp, right, apply hsat, simp},
  {apply Γ.pmain, apply sat_or_of_sat_split_right, exact h, exact hsat, exact hin, exact hall}
end,
Γ.phdld⟩

inductive or_instance_seqt (Γ : seqt) : seqt → seqt → Type
| cons : Π {φ ψ} (h : nnf.or φ ψ ∈ Γ.main),
         or_instance_seqt (or_child_left Γ h) (or_child_right Γ h)

def box_child {φ} (Γ : seqt) (h : nnf.box φ ∈ Γ.main) : seqt :=
⟨φ :: Γ.main.erase (box φ), box φ :: Γ.hdld,
begin
  intros k s γ hsat hin hall,
  cases hin,
  {simp at hin, rw hin, apply hsat, simp},
  {apply Γ.pmain, intros ψ hψ,
   by_cases heq : ψ = box φ,
   {rw heq, dsimp, intros s' hs',
    have := mem_of_mrel_tt hs', cases this,
    {apply hall, simp, assumption},
    {rw ←this, apply hsat, simp} },
   {apply hsat, right,
    have := list.mem_erase_of_ne heq, swap, exact Γ.main,
    rw ←this at hψ, assumption},
  {assumption},{intros, apply hall, simp [a], exact H} }
end,
cons_box_only Γ.phdld⟩

inductive copy_instance_seqt (Γ : seqt) : seqt → Type
| cons : Π {φ} (h : nnf.box φ ∈ Γ.main),
         copy_instance_seqt $ box_child Γ h

theorem build_model_seqt : Π Γ (h : model_constructible Γ),
sat builder (cons h.v []) (Γ.main ++ Γ.hdld) :=
begin
  intros Γ h, apply sat_append, apply build_model,
  intros ψ hψ,
  have := box_only_ex Γ.phdld hψ, cases this with w hw,
  rw hw, apply force_box_of_leaf, apply Γ.pmain _ _,
  {intros ψ hin m hm, exfalso, apply list.not_mem_nil, exact hm},
  {apply build_model},
  {rw hw at hψ, assumption}
end


/-
Copyright (c) 2020 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.polynomial.ring_division
import Mathlib.data.mv_polynomial.rename
import Mathlib.ring_theory.polynomial.basic
import Mathlib.PostPort

universes u_1 u_2

namespace Mathlib

/-!
## Function extensionality for multivariate polynomials

In this file we show that two multivariate polynomials over an infinite integral domain are equal
if they are equal upon evaluating them on an arbitrary assignment of the variables.

# Main declaration

* `mv_polynomial.funext`: two polynomials `φ ψ : mv_polynomial σ R`
  over an infinite integral domain `R` are equal if `eval x φ = eval x ψ` for all `x : σ → R`.

-/

namespace mv_polynomial

/-- Two multivariate polynomials over an infinite integral domain are equal
if they are equal upon evaluating them on an arbitrary assignment of the variables. -/
theorem funext {R : Type u_1} [integral_domain R] [infinite R] {σ : Type u_2}
    {p : mv_polynomial σ R} {q : mv_polynomial σ R}
    (h : ∀ (x : σ → R), coe_fn (eval x) p = coe_fn (eval x) q) : p = q :=
  sorry

theorem funext_iff {R : Type u_1} [integral_domain R] [infinite R] {σ : Type u_2}
    {p : mv_polynomial σ R} {q : mv_polynomial σ R} :
    p = q ↔ ∀ (x : σ → R), coe_fn (eval x) p = coe_fn (eval x) q :=
  sorry

end Mathlib


/-
Copyright (c) 2018 Luca Gerolla. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Luca Gerolla, Kevin Buzzard
Definition of homotopy, properties and equivalence relation.
-/
import analysis.topology.continuity
import analysis.topology.topological_space
import analysis.topology.infinite_sum
import analysis.topology.topological_structures
import analysis.topology.uniform_space
import analysis.real
import data.real.basic tactic.norm_num
import data.set.basic
import Topology.Material.pasting_lemma
import Topology.Material.path
import Topology.Material.real_results

open set filter lattice classical
namespace homotopy
open path

variables {α  : Type*} [topological_space α ]
variables {β  : Type*} [topological_space β ] { x y z w : β  }
variables ( x0 : β  )
variable s : I01

noncomputable theory

local attribute [instance] classical.prop_decidable

-- HOMOTOPY

-- General Homotopy
structure homotopy  {f : α → β} {g : α → β} ( hcf : continuous f) ( hcg : continuous g) :=
(to_fun : I01 × α →  β )
(at_zero : ( λ x, to_fun ( 0 , x) ) = f )
(at_one : ( λ x, to_fun ( 1 , x) ) = g)
(cont :  continuous  to_fun )

structure path_homotopy ( f : path x y) ( g : path x y) :=
(to_fun : I01 × I01 →  β )
(path_s : ∀ s : I01, is_path x y ( λ t, to_fun (s, t) ) )
(at_zero : ∀ y, to_fun (0,y) = f.to_fun y )
(at_one :  ∀ y, to_fun (1,y) = g.to_fun y)
(cont : continuous to_fun)

-- Simp lemmas
@[simp]
lemma at_zero_path_hom { f : path x y } { g : path x y} (F : path_homotopy f g) (y : I01) :
F.to_fun (0, y) = path.to_fun f y := F.3 y

@[simp]
lemma at_one_path_hom { f : path x y} { g : path x y} (F : path_homotopy f g) (y : I01):
F.to_fun (1, y) = path.to_fun g y := F.4 y

@[simp]
lemma at_pt_zero_hom  { f : path x y} { g : path x y} (F : path_homotopy f g) (s : I01) :
F.to_fun (s, 0) = x :=  begin exact (F.2 s).1 end

@[simp]
lemma at_pt_one_hom  { f : path x y} { g : path x y} (F : path_homotopy f g) (s : I01) :
F.to_fun (s, 1) = y :=  begin exact (F.2 s).2.1  end

variables { l  k : path x y }
variable F : path_homotopy l k

-- Alternative path_homotopy.mk
def path_homotopy.mk'  { f : path x y} { g : path x y}
  (F : I01 × I01 →  β) (start_pt : ∀ s : I01, F (s, 0) = x) (end_pt : ∀ s : I01, F (s, 1) = y)
  (at_zero : ∀ y, F (0,y) = f.to_fun y ) (at_one : ∀ y, F (1,y) = g.to_fun y )
  (F_cont : continuous F) : path_homotopy f g :=
{   to_fun := F,
    path_s :=
    begin
      unfold is_path, intro s, split, exact start_pt s, split, exact end_pt s,
      refine continuous.comp _ F_cont,
      exact continuous.prod_mk continuous_const continuous_id,
    end,
    at_zero := at_zero,
    at_one := at_one,
    cont := F_cont
}

-- Ending points of path_homotopy are fixed  (Can Remove - not Used)
lemma hom_eq_of_pts { x y : β } { f g : path x y } ( F : path_homotopy f g ) :
∀ s : I01, check_pts x y ( λ t,  F.to_fun (s, t)) :=
begin
  intro s, unfold check_pts, split,
    have h₁ : F.to_fun (s, 0) =  ( λ t,  F.to_fun (s, t)) 0, by simp,
    rw h₁ , exact (F.path_s s).left,
    have h₂  : F.to_fun (s, 1) =  ( λ t,  F.to_fun (s, t)) 1, by simp,
    rw h₂ , exact (F.path_s s).right.left
end

--- (Can Remove - not Used)
lemma hom_path_is_cont { x y : β } { f g : path x y } ( F : path_homotopy f g ) :
∀ s : I01, continuous ( λ t,  F.to_fun (s, t)) :=
begin intro s, exact (F.path_s s).right.right end

def hom_to_path { f g : path x y } ( F : path_homotopy f g ) (s : I01) : path x y :=
to_path ( λ t,  F.to_fun (s, t)) (F.path_s s)

--------------------------------------------

--------------------------------------------
-- IDENTITY / INVERSE / COMPOSITION of HOMOTOPY

--- Identity homotopy
def path_homotopy_id { x y : β} (f : path x y) : path_homotopy f f :=
{   to_fun :=  λ st  , f.to_fun (prod.snd st) ,

    path_s := begin  intro s, unfold is_path, exact ⟨ f.at_zero,  f.at_one, f.cont ⟩ end,

    at_zero := by simp ,
    at_one := by simp ,

    cont :=
    begin
      let h := λ st, f.to_fun ( @prod.snd I01 I01 st ) ,
      have hc : continuous h,
        exact continuous.comp  continuous_snd f.cont,
      exact hc,
    end
}

--- Inverse homotopy
lemma help_hom_inv : (λ (st : ↥I01 × ↥I01), F.to_fun (par_inv (st.fst), st.snd)) =
  ((λ (st : ↥I01 × ↥I01), F.to_fun (st.fst , st.snd)) ∘
     (λ (x : I01 × I01) , (( par_inv x.1 , x.2 ) : I01 × I01))) := by trivial

def path_homotopy_inverse { x y : β} {f : path x y} {g : path x y} ( F : path_homotopy f g) : path_homotopy g f :=
{   to_fun :=   λ st  , F.to_fun ( par_inv st.1 , st.2 ),
    path_s :=
    begin
      intro s, unfold is_path, split,
        exact (F.path_s (par_inv s)).1, split,
          exact (F.path_s (par_inv s)).2.1,
          exact (F.path_s (par_inv s)).2.2
    end,
    at_zero := begin intro t,  simp [eqn_1_par_inv],  end,
    at_one := begin intro t, simp, end,
    cont :=
    begin
      show continuous ((λ (st : ↥I01 × ↥I01), F.to_fun (st.fst , st.snd)) ∘ (λ (x : I01 × I01) , (( par_inv x.1 , x.2 ) : I01 × I01))),
      have H : continuous (λ (x : I01 × I01) , (( par_inv x.1 , x.2 ) : I01 × I01)),
        { exact continuous.prod_mk ( continuous.comp  continuous_fst continuous_par_inv)
          ( @continuous.comp (I01×I01) I01 I01 _ _ _ (λ x : I01×I01, x.2) _ continuous_snd continuous_id) },
      simp [continuous.comp H F.cont],
    end
}

------------------------------------------

---- Composition of homotopy

local notation `I` := @set.univ I01

-- Prove T1 × I01, T2 × I01 cover I01 × I01
lemma cover_prod_I01 : ( (set.prod T1 (@set.univ I01)) ∪ (set.prod T2 (@set.univ I01)) ) =
  @set.univ (I01 × I01) :=
begin
  apply set.ext, intro x, split, simp [mem_set_of_eq],
  intro H, simp, have H : 0 ≤ x.1.val ∧ x.1.val ≤ 1, by exact x.1.property,
  unfold T1 T2 T, simp [mem_set_of_eq, or_iff_not_imp_left, -one_div_eq_inv],
  intro nL, have H2 : (1 / 2 :ℝ )< x.1.val, by exact nL H.1,
  exact ⟨ le_of_lt H2, H.2 ⟩ ,
end

-- Closedness and intersection of T1 × I01, T2 × I01
lemma prod_T1_is_closed : is_closed (set.prod T1 I) :=
begin simp [T1_is_closed, is_closed_prod]  end

lemma prod_T2_is_closed : is_closed (set.prod T2 I) :=
begin simp [T2_is_closed, is_closed_prod] end

lemma prod_inter_T : set.inter (set.prod T1 I) (set.prod T2 I) =
  set.prod  { x : I01 | x.val = 1/2 } I :=
begin
  unfold T1 T2 T set.inter set.prod, simp [mem_set_of_eq, -one_div_eq_inv],
  apply set.ext, intro x, split,
  {rw mem_set_of_eq , rw mem_set_of_eq, simp [-one_div_eq_inv], intros A B C D,
   have H : x.1.val < 1 / 2 ∨ x.1.val = 1/2, by exact lt_or_eq_of_le B,
   exact le_antisymm  B C   },
  rw mem_set_of_eq , rw mem_set_of_eq, intro H, rw H, norm_num
end

-- Define general / T1 / T2 reparametrised homotopy and prove continuity
def fgen_hom { x y : α } {r s : ℝ} {f g: path x y } (Hrs : r < s)
 ( F : path_homotopy f g) : (set.prod (T r s Hrs ) I) → α :=
λ st, F.to_fun (( par Hrs ⟨st.1.1, (mem_prod.1 st.2).1 ⟩) , st.1.2 )

theorem p_hom_cont { x y : α } {r s : ℝ} {f g : path x y } (Hrs : r < s) ( F : path_homotopy f g)  : continuous (fgen_hom Hrs F) :=
begin
  unfold fgen_hom, refine continuous.comp _ F.cont ,
  refine continuous.prod_mk _ (continuous.comp continuous_subtype_val continuous_snd),
  refine continuous.comp _ (continuous_par Hrs),
  refine continuous_subtype_mk _ _,
  exact continuous.comp continuous_subtype_val continuous_fst,
end

def fa_hom { x y : α }{f g: path x y } ( F : path_homotopy f g) : (set.prod T1 I) → α  :=
@fgen_hom _ _ _ _ 0 (1/2 : ℝ ) _ _  zero_lt_half F

lemma CA_hom { x y : α }{f g: path x y } ( F : path_homotopy f g) : continuous (fa_hom F) :=
p_hom_cont zero_lt_half F

def fb_hom { x y : α }{f g: path x y } ( F : path_homotopy f g) : (set.prod T2 I) → α  :=
@fgen_hom _ _ _ _ (1/2 : ℝ ) 1 _ _  half_lt_one F

lemma CB_hom { x y : α }{f g: path x y } ( F : path_homotopy f g) : continuous (fb_hom F) :=
p_hom_cont half_lt_one F

---

-- Other helpful lemmas

@[simp]
lemma cond_start {f : path x y} {g : path x y} {h : path x y}
  ( F : path_homotopy f g) ( G : path_homotopy g h) :
  paste cover_prod_I01 (fa_hom F) (fb_hom G) (s, 0) = x :=
begin unfold paste, split_ifs, unfold fa_hom fgen_hom, simp, unfold fb_hom fgen_hom, simp, end

@[simp]
lemma cond_end {f : path x y} {g : path x y} {h : path x y}
  ( F : path_homotopy f g) ( G : path_homotopy g h) :
  paste cover_prod_I01 (fa_hom F) (fb_hom G) (s, 1) = y :=
begin unfold paste, split_ifs, unfold fa_hom fgen_hom, simp, unfold fb_hom fgen_hom, simp, end

-- Homotopy composition
def path_homotopy_comp  {f : path x y} {g : path x y} {h : path x y}
  ( F : path_homotopy f g) ( G : path_homotopy g h) : path_homotopy f h :=
{   to_fun := λ st, ( @paste (I01 × I01) β (set.prod T1 I) (set.prod T2 I)  cover_prod_I01 ( λ st , (fa_hom F ) st ) ) ( λ st, (fb_hom G ) st  )  st  ,

    path_s :=
    begin
      intro s, unfold is_path, split, simp,
        split, simp, simp,

      unfold paste, unfold fa_hom fb_hom fgen_hom, simp,
      by_cases H : ∀ t : I01, (s, t) ∈ set.prod T1 I, simp [H],
        refine (F.path_s (par zero_lt_half ⟨ s, _ ⟩  )).2.2, unfold set.prod at H,
        have H2 : (s, s) ∈ {p : ↥I01 × ↥I01 | p.fst ∈ T1 ∧ p.snd ∈ univ}, exact H s, simp [mem_set_of_eq] at H2, exact H2,
        simp at H,
        have H3:  s ∉ T1, simp [not_forall] at H, exact H.2,
        simp [H3], refine (G.path_s (par half_lt_one ⟨ s, _ ⟩  )).2.2,
        exact T2_of_not_T1 H3,
    end,

    at_zero := begin  intro y, simp, unfold paste, rw dif_pos, unfold fa_hom fgen_hom, simp ,
        simp [mem_set_of_eq], exact help_T1,  end,

    at_one := begin intro y, simp, unfold paste, rw dif_neg, unfold fb_hom fgen_hom, simp ,
        simp [mem_set_of_eq], exact help_02, end,

    cont :=
    begin simp, refine cont_of_paste _ _ _ (CA_hom F) (CB_hom G) ,
      exact prod_T1_is_closed,
      exact prod_T2_is_closed,
      unfold match_of_fun, intros x B1 B2,
        have Int : x ∈ set.inter (set.prod T1 I) (set.prod T2 I), exact ⟨ B1 , B2 ⟩ ,
        rwa [prod_inter_T] at Int,
        have V : x.1.1 = 1/2, rwa [set.prod, mem_set_of_eq] at Int, rwa [mem_set_of_eq] at Int, exact Int.1, cases x,
        have xeq : x_fst = ⟨ 1/2 , help_01 ⟩ , apply subtype.eq, rw V,
        simp [xeq, -one_div_eq_inv],
        show fa_hom F ⟨(⟨1 / 2, help_01⟩, x_snd), _⟩ = fb_hom G ⟨(⟨1 / 2, help_01⟩, x_snd), _⟩ , unfold fa_hom fb_hom fgen_hom,
        simp [eqn_1, eqn_2, -one_div_eq_inv],
    end
}

---------------------------------

------------------------------------------------------

---- EQUIVALENCE OF HOMOTOPY

definition is_homotopic_to  (f : path x y) ( g : path x y) : Prop := nonempty ( path_homotopy f g)

theorem is_reflexive : @reflexive (path x y) ( is_homotopic_to ) :=
begin
  unfold reflexive, intro f, unfold is_homotopic_to,
    have H : path_homotopy f f,
        exact path_homotopy_id f ,
    exact ⟨ H ⟩
end

theorem is_symmetric  : @symmetric (path x y)  (is_homotopic_to) :=
begin
    unfold symmetric, intros f g H, unfold is_homotopic_to,
    cases H with F, exact ⟨path_homotopy_inverse  F⟩,
end

theorem is_transitive  : @transitive (path x y)  (is_homotopic_to) :=
begin
    unfold transitive, intros f g h Hfg Hgh, unfold is_homotopic_to at *,
      cases Hfg  with F,  cases Hgh with G,
    exact ⟨ path_homotopy_comp F G⟩ ,
end

theorem is_equivalence : @equivalence (path x y)  (is_homotopic_to) :=
⟨ is_reflexive, is_symmetric, is_transitive⟩

-----------------------------------------------------

end homotopy


/-
Copyright (c) 2016 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.wf
import Mathlib.Lean3Lib.init.data.nat.basic

namespace Mathlib

namespace nat

protected def div (x : ℕ) : ℕ → ℕ := well_founded.fix lt_wf div.F

protected instance has_div : Div ℕ := { div := nat.div }

theorem div_def_aux (x : ℕ) (y : ℕ) :
    x / y =
        dite (0 < y ∧ y ≤ x) (fun (h : 0 < y ∧ y ≤ x) => (x - y) / y + 1)
          fun (h : ¬(0 < y ∧ y ≤ x)) => 0 :=
  congr_fun (well_founded.fix_eq lt_wf div.F x) y

protected def mod (x : ℕ) : ℕ → ℕ := well_founded.fix lt_wf mod.F

protected instance has_mod : Mod ℕ := { mod := nat.mod }

theorem mod_def_aux (x : ℕ) (y : ℕ) :
    x % y =
        dite (0 < y ∧ y ≤ x) (fun (h : 0 < y ∧ y ≤ x) => (x - y) % y)
          fun (h : ¬(0 < y ∧ y ≤ x)) => x :=
  congr_fun (well_founded.fix_eq lt_wf mod.F x) y

end Mathlib


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

Main functional correctness theorem for stochastic backpropagation.
-/
import .util .graph .compute_grad .predicates .estimators .env .dvec .compute_grad_slow_correct .memoize_correct .lemmas .lemmas_extra

namespace certigrad
open tactic list theorems

theorem backprop_correct {costs : list ID} :
  ∀ {nodes : list node} (inputs : env) (tgts : list reference),
  ∀ {tgt : reference} {idx : ℕ}, at_idx tgts idx tgt →
  nodup (tgts ++ map node.ref nodes) →
  well_formed_at costs nodes inputs tgt →
  grads_exist_at nodes inputs tgt →
  pdfs_exist_at nodes inputs →
  is_gintegrable (λ m, ⟦compute_grad_slow costs nodes m tgt⟧) inputs nodes dvec.head →
  can_differentiate_under_integrals costs nodes inputs tgt →

  ∇ (λ θ₀, E (graph.to_dist (λ m, ⟦sum_costs m costs⟧) (env.insert tgt θ₀ inputs) nodes) dvec.head) (env.get tgt inputs)
  =
  E (graph.to_dist (λ m, backprop costs nodes m tgts) inputs nodes) (λ dict, dvec.get tgt.2 dict idx) :=

assume (nodes : list node) (inputs : env) (tgts : list reference)
       (tgt : reference) (idx : ℕ) (H_at_idx : at_idx tgts idx tgt)
       (H_nd : nodup (tgts ++ map node.ref nodes))
       (H_wf : well_formed_at costs nodes inputs tgt)
       (H_gs_exist : grads_exist_at nodes inputs tgt)
       (H_pdfs_exist : pdfs_exist_at nodes inputs)
       (H_grad_gint : is_gintegrable (λ m, ⟦compute_grad_slow costs nodes m tgt⟧) inputs nodes dvec.head)
       (H_diff_under_int : can_differentiate_under_integrals costs nodes inputs tgt),

have H_gdiff : is_gdifferentiable (λ m, ⟦sum_costs m costs⟧) tgt inputs nodes dvec.head, from
  is_gdifferentiable_of_pre _ _ _ H_wf H_gs_exist H_pdfs_exist H_diff_under_int,
have H_nabla_gint : is_nabla_gintegrable (λ m, ⟦sum_costs m costs⟧) tgt inputs nodes dvec.head, from
  is_nabla_gintegrable_of_gintegrable _ _ _ H_wf H_gs_exist H_pdfs_exist H_gdiff H_diff_under_int H_grad_gint,

begin
rw (compute_grad_slow_correct H_wf H_gs_exist H_pdfs_exist H_gdiff H_nabla_gint H_grad_gint H_diff_under_int),
rw (E.E_move_fn_to_continuation _ _ _ (λ dict, dvec.get tgt.2 dict idx)),
dunfold backprop, dsimp,
simp only [(λ m, tvec.get_from_env H_at_idx m), (λ m, memoize_correct costs nodes m H_at_idx H_nd)]
end

end certigrad


import new.unordered.d
import new.unordered.C

open topological_space Top Top.sheaf
open category_theory
open opposite

universe u
variables {X : Top.{u}} (𝓕 : sheaf Ab X) (U : X.oc)

section C_alt

variables {𝓕 U}
def C.pre.is_skewsymmetric {n : ℕ} (f : C.pre 𝓕 U n) : Prop :=
∀ (i j : fin n) (α : fin n → U.ι),
  f α =
  𝓕.1.map (eq_to_hom (face.swap_eq α i j)).op (- f (swap i j α))

def C.pre.is_skewsymmetric' {n : ℕ} (f : C.pre 𝓕 U n) : Prop :=
∀ (i j : fin n) (α : fin n → U.ι),
  f (swap i j α) =
  - 𝓕.1.map (eq_to_hom (face.swap_eq α i j).symm).op (f α)

lemma is_skewsymmetric_iff_is_skewsymmetric' {n} (f : C.pre 𝓕 U n) :
  C.pre.is_skewsymmetric f ↔ C.pre.is_skewsymmetric' f :=
{ mp := λ h i j α, begin
    specialize h i j α,
    rw [h, map_neg, map_neg, neg_neg, ← comp_apply, ← 𝓕.1.map_comp, ← op_comp, eq_to_hom_trans, eq_to_hom_refl],
    simp,
  end,
  mpr := λ h i j α, begin
    specialize h i j α,
    rw [h, neg_neg, ← comp_apply, ← 𝓕.1.map_comp, ← op_comp, eq_to_hom_trans, eq_to_hom_refl],
    simp
  end }

end C_alt

def C_alt.pre (n : ℕ) : add_subgroup (C 𝓕 U n) :=
{ carrier := { f : C.pre 𝓕 U n | f.is_skewsymmetric ∧ ∀ (α : fin n → U.ι), ¬ function.injective α → f α = 0},
  add_mem' := λ f g hf hg, begin
    rcases hf with ⟨hf1, hf2⟩,
    rcases hg with ⟨hg1, hg2⟩,
    split,
    intros i j α,
    change f α + g α = 𝓕.1.map _ (- (f _ + g _)),
    rw [map_neg, map_add, hf1 i j, hg1 i j, map_neg, map_neg, neg_add],

    intros α ha,
    change f α + g α = 0,
    rw [hf2, hg2, add_zero];
    assumption,
  end,
  zero_mem' := begin
    split,
    intros i j α,
    simp only [C_pre.zero_apply, neg_zero, map_zero],

    intros α ha,
    simp,
  end,
  neg_mem' := λ f ⟨hf1, hf2⟩, begin
    split,
    intros i j α,
    simp only [C_pre.neg_apply],
    rw neg_neg,
    rw hf1 i j,
    simp only [map_neg, neg_neg],

    intros α ha,
    change - (f α) = 0,
    rw hf2 _ ha,
    rw neg_zero,
  end }

def C_alt (n : ℕ) : Ab := AddCommGroup.of $ C_alt.pre 𝓕 U n

def d_alt (n : ℕ) : C_alt 𝓕 U n ⟶ C_alt 𝓕 U (n + 1) :=
{ to_fun := λ f, ⟨d 𝓕 U n f.1, sorry⟩,
  map_zero' := begin
    rw subtype.ext_iff_val,
    simp,
  end,
  map_add' := begin
    rintros ⟨f, hf⟩ ⟨g, hg⟩,
    rw subtype.ext_iff_val,
    simp,
  end }

lemma d_alt_d_alt_eq_zero (n : ℕ) :
  d_alt 𝓕 U n ≫ d_alt 𝓕 U (n + 1) = 0 :=
begin
  ext f α,
  rw [comp_apply],
  simp only [AddCommGroup.zero_apply, add_subgroup.coe_zero, C_pre.zero_apply],
  convert dd_eq_zero 𝓕 U n f.1 α,
end


import SciLean
import Qq

open SciLean

variable {X Y Z W : Type} [SemiHilbert X] [SemiHilbert Y] [SemiHilbert Z] [SemiHilbert W]
         {Y₁ Y₂ : Type} [SemiHilbert Y₁] [SemiHilbert Y₂]
         {ι κ : Type} [Enumtype ι] [Enumtype κ]

example {n : Nat} : (∇ (x : ℝ^{n}), ‖x‖²) = λ x : ℝ^{n} => (2:ℝ)*x := by symdiff; done
example {n : Nat} (m : ℝ) : (∇ (x : ℝ^{n}), 1/2 * m * ‖x‖²) = λ x : ℝ^{n} => m*x := by symdiff; done

@[diff]
theorem adjoint_sum_eval_rank1 (f : ι → X → Y) [∀ i, HasAdjointT (f i)]
  : (λ (x : ι → X) => ∑ i, f i (x i))†
    =
    λ y i => (f i)† y := by symdiff; sorry

@[diff]
theorem adjDiff_sum_eval_rank1 (f : ι → X → Y) [hf : ∀ i, HasAdjDiffT (f i)]
  : ∂† (λ (x : ι → X) => ∑ i, f i (x i))
    =
    λ x dy' i => ∂† (f i) (x i) dy' :=
by
  unfold adjointDifferential
  have := λ i => (hf i).1
  have := λ i => (hf i).2
  symdiff; symdiff; done

@[diff]
theorem revDiff_sum_eval_rank1 (f : ι → X → Y) [hf : ∀ i, HasAdjDiffT (f i)]
  : ℛ (λ (x : ι → X) => ∑ i, f i (x i))
    =
    λ x => (∑ i, f i (x i), λ dy' i => ∂† (f i) (x i) dy') :=
by
  unfold reverseDifferential
  symdiff; done

unif_hint adjoint_sum_eval_rank1.unif_hint_0
  (f? : ι → X → Y)
  (f : ι → W → Y) (h : X → W)
where
  f? =?= λ i x => f i (h x)
  |-
  (λ (x : ι → X) => ∑ i, (f? i) (x i))†
  =?=
  (λ (x : ι → X) => ∑ i, f i (h (x i)))†

unif_hint adjoint_sum_eval_rank1.unif_hint_1
  (f? : ι → X → Y)
  (f : ι → X → α → Y) (g : ι → α)
where
  f? =?= λ i x => f i x (g i)
  |-
  (λ (x : ι → X) => ∑ i, (f? i) (x i))†
  =?=
  (λ (x : ι → X) => ∑ i, f i (x i) (g i))†

unif_hint adjDiff_sum_eval_rank1.unif_hint_1
  (f? : ι → X → Y)
  (f : ι → X → W) (h : ι → W → Y)
where
  f? =?= λ i x => h i (f i x)
  |-
  ∂† (λ (x : ι → X) => ∑ i, (f? i) (x i))
  =?=
  ∂† (λ (x : ι → X) => ∑ i, h i (f i (x i)))

unif_hint adjDiff_sum_eval_rank1.unif_hint_2
  (f? : ι → X → Y)
  (op : Y₁ → Y₂ → Y)
  (f₁ : ι → X → Y₁) (f₂ : ι → X → Y₂)-- (h : ι → W → Y)
where
  f? =?= λ i x => op (f₁ i x) (f₂ i x)
  |-
  ∂† (λ (x : ι → X) => ∑ i, (f? i) (x i))
  =?=
  ∂† (λ (x : ι → X) => ∑ i, (op (f₁ i (x i)) (f₂ i (x i))))

unif_hint adjDiff_sum_eval_rank1.unif_hint_3
  (f? : ι → ℝ → ℝ)
  -- (op : Y₁ → Y₂ → Y)
  -- (f₁ : ι → X → Y₁) (f₂ : ι → X → Y₂)-- (h : ι → W → Y)
where
  f? =?= λ i x => x * x
  |-
  ∂† (λ (x : ι → ℝ) => ∑ i, (f? i) (x i))
  =?=
  ∂† (λ (x : ι → ℝ) => ∑ i, x i * x i)

@[simp]
theorem sum_setElem_zero {Xι} [ArrayType Xι ι X]
  : ∑ i, setElem (0 : Xι) i (f i) = introElem f := sorry

@[diff]
theorem adjDiff_ArrayType_rule_forall₂ {Xι} [ArrayType Xι ι X] (f : ι → X → Y) [∀ i, HasAdjDiffT (f i)]
  : ∂† (λ (x : Xι) i => f i x[i])
    =
    λ x dx' => introElem λ i => ∂† (f i) x[i] (dx' i) :=
by
  symdiff; simp; done

unif_hint adjDiff_ArrayType_rule_forall₂.unif_hint_2 {Xι} [ArrayType Xι ι X]
  (f? : ι → X → Y)
  (f : ι → X → W) (h : ι → W → Y)
where
  f? =?= λ i x => h i (f i x)
  |-
  ∂† (λ (x : Xι) i => f? i x[i])
  =?=
  ∂† (λ (x : Xι) i => h i (f i x[i]))

@[diff]
theorem adjDiff_ArrayType_rule_forall₂.unif_hint_1 {Xι} [ArrayType Xι ι X]
  (f : ι → X → Y) [∀ i, HasAdjDiffT (f i)]
  (h : ι → Y → Z) [∀ i, HasAdjDiffT (h i)]
  : ∂† (λ (x : Xι) i => h i (f i x[i]))
    =
    λ x dx' => introElem λ i => ∂† (λ x => h i (f i x)) x[i] (dx' i) :=
by
  symdiff; done

example {X} [Hilbert X] (c : ℝ) : HasAdjDiffT (fun x : X => c * ‖ x ‖²) := by infer_instance

example (c : ℝ) : HasAdjDiffT (fun x : ℝ => c * ‖ x ‖² ) := by infer_instance
example {X} [Hilbert X] (c : ℝ) : HasAdjDiffT (fun x : X => c * ⟪x,x⟫) := by infer_instance

set_option trace.Meta.Tactic.simp.rewrite true in
example {n : Nat} : ∇ (x : Fin n → ℝ), ∑ i, x i  = λ x i =>    1 := by symdiff; done
set_option trace.Meta.Tactic.simp.rewrite true in
example {n : Nat} : ∇ (x : ℝ^{n}),      ∑ i, x[i] = λ x => ⊞ i, 1 := by symdiff; rfl; done

example {n : Nat} : ∇ (x : Fin n → ℝ), ∑ i, ‖x i‖²  = λ x i =>    (2:ℝ) * x i := by symdiff; done
example {n : Nat} : ∇ (x : ℝ^{n}),      ∑ i, ‖x[i]‖² = λ x => ⊞ i, (2:ℝ) * x[i] := by symdiff; rfl; done

example {n : Nat} (c : ℝ) : ∇ (x : Fin n → ℝ), ∑ i, c * ‖x i‖²  = λ x i =>    2 * c * x i := by symdiff; done

set_option synthInstance.maxSize 1000
set_option trace.Meta.Tactic.simp.unify true in
example {n : Nat} (c : ℝ) : ∇ (x : ℝ^{n}),      ∑ i, c * ‖x[i]‖² = λ x => ⊞ i, 2 * c * x[i] := by symdiff; rfl; done

set_option trace.Meta.Tactic.simp.discharge true in
example {n : Nat} (c : ℝ) : ∂† (λ (x : ℝ^{n}) i => c * ‖x[i]‖²) = λ x dx' => ⊞ i, 2 * c * dx' i * x[i] := by
  symdiff
  rw[adjDiff_ArrayType_rule_forall₂.unif_hint]; symdiff; rfl -- (λ _ (x : ℝ) => ‖x‖²) (λ _ (x : ℝ) => c * x)
  done

example {n : Nat} (c : ℝ) : ∇ (x : Fin n → ℝ), ∑ i, (c + i) * ‖x i‖² = λ x (i : Fin n) => 2 * (c + i) * x i := by symdiff; done
set_option trace.Meta.Tactic.simp.unify true in
example {n : Nat} : ∇ (x : Fin n → ℝ), ∑ i, x i * x i = λ x i => 2 * x i :=
by
  unfold gradient; funext x;
  rw[adjDiff_sum_eval_rank1 (λ i xi => xi * xi)]
  symdiff; done
example {n : Nat} : ∇ (x : ℝ^{n}), ∑ i, x[i]*x[i] = λ x => ⊞ i, (2:ℝ) * x[i] := by symdiff; done

open Lean Qq Meta Elab Term

def unifyTest (lhs rhs : Expr) : MetaM Unit := do
  let ppLhs ← Meta.ppExpr lhs
  let ppRhs ← Meta.ppExpr rhs
  let test ← isDefEq lhs rhs
  if test then
    IO.println s!"Success: {ppLhs} =?= {ppRhs}"
  else
    throwError "Failure: {ppLhs} =?= {ppRhs}"

unif_hint
  (α β γ : Type) (F : (α→β) → (α→γ)) (g : β → γ)
where
  F =?= λ f x => g (f x)
  |-
  (λ f x => g (f x))
  =?=
  λ f => F f

unif_hint
  (α β γ : Type) (F : (α→β) → (α→γ)) (g : β → γ)
where
  F =?= λ f x => g (f x)
  |-
  λ f => F f
  =?=
  (λ f x => g (f x))

notation x " =?= " y => unifyTest x y

#eval show MetaM Unit from do
  let f? : Q(Nat→Nat) ← mkFreshExprMVar q(Nat→Nat)

  unifyTest q(λ (x : Nat) => $f? x)
            q(λ (x : Nat) => Nat.succ (Nat.succ x))

#eval show MetaM Unit from do
  let n? : Q(Nat) ← mkFreshExprMVarQ q(Nat)
  let f? : Q(Nat→Nat) ← mkFreshExprMVarQ q(Nat→Nat)

  unifyTest q(λ (x : Fin $n? → Nat) i => $f? (x i))
            q(λ (x : Fin $n? → Nat) i => Nat.succ (x i))

#eval show MetaM Unit from do
  let n? : Q(Nat) ← mkFreshExprMVarQ q(Nat)
  let f? : Q(Nat→Nat) ← mkFreshExprMVarQ q(Nat→Nat)
  let g? : Q(Nat→Nat) ← mkFreshExprMVarQ q(Nat→Nat)

  unifyTest q(λ (x : Fin $n? → Nat) i => $f? (x i))
            q(λ (x : Fin $n? → Nat) i => $g? (x i))

#eval show MetaM Unit from do
  let n? : Q(Nat) ← mkFreshExprMVarQ q(Nat)
  let F? : Q((Fin $n?→Nat)→(Fin $n?→Nat)) ← mkFreshExprMVarQ q((Fin $n?→Nat)→(Fin $n?→Nat))
  let g? : Q(Nat→Nat) ← mkFreshExprMVarQ q(Nat→Nat)

  unifyTest q(λ (x : Fin $n? → Nat) => $F? x)
            q(λ (x : Fin $n? → Nat) i => $g? (x i))

#eval show MetaM Unit from do
  let X? : Q(Type) ← mkFreshExprMVarQ q(Type)
  let Y? : Q(Type) ← mkFreshExprMVarQ q(Type)
  let Z? : Q(Type) ← mkFreshExprMVarQ q(Type)
  let g? : Q($Y?→$Z?) ← mkFreshExprMVarQ q($Y?→$Z?)
  let h? : Q($Y?→$Z?) ← mkFreshExprMVarQ q($Y?→$Z?)

  q(λ (f : $X? → $Y?) x => $g? (f x))
  =?=
  q(λ (f : $X? → $Y?) x => $h? (f x))

#eval show MetaM Unit from do
  let X? : Q(Type) ← mkFreshExprMVarQ q(Type)
  let Y? : Q(Type) ← mkFreshExprMVarQ q(Type)
  let F? : Q(($X?→$Y?)→($X?→$Y?)) ← mkFreshExprMVarQ q(($X?→$Y?)→($X?→$Y?))
  let G? : Q(($X?→$Y?)→($X?→$Y?)) ← mkFreshExprMVarQ q(($X?→$Y?)→($X?→$Y?))
  let g? : Q($Y?→$Y?) ← mkFreshExprMVarQ q($Y?→$Y?)

  q(λ (f : $X? → $Y?) => $F? f)
  =?=
  q(λ (f : $X? → $Y?) x => $g? (f x))

#eval show MetaM Unit from do
  let n? : Q(Nat) ← mkFreshExprMVarQ q(Nat)
  let f? : Q(Nat→Nat) ← mkFreshExprMVarQ q(Nat→Nat)

  unifyTest q(id $ λ (x : Fin $n? → Nat) i => $f? (x i))
            q(id $ λ (x : Fin $n? → Nat) i => Nat.succ (x i))

#eval show MetaM Unit from do
  let n? : Q(Nat) ← mkFreshExprMVarQ q(Nat)
  let op? : Q(ℝ → ℝ → ℝ) ← mkFreshExprMVarQ q(ℝ → ℝ → ℝ)

  unifyTest q(λ (x : Fin $n? → ℝ) i => $op? (x i) (x i))
            q(λ (x : Fin $n? → ℝ) i => x i * x i)

#eval show MetaM Unit from do
  let n? : Q(Nat) ← mkFreshExprMVarQ q(Nat)
  let f? : Q(Fin $n? → ℝ → ℝ) ← mkFreshExprMVarQ q(Fin $n? → ℝ → ℝ)

  unifyTest q(λ (x : Fin $n? → ℝ) i => $f? i (x i))
            q(λ (x : Fin $n? → ℝ) i => x i * x i)

def n := q(10)

-- works fine
def FinExpr :=
  let n := q(10)
  q(Fin $n)

def FinExpr' : Q(Type) :=
  let n := q(10)
  q(Fin $n) -- unknown identifier '«$n»'

-- Construct an expression
def a : Expr := q([42 + 1])

-- Construct a typed expression
def b : Q(List Nat) := q([42 + 1])

def b' : Q(Nat) := q(42 + 1)

-- Antiquotations
def c :=
  let n : Q(Nat) := q(10)
  q([42 + $n + $b'])

-- Dependently-typed antiquotations
def d (u : Level) (n : Q(Nat)) (x : Q(Type u × Fin ($n + 1))) : Q(Fin ($n + 3)) :=
  q(⟨$x.2, Nat.lt_of_lt_of_le $x.2.2 (Nat.le_add_right _ 2)⟩)

#eval show MetaM Unit from do
  let a? ← mkFreshExprMVar q(Nat)
  let b? ← mkFreshExprMVar q(Nat)
  pure ()

#eval show MetaM Unit from do
  let a? ← mkFreshExprMVarQ q(Nat)
  let b? ← mkFreshExprMVarQ q(Nat) -- incompatible metavariable _uniq.146616
  pure ()


/-
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.algebra.group.hom
import Mathlib.category_theory.limits.shapes.kernels
import Mathlib.algebra.big_operators.basic
import Mathlib.PostPort

universes v u l u_1

namespace Mathlib

/-!
# Preadditive categories

A preadditive category is a category in which `X ⟶ Y` is an abelian group in such a way that
composition of morphisms is linear in both variables.

This file contains a definition of preadditive category that directly encodes the definition given
above. The definition could also be phrased as follows: A preadditive category is a category
enriched over the category of Abelian groups. Once the general framework to state this in Lean is
available, the contents of this file should become obsolete.

## Main results

* Definition of preadditive categories and basic properties
* In a preadditive category, `f : Q ⟶ R` is mono if and only if `g ≫ f = 0 → g = 0` for all
  composable `g`.
* A preadditive category with kernels has equalizers.

## Implementation notes

The simp normal form for negation and composition is to push negations as far as possible to
the outside. For example, `f ≫ (-g)` and `(-f) ≫ g` both become `-(f ≫ g)`, and `(-f) ≫ (-g)`
is simplified to `f ≫ g`.

## References

* [F. Borceux, *Handbook of Categorical Algebra 2*][borceux-vol2]

## Tags

additive, preadditive, Hom group, Ab-category, Ab-enriched
-/

namespace category_theory

/-- A category is called preadditive if `P ⟶ Q` is an abelian group such that composition is
    linear in both variables. -/
class preadditive (C : Type u) [category C] where
  hom_group :
    autoParam ((P Q : C) → add_comm_group (P ⟶ Q))
      (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.tactic.apply_instance")
        (Lean.Name.mkStr (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "tactic")
          "apply_instance")
        [])
  add_comp' :
    autoParam (∀ (P Q R : C) (f f' : P ⟶ Q) (g : Q ⟶ R), (f + f') ≫ g = f ≫ g + f' ≫ g)
      (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.obviously")
        (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "obviously") [])
  comp_add' :
    autoParam (∀ (P Q R : C) (f : P ⟶ Q) (g g' : Q ⟶ R), f ≫ (g + g') = f ≫ g + f ≫ g')
      (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.obviously")
        (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "obviously") [])

@[simp] theorem preadditive.add_comp {C : Type u} [category C] [c : preadditive C] (P : C) (Q : C)
    (R : C) (f : P ⟶ Q) (f' : P ⟶ Q) (g : Q ⟶ R) : (f + f') ≫ g = f ≫ g + f' ≫ g :=
  sorry

@[simp] theorem preadditive.comp_add {C : Type u} [category C] [c : preadditive C] (P : C) (Q : C)
    (R : C) (f : P ⟶ Q) (g : Q ⟶ R) (g' : Q ⟶ R) : f ≫ (g + g') = f ≫ g + f ≫ g' :=
  sorry

@[simp] theorem preadditive.add_comp_assoc {C : Type u} [category C] [c : preadditive C] (P : C)
    (Q : C) (R : C) (f : P ⟶ Q) (f' : P ⟶ Q) (g : Q ⟶ R) {X' : C} :
    ∀ (f'_1 : R ⟶ X'), (f + f') ≫ g ≫ f'_1 = (f ≫ g + f' ≫ g) ≫ f'_1 :=
  sorry

theorem preadditive.comp_add_assoc {C : Type u} [category C] [c : preadditive C] (P : C) (Q : C)
    (R : C) (f : P ⟶ Q) (g : Q ⟶ R) (g' : Q ⟶ R) {X' : C} (f' : R ⟶ X') :
    f ≫ (g + g') ≫ f' = (f ≫ g + f ≫ g') ≫ f' :=
  sorry

end category_theory

namespace category_theory.preadditive

/-- Composition by a fixed left argument as a group homomorphism -/
def left_comp {C : Type u} [category C] [preadditive C] {P : C} {Q : C} (R : C) (f : P ⟶ Q) :
    (Q ⟶ R) →+ (P ⟶ R) :=
  add_monoid_hom.mk' (fun (g : Q ⟶ R) => f ≫ g) sorry

/-- Composition by a fixed right argument as a group homomorphism -/
def right_comp {C : Type u} [category C] [preadditive C] (P : C) {Q : C} {R : C} (g : Q ⟶ R) :
    (P ⟶ Q) →+ (P ⟶ R) :=
  add_monoid_hom.mk' (fun (f : P ⟶ Q) => f ≫ g) sorry

@[simp] theorem sub_comp_assoc {C : Type u} [category C] [preadditive C] {P : C} {Q : C} {R : C}
    (f : P ⟶ Q) (f' : P ⟶ Q) (g : Q ⟶ R) {X' : C} :
    ∀ (f'_1 : R ⟶ X'), (f - f') ≫ g ≫ f'_1 = (f ≫ g - f' ≫ g) ≫ f'_1 :=
  sorry

-- The redundant simp lemma linter says that simp can prove the reassoc version of this lemma.

@[simp] theorem comp_sub {C : Type u} [category C] [preadditive C] {P : C} {Q : C} {R : C}
    (f : P ⟶ Q) (g : Q ⟶ R) (g' : Q ⟶ R) : f ≫ (g - g') = f ≫ g - f ≫ g' :=
  add_monoid_hom.map_sub (left_comp R f) g g'

@[simp] theorem neg_comp {C : Type u} [category C] [preadditive C] {P : C} {Q : C} {R : C}
    (f : P ⟶ Q) (g : Q ⟶ R) : (-f) ≫ g = -f ≫ g :=
  add_monoid_hom.map_neg (right_comp P g) f

/- The redundant simp lemma linter says that simp can prove the reassoc version of this lemma. -/

theorem comp_neg_assoc {C : Type u} [category C] [preadditive C] {P : C} {Q : C} {R : C} (f : P ⟶ Q)
    (g : Q ⟶ R) {X' : C} (f' : R ⟶ X') : f ≫ (-g) ≫ f' = (-f ≫ g) ≫ f' :=
  sorry

theorem neg_comp_neg {C : Type u} [category C] [preadditive C] {P : C} {Q : C} {R : C} (f : P ⟶ Q)
    (g : Q ⟶ R) : (-f) ≫ (-g) = f ≫ g :=
  sorry

theorem comp_sum {C : Type u} [category C] [preadditive C] {P : C} {Q : C} {R : C} {J : Type u_1}
    {s : finset J} (f : P ⟶ Q) (g : J → (Q ⟶ R)) :
    (f ≫ finset.sum s fun (j : J) => g j) = finset.sum s fun (j : J) => f ≫ g j :=
  sorry

theorem sum_comp_assoc {C : Type u} [category C] [preadditive C] {P : C} {Q : C} {R : C}
    {J : Type u_1} {s : finset J} (f : J → (P ⟶ Q)) (g : Q ⟶ R) {X' : C} (f' : R ⟶ X') :
    finset.sum s f ≫ g ≫ f' = (finset.sum s fun (j : J) => f j ≫ g) ≫ f' :=
  sorry

protected instance has_neg.neg.category_theory.epi {C : Type u} [category C] [preadditive C] {P : C}
    {Q : C} {f : P ⟶ Q} [epi f] : epi (-f) :=
  epi.mk
    fun (R : C) (g g' : Q ⟶ R) (H : (-f) ≫ g = (-f) ≫ g') =>
      eq.mp (Eq._oldrec (Eq.refl (-g = -g')) (propext neg_inj))
        (eq.mp (Eq._oldrec (Eq.refl (f ≫ (-g) = f ≫ (-g'))) (propext (cancel_epi f)))
          (eq.mp (Eq._oldrec (Eq.refl (f ≫ (-g) = -f ≫ g')) (Eq.symm (comp_neg f g')))
            (eq.mp (Eq._oldrec (Eq.refl (-f ≫ g = -f ≫ g')) (Eq.symm (comp_neg f g)))
              (eq.mp (Eq._oldrec (Eq.refl (-f ≫ g = (-f) ≫ g')) (neg_comp f g'))
                (eq.mp (Eq._oldrec (Eq.refl ((-f) ≫ g = (-f) ≫ g')) (neg_comp f g)) H)))))

protected instance has_neg.neg.category_theory.mono {C : Type u} [category C] [preadditive C]
    {P : C} {Q : C} {f : P ⟶ Q} [mono f] : mono (-f) :=
  mono.mk
    fun (R : C) (g g' : R ⟶ P) (H : g ≫ (-f) = g' ≫ (-f)) =>
      eq.mp (Eq._oldrec (Eq.refl (-g = -g')) (propext neg_inj))
        (eq.mp (Eq._oldrec (Eq.refl ((-g) ≫ f = (-g') ≫ f)) (propext (cancel_mono f)))
          (eq.mp (Eq._oldrec (Eq.refl ((-g) ≫ f = -g' ≫ f)) (Eq.symm (neg_comp g' f)))
            (eq.mp (Eq._oldrec (Eq.refl (-g ≫ f = -g' ≫ f)) (Eq.symm (neg_comp g f)))
              (eq.mp (Eq._oldrec (Eq.refl (-g ≫ f = g' ≫ (-f))) (comp_neg g' f))
                (eq.mp (Eq._oldrec (Eq.refl (g ≫ (-f) = g' ≫ (-f))) (comp_neg g f)) H)))))

protected instance preadditive_has_zero_morphisms {C : Type u} [category C] [preadditive C] :
    limits.has_zero_morphisms C :=
  limits.has_zero_morphisms.mk

theorem mono_of_cancel_zero {C : Type u} [category C] [preadditive C] {Q : C} {R : C} (f : Q ⟶ R)
    (h : ∀ {P : C} (g : P ⟶ Q), g ≫ f = 0 → g = 0) : mono f :=
  mono.mk
    fun (P : C) (g g' : P ⟶ Q) (hg : g ≫ f = g' ≫ f) =>
      iff.mp sub_eq_zero
        (h (g - g')
          (Eq.trans (add_monoid_hom.map_sub (right_comp P f) g g') (iff.mpr sub_eq_zero hg)))

theorem mono_iff_cancel_zero {C : Type u} [category C] [preadditive C] {Q : C} {R : C} (f : Q ⟶ R) :
    mono f ↔ ∀ (P : C) (g : P ⟶ Q), g ≫ f = 0 → g = 0 :=
  { mp := fun (m : mono f) (P : C) (g : P ⟶ Q) => limits.zero_of_comp_mono f,
    mpr := mono_of_cancel_zero f }

theorem mono_of_kernel_zero {C : Type u} [category C] [preadditive C] {X : C} {Y : C} {f : X ⟶ Y}
    [limits.has_limit (limits.parallel_pair f 0)] (w : limits.kernel.ι f = 0) : mono f :=
  sorry

theorem epi_of_cancel_zero {C : Type u} [category C] [preadditive C] {P : C} {Q : C} (f : P ⟶ Q)
    (h : ∀ {R : C} (g : Q ⟶ R), f ≫ g = 0 → g = 0) : epi f :=
  epi.mk
    fun (R : C) (g g' : Q ⟶ R) (hg : f ≫ g = f ≫ g') =>
      iff.mp sub_eq_zero
        (h (g - g')
          (Eq.trans (add_monoid_hom.map_sub (left_comp R f) g g') (iff.mpr sub_eq_zero hg)))

theorem epi_iff_cancel_zero {C : Type u} [category C] [preadditive C] {P : C} {Q : C} (f : P ⟶ Q) :
    epi f ↔ ∀ (R : C) (g : Q ⟶ R), f ≫ g = 0 → g = 0 :=
  { mp := fun (e : epi f) (R : C) (g : Q ⟶ R) => limits.zero_of_epi_comp f,
    mpr := epi_of_cancel_zero f }

theorem epi_of_cokernel_zero {C : Type u} [category C] [preadditive C] {X : C} {Y : C} (f : X ⟶ Y)
    [limits.has_colimit (limits.parallel_pair f 0)] (w : limits.cokernel.π f = 0) : epi f :=
  sorry

end preadditive

/-- A kernel of `f - g` is an equalizer of `f` and `g`. -/
theorem preadditive.has_limit_parallel_pair {C : Type u} [category C] [preadditive C] {X : C}
    {Y : C} (f : X ⟶ Y) (g : X ⟶ Y) [limits.has_kernel (f - g)] :
    limits.has_limit (limits.parallel_pair f g) :=
  sorry

/-- If a preadditive category has all kernels, then it also has all equalizers. -/
theorem preadditive.has_equalizers_of_has_kernels {C : Type u} [category C] [preadditive C]
    [limits.has_kernels C] : limits.has_equalizers C :=
  limits.has_equalizers_of_has_limit_parallel_pair C

/-- A cokernel of `f - g` is a coequalizer of `f` and `g`. -/
theorem preadditive.has_colimit_parallel_pair {C : Type u} [category C] [preadditive C] {X : C}
    {Y : C} (f : X ⟶ Y) (g : X ⟶ Y) [limits.has_cokernel (f - g)] :
    limits.has_colimit (limits.parallel_pair f g) :=
  sorry

/-- If a preadditive category has all cokernels, then it also has all coequalizers. -/
theorem preadditive.has_coequalizers_of_has_cokernels {C : Type u} [category C] [preadditive C]
    [limits.has_cokernels C] : limits.has_coequalizers C :=
  limits.has_coequalizers_of_has_colimit_parallel_pair C

end Mathlib


/-
# Expressions

Expressions (terms of type `Expr`) are an abstract syntax tree for Lean
programs. This means that each term which can be written in Lean has a
corresponding `Expr`. For example, the application `f e` is represented by the
expression `Expr.app ⟦f⟧ ⟦e⟧`, where `⟦f⟧` is a representation of `f` and `⟦e⟧`
a representation of `e`. Similarly, the term `Nat` is represented by the
expression ``Expr.const `Nat []``. (The backtick and empty list are discussed
below.)

The ultimate purpose of a Lean tactic block is to generate a term which serves
as a proof of the theorem we want to prove. Thus, the purpose of a tactic is to
produce (part of) an `Expr` of the right type. Much metaprogramming therefore
comes down to manipulating expressions: constructing new ones and taking apart
existing ones.

Once a tactic block is finished, the `Expr` is sent to the kernel, which checks
whether it is well-typed and whether it really has the type claimed by the
theorem. As a result, tactic bugs are not fatal: if you make a mistake, the
kernel will ultimately catch it. However, many internal Lean functions also
assume that expressions are well-typed, so you may crash Lean before the
expression ever reaches the kernel. To avoid this, Lean provides many functions
which help with the manipulation of expressions. This chapter and the next
survey the most important ones.

Let's get concrete and look at the
[`Expr`](https://github.com/leanprover/lean4/blob/master/src/Lean/Expr.lean)
type:
-/

import Lean

namespace Playground

inductive Expr where
  | bvar    : Nat → Expr                              -- bound variables
  | fvar    : FVarId → Expr                           -- free variables
  | mvar    : MVarId → Expr                           -- meta variables
  | sort    : Level → Expr                            -- Sort
  | const   : Name → List Level → Expr                -- constants
  | app     : Expr → Expr → Expr                      -- application
  | lam     : Name → Expr → Expr → BinderInfo → Expr  -- lambda abstraction
  | forallE : Name → Expr → Expr → BinderInfo → Expr  -- (dependent) arrow
  | letE    : Name → Expr → Expr → Expr → Bool → Expr -- let expressions
  -- less essential constructors:
  | lit     : Literal → Expr                          -- literals
  | mdata   : MData → Expr → Expr                     -- metadata
  | proj    : Name → Nat → Expr → Expr                -- projection

end Playground

/-! What is each of these constructors doing?

- `bvar` is a __bound variable__. For example, the `x` in `fun x => x + 2` or
  `∑ x, x²`. This is any occurrence of a variable in an expression where there
  is a binder above it. Why is the argument a `Nat`? This is called a de Bruijn
  index and will be explained later. You can figure out the type of a bound
  variable by looking at its binder, since the binder always has the type
  information for it.
- `fvar` is a __free variable__. These are variables which are not bound by a
  binder. An example is `x` in `x + 2`. Note that you can't just look at a free
  variable `x` and tell what its type is, there needs to be a context
  which contains a declaration for `x` and its type. A free variable has an ID
  that tells you where to look for it in a `LocalContext`. In Lean 3, free
  variables were called "local constants" or "locals".
- `mvar` is a __metavariable__. There will be much more on these later, but you
  can think of it as a placeholder or a 'hole' in an expression that needs to be
  filled at a later point.
- `sort` is used for `Type u`, `Prop` etc.
- `const` is a constant that has been defined earlier in the Lean document.
- `app` is a function application. Multiple arguments are done using _partial
  application_: `f x y ↝ app (app f x) y`.
- `lam n t b` is a lambda expression (`fun ($n : $t) => $b`). The `b` argument
  is called the __body__. Note that you have to give the type of the variable
  you are binding.
- `forallE n t b` is a dependent arrow expression (`($n : $t) → $b`). This is
  also sometimes called a Π-type or Π-expression and is often written `∀ $n :
  $t, $b`. Note that the non-dependent arrow `α → β` is a special case of `(a :
  α) → β` where `β` doesn't depend on `a`. The `E` on the end of `forallE` is to
  distinguish it from the `forall` keyword.
- `letE n t v b` is a __let binder__ (`let ($n : $t) := $v in $b`).
- `lit` is a __literal__, this is a number or string literal like `4` or
  `"hello world"`. Literals help with performance: we don't want to represent
  the expression `(10000 : Nat)` as `Nat.succ $ ... $ Nat.succ Nat.zero`.
- `mdata` is just a way of storing extra information on expressions that might
  be useful, without changing the nature of the expression.
- `proj` is for projection. Suppose you have a structure such as `p : α × β`,
  rather than storing the projection `π₁ p` as `app π₁ p`, it is expressed as
  `proj Prod 0 p`. This is for efficiency reasons ([todo] find link to docstring
  explaining this).

You've probably noticed that you can write many Lean programs which do not have
an obvious corresponding `Expr`. For example, what about `match` statements,
`do` blocks or `by` blocks? These constructs, and many more, must indeed first
be translated into expressions. The part of Lean which performs this
(substantial) task is called the elaborator and is discussed in its own chapter.
The benefit of this setup is that once the translation to `Expr` is done, we
have a relatively simple structure to work with. (The downside is that going
back from `Expr` to a high-level Lean program can be challenging.)

The elaborator also fills in any implicit or typeclass instance arguments which
you may have omitted from your Lean program. Thus, at the `Expr` level,
constants are always applied to all their arguments, implicit or not. This is
both a blessing (because you get a lot of information which is not obvious from
the source code) and a curse (because when you build an `Expr`, you must supply
any implicit or instance arguments yourself).

## De Bruijn Indexes

Consider the following lambda expression `(λ f x => f x x) (λ x y => x + y) 5`,
we have to be very careful when we reduce this, because we get a clash in the
variable `x`.

To avoid variable name-clash carnage, `Expr`s use a nifty trick called
__de Bruijn indexes__. In de Bruijn indexing, each variable bound by a `lam` or
a `forallE` is converted into a number `#n`. The number says how many binders up
the `Expr` tree we should look to find the binder which binds this variable.
So our above example would become (putting wildcards `_` in the type arguments
for now for brevity):
``app (app (lam `f _ (lam `x _ (app (app #1 #0) #0))) (lam `x _ (lam `y _ (app (app plus #1) #0)))) five``
Now we don't need to rename variables when we perform β-reduction. We also
really easily check if two `Expr`s containing bound expressions are equal. This
is why the signature of the `bvar` case is `Nat → Expr` and not
`Name → Expr`.

If a de Bruijn index is too large for the number of binders preceding it, we say
it is a __loose `bvar`__; otherwise we say it is __bound__. For example, in the
expression ``lam `x _ (app #0 #1)`` the `bvar` `#0` is bound by the preceding
binder and `#1` is loose. The fact that Lean calls all de Bruijn indexes `bvar`s
("bound variables") points to an important invariant: outside of some very
low-level functions, Lean expects that expressions do not contain any loose
`bvar`s. Instead, whenever we would be tempted to introduce a loose `bvar`, we
immediately convert it into an `fvar` ("free variable"). Precisely how that
works is discussed in the next chapter.

If there are no loose `bvar`s in an expression, we say that the expression is
__closed__. The process of replacing all instances of a loose `bvar` with an
`Expr` is called __instantiation__. Going the other way is called
__abstraction__.

If you are familiar with the standard terminology around variables, Lean's
terminology may be confusing, so here's a map: Lean's "bvars" are usually called
just "variables"; Lean's "loose" is usually called "free"; and Lean's "fvars"
might be called "local hypotheses".

## Universe Levels

Some expressions involve universe levels, represented by the `Lean.Level` type.
A universe level is a natural number, a universe parameter (introduced with a
`universe` declaration), a universe metavariable or the maximum of two
universes. They are relevant for two kinds of expressions.

First, sorts are represented by `Expr.sort u`, where `u` is a `Level`. `Prop` is
`sort Level.zero`; `Type` is `sort (Level.succ Level.zero)`.

Second, universe-polymorphic constants have universe arguments. A
universe-polymorphic constant is one whose type contains universe parameters.
For example, the `List.map` function is universe-polymorphic, as the
`pp.universes` pretty-printing option shows: -/

set_option pp.universes true in
#check @List.map

/-!
The `.{u_1,u_2}` suffix after `List.map` means that `List.map` has two universe
arguments, `u_1` and `u_2`. The `.{u_1}` suffix after `List` (which is itself a
universe-polymorphic constant) means that `List` is applied to the universe
argument `u_1`, and similar for `.{u_2}`.

In fact, whenever you use a universe-polymorphic constant, you must apply it to
the correct universe arguments. This application is represented by the `List
Level` argument of `Expr.const`. When we write regular Lean code, Lean infers
the universes automatically, so we do not need think about them much. But when
we construct `Expr`s, we must be careful to apply each universe-polymorphic
constant to the right universe arguments.

## Constructing Expressions

The simplest expressions we can construct are constants. We use the `const`
constructor and give it a name and a list of universe levels. Most of our
examples only involve non-universe-polymorphic constants, in which case the list
is empty.

We also show a second form where we write the name with double backticks. This
checks that the name in fact refers to a defined constant, which is useful to
avoid typos. -/

open Lean

def z' := Expr.const `Nat.zero []
#eval z' -- Lean.Expr.const `Nat.zero []

def z := Expr.const ``Nat.zero []
#eval z -- Lean.Expr.const `Nat.zero []

/- The double-backtick variant also resolves the given name, making it
fully-qualified. To illustrate this mechanism, here are two further examples.
The first expression, `z₁`, is unsafe: if we use it in a context where the `Nat`
namespace is not open, Lean will complain that there is no constant called
`zero` in the environment. In contrast, the second expression, `z₂`, contains
the fully-qualified name `Nat.zero` and does not have this problem. -/

open Nat

def z₁ := Expr.const `zero []
#eval z₁ -- Lean.Expr.const `zero []

def z₂ := Expr.const ``zero []
#eval z₂ -- Lean.Expr.const `Nat.zero []

/- The next class of expressions we consider are function applications. These
can be built using the `app` constructor, with the first argument being an
expression for the function and the second being an expression for the argument.

Here are two examples. The first is simply a constant applied to another. The
second is a recursive definition giving an expression as a function of a natural
number. -/

def one := Expr.app (.const ``Nat.succ []) z
#eval one
-- Lean.Expr.app (Lean.Expr.const `Nat.succ []) (Lean.Expr.const `Nat.zero [])

def natExpr: Nat → Expr
| 0     => z
| n + 1 => .app (.const ``Nat.succ []) (natExpr n)

/-  Next we use the variant `mkAppN` which allows application with multiple
arguments. -/

def sumExpr : Nat → Nat → Expr
| n, m => mkAppN (.const ``Nat.add []) #[natExpr n, natExpr m]

/- As you may have noticed, we didn't show `#eval` outputs for the two last
functions. That's because the resulting expressions can grow so large that it's
hard to make sense of them.

We next use the constructor `lam` to construct a simple function which takes any
natural number `x` and returns `Nat.zero`. The argument `BinderInfo.default`
says that `x` is an explicit argument (rather than an implicit or typeclass
argument). -/

def constZero : Expr :=
  .lam `x (.const ``Nat []) (.const ``Nat.zero []) BinderInfo.default

#eval constZero
-- Lean.Expr.lam `x (Lean.Expr.const `Nat []) (Lean.Expr.const `Nat.zero [])
--   (Lean.BinderInfo.default)

/-! As a more elaborate example which also involves universe levels, here is the
`Expr` that represents `List.map (λ x => Nat.add x 1) []` (broken up into
several definitions to make it somewhat readable): -/

def nat : Expr := .const ``Nat []

def addOne : Expr :=
  .lam `x nat
    (mkAppN (.const ``Nat.add []) #[.bvar 0, mkNatLit 1])
    BinderInfo.default

def mapAddOneNil : Expr :=
  mkAppN (.const ``List.map [levelOne, levelOne])
    #[nat, nat, addOne, .app (.const ``List.nil [levelOne]) nat]

/-! With a little trick (more about which in the Elaboration chapter), we can
turn our `Expr` into a Lean term, which allows us to inspect it more easily. -/

elab "mapAddOneNil" : term => return mapAddOneNil

#check mapAddOneNil
-- List.map (fun x => Nat.add x 1) [] : List Nat

set_option pp.universes true in
set_option pp.explicit true in
#check mapAddOneNil
-- @List.map.{1, 1} Nat Nat (fun x => Nat.add x 1) (@List.nil.{1} Nat) : List.{1} Nat

#reduce mapAddOneNil
-- []

/- In the next chapter we explore the `MetaM` monad, which, among many other
things, allows us to more conveniently construct and destruct larger
expressions.

## Exercises

1. Create expression `1 + 2` with `Expr.app`.
2. Create expression `1 + 2` with `Lean.mkAppN`.
3. Create expression `fun x => 1 + x`.
4. [**De Bruijn Indexes**] Create expression `fun a, fun b, fun c, (b * a) + c`.
5. Create expression `fun x y => x + y`.
6. Create expression `fun x, String.append "hello, " x`.
7. Create expression `∀ x : Prop, x ∧ x`.
8. Create expression `Nat → String`.
9. Create expression `fun (p : Prop) => (λ hP : p => hP)`.
10. [**Universe levels**] Create expression `Type 6`.
-/


/-
Copyright (c) 2014 Robert Lewis. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Robert Lewis, Leonardo de Moura, Mario Carneiro, Floris van Doorn

! This file was ported from Lean 3 source module algebra.order.field.canonical.basic
! leanprover-community/mathlib commit 448144f7ae193a8990cb7473c9e9a01990f64ac7
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Algebra.Order.Field.Canonical.Defs

/-!
# Lemmas about canonically ordered semifields.

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

-/

variable {α : Type _}

section CanonicallyLinearOrderedSemifield

variable [CanonicallyLinearOrderedSemifield α] [Sub α] [OrderedSub α]

/- warning: tsub_div -> tsub_div is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} [_inst_1 : CanonicallyLinearOrderedSemifield.{u1} α] [_inst_2 : Sub.{u1} α] [_inst_3 : OrderedSub.{u1} α (Preorder.toLE.{u1} α (PartialOrder.toPreorder.{u1} α (OrderedCancelAddCommMonoid.toPartialOrder.{u1} α (StrictOrderedSemiring.toOrderedCancelAddCommMonoid.{u1} α (LinearOrderedSemiring.toStrictOrderedSemiring.{u1} α (LinearOrderedCommSemiring.toLinearOrderedSemiring.{u1} α (LinearOrderedSemifield.toLinearOrderedCommSemiring.{u1} α (CanonicallyLinearOrderedSemifield.toLinearOrderedSemifield.{u1} α _inst_1)))))))) (Distrib.toHasAdd.{u1} α (NonUnitalNonAssocSemiring.toDistrib.{u1} α (NonAssocSemiring.toNonUnitalNonAssocSemiring.{u1} α (Semiring.toNonAssocSemiring.{u1} α (StrictOrderedSemiring.toSemiring.{u1} α (LinearOrderedSemiring.toStrictOrderedSemiring.{u1} α (LinearOrderedCommSemiring.toLinearOrderedSemiring.{u1} α (LinearOrderedSemifield.toLinearOrderedCommSemiring.{u1} α (CanonicallyLinearOrderedSemifield.toLinearOrderedSemifield.{u1} α _inst_1))))))))) _inst_2] (a : α) (b : α) (c : α), Eq.{succ u1} α (HDiv.hDiv.{u1, u1, u1} α α α (instHDiv.{u1} α (DivInvMonoid.toHasDiv.{u1} α (GroupWithZero.toDivInvMonoid.{u1} α (DivisionSemiring.toGroupWithZero.{u1} α (Semifield.toDivisionSemiring.{u1} α (LinearOrderedSemifield.toSemifield.{u1} α (CanonicallyLinearOrderedSemifield.toLinearOrderedSemifield.{u1} α _inst_1))))))) (HSub.hSub.{u1, u1, u1} α α α (instHSub.{u1} α _inst_2) a b) c) (HSub.hSub.{u1, u1, u1} α α α (instHSub.{u1} α _inst_2) (HDiv.hDiv.{u1, u1, u1} α α α (instHDiv.{u1} α (DivInvMonoid.toHasDiv.{u1} α (GroupWithZero.toDivInvMonoid.{u1} α (DivisionSemiring.toGroupWithZero.{u1} α (Semifield.toDivisionSemiring.{u1} α (LinearOrderedSemifield.toSemifield.{u1} α (CanonicallyLinearOrderedSemifield.toLinearOrderedSemifield.{u1} α _inst_1))))))) a c) (HDiv.hDiv.{u1, u1, u1} α α α (instHDiv.{u1} α (DivInvMonoid.toHasDiv.{u1} α (GroupWithZero.toDivInvMonoid.{u1} α (DivisionSemiring.toGroupWithZero.{u1} α (Semifield.toDivisionSemiring.{u1} α (LinearOrderedSemifield.toSemifield.{u1} α (CanonicallyLinearOrderedSemifield.toLinearOrderedSemifield.{u1} α _inst_1))))))) b c))
but is expected to have type
  forall {α : Type.{u1}} [_inst_1 : CanonicallyLinearOrderedSemifield.{u1} α] [_inst_2 : Sub.{u1} α] [_inst_3 : OrderedSub.{u1} α (Preorder.toLE.{u1} α (PartialOrder.toPreorder.{u1} α (StrictOrderedSemiring.toPartialOrder.{u1} α (LinearOrderedSemiring.toStrictOrderedSemiring.{u1} α (LinearOrderedCommSemiring.toLinearOrderedSemiring.{u1} α (LinearOrderedSemifield.toLinearOrderedCommSemiring.{u1} α (CanonicallyLinearOrderedSemifield.toLinearOrderedSemifield.{u1} α _inst_1))))))) (Distrib.toAdd.{u1} α (NonUnitalNonAssocSemiring.toDistrib.{u1} α (NonAssocSemiring.toNonUnitalNonAssocSemiring.{u1} α (Semiring.toNonAssocSemiring.{u1} α (StrictOrderedSemiring.toSemiring.{u1} α (LinearOrderedSemiring.toStrictOrderedSemiring.{u1} α (LinearOrderedCommSemiring.toLinearOrderedSemiring.{u1} α (LinearOrderedSemifield.toLinearOrderedCommSemiring.{u1} α (CanonicallyLinearOrderedSemifield.toLinearOrderedSemifield.{u1} α _inst_1))))))))) _inst_2] (a : α) (b : α) (c : α), Eq.{succ u1} α (HDiv.hDiv.{u1, u1, u1} α α α (instHDiv.{u1} α (CanonicallyLinearOrderedSemifield.toDiv.{u1} α _inst_1)) (HSub.hSub.{u1, u1, u1} α α α (instHSub.{u1} α _inst_2) a b) c) (HSub.hSub.{u1, u1, u1} α α α (instHSub.{u1} α _inst_2) (HDiv.hDiv.{u1, u1, u1} α α α (instHDiv.{u1} α (CanonicallyLinearOrderedSemifield.toDiv.{u1} α _inst_1)) a c) (HDiv.hDiv.{u1, u1, u1} α α α (instHDiv.{u1} α (CanonicallyLinearOrderedSemifield.toDiv.{u1} α _inst_1)) b c))
Case conversion may be inaccurate. Consider using '#align tsub_div tsub_divₓ'. -/
theorem tsub_div (a b c : α) : (a - b) / c = a / c - b / c := by simp_rw [div_eq_mul_inv, tsub_mul]
#align tsub_div tsub_div

end CanonicallyLinearOrderedSemifield


/-
Copyright (c) 2022 Yury G. Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury G. Kudryashov
-/
import algebra.hom.group_instances
import topology.algebra.uniform_group
import topology.uniform_space.completion

/-!
# Multiplicative action on the completion of a uniform space

In this file we define typeclasses `has_uniform_continuous_const_vadd` and
`has_uniform_continuous_const_smul` and prove that a multiplicative action on `X` with uniformly
continuous `(•) c` can be extended to a multiplicative action on `uniform_space.completion X`.

In later files once the additive group structure is set up, we provide
* `uniform_space.completion.distrib_mul_action`
* `uniform_space.completion.mul_action_with_zero`
* `uniform_space.completion.module`
-/

universes u v w x y z

noncomputable theory

variables (R : Type u) (M : Type v) (N : Type w) (X : Type x) (Y : Type y)
  [uniform_space X] [uniform_space Y]

/-- An additive action such that for all `c`, the map `λ x, c +ᵥ x` is uniformly continuous. -/
class has_uniform_continuous_const_vadd [uniform_space X] [has_vadd M X] : Prop :=
(uniform_continuous_const_vadd : ∀ (c : M), uniform_continuous ((+ᵥ) c : X → X))

/-- A multiplicative action such that for all `c`, the map `λ x, c • x` is uniformly continuous. -/
@[to_additive]
class has_uniform_continuous_const_smul [uniform_space X] [has_scalar M X] : Prop :=
(uniform_continuous_const_smul : ∀ (c : M), uniform_continuous ((•) c : X → X))

export has_uniform_continuous_const_vadd (uniform_continuous_const_vadd)
  has_uniform_continuous_const_smul (uniform_continuous_const_smul)

instance add_monoid.has_uniform_continuous_const_smul_nat [add_group X] [uniform_add_group X] :
  has_uniform_continuous_const_smul ℕ X :=
⟨uniform_continuous_const_nsmul⟩

instance add_group.has_uniform_continuous_const_smul_int [add_group X] [uniform_add_group X] :
  has_uniform_continuous_const_smul ℤ X :=
⟨uniform_continuous_const_zsmul⟩

section has_scalar

variable [has_scalar M X]

@[priority 100, to_additive]
instance has_uniform_continuous_const_smul.to_has_continuous_const_smul
  [has_uniform_continuous_const_smul M X] : has_continuous_const_smul M X :=
⟨λ c, (uniform_continuous_const_smul c).continuous⟩

variables {M X Y}

@[to_additive] lemma uniform_continuous.const_smul [has_uniform_continuous_const_smul M X]
  {f : Y → X} (hf : uniform_continuous f) (c : M) :
  uniform_continuous (c • f) :=
(uniform_continuous_const_smul c).comp hf

/-- If a scalar is central, then its right action is uniform continuous when its left action is. -/
@[priority 100]
instance has_uniform_continuous_const_smul.op [has_scalar Mᵐᵒᵖ X] [is_central_scalar M X]
  [has_uniform_continuous_const_smul M X] : has_uniform_continuous_const_smul Mᵐᵒᵖ X :=
⟨mul_opposite.rec $ λ c, begin
  change uniform_continuous (λ m, mul_opposite.op c • m),
  simp_rw op_smul_eq_smul,
  exact uniform_continuous_const_smul c,
end⟩

@[to_additive] instance mul_opposite.has_uniform_continuous_const_smul
  [has_uniform_continuous_const_smul M X] : has_uniform_continuous_const_smul M Xᵐᵒᵖ :=
⟨λ c, mul_opposite.uniform_continuous_op.comp $ mul_opposite.uniform_continuous_unop.const_smul c⟩

end has_scalar

@[to_additive] instance uniform_group.to_has_uniform_continuous_const_smul
  {G : Type u} [group G] [uniform_space G] [uniform_group G] :
  has_uniform_continuous_const_smul G G :=
⟨λ c, uniform_continuous_const.mul uniform_continuous_id⟩

namespace uniform_space

namespace completion

section has_scalar

variable [has_scalar M X]

@[to_additive has_vadd] instance : has_scalar M (completion X) :=
⟨λ c, completion.map ((•) c)⟩

@[to_additive] instance : has_uniform_continuous_const_smul M (completion X) :=
⟨λ c, uniform_continuous_map⟩

instance [has_scalar Mᵐᵒᵖ X] [is_central_scalar M X] : is_central_scalar M (completion X) :=
⟨λ c a, congr_arg (λ f, completion.map f a) $ by exact funext (op_smul_eq_smul c)⟩

variables {M X} [has_uniform_continuous_const_smul M X]

@[simp, norm_cast, to_additive]

end has_scalar

@[to_additive] instance [monoid M] [mul_action M X] [has_uniform_continuous_const_smul M X] :
  mul_action M (completion X) :=
{ smul := (•),
  one_smul := ext' (continuous_const_smul _) continuous_id $ λ a, by rw [← coe_smul, one_smul],
  mul_smul := λ x y, ext' (continuous_const_smul _) ((continuous_const_smul _).const_smul _) $
    λ a, by simp only [← coe_smul, mul_smul] }

end completion

end uniform_space


import Advent

inductive DDigit (base: Nat)
  | Z
  | DP (d: Fin base)
  | DN (d: Fin base)
deriving Repr, BEq, Inhabited

instance {base}: ToString (DDigit base) where
  toString
  | .Z => "0"
  | .DP x => toString <| (x : Nat) + 1
  | .DN x => "-" ++ (toString <| (x : Nat) + 1)

def DoubleSys base := Array (DDigit base)
namespace DoubleSys
  instance {base}: BEq (DoubleSys base) where beq (x: Array _) y := x == y
  instance {base}: Inhabited (DoubleSys base) where default := Array.empty
  instance {base}: ToString (DoubleSys base) where
    toString := Array.foldl (·.append <| char · |> (·.push '|')) ""
  where
    char
    | .Z => "0"
    | .DP d => s!"{d.succ}"
    | .DN d => s!"-{d.succ}"

  instance {base}: Coe (DoubleSys base) Nat where
    coe := Array.foldl addDig 0
  where
    base' := base * 2 + 1
    addDig n
    | .Z => n * base'
    | .DP d => n * base' + d + 1
    | .DN d => n * base' - d - 1

  private theorem doubleLe: b > 0 -> a < b * 2 -> ¬ (a < b) -> b * 2 - 1 - a < b := by
    intros u p q
    rw [<-Nat.sub_add_eq]
    have p₂: b = b * 2 - b := by
      rw [Nat.mul_add b 1 1]
      simp
    conv => rhs; rw [p₂]
    apply Nat.sub_lt_sub_left
    . apply Nat.lt_add_of_pos_left
      simp
      assumption
    . apply Nat.lt_of_not_le
      intro p
      apply q
      apply Nat.lt_of_succ_le
      rw [Nat.add_comm] at p
      assumption

  instance {base}: Coe Nat (DoubleSys base) where
    coe x := go Array.empty x x
  where
    go acc x
    | 0 => acc.reverse
    | fuel + 1 =>
      let base' := base * 2 + 1
      if x == 0 then acc.reverse else
      let r := x % base'
      let x' := x / base'
      let d := match q: r with
        | 0 => DDigit.Z
        | r' + 1 =>
          if p: r' < base then DDigit.DP ⟨ r', p ⟩
          else
            let r'' := base * 2 - 1 - r'
            DDigit.DN <| Fin.mk r'' <| by
              apply doubleLe
              . apply Nat.lt_of_not_le
                intro p₂
                rw [Nat.le_zero] at p₂
                have bq: base' = base * 2 + 1 := Eq.refl _
                conv at bq =>
                  rw [p₂]
                  rhs
                  simp
                have rp: r = x % base' := Eq.refl _
                have rp₂ : x % base' < 1 := by
                  rw [<-bq]
                  apply Nat.mod_lt
                  apply Nat.zero_lt_of_ne_zero
                  simp
                rw [←rp, q] at rp₂
                contradiction
              . apply Nat.lt_of_succ_le
                rw [<-q]
                apply Nat.le_of_lt_succ
                have qq: base' = (base * 2).succ := by simp
                rw [<-qq]
                have qqq: r = x % base' := by simp
                rw [qqq]
                apply Nat.mod_lt
                rw [qq]
                apply Nat.zero_lt_succ
              . assumption
      let x := if let .DN _ := d then x' + 1 else x'
      go (acc.push d) x fuel

end DoubleSys

abbrev SNAFU := DoubleSys 2

def readSnafu (s: String): Option SNAFU :=
  s.toList.toArray.mapM go
where
  go: Char -> Option (DDigit 2)
  | '-' => some <| DDigit.DN 0
  | '=' => some <| DDigit.DN 1
  | '0' => some <| DDigit.Z
  | '1' => some <| DDigit.DP 0
  | '2' => some <| DDigit.DP 1
  | _   => none

def writeSnafu : SNAFU -> String :=
  String.mk ∘ Array.toList ∘ Array.map toChar
where
  toChar
  | DDigit.DN 0 => '-'
  | DDigit.DN 1 => '='
  | DDigit.Z => '0'
  | DDigit.DP 0 => '1'
  | DDigit.DP 1 => '2'

def main: IO Unit := do
  let lines <- readLines 25
  let snafus := (lines.mapM readSnafu).get!
  snafus.forM IO.println
  let nats: List Nat := snafus.map <| λ (x: SNAFU) => ↑x
  nats.forM IO.println
  let back := nats.map (fun (x: Nat) => (x: SNAFU))
  if back == snafus then IO.println "OK!"
  let s := nats.sum
  IO.println s
  IO.println <| writeSnafu s