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

import category_theory.isomorphism
import category_theory.functor_category

namespace category_theory

universes u₁ v₁ u₂ v₂ u₃ v₃ u₄ v₄

section
variables (C : Type u₁) [𝒞 : category.{v₁} C]
          (D : Type u₂) [𝒟 : category.{v₂} D]
          (E : Type u₃) [ℰ : category.{v₃} E]
include 𝒞 𝒟 ℰ

def whiskering_left : (C ⥤ D) ⥤ ((D ⥤ E) ⥤ (C ⥤ E)) :=
{ obj := λ F,
  { obj := λ G, F ⋙ G,
    map := λ G H α,
    { app := λ c, α.app (F.obj c),
      naturality' := by intros X Y f; rw [functor.comp_map, functor.comp_map, α.naturality] } },
  map := λ F G τ,
  { app := λ H,
    { app := λ c, H.map (τ.app c),
      naturality' := λ X Y f, begin dsimp at *, rw [←H.map_comp, ←H.map_comp, ←τ.naturality] end },
    naturality' := λ X Y f, begin ext1, dsimp at *, rw [←nat_trans.naturality] end } }

def whiskering_right : (D ⥤ E) ⥤ ((C ⥤ D) ⥤ (C ⥤ E)) :=
{ obj := λ H,
  { obj := λ F, F ⋙ H,
    map := λ _ _ α,
    { app := λ c, H.map (α.app c),
      naturality' := by intros X Y f;
        rw [functor.comp_map, functor.comp_map, ←H.map_comp, ←H.map_comp, α.naturality] } },
  map := λ G H τ,
  { app := λ F,
    { app := λ c, τ.app (F.obj c),
      naturality' := λ X Y f, begin dsimp at *, rw [τ.naturality] end },
    naturality' := λ X Y f, begin ext1, dsimp at *, rw [←nat_trans.naturality] end } }

variables {C} {D} {E}

def whisker_left (F : C ⥤ D) {G H : D ⥤ E} (α : G ⟹ H) : (F ⋙ G) ⟹ (F ⋙ H) :=
((whiskering_left C D E).obj F).map α

@[simp] lemma whisker_left.app (F : C ⥤ D) {G H : D ⥤ E} (α : G ⟹ H) (X : C) :
  (whisker_left F α).app X = α.app (F.obj X) :=
rfl

def whisker_right {G H : C ⥤ D} (α : G ⟹ H) (F : D ⥤ E) : (G ⋙ F) ⟹ (H ⋙ F) :=
((whiskering_right C D E).obj F).map α

@[simp] lemma whisker_right.app {G H : C ⥤ D} (α : G ⟹ H) (F : D ⥤ E) (X : C) :
   (whisker_right α F).app X = F.map (α.app X) :=
rfl

@[simp] lemma whisker_left_id (F : C ⥤ D) {G : D ⥤ E} :
  whisker_left F (nat_trans.id G) = nat_trans.id (F.comp G) :=
rfl

@[simp] lemma whisker_right_id {G : C ⥤ D} (F : D ⥤ E) :
  whisker_right (nat_trans.id G) F = nat_trans.id (G.comp F) :=
((whiskering_right C D E).obj F).map_id _

@[simp] lemma whisker_left_vcomp (F : C ⥤ D) {G H K : D ⥤ E} (α : G ⟹ H) (β : H ⟹ K) :
  whisker_left F (α ⊟ β) = (whisker_left F α) ⊟ (whisker_left F β) :=
rfl

@[simp] lemma whisker_right_vcomp {G H K : C ⥤ D} (α : G ⟹ H) (β : H ⟹ K) (F : D ⥤ E)  :
  whisker_right (α ⊟ β) F = (whisker_right α F) ⊟ (whisker_right β F) :=
((whiskering_right C D E).obj F).map_comp α β

variables {B : Type u₄} [ℬ : category.{v₄} B]
include ℬ

local attribute [elab_simple] whisker_left whisker_right

@[simp] lemma whisker_left_twice (F : B ⥤ C) (G : C ⥤ D) {H K : D ⥤ E} (α : H ⟹ K) :
  whisker_left F (whisker_left G α) = whisker_left (F ⋙ G) α :=
rfl

@[simp] lemma whisker_right_twice {H K : B ⥤ C} (F : C ⥤ D) (G : D ⥤ E) (α : H ⟹ K) :
  whisker_right (whisker_right α F) G = whisker_right α (F ⋙ G) :=
rfl

lemma whisker_right_left (F : B ⥤ C) {G H : C ⥤ D} (α : G ⟹ H) (K : D ⥤ E) :
  whisker_right (whisker_left F α) K = whisker_left F (whisker_right α K) :=
rfl
end

namespace functor

universes u₅ v₅

variables {A : Type u₁} [𝒜 : category.{v₁} A]
variables {B : Type u₂} [ℬ : category.{v₂} B]
include 𝒜 ℬ

def left_unitor (F : A ⥤ B) : ((functor.id _) ⋙ F) ≅ F :=
{ hom := { app := λ X, 𝟙 (F.obj X) },
  inv := { app := λ X, 𝟙 (F.obj X) } }

@[simp] lemma left_unitor_hom_app {F : A ⥤ B} {X} : F.left_unitor.hom.app X = 𝟙 _ := rfl
@[simp] lemma left_unitor_inv_app {F : A ⥤ B} {X} : F.left_unitor.inv.app X = 𝟙 _ := rfl

def right_unitor (F : A ⥤ B) : (F ⋙ (functor.id _)) ≅ F :=
{ hom := { app := λ X, 𝟙 (F.obj X) },
  inv := { app := λ X, 𝟙 (F.obj X) } }

@[simp] lemma right_unitor_hom_app {F : A ⥤ B} {X} : F.right_unitor.hom.app X = 𝟙 _ := rfl
@[simp] lemma right_unitor_inv_app {F : A ⥤ B} {X} : F.right_unitor.inv.app X = 𝟙 _ := rfl

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

def associator (F : A ⥤ B) (G : B ⥤ C) (H : C ⥤ D) : ((F ⋙ G) ⋙ H) ≅ (F ⋙ (G ⋙ H)) :=
{ hom := { app := λ _, 𝟙 _ },
  inv := { app := λ _, 𝟙 _ } }

@[simp] lemma associator_hom_app {F : A ⥤ B} {G : B ⥤ C} {H : C ⥤ D} {X} :
(associator F G H).hom.app X = 𝟙 _ := rfl
@[simp] lemma associator_inv_app {F : A ⥤ B} {G : B ⥤ C} {H : C ⥤ D} {X} :
(associator F G H).inv.app X = 𝟙 _ := rfl

omit 𝒟

lemma triangle (F : A ⥤ B) (G : B ⥤ C) :
  (associator F (functor.id B) G).hom ⊟ (whisker_left F (left_unitor G).hom) =
    (whisker_right (right_unitor F).hom G) :=
begin
  ext1,
  dsimp [associator, left_unitor, right_unitor],
  simp
end

variables {E : Type u₅} [ℰ : category.{v₅} E]
include 𝒟 ℰ

variables (F : A ⥤ B) (G : B ⥤ C) (H : C ⥤ D) (K : D ⥤ E)

lemma pentagon :
  (whisker_right (associator F G H).hom K) ⊟ (associator F (G ⋙ H) K).hom ⊟ (whisker_left F (associator G H K).hom) =
    ((associator (F ⋙ G) H K).hom ⊟ (associator F G (H ⋙ K)).hom) :=
begin
  ext1,
  dsimp [associator],
  simp,
end

end functor

end category_theory


example (p q : Prop) : p ∧ q → p := by
  refine fun ⟨a, b⟩ => a

example (p q : Prop) : p ∧ q → p := by
  refine fun a => ?hp
  trace_state
  exact a.1

example (p q : Prop) : p ∧ q → p := by
  refine fun ⟨a, b⟩ => a

example (p q : Prop) : p ∧ q → p := by
  refine fun ⟨a, b⟩ => ?hp
  trace_state
  exact a

example (p q : Prop) : p ∧ q → p := by
  refine fun a => ?hp
  case hp => exact a.1

example (p q : Prop) : p ∧ q → p := by
  refine fun ⟨a, b⟩ => ?hp
  case hp => exact a

example (p q : Prop) : p ∧ q → p := by
  refine λ ⟨a, b⟩ => ?hp
  trace_state
  exact a


-- Copyright © 2019 François G. Dorais. All rights reserved.
-- Released under Apache 2.0 license as described in the file LICENSE.

import .meta.ind_utils

/-

structure {u_0 u_1 ... u_{n-1} v_0 v_1 ... v_{n-1}} multi_function_n
(α_0 : Sort u_0) (α_1 : Sort u_1) ... (α_{n-1} : Sort u_{n-1})
(β_0 : Sort v_0) (β_1 : Sort v_1) ... (β_{n-1} : Sort v_{n-1}) :=
mk :: (fn_0 : α_0 → β_0) (fn_1 : α_1 → β_1) ... (fn_{n-1} : α_{n-1} → β_{n-1})

theorem multi_function_n.mk.eta {α_0 α_1 ... α_{n-1} β_0 β_1 ... β_{n-1}} (f : multi_function_n α_0 α_1 ... α_{n-1} β_0 β_1 ... β_{n-1}),
multi_function_n.mk (multi_function_n.fn_0 f) (multi_function_n.fn_1 f) ... (multi_function_n.fn_{n-1} f) = f

definition multi_function_n.id {α_0 α_1 ... α_{n-1}} :
multi_function_n α_0 α_1 ... α_{n-1} α_0 α_1 ... α_{n-1}

definition multi_function_n.comp {α_0 α_1 ... α_{n-1} β_0 β_1 ... β_{n-1} γ_0 γ_1 ... γ_{n-1}} :
multi_function_n β_0 β_1 ... β_{n-1} γ_0 γ_1 ... γ_{n-1} →
multi_function_n α_0 α_1 ... α_{n-1} β_0 β_1 ... β_{n-1} →
multi_function_n α_0 α_1 ... α_{n-1} γ_0 γ_1 ... γ_{n-1}

theorem multi_function_n.comp.assoc {α_0 α_1 ... α_{n-1} β_0 β_1 ... β_{n-1} γ_0 γ_1 ... γ_{n-1} δ_0 δ_1 ... δ_{n-1}}
(f : multi_function_n γ_0 γ_1 ... γ_{n-1} δ_0 δ_1 ... δ_{n-1})
(g : multi_function_n β_0 β_1 ... β_{n-1} γ_0 γ_1 ... γ_{n-1})
(h : multi_function_n α_0 α_1 ... α_{n-1} β_0 β_1 ... β_{n-1}) :
multi_function_n.comp (multi_function_n.comp f g) h = multi_function_n.comp f (multi_function_n.comp g h)

theorem multi_function_n.comp.left_id {α_0 α_1 ... α_{n-1} β_0 β_1 ... β_{n-1}}
(f : multi_function_n α_0 α_1 ... α_{n-1} β_0 β_1 ... β_{n-1}) :
multi_function_n.comp multi_function_n.id f = f

theorem multi_function_n.comp.right_id {α_0 α_1 ... α_{n-1} β_0 β_1 ... β_{n-1}}
(f : multi_function_n α_0 α_1 ... α_{n-1} β_0 β_1 ... β_{n-1}) :
multi_function_n.comp f multi_function_n.id = f

-/

namespace multi_function

def to_name (n : nat) : name := mk_sub_name `multi_function n

def mk_name (n : nat) : name := to_name n ++ `mk

def fn_name (n i : nat) : name := to_name n ++ mk_sub_name `fn i

meta def mk_decl (n : nat) : inductive_declaration :=
let nm := to_name n in
let dus := mk_sub_names `u n in
let dls := dus.map level.param in
let dns := mk_sub_names `α n in
let cus := mk_sub_names `v n in
let cls := cus.map level.param in
let cns := mk_sub_names `β n in
let ctx : expr_ctx :=
  (dns ++ cns).reverse.zip $
  (dls ++ cls).reverse.map $
  λ l, (expr.sort l, binder_info.default) in
let lt := level.list_max (level.one :: dls ++ cls) in
let type : expr := ctx.pi (expr.sort lt) in
let inst : expr := ctx.app (expr.const nm (dls ++ cls)) in
let ctx : expr_ctx := ctx.map (λ ⟨n, t, _⟩, (n, t, binder_info.implicit)) in
let ctx : expr_ctx := (mk_sub_names `fn n).reverse.enum.foldr (λ ⟨k, fn⟩ ctx,
  ctx.add fn (expr.pi `_ binder_info.default (expr.var (2 * n - 1)) (expr.var n))
) ctx in
let cons : expr := ctx.pi (inst.lift_vars 0 n) in
{ to_name := nm
, univ_params := dus ++ cus
, type := type
, recursor := some (nm ++ `rec)
, constructors := [(mk_name n, cons)]
, num_params := 2 * n
, num_indices := 0
, is_trusted := tt
}

meta def mk_proj (n : nat) : list declaration :=
let nm := to_name n in
let dus := mk_sub_names `u n in
let dls := dus.map level.param in
let dns := mk_sub_names `α n in
let cus := mk_sub_names `v n in
let cls := cus.map level.param in
let cns := mk_sub_names `β n in
let ctx : expr_ctx :=
  (dns ++ cns).reverse.zip $
  (dls ++ cls).reverse.map $
  λ l, (expr.sort l, binder_info.implicit) in
let inst : expr := ctx.app (expr.const nm (dls ++ cls)) in
let tctx : expr_ctx := ctx.add `f inst in
let types : list expr := (list.range' n).map (λ k,
  tctx.pi (expr.pi `_ binder_info.default (expr.var (2 * n - k)) (expr.var (n + 1 - k)))
) in
let fctx : expr_ctx := (mk_sub_names `fn n).reverse.map (λ fn,
  (fn, (expr.pi `_ binder_info.default (expr.var (2 * n - 1)) (expr.var n)), binder_info.default)
) in
let values : list expr := (list.range' n).map (λ k,
  let l := level.imax (level.param $ mk_sub_name `u k) (level.param $ mk_sub_name `v k) in
  let mot : expr := expr.pi `_ binder_info.default (expr.var (2 * n - k)) (expr.var (n + 1 - k)) in
  let mot : expr := expr.lam `H binder_info.default inst mot in
  let val : expr := fctx.lam (expr.var (n - k - 1)) in
  let rec : expr := ctx.app (expr.const (nm ++ `rec) (l :: dls ++ cls)) in
  let rec : expr := rec.app mot in
  let rec : expr := rec.app val in
  ctx.lam rec
) in
(list.zip types values).enum.map (λ ⟨k, t, v⟩,
  declaration.defn (fn_name n k) (dus ++ cus) t v reducibility_hints.abbrev tt
)

meta def mk_eta (n : nat) : declaration :=
let nm := to_name n in
let dus := mk_sub_names `u n in
let dls := dus.map level.param in
let dns := mk_sub_names `α n in
let cus := mk_sub_names `v n in
let cls := cus.map level.param in
let cns := mk_sub_names `β n in
let lvl := level.list_max (level.one :: dls ++ cls) in
let ctx : expr_ctx :=
  (dns ++ cns).reverse.zip $
  (dls ++ cls).reverse.map $
  λ l, (expr.sort l, binder_info.implicit) in
let inst : expr := ctx.app (expr.const nm (dls ++ cls)) in
let cons : expr := ctx.app (expr.const (mk_name n) (dls ++ cls)) in
let tctx : expr_ctx := ctx.add `f inst in
let fns : list expr := (list.range n).map (λ k,
  let e : expr := expr.const (fn_name n k) (dls ++ cls) in
  tctx.app e
) in
let lhs : expr := expr.mk_app (cons.lift_vars 0 1) fns in
let eqn : expr := expr.mk_app (expr.const `eq [lvl]) [inst.lift_vars 0 1, lhs, expr.var 0] in
let type : expr := tctx.pi $ eqn in
let rec : expr := ctx.app $ expr.const (nm ++ `rec_on) (level.zero :: dls ++ cls) in
let rec : expr := rec.app (expr.lam `f binder_info.default inst eqn) in
let rec : expr := expr.app (rec.lift_vars 0 1) (expr.var 0) in
let fctx : expr_ctx := (list.range n).map (λ k,
  (mk_sub_name `fn (n-k-1), expr.pi `_ binder_info.default (expr.var (2 * n)) (expr.var (n+1)), binder_info.default)
) in
let fobj : expr := fctx.app (cons.lift_vars 0 (n+1)) in
let prf : expr := expr.const `eq.refl [lvl] in
let prf : expr := prf.mk_app [inst.lift_vars 0 (n+1), fobj] in
let value : expr := tctx.lam (rec.app $ fctx.lam prf) in
declaration.thm (mk_name n ++ `eta) (dus ++ cus) type (pure value)

/-
meta def mk_eq (n : nat) : declaration :=
let nm := to_name n in
let dus := mk_sub_names `u n in
let dls := dus.map level.param in
let dns := mk_sub_names `α n in
let cus := mk_sub_names `v n in
let cls := cus.map level.param in
let cns := mk_sub_names `β n in
let lvl := level.list_max (level.one :: dls ++ cls) in
let ctx : expr_ctx :=
  (dns ++ cns).reverse.zip $
  (dls ++ cls).reverse.map $
  λ l, (expr.sort l, binder_info.implicit) in
let inst : expr := ctx.app (expr.const nm (dls ++ cls)) in
let tctx : expr_ctx :=
[ (mk_sub_name `f 2, inst.lift_vars 0 1, binder_info.default)
, (mk_sub_name `f 1, inst, binder_info.default)
] ++ ctx in
let tctx : expr_ctx := (list.zip dls cls).indexed.foldl (λ tctx ⟨k, dl, cl⟩,
  let typ : expr := expr.pi `_ binder_info.default (expr.var (2 * n + 1)) (expr.var (n + 2)) in
  let lhs : expr := expr.const (nm ++ mk_sub_name `fn k) (dls ++ cls) in
  let lhs : expr := lhs.app (expr.var (k+1)) in
  let rhs : expr := expr.const (nm ++ mk_sub_name `fn k) (dls ++ cls) in
  let rhs : expr := rhs.app (expr.var k) in
  let eqn : expr := expr.const `eq [level.imax dl cl] in
  let eqn : expr := eqn.mk_app [typ, lhs, rhs] in
  tctx.add (mk_sub_name `h k) eqn
) tctx in
let type : expr := tctx.pi $ expr.mk_app (expr.const `eq [lvl]) [inst.lift_vars 0 (n+2), expr.var (n+1), expr.var n]
in
let value : expr := inhabited.default expr in
declaration.thm (nm ++ `eq) (dus ++ cus) type (pure value)
-/

meta def mk_id (n : nat) : declaration :=
let nm := to_name n in
let us := mk_sub_names `u n in
let ls := us.map level.param in
let ts := mk_sub_names `α n in
let ctx : expr_ctx := ts.reverse.zip $ ls.reverse.map (λ l, (expr.sort l, binder_info.implicit)) in
let type : expr := expr.const nm (ls ++ ls) in
let type : expr := type.mk_app (expr.mk_num_vars n ++ expr.mk_num_vars n).reverse in
let type : expr := ctx.pi type in
let value : expr := expr.const (nm ++ `mk) (ls ++ ls) in
let value : expr := value.mk_app (expr.mk_num_vars n ++ expr.mk_num_vars n).reverse in
let value : expr := value.mk_app $ (list.range' n).map (λ k,
  let e : expr := expr.const `id [level.param $ mk_sub_name `u k] in
  e.app (expr.var (n - k - 1))
) in
let value : expr := ctx.lam value in
declaration.defn (nm ++ `id) us type value reducibility_hints.abbrev tt

meta def mk_comp (n : nat) : declaration :=
let nm := to_name n in
let nus := mk_sub_names `u n in
let nvs := mk_sub_names `v n in
let nws := mk_sub_names `w n in
let lus := nus.map level.param in
let lvs := nvs.map level.param in
let lws := nws.map level.param in
let tus := mk_sub_names `α n in
let tvs := mk_sub_names `β n in
let tws := mk_sub_names `γ n in
let ctx : expr_ctx :=
  (tus ++ tvs ++ tws).reverse.zip $
  (lus ++ lvs ++ lws).reverse.map $
    λ l, (expr.sort l, binder_info.implicit) in
let typeuv : expr := expr.const nm (lus ++ lvs) in
let typevw : expr := expr.const nm (lvs ++ lws) in
let typeuw : expr := expr.const nm (lus ++ lws) in
let typeuv : expr := typeuv.mk_app (expr.mk_num_vars n (2 * n)).reverse in
let typeuv : expr := typeuv.mk_app (expr.mk_num_vars n (1 * n)).reverse in
let typeuw : expr := typeuw.mk_app (expr.mk_num_vars n (2 * n)).reverse in
let typeuw : expr := typeuw.mk_app (expr.mk_num_vars n (0 * n)).reverse in
let typevw : expr := typevw.mk_app (expr.mk_num_vars n (1 * n)).reverse in
let typevw : expr := typevw.mk_app (expr.mk_num_vars n (0 * n)).reverse in
let ctx : expr_ctx := ctx.add `f typevw in
let ctx : expr_ctx := ctx.add `g (typeuv.lift_vars 0 1) in
let type : expr := ctx.pi (typeuw.lift_vars 0 2) in
let pruv : list expr := (list.range n).map (λ k,
  let e : expr := expr.const (nm ++ mk_sub_name `fn k) (lus ++ lvs) in
  let e : expr := e.mk_app (expr.mk_num_vars n (2 * n + 2)).reverse in
  let e : expr := e.mk_app (expr.mk_num_vars n (1 * n + 2)).reverse in
  e.app (expr.var 0)
) in
let prvw : list expr := (list.range n).map (λ k,
  let e : expr := expr.const (nm ++ mk_sub_name `fn k) (lvs ++ lws) in
  let e : expr := e.mk_app (expr.mk_num_vars n (1 * n + 2)).reverse in
  let e : expr := e.mk_app (expr.mk_num_vars n (0 * n + 2)).reverse in
  e.app (expr.var 1)
) in
let args : list expr := (list.zip pruv prvw).reverse.enum.map (λ ⟨k, fuv, fvw⟩,
  let u := [mk_sub_name `u (n-k-1), mk_sub_name `v (n-k-1), mk_sub_name `w (n-k-1)] in
  let e : expr := expr.const `function.comp (u.map level.param) in
  e.mk_app [expr.var (2*n+2+k), expr.var (1*n+2+k), expr.var (0*n+2+k), fvw, fuv]
) in
let value : expr := expr.const (nm ++ `mk) (lus ++ lws) in
let value : expr := value.mk_app (expr.mk_num_vars n (2 * n + 2)).reverse in
let value : expr := value.mk_app (expr.mk_num_vars n (0 * n + 2)).reverse in
let value : expr := value.mk_app args.reverse in
let value : expr := ctx.lam value in
declaration.defn (nm ++ `comp) (nus ++ nvs ++ nws) type value reducibility_hints.abbrev tt

meta def mk_comp_assoc (n : nat) : declaration :=
let nm := to_name n in
let nts := mk_sub_names `t n in
let nus := mk_sub_names `u n in
let nvs := mk_sub_names `v n in
let nws := mk_sub_names `w n in
let lts := nts.map level.param in
let lus := nus.map level.param in
let lvs := nvs.map level.param in
let lws := nws.map level.param in
let tts := mk_sub_names `α n in
let tus := mk_sub_names `β n in
let tvs := mk_sub_names `γ n in
let tws := mk_sub_names `δ n in
let ctx : expr_ctx :=
  (tts ++ tus ++ tvs ++ tws).reverse.zip $
  (lts ++ lus ++ lvs ++ lws).reverse.map $
    λ l, (expr.sort l, binder_info.implicit) in
let typetu : expr := expr.const nm (lts ++ lus) in
let typetu : expr := typetu.mk_app (expr.mk_num_vars n (3 * n)).reverse in
let typetu : expr := typetu.mk_app (expr.mk_num_vars n (2 * n)).reverse in
let typeuv : expr := expr.const nm (lus ++ lvs) in
let typeuv : expr := typeuv.mk_app (expr.mk_num_vars n (2 * n)).reverse in
let typeuv : expr := typeuv.mk_app (expr.mk_num_vars n (1 * n)).reverse in
let typevw : expr := expr.const nm (lvs ++ lws) in
let typevw : expr := typevw.mk_app (expr.mk_num_vars n (1 * n)).reverse in
let typevw : expr := typevw.mk_app (expr.mk_num_vars n (0 * n)).reverse in
let typetw : expr := expr.const nm (lts ++ lws) in
let typetw : expr := typetw.mk_app (expr.mk_num_vars n (3 * n)).reverse in
let typetw : expr := typetw.mk_app (expr.mk_num_vars n (0 * n)).reverse in
let ctx : expr_ctx := ctx.add `f typevw in
let ctx : expr_ctx := ctx.add `g (typeuv.lift_vars 0 1) in
let ctx : expr_ctx := ctx.add `h (typetu.lift_vars 0 2) in
let lhsl : expr := expr.const (nm ++ `comp) (lus ++ lvs ++ lws) in
let lhsl : expr := lhsl.mk_app (expr.mk_num_vars n (2 * n + 3)).reverse in
let lhsl : expr := lhsl.mk_app (expr.mk_num_vars n (1 * n + 3)).reverse in
let lhsl : expr := lhsl.mk_app (expr.mk_num_vars n (0 * n + 3)).reverse in
let lhsl : expr := lhsl.mk_app [expr.var 2, expr.var 1] in
let lhs : expr := expr.const (nm ++ `comp) (lts ++ lus ++ lws) in
let lhs : expr := lhs.mk_app (expr.mk_num_vars n (3 * n + 3)).reverse in
let lhs : expr := lhs.mk_app (expr.mk_num_vars n (2 * n + 3)).reverse in
let lhs : expr := lhs.mk_app (expr.mk_num_vars n (0 * n + 3)).reverse in
let lhs : expr := lhs.mk_app [lhsl, expr.var 0] in
let rhsr : expr := expr.const (nm ++ `comp) (lts ++ lus ++ lvs) in
let rhsr : expr := rhsr.mk_app (expr.mk_num_vars n (3 * n + 3)).reverse in
let rhsr : expr := rhsr.mk_app (expr.mk_num_vars n (2 * n + 3)).reverse in
let rhsr : expr := rhsr.mk_app (expr.mk_num_vars n (1 * n + 3)).reverse in
let rhsr : expr := rhsr.mk_app [expr.var 1, expr.var 0] in
let rhs : expr := expr.const (nm ++ `comp) (lts ++ lvs ++ lws) in
let rhs : expr := rhs.mk_app (expr.mk_num_vars n (3 * n + 3)).reverse in
let rhs : expr := rhs.mk_app (expr.mk_num_vars n (1 * n + 3)).reverse in
let rhs : expr := rhs.mk_app (expr.mk_num_vars n (0 * n + 3)).reverse in
let rhs : expr := rhs.mk_app [expr.var 2, rhsr] in
let lvl : level := level.list_max (level.one :: lts ++ lws) in
let eqn : expr := expr.const `eq [lvl] in
let eqn : expr := eqn.mk_app [typetw.lift_vars 0 3, lhs, rhs] in
let type : expr := ctx.pi eqn in
let proof : expr := expr.const `eq.refl [lvl] in
let proof : expr := proof.mk_app [typetw.lift_vars 0 3, lhs] in
let proof : expr := ctx.lam proof in
declaration.thm (nm ++ `comp ++ `assoc) (nts ++ nus ++ nvs ++ nws) type (pure proof)

meta def mk_comp_left_id (n : nat) : declaration :=
let nm := to_name n in
let nus := mk_sub_names `u n in
let nvs := mk_sub_names `v n in
let lus := nus.map level.param in
let lvs := nvs.map level.param in
let tus := mk_sub_names `α n in
let tvs := mk_sub_names `β n in
let ctx : expr_ctx := (list.zip (tus ++ tvs) (lus ++ lvs)).reverse.map (λ ⟨n, l⟩,
  (n, expr.sort l, binder_info.implicit)
) in
let typeuv : expr := ctx.app (expr.const nm (lus ++ lvs)) in
let ctx : expr_ctx := ctx.add `f typeuv in
let compuvv : expr := expr.const (nm ++ `comp) (lus ++ lvs ++ lvs) in
let compuvv : expr := compuvv.mk_app (expr.mk_num_vars n n).reverse in
let compuvv : expr := compuvv.mk_app (expr.mk_num_vars n 0).reverse in
let compuvv : expr := compuvv.mk_app (expr.mk_num_vars n 0).reverse in
let idv : expr := expr.const (nm ++ `id) lvs in
let idv : expr := idv.mk_app (expr.mk_num_vars n 0).reverse in
let lvl : level := level.list_max (level.one :: lus ++ lvs) in
let lhs : expr := expr.mk_app (compuvv.lift_vars 0 1) [idv.lift_vars 0 1, expr.var 0] in
let type : expr := expr.const `eq [lvl] in
let type : expr := type.mk_app [typeuv.lift_vars 0 1, lhs, expr.var 0] in
let type : expr := ctx.pi type in
let proof : expr := ctx.app $ expr.const (mk_name n ++ `eta) (lus ++ lvs) in
let proof : expr := ctx.lam proof in
declaration.thm (nm ++ `comp ++ `left_id) (nus ++ nvs) type (pure proof)

meta def mk_comp_right_id (n : nat) : declaration :=
let nm := to_name n in
let nus := mk_sub_names `u n in
let nvs := mk_sub_names `v n in
let lus := nus.map level.param in
let lvs := nvs.map level.param in
let tus := mk_sub_names `α n in
let tvs := mk_sub_names `β n in
let ctx : expr_ctx := (list.zip (tus ++ tvs) (lus ++ lvs)).reverse.map (λ ⟨n, l⟩,
  (n, expr.sort l, binder_info.implicit)
) in
let typeuv : expr := ctx.app (expr.const nm (lus ++ lvs)) in
let ctx : expr_ctx := ctx.add `f typeuv in
let compuuv : expr := expr.const (nm ++ `comp) (lus ++ lus ++ lvs) in
let compuuv : expr := compuuv.mk_app (expr.mk_num_vars n n).reverse in
let compuuv : expr := compuuv.mk_app (expr.mk_num_vars n n).reverse in
let compuuv : expr := compuuv.mk_app (expr.mk_num_vars n 0).reverse in
let idu : expr := expr.const (nm ++ `id) lus in
let idu : expr := idu.mk_app (expr.mk_num_vars n n).reverse in
let lvl : level := level.list_max (level.one :: lus ++ lvs) in
let lhs : expr := expr.mk_app (compuuv.lift_vars 0 1) [expr.var 0, idu.lift_vars 0 1] in
let type : expr := expr.const `eq [lvl] in
let type : expr := type.mk_app [typeuv.lift_vars 0 1, lhs, expr.var 0] in
let type : expr := ctx.pi type in
let proof : expr := ctx.app $ expr.const (mk_name n ++ `eta) (lus ++ lvs) in
let proof : expr := ctx.lam proof in
declaration.thm (nm ++ `comp ++ `right_id) (nus ++ nvs) type (pure proof)

end multi_function

meta def environment.add_multi_function (env : environment) (n : nat) : exceptional environment :=
env.add_ind (multi_function.mk_decl n) tt >>= λ env, list.mfoldl environment.add env $
multi_function.mk_proj n ++
[ multi_function.mk_eta n
, multi_function.mk_id n
, multi_function.mk_comp n
, multi_function.mk_comp_assoc n
, multi_function.mk_comp_left_id n
, multi_function.mk_comp_right_id n
]

namespace tactic

meta def add_multi_function (n : nat) : tactic unit :=
do {
  let mfn := multi_function.to_name n,
  updateex_env $ λ env, env.add_multi_function n,
  -- vm needs code for cases_on ...
  ron ← get_decl (mfn ++ `rec_on),
  add_decl (ron.update_name $ mfn ++ `cases_on),
  -- set attributes
  (list.range n).mmap (λ k,
    set_basic_attribute `reducible (mfn ++ mk_sub_name `fn k) tt >>
    set_basic_attribute `inline (mfn ++ mk_sub_name `fn k) tt
  ),
  set_basic_attribute `reducible (mfn ++ `id) tt,
  set_basic_attribute `reducible (mfn ++ `comp) tt,
  guard (n = 0) <|> set_basic_attribute `simp (mfn ++ `mk.eta) tt,
  guard (n = 0) <|> set_basic_attribute `simp (mfn ++ `comp.left_id) tt,
  guard (n = 0) <|> set_basic_attribute `simp (mfn ++ `comp.right_id) tt,
  skip
}

meta def ensure_multi_function (n : nat) : tactic unit :=
get_decl (multi_function.to_name n) >> skip <|> add_multi_function n

end tactic

run_cmd tactic.add_multi_function 1
run_cmd tactic.add_multi_function 2

instance {α} {β} : has_coe_to_fun (multi_function_1 α β) := ⟨_, multi_function_1.fn_0⟩

theorem multi_function_1.eq {α} {β} {f g : multi_function_1 α β} : f.fn_0 = g.fn_0 → f = g :=
λ h,
eq.subst (multi_function_1.mk.eta f) $
eq.subst (multi_function_1.mk.eta g) $
congr rfl h

theorem multi_function_2.eq {α_0} {α_1} {β_0} {β_1} {f g : multi_function_2 α_0 α_1 β_0 β_1} : f.fn_0 = g.fn_0 → f.fn_1 = g.fn_1 → f = g :=
λ h_0 h_1,
eq.subst (multi_function_2.mk.eta f) $
eq.subst (multi_function_2.mk.eta g) $
congr (congr rfl h_0) h_1


import polycodable_init
import polytime_tac

variables {α β γ : Type*} [polycodable α] [polycodable β] [polycodable γ]
open ptree.pencodable (encode decode)

section bool

instance : polycodable bool :=
{ polytime_decode := ⟨_,
  (polytime_ite polytime_id polytime_nil (polytime_const ptree.non_nil)), λ x, by cases x; simp [ptree.of_option, encode, decode]⟩ }

@[polyfun]
lemma polytime_fun.ite' {f : α → bool} {g h : α → β} : polytime_fun f → polytime_fun g → polytime_fun h → polytime_fun (λ x, cond (f x) (g x) (h x))
| ⟨cf, pf, sf⟩ ⟨cg, pg, sg⟩ ⟨ch, ph, sh⟩ :=
⟨_, polytime_ite pf pg ph, λ x, by cases H : (f x); simp [sf, sg, sh, ← apply_ite part.some, ← apply_ite encode, encode, H]⟩

@[polyfun]
lemma polytime_fun.ite {P : α → Prop} [decidable_pred P] {g h : α → β} (hP : polytime_fun (λ x, (P x : bool))) (hg : polytime_fun g) (hh : polytime_fun h) :
  polytime_fun (λ x, if P x then g x else h x) :=
begin
  convert_to polytime_fun (λ x, cond (P x) (g x) (h x)),
  { ext x, by_cases P x; simp, }, polyfun,
end

private lemma polytime_fun.eq_nil_aux : polytime_fun (λ x', (x' = ptree.nil : bool)) :=
⟨_, polytime_ite polytime_id polytime_nil (polytime_const ptree.non_nil), λ x, by cases x; simp [encode]⟩

local attribute [polyfun] polytime_fun.eq_nil_aux

@[polyfun]
lemma polytime_fun.band : polytime_fun₂ (&&) :=
begin
  convert_to polytime_fun₂ (λ b₁ b₂ : bool, cond b₁ b₂ ff),
  { ext b₁, cases b₁; simp, }, polyfun,
end

@[polyfun]
lemma polytime_fun.bor : polytime_fun₂ (||) :=
begin
  convert_to polytime_fun₂ (λ b₁ b₂ : bool, cond b₁ tt b₂),
  { ext b₁, cases b₁; simp, }, polyfun,
end

@[polyfun]
lemma polytime_fun.bnot : polytime_fun bnot :=
by { convert_to polytime_fun (λ b, cond b ff tt), { ext b, cases b; refl, }, polyfun, }

lemma ptree_children {f g : ptree → bool} (hf : polytime_fun f) (hg : polytime_fun g) :
  polytime_fun (λ x : ptree, (x ≠ ptree.nil) && (f x.left && g x.right)) :=
by polyfun

private lemma polytime_fun.eq_const_aux : ∀ (x : ptree), polytime_fun (λ x', (x' = x : bool))
| ptree.nil := polytime_fun.eq_nil_aux
| (ptree.node a b) :=
begin
  convert ptree_children (polytime_fun.eq_const_aux a) (polytime_fun.eq_const_aux b),
  ext x, cases x; simp,
end

@[polyfun]
lemma polytime_fun.eq_const {f : α → β} [decidable_eq β] (hf : polytime_fun f) (x : β) : polytime_fun (λ x', (f x' = x : bool)) :=
begin
  convert_to polytime_fun (λ x', (encode (f x') = encode x : bool)), { simp, },
  exact polytime_fun.comp (polytime_fun.eq_const_aux (encode x)) hf,
end

end bool

section option

instance : polycodable (option α) :=
{ polytime_decode :=
begin
  convert_to polytime_fun (λ x : ptree, if x = ptree.nil then ptree.nil else ptree.of_option (some (encode (decode x.right : α)))),
  { ext x, cases x; simp [ptree.to_option, ptree.of_option, encode, decode], },
  simp only [ptree.of_option], polyfun,
end }

@[polyfun]
lemma polytime_fun.some : polytime_fun (@some α) :=
by { apply polytime_fun.decode, simp [encode, function.comp, ptree.of_option], polyfun, }

@[polyfun]
lemma polytime_fun.iget [inhabited α] : polytime_fun (@option.iget α _) :=
⟨code.ite code.id (code.const (encode (default : α))) code.right, polytime_ite polytime_id (polytime_const _) polytime_right, λ x,
by { cases x; simp [encode, ptree.of_option], }⟩

@[polyfun]
lemma polytime_fun.is_none : polytime_fun (@option.is_none α) :=
⟨code.ite code.id (code.const $ encode tt) (code.const $ encode ff), polytime_ite polytime_id (polytime_const _) (polytime_const _), λ x,
by { cases x; simp [encode, ptree.of_option], }⟩

@[polyfun]
lemma polytime_fun.option_elim {f : α → option β} {g : α → γ} {h : α → β → γ} (hf : polytime_fun f) (hg : polytime_fun g) (hh : polytime_fun₂ h) :
  polytime_fun (λ x, (f x).elim (g x) (h x)) :=
begin
  apply polytime_fun.decode,
  haveI : inhabited β := ⟨decode ptree.nil⟩,
  convert_to polytime_fun (λ x : α, if (f x).is_none then encode (g x) else encode (h x (f x).iget)),
  { ext x, cases H : (f x); simp [H], },
  polyfun,
end

@[polyfun]
lemma polytime_fun.option_map {f : α → option β} {g : α → β → γ} (hf : polytime_fun f) (hg : polytime_fun₂ g) :
  polytime_fun (λ x, (f x).map (g x)) :=
begin
  convert_to polytime_fun (λ x, (f x).elim none (λ r, some (g x r))),
  { ext x : 1, cases (f x); simp, },
  polyfun,
end

@[polyfun]
lemma polytime_fun.get_or_else : polytime_fun₂ (@option.get_or_else α) :=
begin
  convert_to polytime_fun₂ (λ (a : option α) (b : α), a.elim b id),
  { ext a b, cases a; simp, }, polyfun,
end

@[polyfun]
lemma polytime_fun.is_some : polytime_fun (@option.is_some α) :=
begin
  convert_to polytime_fun (λ (a : option α), a.elim ff (λ _, tt)),
  { ext x, cases x; simp, }, polyfun,
end

end option

section mk

def polycodable.mk' {δ : Type*} (encode : δ → α) (decode : α → δ) (encode_decode : ∀ x, decode (encode x) = x)
  (polytime_decode : polytime_fun (encode ∘ decode)) : polycodable δ :=
{ polytime_decode :=
by { apply polytime_fun.comp polytime_decode, polyfun, },
  ..ptree.pencodable.mk' encode decode encode_decode, }

lemma polycodable.mk_encode {δ : Type*} (encode : δ → α) (decode : α → δ) (encode_decode : ∀ x, decode (encode x) = x) :
  @polytime_fun δ α (ptree.pencodable.mk' encode decode encode_decode) _ encode :=
by { apply polytime_fun.id, }

lemma polycodable.mk_decode' {δ : Type*} (encode : δ → α) (decode : α → δ) (encode_decode : ∀ x, decode (encode x) = x)
  (polytime_decode : polytime_fun (encode ∘ decode)) :
  @polytime_fun α δ _ (polycodable.mk' encode decode encode_decode polytime_decode).to_pencodable decode :=
polytime_decode

lemma polycodable.mk_decode {δ : Type*} (encode : δ → α) (decode : α → δ) (encode_decode : ∀ x, decode (encode x) = x)
  (f : β → δ) (hf : polytime_fun (encode ∘ f)) :
  @polytime_fun β δ _ (ptree.pencodable.mk' encode decode encode_decode) f :=
hf

def polycodable.of_equiv {δ : Type*} (eqv : δ ≃ α) : polycodable δ :=
polycodable.mk'
(λ x, eqv x)
(λ y, eqv.symm y)
(by simp)
(by simpa using polytime_fun.id)

@[polyfun]
lemma polycodable.of_equiv_polytime {δ : Type*} (eqv : δ ≃ α) :
  @polytime_fun δ α (ptree.pencodable.of_equiv eqv) _ eqv :=
by { apply polytime_fun.id, }

@[polyfun]
lemma polycodable.of_equiv_polytime_symm {δ : Type*} (eqv : δ ≃ α) :
  @polytime_fun α δ _ (polycodable.of_equiv eqv).to_pencodable eqv.symm :=
by { apply polycodable.mk_decode', }

end mk

section unit

instance : polycodable unit :=
{ polytime_decode := polytime_fun.const ptree.nil }

end unit

section sum

end sum


/-
File: signature_recover_public_key_is_zero_soundness.lean

Autogenerated file.
-/
import starkware.cairo.lean.semantics.soundness.hoare
import .signature_recover_public_key_code
import ..signature_recover_public_key_spec
import .signature_recover_public_key_verify_zero_soundness
import .signature_recover_public_key_unreduced_mul_soundness
import .signature_recover_public_key_nondet_bigint3_soundness
open tactic

open starkware.cairo.common.cairo_secp.field
open starkware.cairo.common.cairo_secp.bigint

variables {F : Type} [field F] [decidable_eq F] [prelude_hyps F]
variable  mem : F → F
variable  σ : register_state F

/- starkware.cairo.common.cairo_secp.field.is_zero autogenerated soundness theorem -/

theorem auto_sound_is_zero
    -- arguments
    (range_check_ptr : F) (x : BigInt3 F)
    -- code is in memory at σ.pc
    (h_mem : mem_at mem code_is_zero σ.pc)
    -- all dependencies are in memory
    (h_mem_4 : mem_at mem code_nondet_bigint3 (σ.pc  - 71))
    (h_mem_5 : mem_at mem code_unreduced_mul (σ.pc  - 59))
    (h_mem_7 : mem_at mem code_verify_zero (σ.pc  - 23))
    -- input arguments on the stack
    (hin_range_check_ptr : range_check_ptr = mem (σ.fp - 6))
    (hin_x : x = cast_BigInt3 mem (σ.fp - 5))
    -- conclusion
  : ensures_ret mem σ (λ κ τ,
      ∃ μ ≤ κ, rc_ensures mem (rc_bound F) μ (mem (σ.fp - 6)) (mem $ τ.ap - 2)
        (spec_is_zero mem κ range_check_ptr x (mem (τ.ap - 2)) (mem (τ.ap - 1)))) :=
begin
  apply ensures_of_ensuresb, intro νbound,
  have h_mem_rec := h_mem,
  unpack_memory code_is_zero at h_mem with ⟨hpc0, hpc1, hpc2, hpc3, hpc4, hpc5, hpc6, hpc7, hpc8, hpc9, hpc10, hpc11, hpc12, hpc13, hpc14, hpc15, hpc16, hpc17, hpc18, hpc19, hpc20, hpc21, hpc22, hpc23, hpc24, hpc25, hpc26, hpc27, hpc28, hpc29, hpc30, hpc31, hpc32, hpc33, hpc34, hpc35⟩,
  -- if statement
  -- tempvar
  apply of_register_state,
  intros regstate_ιχ__temp40 regstateeq_ιχ__temp40,
  generalize' hl_rev_ιχ__temp40: mem regstate_ιχ__temp40.ap = ιχ__temp40,
  have hl_ιχ__temp40 := hl_rev_ιχ__temp40.symm,
  rw [regstateeq_ιχ__temp40] at hl_ιχ__temp40, try { dsimp at hl_ιχ__temp40 },
  -- ap += 1
  step_advance_ap hpc0 hpc1,
  step_jnz hpc2 hpc3 with hcond hcond,
  {
    -- if: positive branch
    have a0 : ιχ__temp40 = 0, {
      try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_x, hl_ιχ__temp40] },
      try { dsimp [cast_BigInt3] },
      try { arith_simps }, try { simp only [hcond] },
      try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } },
    },
    try { dsimp at a0 }, try { arith_simps at a0 },
    clear hcond,
    -- jump statement
    step_jump_imm hpc4 hpc5,
    -- function call
    step_assert_eq hpc15 with arg0,
    step_sub hpc16 (auto_sound_nondet_bigint3 mem _ range_check_ptr _ _),
    { rw hpc17, norm_num2, exact h_mem_4 },
    { try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_x, hl_ιχ__temp40] },
      try { dsimp [cast_BigInt3] },
      try { arith_simps }, try { simp only [arg0] },
      try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } }, },
    intros κ_call18 ap18 h_call18,
    rcases h_call18 with ⟨h_call18_ap_offset, h_call18⟩,
    rcases h_call18 with ⟨rc_m18, rc_mle18, hl_range_check_ptr₁, h_call18⟩,
    generalize' hr_rev_range_check_ptr₁: mem (ap18 - 4) = range_check_ptr₁,
    have htv_range_check_ptr₁ := hr_rev_range_check_ptr₁.symm, clear hr_rev_range_check_ptr₁,
    generalize' hr_rev_x_inv: cast_BigInt3 mem (ap18 - 3) = x_inv,
    simp only [hr_rev_x_inv] at h_call18,
    have htv_x_inv := hr_rev_x_inv.symm, clear hr_rev_x_inv,
    try { simp only [arg0] at hl_range_check_ptr₁ },
    rw [←htv_range_check_ptr₁, ←hin_range_check_ptr] at hl_range_check_ptr₁,
    try { simp only [arg0] at h_call18 },
    rw [hin_range_check_ptr] at h_call18,
    clear arg0,
    -- function call
    step_assert_eq hpc18 with arg0,
    step_assert_eq hpc19 with arg1,
    step_assert_eq hpc20 with arg2,
    step_assert_eq hpc21 with arg3,
    step_assert_eq hpc22 with arg4,
    step_assert_eq hpc23 with arg5,
    step_sub hpc24 (auto_sound_unreduced_mul mem _ x x_inv _ _ _),
    { rw hpc25, norm_num2, exact h_mem_5 },
    { try { ext } ; {
        try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_x, hl_ιχ__temp40, htv_range_check_ptr₁, htv_x_inv] },
        try { dsimp [cast_BigInt3] },
        try { arith_simps }, try { simp only [arg0, arg1, arg2, arg3, arg4, arg5] },
        try { simp only [h_call18_ap_offset] },
        try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } },}, },
    { try { ext } ; {
        try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_x, hl_ιχ__temp40, htv_range_check_ptr₁, htv_x_inv] },
        try { dsimp [cast_BigInt3] },
        try { arith_simps }, try { simp only [arg0, arg1, arg2, arg3, arg4, arg5] },
        try { simp only [h_call18_ap_offset] },
        try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } },}, },
    intros κ_call26 ap26 h_call26,
    rcases h_call26 with ⟨h_call26_ap_offset, h_call26⟩,
    generalize' hr_rev_x_x_inv: cast_UnreducedBigInt3 mem (ap26 - 3) = x_x_inv,
    simp only [hr_rev_x_x_inv] at h_call26,
    have htv_x_x_inv := hr_rev_x_x_inv.symm, clear hr_rev_x_x_inv,
    clear arg0 arg1 arg2 arg3 arg4 arg5,
    -- function call
    step_assert_eq hpc26 with arg0,
    step_assert_eq hpc27 hpc28 with arg1,
    step_assert_eq hpc29 with arg2,
    step_assert_eq hpc30 with arg3,
    step_sub hpc31 (auto_sound_verify_zero mem _ range_check_ptr₁ {
      d0 := x_x_inv.d0 - 1,
      d1 := x_x_inv.d1,
      d2 := x_x_inv.d2
    } _ _ _),
    { rw hpc32, norm_num2, exact h_mem_7 },
    { try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_x, hl_ιχ__temp40, htv_range_check_ptr₁, htv_x_inv, htv_x_x_inv] },
      try { dsimp [cast_BigInt3, cast_UnreducedBigInt3] },
      try { arith_simps }, try { simp only [arg0, arg1, arg2, arg3] },
      try { simp only [h_call18_ap_offset, h_call26_ap_offset] },
      try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } }, },
    { try { ext } ; {
        try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_x, hl_ιχ__temp40, htv_range_check_ptr₁, htv_x_inv, htv_x_x_inv] },
        try { dsimp [cast_BigInt3, cast_UnreducedBigInt3] },
        try { arith_simps }, try { simp only [arg0, arg1, arg2, arg3] },
        try { simp only [h_call18_ap_offset, h_call26_ap_offset] },
        try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } },}, },
    intros κ_call33 ap33 h_call33,
    rcases h_call33 with ⟨h_call33_ap_offset, h_call33⟩,
    rcases h_call33 with ⟨rc_m33, rc_mle33, hl_range_check_ptr₂, h_call33⟩,
    generalize' hr_rev_range_check_ptr₂: mem (ap33 - 1) = range_check_ptr₂,
    have htv_range_check_ptr₂ := hr_rev_range_check_ptr₂.symm, clear hr_rev_range_check_ptr₂,
    try { simp only [arg0 ,arg1 ,arg2 ,arg3] at hl_range_check_ptr₂ },
    try { rw [h_call26_ap_offset] at hl_range_check_ptr₂ }, try { arith_simps at hl_range_check_ptr₂ },
    rw [←htv_range_check_ptr₂, ←htv_range_check_ptr₁] at hl_range_check_ptr₂,
    try { simp only [arg0 ,arg1 ,arg2 ,arg3] at h_call33 },
    try { rw [h_call26_ap_offset] at h_call33 }, try { arith_simps at h_call33 },
    rw [←htv_range_check_ptr₁, hl_range_check_ptr₁, hin_range_check_ptr] at h_call33,
    clear arg0 arg1 arg2 arg3,
    -- return
    step_assert_eq hpc33 hpc34 with hret0,
    step_ret hpc35,
    -- finish
    step_done, use_only [rfl, rfl],
    -- range check condition
    use_only (rc_m18+rc_m33+0+0), split,
    linarith [rc_mle18, rc_mle33],
    split,
    { arith_simps, try { simp only [hret0] },
      rw [←htv_range_check_ptr₂, hl_range_check_ptr₂, hl_range_check_ptr₁, hin_range_check_ptr],
      try { arith_simps, refl <|> norm_cast }, try { refl } },
    intro rc_h_range_check_ptr, repeat { rw [add_assoc] at rc_h_range_check_ptr },
    have rc_h_range_check_ptr' := range_checked_add_right rc_h_range_check_ptr,
    -- Final Proof
    -- user-provided reduction
    suffices auto_spec: auto_spec_is_zero mem _ range_check_ptr x _ _,
    { apply sound_is_zero, apply auto_spec },
    -- prove the auto generated assertion
    dsimp [auto_spec_is_zero],
    try { norm_num1 }, try { arith_simps },
    use_only [ιχ__temp40],
    right,
    use_only [a0],
    use_only [κ_call18],
    use_only [range_check_ptr₁],
    use_only [x_inv],
    have rc_h_range_check_ptr₁ := range_checked_offset' rc_h_range_check_ptr,
    have rc_h_range_check_ptr₁' := range_checked_add_right rc_h_range_check_ptr₁, try { norm_cast at rc_h_range_check_ptr₁' },
    have spec18 := h_call18 rc_h_range_check_ptr',
    rw [←hin_range_check_ptr, ←htv_range_check_ptr₁] at spec18,
    try { dsimp at spec18, arith_simps at spec18 },
    use_only [spec18],
    use_only [κ_call26],
    use_only [x_x_inv],
    try { dsimp at h_call26, arith_simps at h_call26 },
    try { use_only [h_call26] },
    use_only [κ_call33],
    use_only [range_check_ptr₂],
    have rc_h_range_check_ptr₂ := range_checked_offset' rc_h_range_check_ptr₁,
    have rc_h_range_check_ptr₂' := range_checked_add_right rc_h_range_check_ptr₂, try { norm_cast at rc_h_range_check_ptr₂' },
    have spec33 := h_call33 rc_h_range_check_ptr₁',
    rw [←hin_range_check_ptr, ←hl_range_check_ptr₁, ←htv_range_check_ptr₂] at spec33,
    try { dsimp at spec33, arith_simps at spec33 },
    use_only [spec33],
    try { split, linarith },
    try { ensures_simps; try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_x, hl_ιχ__temp40, htv_range_check_ptr₁, htv_x_inv, htv_x_x_inv, htv_range_check_ptr₂] }, },
    try { dsimp [cast_BigInt3, cast_UnreducedBigInt3] },
    try { arith_simps }, try { simp only [hret0] },
    try { simp only [h_call18_ap_offset, h_call26_ap_offset, h_call33_ap_offset] },
    try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } },
  },
  {
    -- if: negative branch
    have a0 : ιχ__temp40 ≠ 0, {
      try { simp only [ne.def] },
      try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_x, hl_ιχ__temp40] },
      try { dsimp [cast_BigInt3] },
      try { arith_simps }, try { simp only [hcond] },
      try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } },
    },
    try { dsimp at a0 }, try { arith_simps at a0 },
    clear hcond,
    -- function call
    step_assert_eq hpc6 with arg0,
    step_assert_eq hpc7 with arg1,
    step_assert_eq hpc8 with arg2,
    step_assert_eq hpc9 with arg3,
    step_sub hpc10 (auto_sound_verify_zero mem _ range_check_ptr {
      d0 := x.d0,
      d1 := x.d1,
      d2 := x.d2
    } _ _ _),
    { rw hpc11, norm_num2, exact h_mem_7 },
    { try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_x, hl_ιχ__temp40] },
      try { dsimp [cast_BigInt3] },
      try { arith_simps }, try { simp only [arg0, arg1, arg2, arg3] },
      try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } }, },
    { try { ext } ; {
        try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_x, hl_ιχ__temp40] },
        try { dsimp [cast_BigInt3] },
        try { arith_simps }, try { simp only [arg0, arg1, arg2, arg3] },
        try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } },}, },
    intros κ_call12 ap12 h_call12,
    rcases h_call12 with ⟨h_call12_ap_offset, h_call12⟩,
    rcases h_call12 with ⟨rc_m12, rc_mle12, hl_range_check_ptr₁, h_call12⟩,
    generalize' hr_rev_range_check_ptr₁: mem (ap12 - 1) = range_check_ptr₁,
    have htv_range_check_ptr₁ := hr_rev_range_check_ptr₁.symm, clear hr_rev_range_check_ptr₁,
    try { simp only [arg0 ,arg1 ,arg2 ,arg3] at hl_range_check_ptr₁ },
    rw [←htv_range_check_ptr₁, ←hin_range_check_ptr] at hl_range_check_ptr₁,
    try { simp only [arg0 ,arg1 ,arg2 ,arg3] at h_call12 },
    rw [hin_range_check_ptr] at h_call12,
    clear arg0 arg1 arg2 arg3,
    -- return
    step_assert_eq hpc12 hpc13 with hret0,
    step_ret hpc14,
    -- finish
    step_done, use_only [rfl, rfl],
    -- range check condition
    use_only (rc_m12+0+0), split,
    linarith [rc_mle12],
    split,
    { arith_simps, try { simp only [hret0] },
      rw [←htv_range_check_ptr₁, hl_range_check_ptr₁, hin_range_check_ptr],
      try { arith_simps, refl <|> norm_cast }, try { refl } },
    intro rc_h_range_check_ptr, repeat { rw [add_assoc] at rc_h_range_check_ptr },
    have rc_h_range_check_ptr' := range_checked_add_right rc_h_range_check_ptr,
    -- Final Proof
    -- user-provided reduction
    suffices auto_spec: auto_spec_is_zero mem _ range_check_ptr x _ _,
    { apply sound_is_zero, apply auto_spec },
    -- prove the auto generated assertion
    dsimp [auto_spec_is_zero],
    try { norm_num1 }, try { arith_simps },
    use_only [ιχ__temp40],
    left,
    use_only [a0],
    use_only [κ_call12],
    use_only [range_check_ptr₁],
    have rc_h_range_check_ptr₁ := range_checked_offset' rc_h_range_check_ptr,
    have rc_h_range_check_ptr₁' := range_checked_add_right rc_h_range_check_ptr₁, try { norm_cast at rc_h_range_check_ptr₁' },
    have spec12 := h_call12 rc_h_range_check_ptr',
    rw [←hin_range_check_ptr, ←htv_range_check_ptr₁] at spec12,
    try { dsimp at spec12, arith_simps at spec12 },
    use_only [spec12],
    try { split, linarith },
    try { ensures_simps; try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_x, hl_ιχ__temp40, htv_range_check_ptr₁] }, },
    try { dsimp [cast_BigInt3] },
    try { arith_simps }, try { simp only [hret0] },
    try { simp only [h_call12_ap_offset] },
    try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } },
  }
end


/-
Define the semantics of core Linalg operations.
-/
import MLIR.Semantics.Fitree
import MLIR.Semantics.Semantics
import MLIR.Semantics.SSAEnv
import MLIR.Semantics.UB
import MLIR.Util.Metagen
import MLIR.AST
import MLIR.EDSL
open MLIR.AST

/-
Consider the following MWE:

```lean
structure DepProof where
   val: Nat
   H: val = 0

def MonadicDepProof [Mon: Monad M]: M DepProof := do
   let v ← pure 0
   return {
      val := v
      H := by {
         /-
         M: Type → Type ?u.380
         Mon: Monad M
         v: ℕ
         ⊢ v = 0
         -/
         sorry
      }
   }
```

How to see in the proof mode that `v` originated from `pure 0`?
-/

instance linalg: Dialect Void Void (fun x => Unit) where
  name := "linalg"
  iα := inferInstance
  iε := inferInstance

-- We assume that we only run regions that behave purely (otherwise most of the
-- theorems on generic don't work).
def validGenericRegion {Δ: Dialect α σ ε} (r: Region Δ) (f: Int → FinInt 32 → FinInt 32) :=
  forall (i: Int) (v: FinInt 32),
  OpM.denoteRegion r 0 [⟨.index, i⟩, ⟨.i32, v⟩] = return [⟨.i32, f i v⟩]

def OpM.findIndex (d: AttrDict δ) (key: String): OpM Δ Nat :=
 match d.find_int key with
 | .some ⟨v, MLIRType.index⟩ => return v.toNat
 | _ => OpM.Error s!"{d}.lookup {key} failed to find int"

def OpM.findI32 (d: AttrDict δ) (key: String): OpM Δ (FinInt 32) :=
 match d.find_int key with
 | .some (v, _) => return (FinInt.ofInt 32 v)
 | _ => OpM.Error s!"{d}.lookup {key} failed to find int"

-- in general, xtract slice has offset, size, stride.
-- We ignore the stride and offset for now, just use size.
def linalg_semantics_op {Δ: Dialect α σ ε}: IOp Δ → OpM Δ (TypedArgs Δ)
 | IOp.mk "linalg.extractslice1d" _ [⟨.tensor1d, t⟩] [] dict => do
    let len ←  OpM.findIndex dict "len"
    let t' := t.extract len
    return [⟨.tensor1d, t'⟩]
 | IOp.mk "linalg.fill1d" _ [⟨.tensor1d, t⟩]  [] dict => do
     let cst ←  OpM.findI32 dict "cst"
     let t' := t.fill cst
     return [⟨.tensor1d, t'⟩]
 | IOp.mk "linalg.generic1d'" _ [⟨.tensor1d, t⟩] [r] _ => do -- generic1d without array index.
      let t' <- t.mapM (fun val => do
            let rets ← r [⟨.i32, val⟩]
            match rets with
            | [⟨.i32, v⟩] => pure v
            | _ => OpM.Error s!"linalg.generic1d: unknown return value '{rets}'")
      return [⟨.tensor1d, t'⟩]
 | IOp.mk "linalg.generic1d" _ [⟨.tensor1d, t⟩] [r] _ => do
      let t' <- t.mapMWithFlatIndex (fun idx val => do
            let rets ← r [⟨.index, idx.ix⟩, ⟨.i32, val⟩]
            match rets with
            | [⟨.i32, v⟩] => pure v
            | _ => OpM.Error s!"linalg.generic1d: unknown return value '{rets}'")
      return [⟨.tensor1d, t'⟩]
 | IOp.mk "linalg.extractslice2d" _ [⟨.tensor2d, t⟩]  [r] dict =>  do
      let len0 ←  OpM.findIndex dict "len0"
      let len1 ←  OpM.findIndex dict "len1"
      dite (α := OpM Δ (TypedArgs Δ))
         (len0 <= t.size0)
         (fun LEQ0 =>
            dite (len1 <= t.size1)
               (fun LEQ1 => do
                  let subview : TensorSubview2D t.size0 t.size1
                     := { size0 := len0, size1 := len1, IX0 := LEQ0, IX1 := LEQ1}
                  let t' := t.extractslice' subview
                  return [⟨.tensor2d, t'⟩])
               (fun GT0 => OpM.Error "expected index inbounds"))
         (fun GT1 => OpM.Error "expected index inbounds")
 | IOp.mk "linalg.fill2d" _ [⟨.tensor2d, t⟩]  [r] dict => do
     let cst ←  OpM.findI32 dict "cst"
     let t' := t.fill (FinInt.toSint cst)
     return [⟨.tensor2d, t'⟩]
 | IOp.mk "linalg.transpose2d"   _ [⟨.tensor2d, t⟩]  [r] dict => do
     let t' := t.transpose
     return [⟨.tensor2d, t'⟩]
 | IOp.mk "linalg.insertslice2d" _ [⟨.tensor1d, t⟩]  [r] dict => sorry
 | IOp.mk "linalg.generic2d" _ [⟨.tensor1d, t⟩]  [r] dict => sorry
 | IOp.mk "linalg.parallel2d" _ [⟨.tensor1d, t⟩]  [r] dict => do
      return []
 | IOp.mk name .. => OpM.Unhandled s!"unhandled {name}"

-- TODO: timeout! with maxHeartbeats, all RAM is consumed.
/-
set_option maxHeartbeats 10000 in
theorem linalg_semantics_generic1d {Δ: Dialect α σ ε} {r: Region Δ} {rSpec types attrs}:
  validGenericRegion r rSpec →
  linalg_semantics_op (Δ := Δ)
      (IOp.mk "linalg.generic1d"
         types [⟨.tensor1d, t⟩]
         [OpM.denoteRegion r 0]
         attrs) =
    return [⟨.tensor1d, t.mapWithFlatIndex (fun idx val => rSpec idx.ix val)⟩] := by
  intros h
  simp [linalg_semantics_op]
  simp [validGenericRegion] at h
  simp [h]
  rw [Tensor1D.mapM_map]
  . rfl
  . intros; rfl
-/
instance : Semantics linalg where
   semantics_op := linalg_semantics_op

namespace BubbleUpExtractSlice
/-
convert extract slice (linalg.generic x) ->  linalg.generic (extract slice x)
-/

#check mapM
theorem bubble_up_extract_slice  [MM: Monad M] [LM: LawfulMonad M]
   (t: Tensor1D)
   (f : FinInt 32 -> M (FinInt 32)):
  (fun s => s.extract len) <$> (t.mapM f) =  (t.extract len).mapM f := by {
  cases t;
  sorry
}

/- TODO -/
end BubbleUpExtractSlice

namespace SwapExtractSlice
/- TODO -/
end SwapExtractSlice

namespace DecomposeLinalgOps
/- TODO -/
end DecomposeLinalgOps

namespace Fusion
/- TODO -/
end Fusion

namespace FusionOnTensors
/- TODO -/
end FusionOnTensors

/-
For each transformation, we implement
1) a theorem that proves correctness
2) a test in Test/SemanticTests.lean which tests
   both versions of the program.
-/
namespace ExtractSliceFillCommuteOneD

-- TODO: timeout!
theorem extract_fill_commute:
 Tensor1D.fill (Tensor1D.extract t extractlen) fillval =
 Tensor1D.extract (Tensor1D.fill t fillval) extractlen := by {
   simp [Tensor1D.fill, Tensor1D.extract];
   apply List.extF
   intros n h; simp; simp at h
   sorry
   sorry
   /-
   repeat rw [List.getF_replicate]
   . apply Nat.lt_min_left; apply h
   . simp
   . assumption
   -/
 }
-- https://mlir.llvm.org/doxygen/BubbleUpExtractSlice_8cpp_source.html
def LHS : Region linalg  := [mlir_region| {
   %x = "linalg.extractslice1d" (%t) { len = 10 : index }: (tensor1d) -> (tensor1d)
   %out = "linalg.fill1d" (%x) { cst = 42 : index }: (tensor1d) -> (tensor1d)
}]
def RHS : Region linalg := [mlir_region| {
   %x = "linalg.fill1d" (%t) { cst = 42 : index }: (tensor1d) -> (tensor1d)
   %out = "linalg.extractslice1d" (%x) { len = 10 : index }: (tensor1d) -> (tensor1d)
}]
/-
TODO: Create a predicate to say that the programs agree on output value `out`.
-/
/-
theorem equiv (t: Tensor1D):
   run ⟦LHS⟧ (SSAEnv.One [ ("t", ⟨.tensor1d, t⟩) ]) =
    run ⟦RHS⟧ (SSAEnv.One [ ("t", ⟨.tensor1d, t⟩) ]) := by {
      simp[LHS, RHS];
      simp_all[denoteRegion, run, StateT.run, denoteTypedArgs, pure, StateT.pure, Except.pure,
            StateT.run, Except.ok, bind, Except.bind, denoteOps, denoteOps
            , StateT.bind, denoteOp, List.mapM, List.mapM.loop, TopM.get,
            StateT.get, OpM.toTopM, TopM.raiseUB, liftM, TopM.set,
            StateT.set, cast];

 }
-/

end ExtractSliceFillCommuteOneD

namespace ExtractSliceGenericCommute1D
variable (r : Region linalg)

-- https://mlir.llvm.org/doxygen/BubbleUpExtractSlice_8cpp_source.html
def LHS: Region linalg  := [mlir_region| {
   %x = "linalg.generic1d" (%t) ($(r)) { len = 10 : index }: (tensor1d) -> (tensor1d)
   %out = "linalg.fill1d" (%x) { cst = 42 : index }: (tensor1d) -> (tensor1d)
}]
def RHS : Region linalg := [mlir_region| {
   %x = "linalg.generic1d" (%t) ($(r)) { cst = 42 : index }: (tensor1d) -> (tensor1d)
   %out = "linalg.extractslice1d" (%x) { len = 10 : index }: (tensor1d) -> (tensor1d)
}]

@[simp]
theorem OpM.bind_ret {Δ: Dialect α σ ε} (a: α) (k: α → OpM Δ β):
  bind (OpM.Ret a) k = k a := rfl

@[simp]
theorem OpM.toTopM_pure {r: TypedArgs Δ}:
  OpM.toTopM rs (pure r) env = Except.ok (r, env) := rfl

theorem equiv (t: Tensor1D) r rSpec:
   validGenericRegion r rSpec →
   run ⟦LHS r⟧ (SSAEnv.One [ ("t", ⟨.tensor1d, t⟩) ]) =
   run ⟦RHS r⟧ (SSAEnv.One [ ("t", ⟨.tensor1d, t⟩) ]) := by {
      intros valid_r;
      simp[LHS, RHS];
      -- tactic bug: (kernel) constant has already been declared '_private.MLIR.Dialects.LinalgSemantics.0.linalg_semantics_op.match_2.eq_1'
      /-
      simp_all[denoteRegion, run, StateT.run, List.map, denoteTypedArgs, pure, StateT.pure, Except.pure,
            StateT.run, Except.ok, bind, Except.bind, denoteOps, denoteOps
            , StateT.bind, denoteOp, List.mapM, List.mapM.loop, TopM.get,
            StateT.get, OpM.toTopM, TopM.raiseUB, liftM, TopM.set,
            StateT.set, cast, OpM.denoteRegions, TopM.mapDenoteRegion,
             OpM.toTopM, denoteRegion, denoteOpArgs, SSAEnv.get, SSAEnv.getT, Semantics.semantics_op, linalg_semantics_op];
      -/
      sorry
    }
end ExtractSliceGenericCommute1D

namespace mapMCommute
def fish [Monad m] (f: a -> m b) (g: b -> m c): a -> m c := fun a => (f a) >>= g

theorem mapM_cons [M: Monad m] [LM: LawfulMonad m] (x: a) (xs: List a) (f: a -> m b):
  List.mapM f (x :: xs) =  f x >>= (fun b => do let bs <- List.mapM f xs; pure (b :: bs)) := by {
  simp[List.mapM, List.mapM.loop];
  sorry;
}
theorem commute_implies_mapM_commute [Monad m] [LawfulMonad m]
  (f g : a -> m a ) (k: List a -> a -> m b)
  (COMMUTE: forall {b: Type} (x y : a)  (k: a -> a -> m b), f x >>= (fun r1 => (g y >>= fun r2 => k r1 r2 )) =
                                        g y >>= fun r2 => f x >>= fun r1 => k r1 r2):
  List.mapM f xs >>= (fun r1 => (g y >>= fun r2 => k r1 r2 )) =
                                        g y >>= fun r2 => List.mapM f xs >>= fun r1 => k r1 r2 := by sorry

theorem mapM_commute [M: Monad m] [LM: LawfulMonad m]
  (f g: a -> m a) (COMMUTE: forall {b : Type} (x y : a)  (k: a -> a -> m b), f x >>= (fun r1 => (g y >>= fun r2 => k r1 r2 )) =
                                        g y >>= fun r2 => f x >>= fun r1 => k r1 r2)
  : fish (List.mapM f) (List.mapM g) = List.mapM (fish f g) := by {

     funext x;
     induction x;
     case nil => {
          simp[fish, List.mapM, List.mapM.loop];
     }
     case cons head tail IH => {
       -- simp[fish];
       rewrite [mapM_cons];
       simp[fish];
       -- rewrite [mapM_cons];

       simp [bind_assoc]
       simp[mapM_cons];
       congr; -- remove the head
       funext x';
       rewrite [commute_implies_mapM_commute];
       congr;
       funext x';
       simp [fish] at IH;
       rewrite [<- IH];
       simp[bind_assoc];
       apply COMMUTE;

     }

}
end mapMCommute

namespace Generic1DFusion

variable (r s : Region linalg)

-- See section MapMCommute.
-- See section MapMCommute
-- fmap f . fmap g == fmap (f . g)
-- true iff f commutes with g?
-- mapM f >=> mapM g == mapM (f >=> g)
-- naive proof: induction on size of %t.
-- god's proof in the book: show that the computation of y[i] looks like
--     as what's written below. (need some notion of funext on the array).
def LHS: Region linalg  := [mlir_region| {
   %x = "linalg.generic1d" (%t) ($(r)): (tensor1d) -> (tensor1d) -- fmap r | x[i] <- r(t(i))
   %y = "linalg.generic1d" (%x) ($(s)): (tensor1d) -> (tensor1d) -- fmap s | y[i] <- s(x[i]) = s(r(t(i)))
}]
def RHS : Region linalg := [mlir_region| {
   %y = "linalg.generic1d" (%t) ({
   ^entry(%x: i32):
     %v1 = "region.run" (%x)  ($(r)) {} : (index) -> (index)
     %v2 = "region.run" (%v1)  ($(s)) {} : (index) -> (index)
     "scf.yield"(%v2): (i32) -> (i32)
   }): (tensor1d) -> (tensor1d)
}]
end Generic1DFusion

namespace Generic1DTiling
variable (r: Region linalg)
-- Need a precondition that the width is divisible by 4.

def LHS: Region linalg  := [mlir_region| {
   %y = "linalg.generic1d" (%x) ($(r)): (tensor1d) -> (tensor1d)
}]
def RHS : Region linalg := [mlir_region| {
   %width = "linalg.dim" (%x)  { "index" = 0 : index } : (tensor1d) -> (index)
   %four = "arith.constant" () { "value" = 4 : index } : () -> (index)
   %num_tiles = "arith.div"(%width , %four) : (index, index) -> (index)
   %y = "scf.for_iter" (%zero, %num_tiles, %x) ({ -- begin, end, loop variable.
     ^entry(%i: index):
       %xchunk = "linalg.extractindex"(%x, %i_times_four, %four) : (tensor1d, index, index) -> (tensor1d)
       %ychunk = "linalg.generic1d" (%xchunk) ($(r)): (tensor1d) -> (tensor1d)
       %yout = "linalg.insertindex"(%x, %i_times_four, %ychunk) : (tensor1d, index, tensor1d) -> (tensor1d)
       "scf.yield"(%yout) : (tensor1d) -> (tensor1d)
   }): (tensor1d) -> (tensor1d)
}]
end Generic1DTiling

namespace Transpose2D

def LHS: Region linalg  := [mlir_region| {
   %x = "linalg.transpsose2d" (%t) : (tensor2d) -> (tensor2d)
   %y = "linalg.transpose2d" (%x) : (tensor2d) -> (tensor2d)
}]
def RHS : Region linalg := [mlir_region| {
   %y = "scf.id"(%x) : (tensor2d) -> (tensor2d)
}]

-- Done in the tensor, we have the proof that 2d transpose is id.

end Transpose2D


/-
Copyright (c) 2018 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Johannes Hölzl
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.finset.basic
import Mathlib.data.multiset.pi
import Mathlib.PostPort

universes u_1 u_2

namespace Mathlib

/-!
# The cartesian product of finsets
-/

namespace finset

/-! ### pi -/

/-- The empty dependent product function, defined on the empty set. The assumption `a ∈ ∅` is never
satisfied. -/
def pi.empty {α : Type u_1} (β : α → Type u_2) (a : α) (h : a ∈ ∅) : β a :=
  multiset.pi.empty β a h

/-- Given a finset `s` of `α` and for all `a : α` a finset `t a` of `δ a`, then one can define the
finset `s.pi t` of all functions defined on elements of `s` taking values in `t a` for `a ∈ s`.
Note that the elements of `s.pi t` are only partially defined, on `s`. -/
def pi {α : Type u_1} {δ : α → Type u_2} [DecidableEq α] (s : finset α) (t : (a : α) → finset (δ a)) : finset ((a : α) → a ∈ s → δ a) :=
  mk (multiset.pi (val s) fun (a : α) => val (t a)) sorry

@[simp] theorem pi_val {α : Type u_1} {δ : α → Type u_2} [DecidableEq α] (s : finset α) (t : (a : α) → finset (δ a)) : val (pi s t) = multiset.pi (val s) fun (a : α) => val (t a) :=
  rfl

@[simp] theorem mem_pi {α : Type u_1} {δ : α → Type u_2} [DecidableEq α] {s : finset α} {t : (a : α) → finset (δ a)} {f : (a : α) → a ∈ s → δ a} : f ∈ pi s t ↔ ∀ (a : α) (h : a ∈ s), f a h ∈ t a :=
  multiset.mem_pi (val s) (fun (a : α) => (fun (a : α) => val (t a)) a) f

/-- Given a function `f` defined on a finset `s`, define a new function on the finset `s ∪ {a}`,
equal to `f` on `s` and sending `a` to a given value `b`. This function is denoted
`s.pi.cons a b f`. If `a` already belongs to `s`, the new function takes the value `b` at `a`
anyway. -/
def pi.cons {α : Type u_1} {δ : α → Type u_2} [DecidableEq α] (s : finset α) (a : α) (b : δ a) (f : (a : α) → a ∈ s → δ a) (a' : α) (h : a' ∈ insert a s) : δ a' :=
  multiset.pi.cons (val s) a b f a' sorry

@[simp] theorem pi.cons_same {α : Type u_1} {δ : α → Type u_2} [DecidableEq α] (s : finset α) (a : α) (b : δ a) (f : (a : α) → a ∈ s → δ a) (h : a ∈ insert a s) : pi.cons s a b f a h = b :=
  multiset.pi.cons_same (pi.cons._proof_1 s a a h)

theorem pi.cons_ne {α : Type u_1} {δ : α → Type u_2} [DecidableEq α] {s : finset α} {a : α} {a' : α} {b : δ a} {f : (a : α) → a ∈ s → δ a} {h : a' ∈ insert a s} (ha : a ≠ a') : pi.cons s a b f a' h = f a' (or.resolve_left (iff.mp mem_insert h) (ne.symm ha)) :=
  multiset.pi.cons_ne (pi.cons._proof_1 s a a' h) (ne.symm ha)

theorem pi_cons_injective {α : Type u_1} {δ : α → Type u_2} [DecidableEq α] {a : α} {b : δ a} {s : finset α} (hs : ¬a ∈ s) : function.injective (pi.cons s a b) := sorry

@[simp] theorem pi_empty {α : Type u_1} {δ : α → Type u_2} [DecidableEq α] {t : (a : α) → finset (δ a)} : pi ∅ t = singleton (pi.empty δ) :=
  rfl

@[simp] theorem pi_insert {α : Type u_1} {δ : α → Type u_2} [DecidableEq α] [(a : α) → DecidableEq (δ a)] {s : finset α} {t : (a : α) → finset (δ a)} {a : α} (ha : ¬a ∈ s) : pi (insert a s) t = finset.bUnion (t a) fun (b : δ a) => image (pi.cons s a b) (pi s t) := sorry

theorem pi_singletons {α : Type u_1} [DecidableEq α] {β : Type u_2} (s : finset α) (f : α → β) : (pi s fun (a : α) => singleton (f a)) = singleton fun (a : α) (_x : a ∈ s) => f a := sorry

theorem pi_const_singleton {α : Type u_1} [DecidableEq α] {β : Type u_2} (s : finset α) (i : β) : (pi s fun (_x : α) => singleton i) = singleton fun (_x : α) (_x : _x ∈ s) => i :=
  pi_singletons s fun (_x : α) => i

theorem pi_subset {α : Type u_1} {δ : α → Type u_2} [DecidableEq α] {s : finset α} (t₁ : (a : α) → finset (δ a)) (t₂ : (a : α) → finset (δ a)) (h : ∀ (a : α), a ∈ s → t₁ a ⊆ t₂ a) : pi s t₁ ⊆ pi s t₂ :=
  fun (g : (a : α) → a ∈ s → δ a) (hg : g ∈ pi s t₁) =>
    iff.mpr mem_pi fun (a : α) (ha : a ∈ s) => h a ha (iff.mp mem_pi hg a ha)

theorem pi_disjoint_of_disjoint {α : Type u_1} [DecidableEq α] {δ : α → Type u_2} [(a : α) → DecidableEq (δ a)] {s : finset α} [DecidableEq ((a : α) → a ∈ s → δ a)] (t₁ : (a : α) → finset (δ a)) (t₂ : (a : α) → finset (δ a)) {a : α} (ha : a ∈ s) (h : disjoint (t₁ a) (t₂ a)) : disjoint (pi s t₁) (pi s t₂) := sorry


import tactic
import category_theory.limits.shapes.pullbacks

namespace category_theory
open category_theory.limits

variables {C D : Type*} [category C] [category D] (e : C ≌ D)
  {X Y B : D} (f : X ⟶ B) (g : Y ⟶ B) [has_pullback (e.inverse.map f) (e.inverse.map g)]

lemma equivalence.hom_eq_map {X Y : C} (f : e.functor.obj X ⟶ e.functor.obj Y)
  (g : X ⟶ Y) : e.inverse.map f = e.symm.counit.app _ ≫ g ≫ e.unit.app _ →
  f = e.functor.map g :=
begin
  intros h,
  change _ = (e.unit_iso.app _).inv ≫ g ≫ (e.unit_iso.app _).hom at h,
  rw iso.eq_inv_comp at h,
  replace h := h.symm,
  rw ← iso.eq_comp_inv at h,
  rw h,
  simp,
  nth_rewrite 0 ← category.id_comp f,
  simp_rw ← category.assoc,
  congr' 1,
  simp,
end

noncomputable theory

/-
I would like to do something for more general shapes, but universes make this difficult
(as usual...)
-/

@[simps]
def equivalence.pullback_cone : cone (cospan f g) :=
{ X := e.functor.obj $ pullback (e.inverse.map f) (e.inverse.map g),
  π :=
  { app := λ i,
    match i with
    | none := e.functor.map pullback.fst ≫ e.counit.app X ≫ f
    | walking_cospan.left := e.functor.map pullback.fst ≫ e.counit.app X
    | walking_cospan.right := e.functor.map pullback.snd ≫ e.counit.app Y
    end,
    naturality' := begin
      rintro (i|i|i) (j|j|j) (h|h),
      { dsimp, simp only [category.id_comp, functor.map_id], dsimp, simp only [category.comp_id], },
      { dsimp, simp only [category.id_comp], dsimp [equivalence.pullback_cone._match_1],
        simp only [category.assoc], },
      { dsimp, simp only [category.id_comp, functor.map_id], dsimp, simp only [category.comp_id], },
      { unfold_aux,
        dsimp, simp, delta id_rhs,
        have : e.counit.app X ≫ f = e.functor.map (e.inverse.map f) ≫ e.counit.app B, by tidy,
        rw this, clear this,
        have : e.counit.app Y ≫ g = e.functor.map (e.inverse.map g) ≫ e.counit.app B, by tidy,
        rw this, clear this,
        simp_rw [← category.assoc, ← e.functor.map_comp, limits.pullback.condition] },
      { tidy }
    end } } .

attribute [reassoc] equivalence.unit_inverse_comp

-- This is a mess :-(
-- Please fix before moving this file to mathlib!
def equivalence.is_limit_pullback_cone : limits.is_limit (e.pullback_cone f g) :=
{ lift := λ S, e.symm.unit.app S.X ≫
    e.functor.map (pullback.lift (e.inverse.map (S.π.app walking_cospan.left))
      (e.inverse.map (S.π.app walking_cospan.right)) begin
        simp_rw ← e.inverse.map_comp,
        change e.inverse.map (_ ≫ (cospan f g).map walking_cospan.hom.inl) =
          e.inverse.map (_ ≫ (cospan f g).map walking_cospan.hom.inr),
        rw [S.w, S.w],
      end),
  fac' := begin
    rintros S (j|j|j),
    { dsimp [equivalence.pullback_cone._match_1],
      simp only [category.assoc],
      have : e.counit.app X ≫ f = e.functor.map (e.inverse.map f) ≫ e.counit.app B,
      { dsimp, simp only [equivalence.fun_inv_map, category.assoc, iso.inv_hom_id_app,
          nat_iso.cancel_nat_iso_hom_left], erw category.comp_id, },
      rw this, clear this,
      simp_rw [← category.assoc _ _ (e.counit.app B), ← e.functor.map_comp],
      simp only [functor.map_comp, pullback.lift_fst_assoc, equivalence.fun_inv_map,
        category.assoc, iso.inv_hom_id_app_assoc, iso.inv_hom_id_app],
      dsimp,
      simp only [category.comp_id],
      change _ ≫ (cospan f g).map walking_cospan.hom.inl = _,
      rw S.w },
    { dsimp [equivalence.pullback_cone._match_1],
      simp only [category.assoc],
      simp_rw [← category.assoc _ _ (e.counit.app X), ← e.functor.map_comp],
      simp only [pullback.lift_fst, equivalence.fun_inv_map, iso.inv_hom_id_app_assoc,
        category.assoc, iso.inv_hom_id_app],
      dsimp,
      rw [category.comp_id] },
    { dsimp [equivalence.pullback_cone._match_1],
      simp only [category.assoc],
      simp_rw [← category.assoc _ _ (e.counit.app Y), ← e.functor.map_comp],
      simp only [pullback.lift_snd, equivalence.fun_inv_map, iso.inv_hom_id_app_assoc,
        category.assoc, iso.inv_hom_id_app],
      dsimp,
      rw [category.comp_id] }
  end,
  uniq' := begin
    intros S m h,
    --dsimp at *,
    change m = (e.counit_iso.app S.X).inv ≫ _,
    rw iso.eq_inv_comp,
    apply equivalence.hom_eq_map,
    change _ = (e.unit_iso.app _).inv ≫ _ ≫ (e.unit_iso.app _).hom,
    rw iso.eq_inv_comp,
    symmetry,
    rw ← iso.eq_comp_inv,
    simp only [category.assoc],
    apply pullback.hom_ext,
    { simp only [functor.map_comp, pullback.lift_fst, iso.app_hom, iso.app_inv, category.assoc],
      specialize h walking_cospan.left,
      rw ← h,
      simp only [functor.map_comp, equivalence.inv_fun_map, category.assoc,
        equivalence.unit_inverse_comp_assoc, category.comp_id,
        equivalence.pullback_cone, equivalence.pullback_cone_π_app, functor.map_comp,
        equivalence.unit_inverse_comp], },
    { simp only [functor.map_comp, pullback.lift_snd, iso.app_hom, iso.app_inv, category.assoc],
      specialize h walking_cospan.right,
      rw ← h,
      simp only [functor.map_comp, equivalence.inv_fun_map, category.assoc,
        equivalence.unit_inverse_comp_assoc, category.comp_id,
        equivalence.pullback_cone, equivalence.pullback_cone_π_app, functor.map_comp,
        equivalence.unit_inverse_comp], }
  end } .

include e

lemma equivalence.has_pullback {X Y B : D} (f : X ⟶ B) (g : Y ⟶ B)
  [has_pullback (e.inverse.map f) (e.inverse.map g)] : has_pullback f g :=
limits.has_limit.mk ⟨e.pullback_cone _ _, e.is_limit_pullback_cone _ _⟩

lemma equivalence.has_pullbacks [has_pullbacks C] : has_pullbacks D :=
begin
  apply has_pullbacks_of_has_limit_cospan _,
  intros X Y B f g,
  apply e.has_pullback,
end

end category_theory


/- -----------------------------------------------------------------------
The topos of trees.
----------------------------------------------------------------------- -/

import ..c1_basic
import ..c2_limits

namespace qp

open stdaux

universe variables ℓobjx ℓhomx

/-! #brief The topos of trees.
-/
definition TreeTopos : Cat
:= PreShCat NatCat

/-! #brief Action of the later endofunctor on objects.
-/
definition LaterObj.obj
    (F : TreeTopos^.obj)
    : ∀ (n : ℕ), Type
| 0 := punit
| (nat.succ n) := F^.obj n

/-! #brief Action of the later endofunctor on objects.
-/
definition LaterObj.hom
    (F : TreeTopos^.obj)
    : ∀ (n₂ n₁ : ℕ) (ωn : n₁ ≤ n₂)
      , LaterObj.obj F n₂ → LaterObj.obj F n₁
| n₂ 0 ωn x := punit.star
| 0 (nat.succ n₁) ωn x := false.rec _ (by cases ωn)
| (nat.succ n₂) (nat.succ n₁) ωn x := F^.hom (nat.le_of_succ_le_succ ωn) x

/-! #brief Action of the later endofunctor on objects.
-/
theorem LaterObj.hom.id
    (F : TreeTopos^.obj)
    : ∀ (n : ℕ)
      , LaterObj.hom F n n (nat.le_refl n) = @id (LaterObj.obj F n)
| 0 := begin apply funext, intro u, cases u, trivial end
| (nat.succ n) := F^.hom_id

/-! #brief Action of the later endofunctor on objects.
-/
theorem LaterObj.hom.circ
    (F : TreeTopos^.obj)
    : ∀ (n₃ n₂ n₁ : ℕ) (ωn₁₂ : n₁ ≤ n₂) (ωn₂₃ : n₂ ≤ n₃)
      , LaterObj.hom F n₃ n₁ (nat.le_trans ωn₁₂ ωn₂₃)
         = λ x, LaterObj.hom F n₂ n₁ ωn₁₂ (LaterObj.hom F n₃ n₂ ωn₂₃ x)
| 0 0 0 ωn₁₂ ωn₂₃ := rfl
| 0 0 (nat.succ n₁) ωn₁₂ ωn₂₃ := rfl
| 0 (nat.succ n₂) 0 ωn₁₂ ωn₂₃ := rfl
| (nat.succ n₃) 0 0 ωn₁₂ ωn₂₃ := rfl
| 0 (nat.succ n₂) (nat.succ n₁) ωn₁₂ ωn₂₃ := by cases ωn₂₃
| (nat.succ n₃) 0 (nat.succ n₁) ωn₁₂ ωn₂₃ := by cases ωn₁₂
| (nat.succ n₃) (nat.succ n₂) 0 ωn₁₂ ωn₂₃ := rfl
| (nat.succ n₃) (nat.succ n₂) (nat.succ n₁) ωn₁₂ ωn₂₃ := F^.hom_circ

/-! #brief Action of the later endofunctor on objects.
-/
definition LaterObj
    (F : TreeTopos^.obj)
    : TreeTopos^.obj
:= { obj := LaterObj.obj F
   , hom := LaterObj.hom F
   , hom_id := LaterObj.hom.id F
   , hom_circ := LaterObj.hom.circ F
   }

/-! #brief Action of the later endofunctor on homs.
-/
definition LaterHom.com
    {F₁ F₂ : TreeTopos^.obj}
    (η : TreeTopos^.hom F₁ F₂)
    : ∀ (n : ℕ)
      , LaterObj.obj F₁ n → LaterObj.obj F₂ n
| 0 := id
| (nat.succ n) := η^.com n

/-! #brief Action of the later endofunctor on homs.
-/
theorem LaterHom.natural
    {F₁ F₂ : TreeTopos^.obj}
    (η : TreeTopos^.hom F₁ F₂)
    : ∀ (n₂ n₁ : ℕ) (ωn : n₁ ≤ n₂)
      , (λ x, LaterHom.com η n₁ (LaterObj.hom F₁ n₂ n₁ ωn x))
         = λ x, LaterObj.hom F₂ n₂ n₁ ωn (LaterHom.com η n₂ x)
| 0 0 ωn := rfl
| 0 (nat.succ n₁) ωn := by cases ωn
| (nat.succ n₂) 0 ωn := rfl
| (nat.succ n₂) (nat.succ n₁) ωn := η^.natural _

/-! #brief Action of the later endofunctor on homs.
-/
definition LaterHom
    (F₁ F₂ : TreeTopos^.obj)
    (η : TreeTopos^.hom F₁ F₂)
    : TreeTopos^.hom (LaterObj F₁) (LaterObj F₂)
:= { com := LaterHom.com η
   , natural := LaterHom.natural η
   }

/-! #brief The later endofunctor.
-/
definition LaterFun : Fun TreeTopos TreeTopos
:= { obj := LaterObj
   , hom := LaterHom
   , hom_id
      := λ F
         , begin
             apply NatTrans.eq,
             apply funext, intro n, cases n,
             { trivial },
             { trivial }
           end
   , hom_circ
      := λ F₁ F₂ F₃ η₂₃ η₁₂
         , begin
             apply NatTrans.eq,
             apply funext, intro n, cases n,
             { trivial },
             { trivial }
           end
   }

/-! #brief The left adjoint of the later endofunctor.
-/
definition SoonerFun
    : Fun TreeTopos TreeTopos
:= { obj := λ F, { obj := λ n, F^.obj (nat.succ n)
                 , hom := λ n₂ n₁ ωn, F^.hom (nat.succ_le_succ ωn)
                 , hom_id := λ n, F^.hom_id
                 , hom_circ := λ n₃ n₂ n₁ ωn₁₂ ωn₂₃, F^.hom_circ
                 }
   , hom := λ F₁ F₂ η, { com := λ n, η^.com (nat.succ n)
                      , natural := λ n₂ n₁ ωn, η^.natural _
                      }
   , hom_id
      := λ F
         , begin
             apply NatTrans.eq,
             apply funext, intro n,
             trivial
           end
   , hom_circ
      := λ F₁ F₂ F₃ η₂₃ η₁₂
         , begin
             apply NatTrans.eq,
             apply funext, intro n,
             trivial
           end
   }

/-! #brief SoonerFun and LaterFun are adjoint.
-/
definition SoonerFun_LaterFun.adj
    : Adj SoonerFun LaterFun
:= { counit
      := { com := λ F, { com := λ n x, x
                       , natural := λ n₂ n₁ f, funext (λ x, rfl)
                       }
         , natural := λ F₁ F₂ η, NatTrans.eq (funext (λ n, funext (λ x, rfl)))
         }
   , unit
      := { com := λ F, { com := λ n x, cast sorry x
                       , natural := λ n₂ n₁ f, funext (λ x, sorry)
                       }
         , natural := λ F₁ F₂ η, NatTrans.eq (funext (λ n, funext (λ x, sorry)))
         }
   , id_left := λ F, NatTrans.eq sorry
   , id_right := λ F, NatTrans.eq sorry
   }

/-! #brief LaterFun preserves all limits.
-/
definition LaterFun.PresLimit
    {X : Cat.{ℓobjx ℓhomx}} (F : Fun X TreeTopos)
    : PresLimit F LaterFun
:= Adj.right.PresLimit SoonerFun_LaterFun.adj F

/-! #brief The next natural transformation.
-/
definition NextTrans.com (X : TreeTopos^.obj)
    : ∀ (n : ℕ)
      , X^.obj n → LaterObj.obj X n
| 0 := λ u, punit.star
| (nat.succ n) := X^.hom (nat.le_succ n)

/-! #brief The next natural transformation.
-/
theorem NextTrans.natural (X : TreeTopos^.obj)
    : ∀ (n₂ n₁ : ℕ) (ωn : n₁ ≤ n₂)
      , Cat.circ LeanCat (NextTrans.com X n₁) (X^.hom ωn)
         = Cat.circ LeanCat (LaterObj.hom X n₂ n₁ ωn) (NextTrans.com X n₂)
| 0 0 ωn := rfl
| 0 (nat.succ n₁) ωn := by cases ωn
| (nat.succ n₂) 0 ωn := rfl
| (nat.succ n₂) (nat.succ n₁) ωn
:= begin
     refine eq.trans (eq.symm X^.hom_circ) _,
     refine eq.trans _ X^.hom_circ,
     trivial
   end

/-! #brief The next natural transformation.
-/
definition NextTrans (X : TreeTopos^.obj)
    : TreeTopos^.hom X (LaterFun^.obj X)
:= { com := NextTrans.com X
   , natural := NextTrans.natural X
   }

end qp


import for_mathlib.ab4
import algebra.category.Module.colimits
import for_mathlib.AddCommGroup.ab4

open category_theory
open category_theory.limits

local attribute [instance] category_theory.limits.has_zero_object.has_zero

universes v'' v' v u'' u' u

open_locale classical

instance Module.forget₂_AddCommGroup_preserves_zero_morphisms {R : Type*} [ring R]
  : (forget₂ (Module R) AddCommGroup).preserves_zero_morphisms := ⟨⟩

instance Module.forget₂_AddCommGroup_faithful {R : Type*} [ring R]
  : faithful (forget₂ (Module R) AddCommGroup) :=
begin
  refine ⟨_⟩,
  intros X Y f g H,
  ext x,
  rw [← linear_map.to_add_monoid_hom_coe, ← linear_map.to_add_monoid_hom_coe],
  exact congr_arg2 _ H (refl x)
end.

noncomputable
instance Module.forget₂_AddCommGroup_reflects_exact_sequences {R : Type*} [ring R]
  : functor.reflects_exact_sequences (forget₂ (Module R) AddCommGroup) :=
begin
  apply functor.reflects_exact_sequences_of_preserves_zero_morphisms_of_faithful
end

instance Module.forget₂_AddCommGroup_reflects_mono {R : Type*} [ring R]
  : functor.reflects_monomorphisms (forget₂ (Module R) AddCommGroup) := by apply_instance

instance Module.forget₂_AddCommGroup_preserves_mono {R : Type*} [ring R]
  : functor.preserves_monomorphisms (forget₂ (Module R) AddCommGroup) := by apply_instance

instance coextension.module_structure (R : Type*) [ring R] (G : Type*) [add_comm_group G]
  : module R (R →+ G) := {
    smul := λ r f, ⟨(λ x, f (x * r)), (by simp), (by { intros, simp [add_mul] })⟩,
    one_smul  := by { intros, simp },
    mul_smul  := by { intros, ext, simp [mul_assoc] },
    smul_add  := by { intros, ext, simp },
    smul_zero := by { intros, ext, simp },
    add_smul  := by { intros, ext, simp [mul_add] },
    zero_smul := by { intros, ext, simp }
  }.

def coextension.map' (R : Type*) [ring R] {G H : Type*} [add_comm_group G] [add_comm_group H]
  (ϕ : G →+ H) : (R →+ G) →ₗ[R] (R →+ H) := {
    to_fun := λ f, ⟨ϕ.comp f, by simp, by { intros, simp }⟩,
    map_add' := by { intros, ext, simp },
    map_smul' := by { intros, ext, simp, refl }
  }.

def Module.coextension (R : Type*) [ring R] : AddCommGroup ⥤ Module R := {
  obj := λ G, Module.of R (R →+ G),
  map := λ G H ϕ, Module.of_hom (coextension.map' R ϕ)
}.

def Module.restriction_coextension_adj_unit (R : Type*) [ring R]
  (M : Type*) [add_comm_group M] [module R M] : M →ₗ[R] (R →+ M) := {
    to_fun := λ x, ⟨(λ r, r • x), zero_smul R x, (λ r s, add_smul r s x)⟩,
    map_add' := by { intros, ext, simp },
    map_smul' := by { intros, ext, simp, symmetry, apply mul_smul }
  }.

def Module.restriction_coextension_adj_counit (R : Type*) [ring R]
  (G : Type*) [add_comm_group G] : (R →+ G) →+ G := {
    to_fun := λ f, f 1,
    map_zero' := rfl,
    map_add' := λ x y, rfl
  }.

def Module.restriction_coextension_adj (R : Type*) [ring R]
  : forget₂ (Module R) AddCommGroup ⊣ Module.coextension R :=
  adjunction.mk_of_unit_counit {
    unit := {
      app := λ M, Module.restriction_coextension_adj_unit R M,
      naturality' := by { intros, ext, symmetry, apply map_smul f }
    },
    counit := {
      app := λ G, Module.restriction_coextension_adj_counit R G,
      naturality' := by { intros, ext, refl }
    },
    left_triangle' := by { ext, exact one_smul _ _ },
    right_triangle' := by { ext M f r, exact congr_arg f.to_fun (one_mul r) }
  }.

instance Module.forget₂_AddCommGroup_preserves_coproduct {R : Type*} [ring R]
  {J : Type*} (f : J → Module R)
  : limits.preserves_colimit (discrete.functor f) (forget₂ (Module R) AddCommGroup) :=
  @preserves_colimits_of_shape.preserves_colimit _ _ _ _ _ _ _
    (@preserves_colimits_of_size.preserves_colimits_of_shape _ _ _ _ _
      (@preserves_colimits_of_size_shrink _ _ _ _ _
        (Module.restriction_coextension_adj R).left_adjoint_preserves_colimits) _ _) _

lemma sigma_comparison_naturality {β : Type*} {C : Type*} [category C] {D : Type*} [category D]
  (G : C ⥤ D) {f g : β → C} (η : Π (b : β), f b ⟶ g b) [has_coproduct f] [has_coproduct g]
  [has_coproduct (λ (b : β), G.obj (f b))]  [has_coproduct (λ (b : β), G.obj (g b))]
  : sigma_comparison G f
  ≫ G.map (colim_map (discrete.nat_trans (λ b', η b'.as) : discrete.functor f ⟶ discrete.functor g))
  = colim_map (discrete.nat_trans (λ b', G.map (η b'.as)) : discrete.functor (λ (b : β), G.obj (f b)) ⟶ discrete.functor (λ (b : β), G.obj (g b)))
  ≫ sigma_comparison G g :=
begin
  ext,
  simp [sigma_comparison],
  rw [← G.map_comp, ← G.map_comp],
  refine congr_arg _ _,
  delta sigma.ι,
  simp
end

-- not sure about the universes here
lemma AB4_of_preserves_coproduct_and_reflects_and_preserves_mono {V W : Type u}
  [category.{v} V] [category.{v} W] [abelian V] [abelian W]
  [i : has_coproducts V] [i' : has_coproducts W]
  (F : V ⥤ W) [F.reflects_monomorphisms] [F.preserves_monomorphisms]
  [∀ (J : Type v) (f : J → V), limits.preserves_colimit (discrete.functor f) F]
  [h : @AB4 W _ i'] : @AB4 V _ i :=
begin
  constructor,
  introsI,
  apply F.mono_of_mono_map,
  suffices : mono (F.map (colim_map (discrete.nat_trans (λ a', f a'.as) : discrete.functor X ⟶ discrete.functor Y))),
  { convert this,
    delta sigma.desc cofan.mk colim_map is_colimit.map cocones.precompose,
    congr,
    ext a, cases a, refl },
  have H := sigma_comparison_naturality F f,
  rw ← is_iso.eq_inv_comp at H,
  rw H,
  apply_with mono_comp {instances:=ff},
  { apply_instance },
  { apply_with mono_comp {instances:=ff},
    { convert AB4.cond (F.obj ∘ X) (F.obj ∘ Y) (λ a, F.map (f a)) (λ a, F.map_mono (f a)),
      delta sigma.desc cofan.mk colim_map is_colimit.map cocones.precompose, dsimp,
      congr,
      ext a, cases a, refl },
    { apply_instance } }
end

instance AB4 {R : Type u} [ring R] : AB4 (Module.{(max v u) u} R) :=
  @AB4_of_preserves_coproduct_and_reflects_and_preserves_mono _ _ _ _ _ _ _ _
    (forget₂ (Module.{(max v u) u} R) AddCommGroup.{max v u})
    _ _
    (λ J f, @preserves_colimits_of_shape.preserves_colimit _ _ _ _ _ _ _
              (@preserves_colimits_of_size.preserves_colimits_of_shape _ _ _ _ _
                (Module.restriction_coextension_adj.{u v} R).left_adjoint_preserves_colimits
                (discrete J) _) (discrete.functor f)) _.


import Lean.Elab
open Lean.Elab.Tactic
open Lean.Elab

syntax (name := poyo) "foo" : tactic
@[tactic poyo]
def evalpoyo : Tactic := fun stx => do
  logInfo m!"<h1>{1}</h1>"

def Set (α : Type u) := α → Prop
def Set.in (s : Set α) (a : α) := s a

notation:50 a " ∈ " s:50 => Set.in s a

def Set.pred (p : α → Prop) : Set α := p

notation "{" a "|" p "}" => Set.pred (fun a => p)

def Set.union (s₁ s₂ : Set α) : Set α :=
  { a | a ∈ s₁ ∨ a ∈ s₂ }

infix:65 " ∪ " => Set.union

def Set.inter (s₁ s₂ : Set α) : Set α :=
  { a | a ∈ s₁ ∧ a ∈ s₂ }

infix:70 " ∩ " => Set.inter

instance (s : Set α) [h : Decidable (s a)] : Decidable (a ∈ Set.pred s) := h

instance (s₁ s₂ : Set α) [Decidable (a ∈ s₁)] [Decidable (a ∈ s₂)] : Decidable (a ∈ s₁ ∩ s₂) :=
  inferInstanceAs (Decidable (_ ∧ _))

instance (s₁ s₂ : Set α) [Decidable (a ∈ s₁)] [Decidable (a ∈ s₂)] : Decidable (a ∈ s₁ ∪ s₂) :=
  inferInstanceAs (Decidable (_ ∨ _))

def main : IO Unit :=
  IO.println "Hello, world!"

abbrev ℕ := Nat

def a := 1

#check ℕ
#check evalpoyo
#check (1,2,3)
#check 3 * 3 = 9
#check (⟨9, ⟨3, rfl⟩⟩:{m: ℕ // ∃r, r * r = m})

theorem test1 {α} (a b : α) (as bs : List α) (h : a::as = b::bs) : a = b :=
by {
  foo;
  skip;
  trace_state;
  injection h;
  assumption;
}

def b:{ll: List (List ℕ) //∃m r, ll.length = m ∧ r * r = m ∧ m > 0} :=
  ⟨[[0,3,2,1], [2,1,0,3], [3,0,1,2], [1,2,3,0]],
  by {
    let m := 4; let r := 2;
    exists m;
    exists r;
    simp;
  }⟩

macro "inductionFinTerm " term:term " with " v:ident lt:ident t:tacticSeq : tactic => `(induction $term with | mk $v $lt => $t)
syntax "repeatWithNat " term " => " tacticSeq : tactic
macro_rules
  | `(tactic| repeatWithNat $num => $seq) => `(tactic| first | let trialNum := $num; ($seq); repeatWithNat (Nat.succ $num) => $seq | skip)

def h: ∃x, x = 0 := Subtype.existsOfSubtype ⟨0, by rfl⟩
noncomputable def aaaa: Nat := sorry
#check Classical.choice
noncomputable def indefiniteDescription {α : Sort u} {p : α → Prop} (h : ∃ x, p x) : {x // p x} :=
  Classical.choice <| let ⟨x, px⟩ := h; ⟨⟨x, px⟩⟩
noncomputable def hoge {α : Sort u} {p : α → Prop} (h : ∃ x, p x) : Nonempty {x // p x} :=
let ⟨w, prop⟩ := h; ⟨w, prop⟩
--てすと,カタカナ，漢字．１２３ｂｃｓ

constant magic (h : ∃ n : ℕ, n > 0) : ℕ
axiom magic_extract (n h) : magic ⟨n, h⟩ = n

example : false :=
have h1 : magic ⟨1, sorry⟩ = 1 := magic_extract _ _;
have h2 : magic ⟨2, sorry⟩ = 2 := magic_extract _ _;
have proof_irrel : magic ⟨1, sorry⟩ = magic ⟨2, sorry⟩ := rfl;
absurd (h1.symm.trans $ proof_irrel.trans h2) sorry