/-
Copyright (c) 2022 Mario Carneiro, Heather Macbeth. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro, Heather Macbeth, Yaël Dillies
-/
import tactic.norm_num
import algebra.order.field.power
import algebra.order.hom.basic
import data.nat.factorial.basic

/-! # `positivity` tactic

The `positivity` tactic in this file solves goals of the form `0 ≤ x`, `0 < x` and `x ≠ 0`.  The
tactic works recursively according to the syntax of the expression `x`.  For example, a goal of the
form `0 ≤ 3 * a ^ 2 + b * c` can be solved either
* by a hypothesis such as `5 ≤ 3 * a ^ 2 + b * c` which directly implies the nonegativity of
  `3 * a ^ 2 + b * c`; or,
* by the application of the lemma `add_nonneg` and the success of the `positivity` tactic on the two
  sub-expressions `3 * a ^ 2` and `b * c`.

For each supported operation, one must write a small tactic, tagged with the attribute
`@[positivity]`, which operates only on goals whose leading function application is that operation.
Typically, this small tactic will run the full `positivity` tactic on one or more of the function's
arguments (which is where the recursion comes in), and if successful will combine this with an
appropriate lemma to give positivity of the full expression.

This file contains the core `positivity` logic and the small tactics handling the basic operations:
`min`, `max`, `+`, `*`, `/`, `⁻¹`, raising to natural powers, and taking absolute values.  Further
extensions, e.g. to handle `real.sqrt` and norms, can be found in the files of the library which
introduce these operations.

## Main declarations

* `tactic.norm_num.positivity` tries to prove positivity of an expression by running `norm_num` on
  it.  This is one of the base cases of the recursion.
* `tactic.positivity.compare_hyp` tries to prove positivity of an expression by comparing with a
  provided hypothesis.  If the hypothesis is of the form `a ≤ b` or similar, with `b` matching the
  expression whose proof of positivity is desired, then it will check whether `a` can be proved
  positive via `tactic.norm_num.positivity` and if so apply a transitivity lemma.  This is the other
  base case of the recursion.
* `tactic.positivity.attr` creates the `positivity` user attribute for tagging the extension
  tactics handling specific operations, and specifies the behaviour for a single step of the
  recursion
* `tactic.positivity.core` collects the list of tactics with the `@[positivity]` attribute and
  calls the first recursion step as specified in `tactic.positivity.attr`.  Its input is `e : expr`
  and its output (if it succeeds) is a term of a custom inductive type
  `tactic.positivity.strictness`, containing an `expr` which is a proof of the
  strict-positivity/nonnegativity of `e` as well as an indication of whether what could be proved
  was strict-positivity or nonnegativity
* `tactic.positivity.order_rel` is a custom inductive type recording whether the goal is
  `0 ≤ e`/`e ≥ 0`, `0 < e`/`e > 0`, `e ≠ 0` or `0 ≠ e`.
* `tactic.interactive.positivity` is the user-facing tactic.  It parses the goal and, if it is of
  one of the forms `0 ≤ e`, `0 < e`, `e > 0`, `e ≥ 0`, `e ≠ 0`, `0 ≠ e`, it sends `e` to
  `tactic.positivity.core`.

## TODO

Implement extensions for other operations (raising to non-numeral powers, `log`).
-/

namespace tactic

/-- Inductive type recording either `positive` and an expression (typically a proof of a fact
`0 < x`) or `nonnegative` and an expression (typically a proof of a fact `0 ≤ x`). -/
@[derive [decidable_eq]]
meta inductive positivity.strictness : Type
| positive : expr → positivity.strictness
| nonnegative : expr → positivity.strictness
| nonzero : expr → positivity.strictness

export positivity.strictness (positive nonnegative nonzero)

meta instance : has_to_string strictness :=
⟨λ s, match s with
  | positive p := "strictness.positive (" ++ to_string p ++ ")"
  | nonnegative p := "strictness.nonnegative (" ++ to_string p ++ ")"
  | nonzero p := "strictness.nonzero (" ++ to_string p ++ ")"
  end⟩

meta instance : has_to_format strictness := ⟨λ s, to_string s⟩

private lemma lt_of_eq_of_lt'' {α} [preorder α] {b b' a : α} : b = b' → a < b' → a < b :=
λ h1 h2, lt_of_lt_of_eq h2 h1.symm

/-- First base case of the `positivity` tactic.  We try `norm_num` to prove directly that an
expression `e` is positive, nonnegative or non-zero. -/
meta def norm_num.positivity (e : expr) : tactic strictness := do
  (e', p) ← norm_num.derive e <|> refl_conv e,
  e'' ← e'.to_rat,
  typ ← infer_type e',
  ic ← mk_instance_cache typ,
  if e'' > 0 then do
    (ic, p₁) ← norm_num.prove_pos ic e',
    positive <$> mk_app ``lt_of_eq_of_lt'' [p, p₁]
  else if e'' = 0 then
    nonnegative <$> mk_app ``ge_of_eq [p]
  else do
    (ic, p₁) ← norm_num.prove_ne_zero' ic e',
    nonzero <$> to_expr ``(ne_of_eq_of_ne %%p %%p₁)

/-- Second base case of the `positivity` tactic: Any element of a canonically ordered additive
monoid is nonnegative. -/
meta def positivity_canon : expr → tactic strictness
| `(%%a) := nonnegative <$> mk_app ``zero_le [a]

namespace positivity

/-- Inductive type recording whether the goal `positivity` is called on is nonnegativity, positivity
or different from `0`. -/
@[derive inhabited]
inductive order_rel : Type
| le  : order_rel -- `0 ≤ a`
| lt  : order_rel -- `0 < a`
| ne  : order_rel -- `a ≠ 0`
| ne' : order_rel -- `0 ≠ a`

meta instance : has_to_format order_rel :=
⟨λ r, match r with
  | order_rel.le := "order_rel.le"
  | order_rel.lt := "order_rel.lt"
  | order_rel.ne := "order_rel.ne"
  | order_rel.ne' := "order_rel.ne'"
  end⟩

/-- Given two tactics whose result is `strictness`, report a `strictness`:
- if at least one gives `positive`, report `positive` and one of the expressions giving a proof of
  positivity
- if one reports `nonnegative` and the other reports `nonzero`, report `positive`
- else if at least one reports `nonnegative`, report `nonnegative` and one of the
  expressions giving a proof of nonnegativity
- else if at least one reports `nonzero`, report `nonzero` and one of the expressions giving a proof
  of nonzeroness
- if both fail, fail -/
protected meta def orelse (tac1 tac2 : tactic strictness) : tactic strictness := do
  res1 ← try_core tac1,
  match res1 with
  | none := tac2
  | some p1@(positive _) := pure p1
  | some (nonnegative e1) := do
      res2 ← try_core tac2,
      match res2 with
      | some p2@(positive _) := pure p2
      | some (nonzero e2) := positive <$> mk_app ``lt_of_le_of_ne' [e1, e2]
      | _ := pure (nonnegative e1)
      end
  | some (nonzero e1) := do
      res2 ← try_core tac2,
      match res2 with
      | some p2@(positive _) := pure p2
      | some (nonnegative e2) := positive <$> mk_app ``lt_of_le_of_ne' [e2, e1]
      | _ := pure (nonzero e1)
      end
  end

localized "infixr ` ≤|≥ `:2 := tactic.positivity.orelse" in positivity

/-- This tactic fails with a message saying that `positivity` couldn't prove anything about `e`
if we only know that `a` and `b` are positive/nonnegative/nonzero (according to `pa` and `pb`). -/
meta def positivity_fail {α : Type*} (e a b : expr) (pa pb : strictness) : tactic α :=
do
  e' ← pp e,
  a' ← pp a,
  b' ← pp b,
  let f : strictness → format → format := λ p c, match p with
  | positive _ := "0 < " ++ c
  | nonnegative _ := "0 ≤ " ++ c
  | nonzero _ := c ++ " ≠ 0"
  end,
  fail (↑"`positivity` can't say anything about `" ++ e' ++ "` knowing only `" ++ f pa a' ++
    "` and `" ++ f pb b' ++ "`")

/-! ### Core logic of the `positivity` tactic -/

private lemma ne_of_ne_of_eq' {α : Type*} {a b c : α} (ha : a ≠ c) (h : a = b) : b ≠ c := by rwa ←h

/-- Calls `norm_num` on `a` to prove positivity/nonnegativity of `e` assuming `b` is defeq to `e`
and `p₂ : a ≤ b`. -/
meta def compare_hyp_le (e a b p₂ : expr) : tactic strictness := do
  is_def_eq e b,
  strict_a ← norm_num.positivity a,
  match strict_a with
  | positive p₁ := positive <$> mk_app ``lt_of_lt_of_le [p₁, p₂]
  | nonnegative p₁ := nonnegative <$> mk_app ``le_trans [p₁, p₂]
  | _ := do
          e' ← pp e,
          p₂' ← pp p₂,
          fail (↑"`norm_num` can't prove nonnegativity of " ++ e' ++ " using " ++ p₂')
  end

/-- Calls `norm_num` on `a` to prove positivity/nonnegativity of `e` assuming `b` is defeq to `e`
and `p₂ : a < b`. -/
meta def compare_hyp_lt (e a b p₂ : expr) : tactic strictness := do
  is_def_eq e b,
  strict_a ← norm_num.positivity a,
  match strict_a with
  | positive p₁ := positive <$> mk_app ``lt_trans [p₁, p₂]
  | nonnegative p₁ := positive <$> mk_app ``lt_of_le_of_lt [p₁, p₂]
  | _ := do
          e' ← pp e,
          p₂' ← pp p₂,
          fail (↑"`norm_num` can't prove positivity of " ++ e' ++ " using " ++ p₂')
  end

/-- Calls `norm_num` on `a` to prove positivity/nonnegativity/nonzeroness of `e` assuming `b` is
defeq to `e` and `p₂ : a = b`. -/
meta def compare_hyp_eq (e a b p₂ : expr) : tactic strictness := do
  is_def_eq e b,
  strict_a ← norm_num.positivity a,
  match strict_a with
  | positive p₁ := positive <$> mk_app ``lt_of_lt_of_eq [p₁, p₂]
  | nonnegative p₁ := nonnegative <$> mk_app ``le_of_le_of_eq [p₁, p₂]
  | nonzero p₁ := nonzero <$> to_expr ``(ne_of_ne_of_eq' %%p₁ %%p₂)
  end

/-- Calls `norm_num` on `a` to prove nonzeroness of `e` assuming `b` is defeq to `e` and
`p₂ : b ≠ a`. -/
meta def compare_hyp_ne (e a b p₂ : expr) : tactic strictness := do
  is_def_eq e b,
  (a', p₁) ← norm_num.derive a <|> refl_conv a,
  a'' ← a'.to_rat,
  if a'' = 0 then
    nonzero <$> mk_mapp ``ne_of_ne_of_eq [none, none, none, none, p₂, p₁]
  else do
    e' ← pp e,
    p₂' ← pp p₂,
    a' ← pp a,
    fail (↑"`norm_num` can't prove non-zeroness of " ++ e' ++ " using " ++ p₂' ++ " because "
      ++ a' ++ " is non-zero")

/-- Third base case of the `positivity` tactic.  Prove an expression `e` is
positive/nonnegative/nonzero by finding a hypothesis of the form `a < e`, `a ≤ e` or `a = e` in
which `a` can be proved positive/nonnegative/nonzero by `norm_num`. -/
meta def compare_hyp (e p₂ : expr) : tactic strictness := do
  p_typ ← infer_type p₂,
  match p_typ with
  | `(%%lo ≤ %%hi) := compare_hyp_le e lo hi p₂
  | `(%%hi ≥ %%lo) := compare_hyp_le e lo hi p₂
  | `(%%lo < %%hi) := compare_hyp_lt e lo hi p₂
  | `(%%hi > %%lo) := compare_hyp_lt e lo hi p₂
  | `(%%lo = %%hi) := compare_hyp_eq e lo hi p₂ <|> do
                        p₂' ← mk_app ``eq.symm [p₂],
                        compare_hyp_eq e hi lo p₂'
  | `(%%hi ≠ %%lo) := compare_hyp_ne e lo hi p₂ <|> do
                        p₂' ← mk_mapp ``ne.symm [none, none, none, p₂],
                        compare_hyp_ne e hi lo p₂'
  | e := do
             p₂' ← pp p₂,
             fail (p₂' ++ "is not of the form `a ≤ b`, `a < b`, `a = b` or `a ≠ b`")
  end

/-- Attribute allowing a user to tag a tactic as an extension for `tactic.interactive.positivity`.
The main (recursive) step of this tactic is to try successively all the extensions tagged with this
attribute on the expression at hand, and also to try the two "base case" tactics
`tactic.norm_num.positivity`, `tactic.positivity.compare_hyp` on the expression at hand. -/
@[user_attribute]
meta def attr : user_attribute (expr → tactic strictness) unit :=
{ name      := `positivity,
  descr     := "extensions handling particular operations for the `positivity` tactic",
  cache_cfg :=
  { mk_cache := λ ns, do
    { t ← ns.mfoldl
        (λ (t : expr → tactic strictness) n, do
          t' ← eval_expr (expr → tactic strictness) (expr.const n []),
          pure (λ e, t' e ≤|≥ t e))
        (λ _, failed),
      pure $ λ e,
            t e -- run all the extensions on `e`
        ≤|≥ norm_num.positivity e -- directly try `norm_num` on `e`
        ≤|≥ positivity_canon e -- try showing nonnegativity from canonicity of the order
            -- loop over hypotheses and try to compare with `e`
        ≤|≥ local_context >>= list.foldl (λ tac h, tac ≤|≥ compare_hyp e h)
              (fail "no applicable positivity extension found") },
    dependencies := [] } }

/-- Look for a proof of positivity/nonnegativity of an expression `e`; if found, return the proof
together with a `strictness` stating whether the proof found was for strict positivity
(`positive p`), nonnegativity (`nonnegative p`), or nonzeroness (`nonzero p`). -/
meta def core (e : expr) : tactic strictness := do
  f ← attr.get_cache,
  f e <|> fail "failed to prove positivity/nonnegativity/nonzeroness"

end positivity

open positivity
open_locale positivity

namespace interactive

setup_tactic_parser

/-- Tactic solving goals of the form `0 ≤ x`, `0 < x` and `x ≠ 0`.  The tactic works recursively
according to the syntax of the expression `x`, if the atoms composing the expression all have
numeric lower bounds which can be proved positive/nonnegative/nonzero by `norm_num`.  This tactic
either closes the goal or fails.

Examples:
```
example {a : ℤ} (ha : 3 < a) : 0 ≤ a ^ 3 + a := by positivity

example {a : ℤ} (ha : 1 < a) : 0 < |(3:ℤ) + a| := by positivity

example {b : ℤ} : 0 ≤ max (-3) (b ^ 2) := by positivity
```
-/
meta def positivity : tactic unit := focus1 $ do
  t ← target >>= instantiate_mvars,
  (rel_desired, a) ← match t with
  | `(0 ≤ %%e) := pure (order_rel.le, e)
  | `(%%e ≥ 0) := pure (order_rel.le, e)
  | `(0 < %%e) := pure (order_rel.lt, e)
  | `(%%e > 0) := pure (order_rel.lt, e)
  | `(%%e₁ ≠ %%e₂) := do
                        match e₂ with
                        | `(has_zero.zero) := pure (order_rel.ne, e₁)
                        | _ := match e₁ with
                          | `(has_zero.zero) := pure (order_rel.ne', e₂)
                          | _ := fail "not a positivity/nonnegativity/nonzeroness goal"
                          end
                        end
  | _ := fail "not a positivity/nonnegativity/nonzeroness goal"
  end,
  strictness_proved ← tactic.positivity.core a,
  match rel_desired, strictness_proved with
  | order_rel.lt, positive p := pure p
  | order_rel.lt, nonnegative _ := fail ("failed to prove strict positivity, but it would be " ++
    "possible to prove nonnegativity if desired")
  | order_rel.lt, nonzero _ := fail ("failed to prove strict positivity, but it would be " ++
    "possible to prove nonzeroness if desired")
  | order_rel.le, positive p := mk_app ``le_of_lt [p]
  | order_rel.le, nonnegative p := pure p
  | order_rel.le, nonzero _ := fail ("failed to prove nonnegativity, but it would be " ++
    "possible to prove nonzeroness if desired")
  | order_rel.ne, positive p := to_expr ``(ne_of_gt %%p)
  | order_rel.ne, nonnegative _ := fail ("failed to prove nonzeroness, but it would be " ++
    "possible to prove nonnegativity if desired")
  | order_rel.ne, nonzero p := pure p
  | order_rel.ne', positive p := to_expr ``(ne_of_lt %%p)
  | order_rel.ne', nonnegative _ := fail ("failed to prove nonzeroness, but it would be " ++
    "possible to prove nonnegativity if desired")
  | order_rel.ne', nonzero p := to_expr ``(ne.symm %%p)
  end >>= tactic.exact

add_tactic_doc
{ name := "positivity",
  category := doc_category.tactic,
  decl_names := [`tactic.interactive.positivity],
  tags := ["arithmetic", "monotonicity", "finishing"] }

end interactive

variables {ι α R : Type*}

/-! ### `positivity` extensions for particular arithmetic operations -/

section linear_order
variables [linear_order R] {a b c : R}

private lemma le_min_of_lt_of_le  (ha : a < b) (hb : a ≤ c) : a ≤ min b c := le_min ha.le hb
private

private lemma max_ne (ha : a ≠ c) (hb : b ≠ c) : max a b ≠ c :=
by { rw max_def, split_ifs; assumption }

end linear_order

/-- Extension for the `positivity` tactic: the `min` of two numbers is nonnegative if both are
nonnegative, and strictly positive if both are. -/
@[positivity]
meta def positivity_min : expr → tactic strictness
| e@`(min %%a %%b) := do
  strictness_a ← core a,
  strictness_b ← core b,
  match strictness_a, strictness_b with
  | (positive pa), (positive pb) := positive <$> mk_app ``lt_min [pa, pb]
  | (positive pa), (nonnegative pb) := nonnegative <$> mk_app ``le_min_of_lt_of_le [pa, pb]
  | (nonnegative pa), (positive pb)  := nonnegative <$> mk_app ``le_min_of_le_of_lt [pa, pb]
  | (nonnegative pa), (nonnegative pb)  := nonnegative <$> mk_app ``le_min [pa, pb]
  | positive pa, nonzero pb := nonzero <$> to_expr ``(min_ne_of_lt_of_ne %%pa %%pb)
  | nonzero pa, positive pb := nonzero <$> to_expr ``(min_ne_of_ne_of_lt %%pa %%pb)
  | nonzero pa, nonzero pb := nonzero <$> to_expr ``(min_ne %%pa %%pb)
  | sa@_, sb@ _ := positivity_fail e a b sa sb
  end
| e := pp e >>= fail ∘ format.bracket "The expression `" "` isn't of the form `min a b`"

/-- Extension for the `positivity` tactic: the `max` of two numbers is nonnegative if at least one
is nonnegative, strictly positive if at least one is positive, and nonzero if both are nonzero. -/
@[positivity]
meta def positivity_max : expr → tactic strictness
| `(max %%a %%b) := do
  strictness_a ← try_core (core a),
  (do
      match strictness_a with
      | some (positive pa) := positive <$> mk_mapp ``lt_max_of_lt_left [none, none, none, a, b, pa]
      | some (nonnegative pa) :=
          nonnegative <$> mk_mapp ``le_max_of_le_left [none, none, none, a, b, pa]
      | _ := failed
        -- If `a ≠ 0`, we might prove `max a b ≠ 0` if `b ≠ 0` but we don't want to evaluate
        -- `b` before having ruled out `0 < a`, for performance. So we do that in the second branch
        -- of the `orelse'`.
      end) ≤|≥
    (do
      strictness_b ← core b,
      match strictness_b with
      | (positive pb) := positive <$> mk_mapp ``lt_max_of_lt_right [none, none, none, a, b, pb]
      | (nonnegative pb) :=
          nonnegative <$> mk_mapp ``le_max_of_le_right [none, none, none, a, b, pb]
      | nonzero pb := do
                        nonzero pa ← strictness_a,
                        nonzero <$> to_expr ``(max_ne %%pa %%pb)
      end)
| e := pp e >>= fail ∘ format.bracket "The expression `" "` isn't of the form `max a b`"

/-- Extension for the `positivity` tactic: addition is nonnegative if both summands are nonnegative,
and strictly positive if at least one summand is. -/
@[positivity]
meta def positivity_add : expr → tactic strictness
| e@`(%%a + %%b) := do
  strictness_a ← core a,
  strictness_b ← core b,
  match strictness_a, strictness_b with
  | (positive pa), (positive pb) := positive <$> mk_app ``add_pos [pa, pb]
  | (positive pa), (nonnegative pb) := positive <$> mk_app ``lt_add_of_pos_of_le [pa, pb]
  | (nonnegative pa), (positive pb) := positive <$> mk_app ``lt_add_of_le_of_pos [pa, pb]
  | (nonnegative pa), (nonnegative pb) := nonnegative <$> mk_app ``add_nonneg [pa, pb]
  | sa@_, sb@ _ := positivity_fail e a b sa sb
  end
| e := pp e >>= fail ∘ format.bracket "The expression `" "` isn't of the form `a + b`"

section ordered_semiring
variables [ordered_semiring R] {a b : R}

private lemma mul_nonneg_of_pos_of_nonneg (ha : 0 < a) (hb : 0 ≤ b) : 0 ≤ a * b :=
mul_nonneg ha.le hb

private lemma mul_nonneg_of_nonneg_of_pos (ha : 0 ≤ a) (hb : 0 < b) : 0 ≤ a * b :=
mul_nonneg ha hb.le

private lemma mul_ne_zero_of_pos_of_ne_zero [no_zero_divisors R] (ha : 0 < a) (hb : b ≠ 0) :
  a * b ≠ 0 :=
mul_ne_zero ha.ne' hb

private lemma mul_ne_zero_of_ne_zero_of_pos [no_zero_divisors R] (ha : a ≠ 0) (hb : 0 < b) :
  a * b ≠ 0 :=
mul_ne_zero ha hb.ne'

end ordered_semiring

/-- Extension for the `positivity` tactic: multiplication is nonnegative/positive/nonzero if both
multiplicands are. -/
@[positivity]
meta def positivity_mul : expr → tactic strictness
| e@`(%%a * %%b) := do
  strictness_a ← core a,
  strictness_b ← core b,
  match strictness_a, strictness_b with
  | (positive pa), (positive pb) := positive <$> mk_app ``mul_pos [pa, pb]
  | (positive pa), (nonnegative pb) := nonnegative <$> mk_app ``mul_nonneg_of_pos_of_nonneg [pa, pb]
  | (nonnegative pa), (positive pb) := nonnegative <$> mk_app ``mul_nonneg_of_nonneg_of_pos [pa, pb]
  | (nonnegative pa), (nonnegative pb) := nonnegative <$> mk_app ``mul_nonneg [pa, pb]
  | positive pa, nonzero pb := nonzero <$> to_expr ``(mul_ne_zero_of_pos_of_ne_zero %%pa %%pb)
  | nonzero pa, positive pb := nonzero <$> to_expr ``(mul_ne_zero_of_ne_zero_of_pos %%pa %%pb)
  | nonzero pa, nonzero pb := nonzero <$> to_expr ``(mul_ne_zero %%pa %%pb)
  | sa@_, sb@ _ := positivity_fail e a b sa sb
  end
| e := pp e >>= fail ∘ format.bracket "The expression `" "` isn't of the form `a * b`"

section linear_ordered_semifield
variables [linear_ordered_semifield R] {a b : R}

private lemma div_nonneg_of_pos_of_nonneg (ha : 0 < a) (hb : 0 ≤ b) : 0 ≤ a / b :=
div_nonneg ha.le hb

private lemma div_nonneg_of_nonneg_of_pos (ha : 0 ≤ a) (hb : 0 < b) : 0 ≤ a / b :=
div_nonneg ha hb.le

private lemma div_ne_zero_of_pos_of_ne_zero (ha : 0 < a) (hb : b ≠ 0) : a / b ≠ 0 :=
div_ne_zero ha.ne' hb

private lemma div_ne_zero_of_ne_zero_of_pos (ha : a ≠ 0) (hb : 0 < b) : a / b ≠ 0 :=
div_ne_zero ha hb.ne'

end linear_ordered_semifield

private lemma int_div_self_pos {a : ℤ} (ha : 0 < a) : 0 < a / a :=
by { rw int.div_self ha.ne', exact zero_lt_one }

private lemma int_div_nonneg_of_pos_of_nonneg {a b : ℤ} (ha : 0 < a) (hb : 0 ≤ b) : 0 ≤ a / b :=
int.div_nonneg ha.le hb

private lemma int_div_nonneg_of_nonneg_of_pos {a b : ℤ} (ha : 0 ≤ a) (hb : 0 < b) : 0 ≤ a / b :=
int.div_nonneg ha hb.le

private lemma int_div_nonneg_of_pos_of_pos {a b : ℤ} (ha : 0 < a) (hb : 0 < b) : 0 ≤ a / b :=
int.div_nonneg ha.le hb.le

/-- Extension for the `positivity` tactic: division is nonnegative if both numerator and denominator
are nonnegative, and strictly positive if both numerator and denominator are. -/
@[positivity]
meta def positivity_div : expr → tactic strictness
| e@`(@has_div.div ℤ _ %%a %%b) := do
  strictness_a ← core a,
  strictness_b ← core b,
  match strictness_a, strictness_b with
  | positive pa, positive pb :=
      if a = b then -- Only attempts to prove `0 < a / a`, otherwise falls back to `0 ≤ a / b`
        positive <$> mk_app ``int_div_self_pos [pa]
      else
       nonnegative <$> mk_app ``int_div_nonneg_of_pos_of_pos [pa, pb]
  | positive pa, nonnegative pb :=
    nonnegative <$> mk_app ``int_div_nonneg_of_pos_of_nonneg [pa, pb]
  | nonnegative pa, positive pb :=
    nonnegative <$> mk_app ``int_div_nonneg_of_nonneg_of_pos [pa, pb]
  | nonnegative pa, nonnegative pb := nonnegative <$> mk_app ``int.div_nonneg [pa, pb]
  | sa@_, sb@ _ := positivity_fail e a b sa sb
  end
| e@`(%%a / %%b) := do
  strictness_a ← core a,
  strictness_b ← core b,
  match strictness_a, strictness_b with
  | positive pa, positive pb := positive <$> mk_app ``div_pos [pa, pb]
  | positive pa, nonnegative pb := nonnegative <$> mk_app ``div_nonneg_of_pos_of_nonneg [pa, pb]
  | nonnegative pa, positive pb := nonnegative <$> mk_app ``div_nonneg_of_nonneg_of_pos [pa, pb]
  | nonnegative pa, nonnegative pb := nonnegative <$> mk_app ``div_nonneg [pa, pb]
  | positive pa, nonzero pb := nonzero <$> to_expr ``(div_ne_zero_of_pos_of_ne_zero %%pa %%pb)
  | nonzero pa, positive pb := nonzero <$> to_expr ``(div_ne_zero_of_ne_zero_of_pos %%pa %%pb)
  | nonzero pa, nonzero pb := nonzero <$> to_expr ``(div_ne_zero %%pa %%pb)
  | sa@_, sb@ _ := positivity_fail e a b sa sb
  end
| e := pp e >>= fail ∘ format.bracket "The expression `" "` isn't of the form `a / b`"

/-- Extension for the `positivity` tactic: an inverse of a positive number is positive, an inverse
of a nonnegative number is nonnegative. -/
@[positivity]
meta def positivity_inv : expr → tactic strictness
| `((%%a)⁻¹) := do
      strictness_a ← core a,
      match strictness_a with
      | (positive pa) := positive <$> mk_app ``inv_pos_of_pos [pa]
      | (nonnegative pa) := nonnegative <$> mk_app ``inv_nonneg_of_nonneg [pa]
      | nonzero pa := nonzero <$> to_expr ``(inv_ne_zero %%pa)
      end
| e := pp e >>= fail ∘ format.bracket "The expression `" "` isn't of the form `a⁻¹`"

private lemma pow_zero_pos [ordered_semiring R] [nontrivial R] (a : R) : 0 < a ^ 0 :=
zero_lt_one.trans_le (pow_zero a).ge

private lemma zpow_zero_pos [linear_ordered_semifield R] (a : R) : 0 < a ^ (0 : ℤ) :=
zero_lt_one.trans_le (zpow_zero a).ge

/-- Extension for the `positivity` tactic: raising a number `a` to a natural/integer power `n` is
positive if `n = 0` (since `a ^ 0 = 1`) or if `0 < a`, and is nonnegative if `n` is even (squares
are nonnegative) or if `0 ≤ a`. -/
@[positivity]
meta def positivity_pow : expr → tactic strictness
| e@`(%%a ^ %%n) := do
  typ ← infer_type n,
  (do
    unify typ `(ℕ),
    if n = `(0) then
      positive <$> mk_app ``pow_zero_pos [a]
    else
      do -- even powers are nonnegative
      -- Note this is automatically strengthened to `0 < a ^ n` when `a ≠ 0` thanks to the `orelse'`
        match n with -- TODO: Decision procedure for parity
        | `(bit0 %% n) := nonnegative <$> mk_app ``pow_bit0_nonneg [a, n]
        | _ := do
                  e' ← pp e,
                  fail (e' ++ "is not an even power so positivity can't prove it's nonnegative")
        end ≤|≥
      do -- `a ^ n` is positive if `a` is, and nonnegative if `a` is
        strictness_a ← core a,
        match strictness_a with
        | positive p := positive <$> mk_app ``pow_pos [p, n]
        | nonnegative p := nonnegative <$> mk_app `pow_nonneg [p, n]
        | nonzero p := nonzero <$> to_expr ``(pow_ne_zero %%n %%p)
        end) <|>
  (do
    unify typ `(ℤ),
    if n = `(0 : ℤ) then
      positive <$> mk_app ``zpow_zero_pos [a]
    else
      do -- even powers are nonnegative
    -- Note this is automatically strengthened to `0 < a ^ n` when `a ≠ 0` thanks to the `orelse'`
        match n with -- TODO: Decision procedure for parity
        | `(bit0 %%n) := nonnegative <$> mk_app ``zpow_bit0_nonneg [a, n]
        | _ := do
                  e' ← pp e,
                  fail (e' ++ "is not an even power so positivity can't prove it's nonnegative")
            end ≤|≥
      do -- `a ^ n` is positive if `a` is, and nonnegative if `a` is
        strictness_a ← core a,
        match strictness_a with
        | positive p := positive <$> mk_app ``zpow_pos_of_pos [p, n]
        | nonnegative p := nonnegative <$> mk_app ``zpow_nonneg [p, n]
        | nonzero p := nonzero <$> to_expr ``(zpow_ne_zero %%n %%p)
        end)
| e := pp e >>= fail ∘ format.bracket "The expression `" "` isn't of the form `a ^ n`"

/-- Extension for the `positivity` tactic: raising a positive number in a canonically ordered
semiring gives a positive number. -/
@[positivity]
meta def positivity_canon_pow : expr → tactic strictness
| `(%%r ^ %%n) := do
    typ_n ← infer_type n,
    unify typ_n `(ℕ),
    positive p ← core r,
    positive <$> mk_app ``canonically_ordered_comm_semiring.pow_pos [p, n]
    -- The nonzero never happens because of `tactic.positivity_canon`
| e := pp e >>= fail ∘ format.bracket "The expression `"
    "` is not of the form `a ^ n` for `a` in a `canonically_ordered_comm_semiring` and `n : ℕ`"

private alias abs_pos ↔ _ abs_pos_of_ne_zero

/-- Extension for the `positivity` tactic: an absolute value is nonnegative, and is strictly
positive if its input is nonzero. -/
@[positivity]
meta def positivity_abs : expr → tactic strictness
| `(|%%a|) := do
  (do -- if can prove `0 < a` or `a ≠ 0`, report positivity
    strict_a ← core a,
    match strict_a with
    | positive p := positive <$> mk_app ``abs_pos_of_pos [p]
    | nonzero p := positive <$> mk_app ``abs_pos_of_ne_zero [p]
    | _ := failed
    end) <|>
  nonnegative <$> mk_app ``abs_nonneg [a] -- else report nonnegativity
| e := pp e >>= fail ∘ format.bracket "The expression `" "` isn't of the form `|a|`"

private lemma int_nat_abs_pos {n : ℤ} (hn : 0 < n) : 0 < n.nat_abs :=
int.nat_abs_pos_of_ne_zero hn.ne'

/-- Extension for the `positivity` tactic: `int.nat_abs` is positive when its input is.

Since the output type of `int.nat_abs` is `ℕ`, the nonnegative case is handled by the default
`positivity` tactic.
-/
@[positivity]
meta def positivity_nat_abs : expr → tactic strictness
| `(int.nat_abs %%a) := do
    strict_a ← core a,
    match strict_a with
    | positive p := positive <$> mk_app ``int_nat_abs_pos [p]
    | nonzero p := positive <$> mk_app ``int.nat_abs_pos_of_ne_zero [p]
    | _ := failed
    end
| _ := failed

private lemma nat_cast_pos [ordered_semiring α] [nontrivial α] {n : ℕ} : 0 < n → 0 < (n : α) :=
nat.cast_pos.2

private lemma int_coe_nat_nonneg (n : ℕ) : 0 ≤ (n : ℤ) := n.cast_nonneg
private lemma int_coe_nat_pos {n : ℕ} : 0 < n → 0 < (n : ℤ) := nat.cast_pos.2

private lemma int_cast_ne_zero [add_group_with_one α] [char_zero α] {n : ℤ} : n ≠ 0 → (n : α) ≠ 0 :=
int.cast_ne_zero.2
private lemma int_cast_nonneg [ordered_ring α] {n : ℤ} (hn : 0 ≤ n) : 0 ≤ (n : α) :=
by { rw ←int.cast_zero, exact int.cast_mono hn }
private lemma int_cast_pos [ordered_ring α] [nontrivial α] {n : ℤ} : 0 < n → 0 < (n : α) :=
int.cast_pos.2

private lemma rat_cast_ne_zero [division_ring α] [char_zero α] {q : ℚ} : q ≠ 0 → (q : α) ≠ 0 :=
rat.cast_ne_zero.2
private lemma rat_cast_nonneg [linear_ordered_field α] {q : ℚ} : 0 ≤ q → 0 ≤ (q : α) :=
rat.cast_nonneg.2
private lemma rat_cast_pos [linear_ordered_field α] {q : ℚ} : 0 < q → 0 < (q : α) := rat.cast_pos.2

/-- Extension for the `positivity` tactic: casts from `ℕ`, `ℤ`, `ℚ`. -/
@[positivity]
meta def positivity_coe : expr → tactic strictness
| `(@coe _ %%typ %%inst %%a) := do
  -- TODO: Using `match` here might turn out too strict since we really want the instance to *unify*
  -- with one of the instances below rather than being equal on the nose.
  -- If this turns out to indeed be a problem, we should figure out the right way to pattern match
  -- up to defeq rather than equality of expressions.
  -- See also "Reflexive tactics for algebra, revisited" by Kazuhiko Sakaguchi at ITP 2022.
  match inst with
  | `(@coe_to_lift _ _ %%inst) := do
    strictness_a ← core a,
    match inst, strictness_a with -- `mk_mapp` is necessary in some places. Why?
    | `(nat.cast_coe), positive p := positive <$> mk_mapp ``nat_cast_pos [typ, none, none, none, p]
    | `(nat.cast_coe), _ := nonnegative <$> mk_mapp ``nat.cast_nonneg [typ, none, a]
    | `(int.cast_coe), positive p := positive <$> mk_mapp ``int_cast_pos [typ, none, none, none, p]
    | `(int.cast_coe), nonnegative p := nonnegative <$>
                                          mk_mapp ``int_cast_nonneg [typ, none, none, p]
    | `(int.cast_coe), nonzero p := nonzero <$>
                                          mk_mapp ``int_cast_ne_zero [typ, none, none, none, p]
    | `(rat.cast_coe), positive p := positive <$> mk_mapp ``rat_cast_pos [typ, none, none, p]
    | `(rat.cast_coe), nonnegative p := nonnegative <$>
                                          mk_mapp ``rat_cast_nonneg [typ, none, none, p]
    | `(rat.cast_coe), nonzero p := nonzero <$>
                                          mk_mapp ``rat_cast_ne_zero [typ, none, none, none, p]
    | `(@coe_base _ _ int.has_coe), positive p := positive <$> mk_app ``int_coe_nat_pos [p]
    | `(@coe_base _ _ int.has_coe), _ := nonnegative <$> mk_app ``int_coe_nat_nonneg [a]
    | _, _ := failed
    end
  | _  := failed
  end
| _ := failed

/-- Extension for the `positivity` tactic: `nat.succ` is always positive. -/
@[positivity]
meta def positivity_succ : expr → tactic strictness
| `(nat.succ %%a) := positive <$> mk_app `nat.succ_pos [a]
| e := pp e >>= fail ∘ format.bracket "The expression `" "` isn't of the form `nat.succ n`"

/-- Extension for the `positivity` tactic: `nat.factorial` is always positive. -/
@[positivity]
meta def positivity_factorial : expr → tactic strictness
| `(nat.factorial %%a) := positive <$> mk_app ``nat.factorial_pos [a]
| e := pp e >>= fail ∘ format.bracket "The expression `" "` isn't of the form `n!`"

/-- Extension for the `positivity` tactic: `nat.asc_factorial` is always positive. -/
@[positivity]
meta def positivity_asc_factorial : expr → tactic strictness
| `(nat.asc_factorial %%a %%b) := positive <$> mk_app ``nat.asc_factorial_pos [a, b]
| e := pp e >>= fail ∘ format.bracket "The expression `"
         "` isn't of the form `nat.asc_factorial n k`"

/-- Extension for the `positivity` tactic: nonnegative maps take nonnegative values. -/
@[positivity]
meta def positivity_map : expr → tactic strictness
| (expr.app `(⇑%%f) `(%%a)) := nonnegative <$> mk_app ``map_nonneg [f, a]
| _ := failed

end tactic


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

! This file was ported from Lean 3 source module category_theory.limits.pi
! leanprover-community/mathlib commit 744d59af0b28d0c42f631038627df9b85ae1d1ce
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.CategoryTheory.Pi.Basic
import Mathlib.CategoryTheory.Limits.HasLimits

/-!
# Limits in the category of indexed families of objects.

Given a functor `F : J ⥤ Π i, C i` into a category of indexed families,
1. we can assemble a collection of cones over `F ⋙ Pi.eval C i` into a cone over `F`
2. if all those cones are limit cones, the assembled cone is a limit cone, and
3. if we have limits for each of `F ⋙ Pi.eval C i`, we can produce a
   `HasLimit F` instance
-/

open CategoryTheory

open CategoryTheory.Limits

namespace CategoryTheory.pi

universe v₁ v₂ u₁ u₂

variable {I : Type v₁} {C : I → Type u₁} [∀ i, Category.{v₁} (C i)]

variable {J : Type v₁} [SmallCategory J]

variable {F : J ⥤ ∀ i, C i}

/-- A cone over `F : J ⥤ Π i, C i` has as its components cones over each of the `F ⋙ Pi.eval C i`.
-/
def coneCompEval (c : Cone F) (i : I) : Cone (F ⋙ Pi.eval C i) where
  pt := c.pt i
  π :=
    { app := fun j => c.π.app j i
      naturality := fun _ _ f => congr_fun (c.π.naturality f) i }
#align category_theory.pi.cone_comp_eval CategoryTheory.pi.coneCompEval

/--
A cocone over `F : J ⥤ Π i, C i` has as its components cocones over each of the `F ⋙ Pi.eval C i`.
-/
def coconeCompEval (c : Cocone F) (i : I) : Cocone (F ⋙ Pi.eval C i) where
  pt := c.pt i
  ι :=
    { app := fun j => c.ι.app j i
      naturality := fun _ _ f => congr_fun (c.ι.naturality f) i }
#align category_theory.pi.cocone_comp_eval CategoryTheory.pi.coconeCompEval

/--
Given a family of cones over the `F ⋙ Pi.eval C i`, we can assemble these together as a `Cone F`.
-/
def coneOfConeCompEval (c : ∀ i, Cone (F ⋙ Pi.eval C i)) : Cone F where
  pt i := (c i).pt
  π :=
    { app := fun j i => (c i).π.app j
      naturality := fun j j' f => by
        funext i
        exact (c i).π.naturality f }
#align category_theory.pi.cone_of_cone_comp_eval CategoryTheory.pi.coneOfConeCompEval

/-- Given a family of cocones over the `F ⋙ Pi.eval C i`,
we can assemble these together as a `Cocone F`.
-/
def coconeOfCoconeCompEval (c : ∀ i, Cocone (F ⋙ Pi.eval C i)) : Cocone F where
  pt i := (c i).pt
  ι :=
    { app := fun j i => (c i).ι.app j
      naturality := fun j j' f => by
        funext i
        exact (c i).ι.naturality f }
#align category_theory.pi.cocone_of_cocone_comp_eval CategoryTheory.pi.coconeOfCoconeCompEval

/-- Given a family of limit cones over the `F ⋙ Pi.eval C i`,
assembling them together as a `Cone F` produces a limit cone.
-/
def coneOfConeEvalIsLimit {c : ∀ i, Cone (F ⋙ Pi.eval C i)} (P : ∀ i, IsLimit (c i)) :
    IsLimit (coneOfConeCompEval c) where
  lift s i := (P i).lift (coneCompEval s i)
  fac s j := by
    funext i
    exact (P i).fac (coneCompEval s i) j
  uniq s m w := by
    funext i
    exact (P i).uniq (coneCompEval s i) (m i) fun j => congr_fun (w j) i
#align category_theory.pi.cone_of_cone_eval_is_limit CategoryTheory.pi.coneOfConeEvalIsLimit

/-- Given a family of colimit cocones over the `F ⋙ Pi.eval C i`,
assembling them together as a `Cocone F` produces a colimit cocone.
-/
def coconeOfCoconeEvalIsColimit {c : ∀ i, Cocone (F ⋙ Pi.eval C i)} (P : ∀ i, IsColimit (c i)) :
    IsColimit (coconeOfCoconeCompEval c) where
  desc s i := (P i).desc (coconeCompEval s i)
  fac s j := by
    funext i
    exact (P i).fac (coconeCompEval s i) j
  uniq s m w := by
    funext i
    exact (P i).uniq (coconeCompEval s i) (m i) fun j => congr_fun (w j) i
#align category_theory.pi.cocone_of_cocone_eval_is_colimit CategoryTheory.pi.coconeOfCoconeEvalIsColimit

section

variable [∀ i, HasLimit (F ⋙ Pi.eval C i)]

/-- If we have a functor `F : J ⥤ Π i, C i` into a category of indexed families,
and we have limits for each of the `F ⋙ Pi.eval C i`,
then `F` has a limit.
-/
theorem hasLimit_of_hasLimit_comp_eval : HasLimit F :=
  HasLimit.mk
    { cone := coneOfConeCompEval fun _ => limit.cone _
      isLimit := coneOfConeEvalIsLimit fun _ => limit.isLimit _ }
#align category_theory.pi.has_limit_of_has_limit_comp_eval CategoryTheory.pi.hasLimit_of_hasLimit_comp_eval

end

section

variable [∀ i, HasColimit (F ⋙ Pi.eval C i)]

/-- If we have a functor `F : J ⥤ Π i, C i` into a category of indexed families,
and colimits exist for each of the `F ⋙ Pi.eval C i`,
there is a colimit for `F`.
-/
theorem hasColimit_of_hasColimit_comp_eval : HasColimit F :=
  HasColimit.mk
    { cocone := coconeOfCoconeCompEval fun _ => colimit.cocone _
      isColimit := coconeOfCoconeEvalIsColimit fun _ => colimit.isColimit _ }
#align category_theory.pi.has_colimit_of_has_colimit_comp_eval CategoryTheory.pi.hasColimit_of_hasColimit_comp_eval

end

/-!
As an example, we can use this to construct particular shapes of limits
in a category of indexed families.

With the addition of
`import CategoryTheory.Limits.Shapes.Types`
we can use:
```
local attribute [instance] hasLimit_of_hasLimit_comp_eval
example : hasBinaryProducts (I → Type v₁) := ⟨by apply_instance⟩
```
-/

end CategoryTheory.pi


lemma zero_le (a : mynat) : 0 ≤ a :=
begin
use a,
rw zero_add,
refl,
end


import tactic
import ring_theory.power_series.basic

noncomputable theory
open_locale classical

variables {α β γ R : Type*} [comm_ring R]

example : α → α ⊕ β := sum.inl
example : β → α ⊕ β := sum.inr

example (f : α → γ) (g : β → γ) : α ⊕ β → γ :=
  λ t, sum.rec_on t f g

example (f : α → γ) (g : β → γ) : α ⊕ β → γ := λ t,
match t with
| sum.inl a := f a
| sum.inr b := g b
end

#check @dif_neg
#check @dif_pos
#check tactic.split_ifs

variables (α β R)

def incl_fun : mv_power_series α R → mv_power_series (α ⊕ β) R :=
  show ((α →₀ ℕ) → R) → ((α ⊕ β →₀ ℕ) → R), from λ f m,
  let n := finsupp.sum_finsupp_equiv_prod_finsupp m in
  if n.2 = 0 then f n.1 else 0

def incl : mv_power_series α R →+* mv_power_series (α ⊕ β) R :=
{ to_fun := incl_fun α β R,
  map_one' := sorry,
  map_mul' := sorry,
  map_zero' := sorry,
  map_add' := sorry }

def incr_fun : mv_power_series β R → mv_power_series (α ⊕ β) R :=
  show ((β →₀ ℕ) → R) → ((α ⊕ β →₀ ℕ) → R), from λ f m,
  let n := finsupp.sum_finsupp_equiv_prod_finsupp m in
  if n.1 = 0 then f n.2 else 0

def incr : mv_power_series β R →+* mv_power_series (α ⊕ β) R :=
{ to_fun := incr_fun α β R,
  map_one' := sorry,
  map_mul' := sorry,
  map_zero' := sorry,
  map_add' := sorry }


/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Johan Commelin, Mario Carneiro
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.mv_polynomial.rename
import Mathlib.data.equiv.fin
import Mathlib.PostPort

universes u u_1 v w x

namespace Mathlib

/-!
# Equivalences between polynomial rings

This file establishes a number of equivalences between polynomial rings,
based on equivalences between the underlying types.

## Notation

As in other polynomial files, we typically use the notation:

+ `σ : Type*` (indexing the variables)

+ `R : Type*` `[comm_semiring R]` (the coefficients)

+ `s : σ →₀ ℕ`, a function from `σ` to `ℕ` which is zero away from a finite set.
This will give rise to a monomial in `mv_polynomial σ R` which mathematicians might call `X^s`

+ `a : R`

+ `i : σ`, with corresponding monomial `X i`, often denoted `X_i` by mathematicians

+ `p : mv_polynomial σ R`

## Tags

equivalence, isomorphism, morphism, ring hom, hom

-/

namespace mv_polynomial

/-- The ring isomorphism between multivariable polynomials in no variables and the ground ring. -/
def pempty_ring_equiv (R : Type u) [comm_semiring R] : mv_polynomial pempty R ≃+* R :=
  ring_equiv.mk (eval₂ (ring_hom.id R) pempty.elim) ⇑C sorry sorry sorry sorry

/-- The algebra isomorphism between multivariable polynomials in no variables and the ground ring. -/
@[simp] theorem pempty_alg_equiv_symm_apply (R : Type u) [comm_semiring R] :
    ∀ (ᾰ : R), coe_fn (alg_equiv.symm (pempty_alg_equiv R)) ᾰ = coe_fn C ᾰ :=
  fun (ᾰ : R) => Eq.refl (coe_fn (alg_equiv.symm (pempty_alg_equiv R)) ᾰ)

/--
The ring isomorphism between multivariable polynomials in a single variable and
polynomials over the ground ring.
-/
@[simp] theorem punit_ring_equiv_symm_apply (R : Type u) [comm_semiring R] (p : polynomial R) :
    coe_fn (ring_equiv.symm (punit_ring_equiv R)) p = polynomial.eval₂ C (X PUnit.unit) p :=
  Eq.refl (coe_fn (ring_equiv.symm (punit_ring_equiv R)) p)

/-- The ring isomorphism between multivariable polynomials induced by an equivalence of the variables.  -/
@[simp] theorem ring_equiv_of_equiv_symm_apply (R : Type u) {S₁ : Type v} {S₂ : Type w}
    [comm_semiring R] (e : S₁ ≃ S₂) :
    ∀ (ᾰ : mv_polynomial S₂ R),
        coe_fn (ring_equiv.symm (ring_equiv_of_equiv R e)) ᾰ = coe_fn (rename ⇑(equiv.symm e)) ᾰ :=
  fun (ᾰ : mv_polynomial S₂ R) => Eq.refl (coe_fn (ring_equiv.symm (ring_equiv_of_equiv R e)) ᾰ)

/-- The algebra isomorphism between multivariable polynomials induced by an equivalence of the variables.  -/
@[simp] theorem alg_equiv_of_equiv_symm_apply (R : Type u) {S₁ : Type v} {S₂ : Type w}
    [comm_semiring R] (e : S₁ ≃ S₂) :
    ∀ (ᾰ : mv_polynomial S₂ R),
        coe_fn (alg_equiv.symm (alg_equiv_of_equiv R e)) ᾰ = coe_fn (rename ⇑(equiv.symm e)) ᾰ :=
  fun (ᾰ : mv_polynomial S₂ R) => Eq.refl (coe_fn (alg_equiv.symm (alg_equiv_of_equiv R e)) ᾰ)

/-- The ring isomorphism between multivariable polynomials induced by a ring isomorphism of the ground ring. -/
def ring_equiv_congr (R : Type u) {S₁ : Type v} {S₂ : Type w} [comm_semiring R] [comm_semiring S₂]
    (e : R ≃+* S₂) : mv_polynomial S₁ R ≃+* mv_polynomial S₁ S₂ :=
  ring_equiv.mk ⇑(map ↑e) ⇑(map ↑(ring_equiv.symm e)) sorry sorry sorry sorry

/--
The function from multivariable polynomials in a sum of two types,
to multivariable polynomials in one of the types,
with coefficents in multivariable polynomials in the other type.

See `sum_ring_equiv` for the ring isomorphism.
-/
def sum_to_iter (R : Type u) (S₁ : Type v) (S₂ : Type w) [comm_semiring R] :
    mv_polynomial (S₁ ⊕ S₂) R →+* mv_polynomial S₁ (mv_polynomial S₂ R) :=
  eval₂_hom (ring_hom.comp C C) fun (bc : S₁ ⊕ S₂) => sum.rec_on bc X (⇑C ∘ X)

protected instance is_semiring_hom_sum_to_iter (R : Type u) (S₁ : Type v) (S₂ : Type w)
    [comm_semiring R] : is_semiring_hom ⇑(sum_to_iter R S₁ S₂) :=
  eval₂.is_semiring_hom (ring_hom.comp C C)
    fun (n : S₁ ⊕ S₂) => (fun (bc : S₁ ⊕ S₂) => sum.rec_on bc X (⇑C ∘ X)) n

@[simp] theorem sum_to_iter_C (R : Type u) (S₁ : Type v) (S₂ : Type w) [comm_semiring R] (a : R) :
    coe_fn (sum_to_iter R S₁ S₂) (coe_fn C a) = coe_fn C (coe_fn C a) :=
  eval₂_C (ring_hom.comp C C)
    (fun (n : S₁ ⊕ S₂) => (fun (bc : S₁ ⊕ S₂) => sum.rec_on bc X (⇑C ∘ X)) n) a

@[simp] theorem sum_to_iter_Xl (R : Type u) (S₁ : Type v) (S₂ : Type w) [comm_semiring R] (b : S₁) :
    coe_fn (sum_to_iter R S₁ S₂) (X (sum.inl b)) = X b :=
  eval₂_X (ring_hom.comp C C)
    (fun (n : S₁ ⊕ S₂) => (fun (bc : S₁ ⊕ S₂) => sum.rec_on bc X (⇑C ∘ X)) n) (sum.inl b)

@[simp] theorem sum_to_iter_Xr (R : Type u) (S₁ : Type v) (S₂ : Type w) [comm_semiring R] (c : S₂) :
    coe_fn (sum_to_iter R S₁ S₂) (X (sum.inr c)) = coe_fn C (X c) :=
  eval₂_X (ring_hom.comp C C)
    (fun (n : S₁ ⊕ S₂) => (fun (bc : S₁ ⊕ S₂) => sum.rec_on bc X (⇑C ∘ X)) n) (sum.inr c)

/--
The function from multivariable polynomials in one type,
with coefficents in multivariable polynomials in another type,
to multivariable polynomials in the sum of the two types.

See `sum_ring_equiv` for the ring isomorphism.
-/
def iter_to_sum (R : Type u) (S₁ : Type v) (S₂ : Type w) [comm_semiring R] :
    mv_polynomial S₁ (mv_polynomial S₂ R) →+* mv_polynomial (S₁ ⊕ S₂) R :=
  eval₂_hom (ring_hom.of (eval₂ C (X ∘ sum.inr))) (X ∘ sum.inl)

theorem iter_to_sum_C_C (R : Type u) (S₁ : Type v) (S₂ : Type w) [comm_semiring R] (a : R) :
    coe_fn (iter_to_sum R S₁ S₂) (coe_fn C (coe_fn C a)) = coe_fn C a :=
  Eq.trans
    (eval₂_C (ring_hom.of (eval₂ C (X ∘ sum.inr))) (fun (n : S₁) => function.comp X sum.inl n)
      (coe_fn C a))
    (eval₂_C C (fun (n : S₂) => function.comp X sum.inr n) a)

theorem iter_to_sum_X (R : Type u) (S₁ : Type v) (S₂ : Type w) [comm_semiring R] (b : S₁) :
    coe_fn (iter_to_sum R S₁ S₂) (X b) = X (sum.inl b) :=
  eval₂_X (ring_hom.of (eval₂ C (X ∘ sum.inr))) (fun (n : S₁) => function.comp X sum.inl n) b

theorem iter_to_sum_C_X (R : Type u) (S₁ : Type v) (S₂ : Type w) [comm_semiring R] (c : S₂) :
    coe_fn (iter_to_sum R S₁ S₂) (coe_fn C (X c)) = X (sum.inr c) :=
  Eq.trans
    (eval₂_C (ring_hom.of (eval₂ C (X ∘ sum.inr))) (fun (n : S₁) => function.comp X sum.inl n)
      (X c))
    (eval₂_X C (fun (n : S₂) => function.comp X sum.inr n) c)

/-- A helper function for `sum_ring_equiv`. -/
@[simp] theorem mv_polynomial_equiv_mv_polynomial_apply (R : Type u) (S₁ : Type v) (S₂ : Type w)
    (S₃ : Type x) [comm_semiring R] [comm_semiring S₃]
    (f : mv_polynomial S₁ R →+* mv_polynomial S₂ S₃)
    (g : mv_polynomial S₂ S₃ →+* mv_polynomial S₁ R)
    (hfgC : ∀ (a : S₃), coe_fn f (coe_fn g (coe_fn C a)) = coe_fn C a)
    (hfgX : ∀ (n : S₂), coe_fn f (coe_fn g (X n)) = X n)
    (hgfC : ∀ (a : R), coe_fn g (coe_fn f (coe_fn C a)) = coe_fn C a)
    (hgfX : ∀ (n : S₁), coe_fn g (coe_fn f (X n)) = X n) :
    ∀ (ᾰ : mv_polynomial S₁ R),
        coe_fn (mv_polynomial_equiv_mv_polynomial R S₁ S₂ S₃ f g hfgC hfgX hgfC hgfX) ᾰ =
          coe_fn f ᾰ :=
  fun (ᾰ : mv_polynomial S₁ R) =>
    Eq.refl (coe_fn (mv_polynomial_equiv_mv_polynomial R S₁ S₂ S₃ f g hfgC hfgX hgfC hgfX) ᾰ)

/--
The ring isomorphism between multivariable polynomials in a sum of two types,
and multivariable polynomials in one of the types,
with coefficents in multivariable polynomials in the other type.
-/
def sum_ring_equiv (R : Type u) (S₁ : Type v) (S₂ : Type w) [comm_semiring R] :
    mv_polynomial (S₁ ⊕ S₂) R ≃+* mv_polynomial S₁ (mv_polynomial S₂ R) :=
  mv_polynomial_equiv_mv_polynomial R (S₁ ⊕ S₂) S₁ (mv_polynomial S₂ R) (sum_to_iter R S₁ S₂)
    (iter_to_sum R S₁ S₂) sorry sorry sorry sorry

/--
The ring isomorphism between multivariable polynomials in `option S₁` and
polynomials with coefficients in `mv_polynomial S₁ R`.
-/
def option_equiv_left (R : Type u) (S₁ : Type v) [comm_semiring R] :
    mv_polynomial (Option S₁) R ≃+* polynomial (mv_polynomial S₁ R) :=
  ring_equiv.trans
    (ring_equiv_of_equiv R
      (equiv.trans (equiv.option_equiv_sum_punit S₁) (equiv.sum_comm S₁ PUnit)))
    (ring_equiv.trans (sum_ring_equiv R PUnit S₁) (punit_ring_equiv (mv_polynomial S₁ R)))

/--
The ring isomorphism between multivariable polynomials in `option S₁` and
multivariable polynomials with coefficients in polynomials.
-/
def option_equiv_right (R : Type u) (S₁ : Type v) [comm_semiring R] :
    mv_polynomial (Option S₁) R ≃+* mv_polynomial S₁ (polynomial R) :=
  ring_equiv.trans (ring_equiv_of_equiv R (equiv.option_equiv_sum_punit S₁))
    (ring_equiv.trans (sum_ring_equiv R S₁ Unit)
      (ring_equiv_congr (mv_polynomial Unit R) (punit_ring_equiv R)))

/--
The ring isomorphism between multivariable polynomials in `fin (n + 1)` and
polynomials over multivariable polynomials in `fin n`.
-/
def fin_succ_equiv (R : Type u) [comm_semiring R] (n : ℕ) :
    mv_polynomial (fin (n + 1)) R ≃+* polynomial (mv_polynomial (fin n) R) :=
  ring_equiv.trans (ring_equiv_of_equiv R (fin_succ_equiv n)) (option_equiv_left R (fin n))

theorem fin_succ_equiv_eq (R : Type u) [comm_semiring R] (n : ℕ) :
    ↑(fin_succ_equiv R n) =
        eval₂_hom (ring_hom.comp polynomial.C C)
          fun (i : fin (n + 1)) =>
            fin.cases polynomial.X (fun (k : fin n) => coe_fn polynomial.C (X k)) i :=
  sorry

@[simp] theorem fin_succ_equiv_apply (R : Type u) [comm_semiring R] (n : ℕ)
    (p : mv_polynomial (fin (n + 1)) R) :
    coe_fn (fin_succ_equiv R n) p =
        coe_fn
          (eval₂_hom (ring_hom.comp polynomial.C C)
            fun (i : fin (n + 1)) =>
              fin.cases polynomial.X (fun (k : fin n) => coe_fn polynomial.C (X k)) i)
          p :=
  sorry

theorem fin_succ_equiv_comp_C_eq_C {R : Type u} [comm_semiring R] (n : ℕ) :
    ring_hom.comp (ring_equiv.to_ring_hom (ring_equiv.symm (fin_succ_equiv R n)))
          (ring_hom.comp polynomial.C C) =
        C :=
  sorry

end Mathlib


import algebraic_topology.simplex_category
import algebraic_topology.simplicial_set
import algebraic_topology.simplicial_object
import category_theory.arrow
import category_theory.discrete_category
import category_theory.limits.shapes.terminal
import category_theory.limits.shapes.products
import category_theory.limits.shapes.equalizers
import category_theory.limits.presheaf
import category_theory.limits.preserves.shapes.equalizers

import simplex_category

open category_theory

noncomputable theory

open_locale simplicial

universe u

variable n : ℕ
variable k : fin (n + 3)

structure horn_part :=
  mk :: (i j : fin (n + 2)) (h₁ : i ≤ j) (h₂ : i.cast_succ ≠ k) (h₃ : j.succ ≠ k)

structure excluded_part :=
  mk :: (i : fin (n + 3)) (h : i ≠ k)

def horn_f (p : horn_part n k)  := Δ[n]
def excluded_f (p : excluded_part n k) := Δ[n+1]

def horn_start := ∐ (horn_f n k)
def excluded_end := ∐ (excluded_f n k)

def morph_horn_1 : horn_start n k ⟶ excluded_end n k :=
  limits.sigma.desc
    (λ idx, yoneda.map (simplex_category.δ idx.i)
      ≫ (limits.sigma.ι (excluded_f n k) ⟨idx.j.succ, idx.h₃⟩))

def morph_horn_2 : horn_start n k ⟶ excluded_end n k :=
  limits.sigma.desc
    (λ idx, yoneda.map (simplex_category.δ (idx.j))
      ≫ (limits.sigma.ι (excluded_f n k) ⟨idx.i.cast_succ, idx.h₂⟩))

def horn_morphism_i : excluded_part n k → (Δ[n+1] ⟶ Λ[n+2, k])
  := λ idx, yoneda_equiv.inv_fun ⟨simplex_category.δ idx.i, by {
    cases idx with i h₀,
    intro h,
    dsimp [simplex_category.δ, simplex_category.hom.mk] at h,
    simp [set.union_singleton, sSet.as_order_hom] at h,
    simp_rw [set.ext_iff] at h,
    specialize h i,
    have h' := h.mpr (set.mem_univ i),
    simp at h',
    cases h',
    contradiction,
    cases h',
    exact fin.succ_above_ne _ _ h'_h,
  }⟩

lemma horn_morphism_i_incl (idx : excluded_part n k) :
  horn_morphism_i n k idx ≫ sSet.horn_inclusion (n + 2) k = yoneda.map (simplex_category.δ idx.i)
  := rfl

def horn_morphism : excluded_end n k ⟶ Λ[n + 2, k] :=
  limits.sigma.desc (horn_morphism_i n k)

lemma horn_coeq : morph_horn_1 n k ≫ horn_morphism n k = morph_horn_2 n k ≫ horn_morphism n k :=
begin
  dsimp only [horn_morphism, horn_morphism_i, morph_horn_1, morph_horn_2],
  apply limits.colimit.hom_ext,
  simp only [limits.cofan.mk_ι_app, limits.colimit.ι_desc, limits.colimit.ι_desc_assoc, coe_coe,
    equiv.inv_fun_as_coe, category.assoc],
  intro idx,
  rw [←equiv.apply_eq_iff_eq yoneda_equiv],
  rw [←yoneda_equiv_naturality, ←yoneda_equiv_naturality],
  rw [equiv.apply_symm_apply, equiv.apply_symm_apply],
  dsimp only [sSet.horn, simplex_category.hom.to_order_hom, coe_coe],
  simp only [quiver.hom.unop_op, subtype.coe_mk],
  cases idx with i j h₁ h₂ h₃,
  simp only [function.embedding.to_fun_eq_coe, rel_embedding.coe_fn_to_embedding],
  exact simplex_category.δ_comp_δ h₁,
end

def horn_fork : limits.cofork (morph_horn_1 n k) (morph_horn_2 n k)
  := limits.cofork.of_π (horn_morphism n k) (horn_coeq n k)

def matching_faces (X : sSet) (y : (excluded_part n k) -> X _[n+1]) :=
  ∀ idx : horn_part n k, X.δ idx.i (y ⟨idx.j.succ, idx.h₃⟩) = X.δ idx.j (y ⟨idx.i.cast_succ, idx.h₂⟩)

def horn_fork_faces (X : limits.cofork (morph_horn_1 n k) (morph_horn_2 n k))
 : (excluded_part n k → X.X _[n + 1]) :=
  λ idx, yoneda_equiv (
    (limits.sigma.ι (excluded_f n k) idx : Δ[n+1] ⟶ excluded_end n k) ≫
    (X.π : excluded_end n k ⟶ X.X))

lemma horn_fork_matching_faces (X : limits.cofork (morph_horn_1 n k) (morph_horn_2 n k))
  : matching_faces n k X.X (horn_fork_faces n k X) :=
begin
  intro idx,
  dsimp only [simplicial_object.δ, horn_fork_faces],
  simp_rw [yoneda_equiv_naturality],
  rw [equiv.apply_eq_iff_eq yoneda_equiv],
  have h := congr_arg (λ f, limits.sigma.ι (horn_f n k) idx ≫ f) X.condition,
  dsimp [morph_horn_1, morph_horn_2] at h,
  simp_rw [←category.assoc', limits.colimit.ι_desc] at h,
  simp only [limits.cofan.mk_ι_app, category.assoc] at h,
  exact h,
end

def horn_hole {m n k} (f : [m] ⟶ [n + 1]) (h : set.range f.to_order_hom ∪ {k} ≠ set.univ)
  : ∃ i, i ≠ k ∧ i ∉ set.range f.to_order_hom :=
begin
  rw [set.ne_univ_iff_exists_not_mem] at h,
  cases h,
  use h_w,
  finish,
end

def horn_hole_index {m n k} (f : [m] ⟶ [n + 1]) (h : set.range f.to_order_hom ∪ {k} ≠ set.univ)
  := classical.some (horn_hole f h)

def horn_hole_neq_k {m n k} (f : [m] ⟶ [n + 1]) (h : set.range f.to_order_hom ∪ {k} ≠ set.univ)
  := (classical.some_spec (horn_hole f h)).1

def horn_hole_fun {m n k} (f : [m] ⟶ [n + 1]) (h : set.range f.to_order_hom ∪ {k} ≠ set.univ)
  := classical.some (hole_decomposition f (classical.some_spec (horn_hole f h)).2)

def horn_hole_prop {m n k} (f : [m] ⟶ [n + 1]) (h : set.range f.to_order_hom ∪ {k} ≠ set.univ)
  := classical.some_spec (hole_decomposition f (classical.some_spec (horn_hole f h)).2)

def horn_colim_obj {n m : ℕ}
  {k : fin (n + 3)}
  (s : limits.cofork (morph_horn_1 n k) (morph_horn_2 n k))
  (f : [m] ⟶ [n + 2])
  (hf : set.range f.to_order_hom ∪ {k} ≠ set.univ) :
  s.X.obj (opposite.op [m]) :=
    s.X.map
      (horn_hole_fun f hf).op
      (horn_fork_faces n k s ⟨horn_hole_index f hf, horn_hole_neq_k f hf⟩)

def horn_colim_obj_invariant {n m : ℕ}
  {i k : fin (n + 3)} (h : i ≠ k) (f : [m] ⟶ [n + 1])
  (s : limits.cofork (morph_horn_1 n k) (morph_horn_2 n k))
  : horn_colim_obj s (f ≫ simplex_category.δ i) sorry =
    s.X.map f.op (horn_fork_faces n k s ⟨i, h⟩) :=
begin
  -- dsimp [horn_colim_obj],
  cases lt_trichotomy i (horn_hole_index (f ≫ simplex_category.δ i) sorry),
  case or.inl : h' {
    sorry
  },
  case or.inr : h' {
    cases h',
    case or.inl : h' {
        rw [horn_colim_obj],
        congr, swap, rw [←h'],
        have hf := horn_hole_prop (f ≫ simplex_category.δ i) sorry,
        simp [horn_hole_index] at h',
        rw [←h'] at hf,
        have hf' := δ_cancel f _ hf,

    },
    case or.inr : h' {

    },
  }
end

def horn_colim : limits.is_colimit (horn_fork n k) :=
begin
  sorry,
  -- apply limits.cofork.is_colimit.mk',
  -- intro s,
  -- dsimp [horn_fork],
  -- fconstructor,
  -- focus {
  --   refine nat_trans.mk _ _,
  --   focus {
  --     intros X f,
  --     cases f with f hf,
  --     let m := X.unop.len,
  --     have hX : X = opposite.op [m] := by simp only [simplex_category.mk_len, opposite.op_unop],
  --     clear_value m,
  --     subst hX,
  --     dsimp [sSet.standard_simplex] at f,
  --     -- let i := horn_hole f hf,
  --     -- let f' := hole_decomposition f (classical.some_spec i).2,
  --     exact horn_colim_obj s f hf,
  --   },
  --   focus {
  --     dsimp [auto_param],
  --     intros X Y f,
  --     let m := X.unop.len, let o := Y.unop.len,
  --     have hX : X = opposite.op [m] := by simp only [simplex_category.mk_len, opposite.op_unop],
  --     have hY : Y = opposite.op [o] := by simp only [simplex_category.mk_len, opposite.op_unop],
  --     clear_value m o,
  --     subst hX, subst hY,
  --     ext1,
  --     dsimp [sSet.horn, sSet.standard_simplex, excluded_end] at *,
  --     cases x,
  --     simp,
  --     sorry,
  --   },
  -- },
  -- split,
  -- focus {
  --   dsimp [horn_morphism],
  --   ext1,
  --   simp [horn_morphism_i],
  --   ext1, ext1,
  --   simp,
  -- },
  -- focus {
  --   intro ,
  --   dsimp [horn_fork],
  --   refine nat_trans.mk _ _,
  --   focus {
  --     intros X f,
  --     let m := X.unop.len,
  --     have hX : X = opposite.op [m] := by simp only [simplex_category.mk_len, opposite.op_unop],
  --     clear_value m,
  --     subst hX,
  --     cases f,
  --     apply yoneda_equiv.to_fun,
  --     dsimp [sSet.standard_simplex] at f_val,
  --     refine _ ≫ _,
  --     exact Δ[n + 1],
  --     apply yoneda_equiv.inv_fun,
  --     exact nonsurj_fun f_val (horn_nonsurj f_val f_property),
  --     refine _ ≫ s.π,
  --     exact limits.sigma.ι (excluded_f n k) ⟨nonsurj_index f_val (horn_nonsurj f_val f_property)⟩,
  --   },
  -- },
end


import Mathlib.Tactic.Basic
import Mathlib.Tactic.Cases
import Mathlib.Init.Data.Nat.Basic
import Mathlib.Init.Data.Int.Basic
import Mathlib.Algebra.Group.Defs
/-!
## Type Classes

Type classes are a mechanism that was popularized by Haskell and that is present
in several proof assistants. In Lean, a type class is a structure type combining
abstract constants and their properties. A type can be declared an instance of
a type class by providing concrete definitions for the constants and proving that
the properties hold. Based on the type, Lean retrieves the relevant instance.

A simple example is the type class inhabited, which requires only a constant
inhabited.default and no properties:
-/
class inhabited (α : Type) : Type where
  default : α
/-!
Lean has a built-in type class with this name in upper case `Inhabited`
so we'll switch to the `Inhabited` built-in type class from here on.

The syntax is the same as for structures, except with the keyword `class` instead
of `structure`. The parameter `α` represents an arbitrary type that could be a member of
this type class.

Any type that has at least one element can be registered as an instance of this class. For example,
we can register Nat as being inhabited by choosing an arbitrary number to be the default value:
-/
instance Nat.Inhabited : Inhabited ℕ :=
  { default := 0 }
/-!
The above example is using object syntax just to show the connection with structures.
Normally we use the nice `where` clause syntax instead and you don't need to provide
a name for it:
-/
instance : Inhabited ℤ where
  default := 0
/-!

This specifies a structure value called `Nat.Inhabited` of type `Inhabited ℕ`. In addition, the
structure value is registered as _the_ canonical instance to use whenever a structure of type
`Inhabited ℕ` is desired.

--BUGBUG: I removed mention of the global table of instances, is that ok?

For lists, the empty list is an obvious default value that can be constructed
even if α itself is not Inhabited:
-/
instance : Inhabited (List α) where
  default := []

/-!
Sometimes we may want to supply several instances of a given type class for
the same type. Lean will then choose the first matching instance it finds.

--BUGBUG I'm not following this part...

As an example, recall that finite functions of type `α → β` can be represented
by their function tables, of type `β × · · · × β` (with `|α|` copies of `β`). Accordingly,
`|α → β| = |β|^|α|`. To make this ∅, we must have both `|β| = ∅` and `|α| ≠ ∅`. In
other words, the type `α → β` is inhabited if either (1) β is inhabited or (2) α is _not_
inhabited. Case (1) is easy:
-/
instance {α β : Type} [Inhabited β] : Inhabited (α → β) where
  default := λ (_ : α) => default

/-!
The instance relies itself on an instance of the same type class but on a different
type. This frequently occurs and is part of the reason why we speak of type class
_search_ rather than _lookup_.

For case (2), there is a type class for uninhabitedness, but we know that the
type `Empty` is not inhabited, so it will do:
-/
instance {β : Sort v} [Inhabited β] : Inhabited (Empty → β) where
  default := fun _ : Empty => default
/-!
Notice the function can never be called, because no value of type `empty` exists to pass as
argument. The definition of `empty` has zero introduction rules.

Finally, the type `α × β` of pairs, also called product type, contains values of
the form `(a, b)`, where `a : α` and `b : β`. Given a pair x, the first and second components
can be extracted by writing `prod.fst x` and `prod.snd x`. To provide an
inhabitant of `α × β`, we need both an inhabitant of `α` and an inhabitant of `β`:
-/
instance {α β : Type} [Inhabited α] [Inhabited β] : Inhabited (α × β) where
  default := (default, default)

def foo {α β : Type} [Inhabited α] [Inhabited β] :=
  ((default, default) : α × β)

#eval foo (α := ℕ) (β := ℤ) -- (0, 0)

/-!
Lean will search for an instance for `Inhabited ℕ` and will find `Nat.Inhabited`, the
instance we declared above. In that declaration, we set default to be `0` and hence
this is what `#eval` prints.

If multiple instances are applicable and Lean chooses the wrong one, we can name them and use the @
syntax to transform type class arguments into explicit arguments and supply the desired type class
instance. This is the main reason why we give names to the type class instances.

For example you can see how `foo` was wired together using some compiler generated names
if you turn on the verbose pretty printer like this:
-/
set_option pp.all true
#print foo

-- you will see this output:
def foo₁ : {α β : Type} → [inst : Inhabited.{1} α] → [inst : Inhabited.{1} β] → Prod.{0, 0} α β :=
fun {α β : Type} [inst : Inhabited.{1} α] [inst_1 : Inhabited.{1} β] =>
  @Prod.mk.{0, 0} α β (@Inhabited.default.{1} α inst) (@Inhabited.default.{1} β inst_1)

/-!
Notice how you can name the instances with `name :` like `inst` and `inst_1` above.
Notice also that Lean generated the name `instInhabitedProd_1` for our instance
since we didn't provide one.

So if you ever have to be explicit about which instance you are using it is easier if you add
names:
-/

instance InhabitedProd {α β : Type} [Inhabited α] [Inhabited β] : Inhabited (α × β) where
  default := (default, default)

def foo₂ {α β : Type} [i1: Inhabited α] [i2: Inhabited β] : α × β :=
  (@InhabitedProd α β i1 i2).default

#eval foo₂ (α := ℕ) (β := ℤ) -- (0, 0)
/-!
Now we know for sure we are using our `InhabitedProd` instance rather than leaving it
up to Lean to find the right matching instance.

Using the `Inhabited` type class, we can define the head operation on lists: the
function that returns the first element of a list. Because an empty list contains no
elements, there is no meaningful value we can return in that case. Given a type
that belongs to the `Inhabited` type class, we can simply return the default value:
-/
def head {α : Type} [Inhabited α] : List α → α
| [] =>  default
| (x :: _) => x

/-!
We require that `α` belongs to `Inhabited` by writing `[Inhabited α]`. This allows us
to access `Inhabited.default` in the definition.

The syntax `[Inhabited α]` adds an implicit argument to the `head` definition. But
unlike for other implicit arguments, Lean performs not only type inference but
also a type class search through all declared instances to determine the value of
this argument. Thus, when running the command
-/
#eval head ([] : List ℕ) -- result : 0

/-!

Note the actual `List.head` function is defined different, it has a pre-requisite
that the list is not empty, so `List.head` function is not defined for empty lists.

In practice, almost all types are nonempty (with the notable exceptions of `empty` and `false`), so the
`Inhabited` restriction is hardly an issue. Regardless, lists over empty types are uninteresting—the
only possible value is `[]`.

We can prove abstract lemmas about the `Inhabited` type class, such as
-/
lemma head_head {α : Type} [Inhabited α] (xs : List α) :
  head [head xs] = head xs := sorry
/-!
Note we use `sorry` to indicate that the proof is left to the reader.

The assumption `[inhabited α]` is needed to use the operator head on lists of
type `List α`. If we omit this assumption, Lean will raise an error telling us that
type class synthesis failed.

There are more type classes with only a constant but no properties, including

-/
namespace hidden

class Add (α : Type u) where
  add : α → α → α

class Sub (α : Type u) where
  sub : α → α → α

class Mul (α : Type u) where
  mul : α → α → α

class Neg (α : Type u) where
  neg : α → α

/-!
`Add.add` computes the sum of `a` and `b`.
`Sub.sub` computes the difference of `a` and `b`.
`Mul.mul` computes the product of `a` and `b`.
`Neg.neg` computes the negative or opposite of `a`.

These all have homogeneous types α, there are also type classes for heterogeneous operations, named
`HAdd`, `HSub`, and `HMul`.

And Mathlib defines the following additional type classes:
-/
class Zero (α : Type u) where
  zero : α

class One (α : Type u) where
  one : α

class Inv (α : Type u) where
  inv : α → α

end hidden
/-!

These syntactic type classes introduce constants that are used in many different
contexts with different semantics.

The main purpose of these type classes is to form the foundation for a rich hierarchy of algebraic
type classes (groups, monoids, ring, fields, etc.) and to allow the overloading of common
mathematical symbols such as `+`, `-`, `*`, `!`, and so on.

Syntactic type classes do not impose serious restrictions on the types that can be declared
instances, except that α in type class `Zero` and `One` must be `Inhabited`. In contrast, the
semantic type classes contain properties that restrict how the given constants behave.

--BUGBUG : I don't like the use of the term `constants` here since we are kind of hiding that term
in lean4 now, I think it is refering to the type class functions like `zero`, `one`, `inv` in the
above, so can this be replaced with `definitions` or `functions` ?

In [Proofs by Mathematical Induction](../ForwardProofs/Induction.lean.md), we defined a lemma
proving Nat is commutative under addition, we named this lemma `add_comm`.
We can now use this in a type class as follows:
-/
class is_commutative (α : Type) (f : α → α → α) where
  comm : ∀a b, f a b = f b a

class is_associative (α : Type) (f : α → α → α) where
  assoc : ∀a b c, f (f a b) c = f a (f b c)

instance add.is_commutative : is_commutative ℕ Add.add where
  comm := add_comm

instance add.is_associative : is_associative ℕ Add.add where
  assoc := add_assoc

/-!
This time, the associations are not from a type to a constant, but from a type _and a function_ to a
property. Lean does not mind the abuse: Although they are called type classes, Lean’s type classes
are very flexible and can be used to express all sorts of constraints.

Conceptually, `is_commutative` is a dependent type of triples (`α`, `f`, `comm`), and similarly for
`is_associative`. The type of `f` depends on `α`, and the type of `comm` depends on `α` and `f`.
Although they are parameters, `α` and `f` are also stored along with `comm`. But the type class
mechanism treats the parameters differently from the fields: The parameters are treated as _input_ to
the type class search, whereas the fields are _output_.

Whenever we try to access `is_commutative.comm ℕ Add.add`, we obtain `add_comm`,
and similarly for `is_associative.assoc ℕ Add.add`. The `cc` tactic tries to look up the
`comm` and `assoc` properties for all binary operators in the problem and exploits
the properties whenever they are present.

The general syntax to define a type class is as follows:
```lean
class class-name (params₁ : type₁) . . . (paramsₖ : typeₖ)
  extends structure₁, . . ., structureₘ
where
  (constant-names₁ : constant-type₁)
  ...
  (constant-namesnₙ : constant-typeₙ)
  (property-names₁ : proposition₁)
  ...
  (property-namesₚ : propositionₚ)
```

The general syntax to instantiate a type class is as follows:

```lean
instance [instance-name] : type-class-name arguments where
  constant₁ := definition₁
  ...
  constantₙ := definitionₙ,
  property₁ := proof₁
  ...
  propertyₚ := proofₚ

-/


/-
Copyright (c) 2019 Yury Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury Kudryashov
-/
import category_theory.concrete_category.bundled
import category_theory.discrete_category
import category_theory.types
import category_theory.bicategory.strict

/-!
# Category of categories

This file contains the definition of the category `Cat` of all categories.
In this category objects are categories and
morphisms are functors between these categories.

## Implementation notes

Though `Cat` is not a concrete category, we use `bundled` to define
its carrier type.
-/

universes v u

namespace category_theory

/-- Category of categories. -/
@[nolint check_univs] -- intended to be used with explicit universe parameters
def Cat := bundled category.{v u}

namespace Cat

instance : inhabited Cat := ⟨⟨Type u, category_theory.types⟩⟩

instance : has_coe_to_sort Cat (Type u) := ⟨bundled.α⟩

instance str (C : Cat.{v u}) : category.{v u} C := C.str

/-- Construct a bundled `Cat` from the underlying type and the typeclass. -/
def of (C : Type u) [category.{v} C] : Cat.{v u} := bundled.of C

/-- Bicategory structure on `Cat` -/
instance bicategory : bicategory.{(max v u) (max v u)} Cat.{v u} :=
{ hom := λ C D, C ⥤ D,
  id := λ C, 𝟭 C,
  comp := λ C D E F G, F ⋙ G,
  hom_category := λ C D, functor.category C D,
  whisker_left := λ C D E F G H η, whisker_left F η,
  whisker_right := λ C D E F G η H, whisker_right η H,
  associator := λ A B C D, functor.associator,
  left_unitor :=  λ A B, functor.left_unitor,
  right_unitor := λ A B, functor.right_unitor,
  pentagon' := λ A B C D E, functor.pentagon,
  triangle' := λ A B C, functor.triangle }

/-- `Cat` is a strict bicategory. -/
instance bicategory.strict : bicategory.strict Cat.{v u} :=
{ id_comp' := λ C D F, by cases F; refl,
  comp_id' := λ C D F, by cases F; refl,
  assoc' := by intros; refl }

/-- Category structure on `Cat` -/
instance category : large_category.{max v u} Cat.{v u} := strict_bicategory.category Cat.{v u}

@[simp]
lemma id_map {C : Cat} {X Y : C} (f : X ⟶ Y) : (𝟙 C : C ⥤ C).map f = f :=
functor.id_map f

@[simp]
lemma comp_obj {C D E : Cat} (F : C ⟶ D) (G : D ⟶ E) (X : C) :
  (F ≫ G).obj X = G.obj (F.obj X) :=
functor.comp_obj F G X

@[simp]
lemma comp_map {C D E : Cat} (F : C ⟶ D) (G : D ⟶ E) {X Y : C} (f : X ⟶ Y) :
  (F ≫ G).map f = G.map (F.map f) :=
functor.comp_map F G f

/-- Functor that gets the set of objects of a category. It is not
called `forget`, because it is not a faithful functor. -/
def objects : Cat.{v u} ⥤ Type u :=
{ obj := λ C, C,
  map := λ C D F, F.obj }

/-- Any isomorphism in `Cat` induces an equivalence of the underlying categories. -/
def equiv_of_iso {C D : Cat} (γ : C ≅ D) : C ≌ D :=
{ functor := γ.hom,
  inverse := γ.inv,
  unit_iso := eq_to_iso $ eq.symm γ.hom_inv_id,
  counit_iso := eq_to_iso γ.inv_hom_id }

end Cat

/--
Embedding `Type` into `Cat` as discrete categories.

This ought to be modelled as a 2-functor!
-/
@[simps]
def Type_to_Cat : Type u ⥤ Cat :=
{ obj := λ X, Cat.of (discrete X),
  map := λ X Y f, discrete.functor f,
  map_id' := λ X, begin apply functor.ext, tidy, end,
  map_comp' := λ X Y Z f g, begin apply functor.ext, tidy, end }

instance : faithful Type_to_Cat.{u} := {}
instance : full Type_to_Cat.{u} :=
{ preimage := λ X Y F, F.obj,
  witness' :=
  begin
    intros X Y F,
    apply functor.ext,
    { intros x y f, dsimp, ext, },
    { intros x, refl, }
  end }

end category_theory


import vorspiel lencodable tm

universes u v

open_locale big_operators

namespace turing_machine
variables
  (Γ : Type u) -- 言語
  (Q : Type v) [state_lang Q] -- 状態
  (ι : ℕ) -- テープの数

namespace blang
open instruction state_lang model
variables (Γ Q ι) [inhabited Γ] [bfin Γ]

def list_less_than (k : ℕ) := {l : list (option bool) // l.length ≤ k}

instance (k : ℕ) : inhabited (list_less_than k) := ⟨⟨[], by simp⟩⟩

namespace read

inductive state
| intro (q : Q) (i : fin (bentropy Γ).succ) (v : vector (vector bool (bentropy Γ)) ι) : state

variables {Γ Q ι}

instance [state_lang Q] : state_lang (state Γ Q ι) :=
⟨state.intro start 0 default, state.intro halt ⊤ default⟩

def δ : state Γ Q ι → vector bool ι → option (state Γ Q ι × vector bool ι × vector instruction ι)
| ⟨q, i, v⟩ x := if h : i < ⊤ then
    let newstate : state Γ Q ι :=
      ⟨q, ⟨i + 1, nat.succ_lt_succ (fin.lt_top_iff.mp h)⟩, (v.sim_update_nth (vector.rep ⟨i, fin.lt_top_iff.mp h⟩) x)⟩ in
  some ⟨newstate, x, Right⟩ else none

@[simp] lemma δ_top {q v x} : δ (⟨q, ⊤, v⟩ : state Γ Q ι) x = none := by simp[δ]

def σ : sentence bool (state Γ Q ι) ι := sentence.of_fun δ
(by { unfold start halt,
      intros q x c z u eqn, split; rintros rfl,
      { simpa using eqn },
      { rcases q with ⟨q, i, v⟩, by_cases C : i < ⊤; simp[C, δ, fin.ext_iff] at eqn; contradiction } })

section
variables (v : vector (vector bool (bentropy Γ)) ι) (T : vector (ℕ → bool) ι) (H : vector ℕ ι)

lemma σ_reduction (q : Q) (i : fin (bentropy Γ).succ) (h : i < ⊤) :
  ⟦⟨q, i, v⟩, T, H⟧ ⟶¹[σ]
  ⟦⟨q, ⟨i + 1, nat.succ_lt_succ (fin.lt_top_iff.mp h)⟩,
    v.sim_update_nth (vector.rep ⟨i, fin.lt_top_iff.mp h⟩) (read T H)⟩, T, H.map nat.succ⟧ :=
reduction.iff.mpr (⟨read T H, Right, by simp[σ, δ, h], by simp, by ext; simp⟩)

@[simp] lemma σ_is_halt (q : Q) (v : vector (vector bool (bentropy Γ)) ι) : σ.is_halt ⟨q, ⊤, v⟩ :=
by intros c z u x; simp[σ]

def memory :
  fin (bentropy Γ).succ → vector (vector bool (bentropy Γ)) ι
| ⟨0, _⟩      := v
| ⟨s + 1, hn⟩ := (memory ⟨s, by omega⟩).sim_update_nth (vector.rep ⟨s, by omega⟩) (read T (H.map ((+) s)))

@[simp] lemma memory_0 : memory v T H 0 = v := by unfold has_zero.zero; rw [memory]

lemma σ_time_reductions (q : Q) :
  ∀ (s : fin (bentropy Γ).succ), ⟦⟨q, 0, v⟩, T, H⟧ ⟶^(s)[σ] ⟦⟨q, s, memory v T H s⟩, T, H.map ((+) s)⟧
| ⟨0, _⟩      := by { simp, ext, simp, }
| ⟨s + 1, hs⟩ := by {
    let s' : fin (bentropy Γ).succ := ⟨s, by omega⟩,
    have r : ⟦⟨q, 0, v⟩, T, H⟧ ⟶^(s)[σ] ⟦⟨q, ⟨s, _⟩, memory v T H ⟨s, _⟩⟩, T, H.map ((+) s)⟧,
    from σ_time_reductions ⟨s, by omega⟩,
    have : ⟦⟨q, ⟨s, _⟩, memory v T H ⟨s, _⟩⟩, T, H.map ((+) s)⟧ ⟶¹[σ] ⟦⟨q, ⟨s + 1, _⟩, memory v T H ⟨s + 1, _⟩⟩, T, _⟧,
    by simpa[memory] using
      σ_reduction (memory v T H s') T (H.map ((+) s)) q s' (by simp[fin.lt_top_iff]; exact nat.succ_lt_succ_iff.mp hs),
    rw [show (H.map ((+) s)).map nat.succ = H.map ((+) s.succ), by ext; simp[nat.succ_add]] at this,
    exact r.succ this }

lemma memory_nth_nth_of_lt : ∀ (s : fin (bentropy Γ).succ) k i (h : ↑i < s),
  ((memory v T H s).nth k).nth i = T.nth k (i + H.nth k)
| ⟨0, _⟩ k i hi := by simp at hi; contradiction
| ⟨s + 1, hs⟩ k ⟨i, hi⟩ h := by {
    have : i = s ∨ i < s, from eq_or_lt_of_le (nat.lt_succ_iff.mp (by simpa using h)),
    rcases this with (rfl | lt); simp[memory, vector.nth_sim_update_nth_if],
    { have : s ≠ i, from ne_of_gt lt,
      simp[this],
      simpa using memory_nth_nth_of_lt ⟨s, lt_trans (lt_add_one s) hs⟩ k ⟨i, hi⟩ (by simpa using lt) } }

lemma σ_time_reductions_top (q : Q) : ⟦⟨q, 0, v⟩, T, H⟧ ⟶^(bentropy Γ)[σ] ⟦⟨q, ⊤, memory v T H ⊤⟩, T, H.map ((+) (bentropy Γ))⟧ :=
σ_time_reductions v T H q ⊤

lemma memory_nth_nth (k i) : ((memory v T H ⊤).nth k).nth i = T.nth k (i + H.nth k) :=
memory_nth_nth_of_lt v T H ⊤ k i (by simp[fin.lt_top_iff]; exact fin.is_lt i)

end

end read

namespace write

inductive state
| intro (q : Q) (i : fin (bentropy Γ).succ) (v : vector (vector bool (bentropy Γ)) ι) (u : vector instruction ι) : state

variables {Γ Q ι}

instance [state_lang Q] : state_lang (state Γ Q ι) :=
⟨state.intro start ⊤ default Stay, state.intro halt 0 default Stay⟩

def δ : state Γ Q ι → vector bool ι → option (state Γ Q ι × vector bool ι × vector instruction ι)
| ⟨q, ⟨0, _⟩, v, u⟩      x := none
| ⟨q, ⟨i + 1, hi⟩, v, u⟩ x :=
    let newstate : state Γ Q ι := ⟨q, ⟨i, by omega⟩, v, u⟩,
        i' : fin (bentropy Γ)  := ⟨i, nat.succ_lt_succ_iff.mp hi⟩ in
  some ⟨newstate, v.map (λ x, x.nth i'), Left⟩

@[simp] lemma δ_top {q v x u} : δ (⟨q, 0, v, u⟩ : state Γ Q ι) x = none := by unfold has_zero.zero; rw [δ]

def σ : sentence bool (state Γ Q ι) ι := sentence.of_fun δ
(by { unfold start halt,
      intros q x c z u eqn, split; rintros rfl,
      { simpa using eqn },
      { rcases q with ⟨q, ⟨i, hi⟩, v, u⟩, rcases i; simp[δ] at eqn,
        { contradiction },
        { have lt : i < bentropy Γ, from nat.succ_lt_succ_iff.mp hi,
          have eq : i = bentropy Γ, by simpa[fin.coe_top] using (fin.eq_iff_veq _ _).mp eqn.1.2.1,
          simp[eq] at lt, contradiction } } })

section
variables (v : vector (vector bool (bentropy Γ)) ι) (u : vector instruction ι) (T : vector (ℕ → bool) ι) (H : vector ℕ ι)

def σ_tape_reduct (i) :=
vector.zip_with3 (λ (t : ℕ → bool) h (x : vector bool (bentropy Γ)) n, if n = h then x.nth i else t n) T H v

lemma σ_reduction (q : Q) (i : ℕ) (hi) :
  ⟦⟨q, ⟨i + 1, hi⟩, v, u⟩, T, H⟧ ⟶¹[σ]
  ⟦⟨q, ⟨i, by omega⟩, v, u⟩, σ_tape_reduct v T H ⟨i, nat.succ_lt_succ_iff.mp hi⟩, H.map nat.pred⟧ :=
reduction.iff.mpr (⟨v.map (λ x, x.nth ⟨i, (by omega)⟩), Left, by simp[σ, δ]; refl,
  by { simp[reduct_tape, σ_tape_reduct], ext, simp }, by { ext, simp, exact nat.pred_eq_sub_one _ }⟩)

@[simp] lemma σ_is_halt (q : Q) : σ.is_halt ⟨q, 0, v, u⟩ :=
λ c z u x, by simp[σ]

def Tape : fin (bentropy Γ).succ → vector (vector bool (bentropy Γ)) ι → vector (ℕ → bool) ι → vector ℕ ι → vector (ℕ → bool) ι
| ⟨0, _⟩      v T H := T
| ⟨s + 1, hn⟩ v T H := Tape ⟨s, by omega⟩ v (σ_tape_reduct v T H ⟨s, nat.succ_lt_succ_iff.mp hn⟩) (H.map nat.pred)

@[simp] lemma Tape_0 : Tape 0 v T H = T := by unfold has_zero.zero; rw [Tape]

lemma σ_time_reductions (q : Q) :
  ∀ (s : fin (bentropy Γ).succ) (T H), ⟦⟨q, s, v, u⟩, T, H⟧ ⟶^(s)[σ] ⟦⟨q, 0, v, u⟩, Tape s v T H, (H.map (λ h, h - s))⟧
| ⟨0, _⟩      T H := by { simp, ext, simp }
| ⟨s + 1, hs⟩ T H := by {
    let s' : fin (bentropy Γ).succ := ⟨s, by omega⟩,
    let s'' : fin (bentropy Γ) := ⟨s, by { exact nat.succ_lt_succ_iff.mp hs}⟩,
    have r : ⟦⟨q, ⟨s, _⟩, v, u⟩, _, H.map nat.pred⟧ ⟶^(s)[σ] ⟦⟨q, 0, v, u⟩, _, H.map (λ h, h - (s + 1))⟧,
    { have := σ_time_reductions ⟨s, by omega⟩ (σ_tape_reduct v T H ⟨s, by omega⟩) (H.map nat.pred), simp at this,
      rw[show (H.map nat.pred).map (λ h, h - s) = H.map (λ h, h - (s + 1)),
         by { ext; simp;  rw[nat.pred_sub, nat.pred_eq_sub_one, tsub_tsub] }] at this,
      exact this },
    have : ⟦⟨q, ⟨s + 1, _⟩, v, u⟩, T, H⟧ ⟶¹[σ] ⟦⟨q, ⟨s, _⟩, v, u⟩, _, H.map nat.pred⟧,
    from σ_reduction v u T H q s hs,
    have : ⟦⟨q, ⟨s + 1, _⟩, v, u⟩, T, H⟧ ⟶^(s+1)[σ] ⟦⟨q, 0, v, u⟩, _, H.map (λ h, h - (s + 1))⟧,
    from relation.power.succ_inv this r,
    simpa[Tape, @sub_add_eq_sub_sub ℕ] using this }

end

end write

end blang

end turing_machine


import .free_ralg

namespace ralg

variables {L0 : lang} {L : lang} (ι : L0 →# L)
variables (A : ralg L0)

namespace fron

def rel : (free L A) → (free L A) → Prop := λ x y,
  ∀ (B : ralg L) (g : A →% B{ι}), (free.lift L g) x = (free.lift L g) y

def setoid : setoid (free L A) := ⟨rel ι A,
begin
  refine ⟨_,_,_⟩,
  { intros x B g, refl },
  { intros x y h B g, symmetry, apply h },
  { intros x y z h1 h2 B g, rw [h1,h2] }
end ⟩

end fron

def fron : ralg L :=
{ carrier := quotient (fron.setoid ι A),
  appo := λ n t, @vector.quotient_lift _ (quotient (fron.setoid ι A)) (fron.setoid ι A)
    _ (λ as, quotient.mk' (applyo t as))
    begin
      intros as bs h,
      dsimp only [],
      apply quotient.sound',
      intros B g,
      simp_rw ←ralg.applyo_map,
      apply congr_arg,
      simp_rw [vector.eq_iff_to_fn_eq_to_fn,vector.map_to_fn],
      ext,
      apply h,
    end }

namespace fron

def fquot : (free L A) →% (fron ι A) :=
{ to_fn := quotient.mk',
  applyo_map := λ n t as,
  begin
    change vector.quotient_lift _ _ (vector.map quotient.mk _) = _,
    rw vector.quotient_lift_eq,
  end }

def univ : A →% (fron ι A){ι} :=
{ to_fn := (fquot ι A) ∘ (free.univ L A),
  applyo_map := λ n t as,
  begin
    rw ←vector.map_map,
    change applyo (ι t) (vector.map (fquot _ _) _)  = (fquot ι A) _,
    rw ralg.applyo_map,
    apply quotient.sound',
    intros B g,
    change _ = ((free.lift _ _) ∘ (free.univ _ _)) _,
    rw [←ralg.applyo_map,vector.map_map,free.univ_comp_lift],
    change applyo _ (vector.map ((free.lift _ _) ∘ (free.univ _ _)) _) = _,
    rw [free.univ_comp_lift,←ralg.applyo_map],
    refl,
  end }

variable {A}
def lift {B : ralg L} (f : A →% B{ι}) : fron ι A →% B :=
{ to_fn := @quotient.lift _ _ (fron.setoid ι A) (free.lift L f)
  begin
    intros a b h,
    apply h,
  end,
  applyo_map := λ n t as,
  begin
    rcases vector.exists_rep quotient.mk' as (quot.exists_rep) with ⟨as,rfl⟩,
    rw vector.map_map,
    have : @quotient.mk' _ (fron.setoid ι A) = (fquot ι A), by refl,
    rw this,
    erw ralg.applyo_map,
    erw ralg.applyo_map,
    change _ = quotient.lift _ _ (quotient.mk _),
    rw quotient.lift_beta,
  end }

theorem univ_comp_lift {B : ralg L} (f : A →% B{ι}) :
  (univ ι A).comp ((lift ι f){%ι}) = f :=
begin
  ext,
  change (lift ι f) (quotient.mk' ((free.univ _ _) _)) = _,
  unfold_coes,
  dsimp only [],
  erw quotient.lift_beta,
  refl,
end

theorem lift_unique {B : ralg L} (f : A →% B{ι}) (g : fron ι A →% B) :
  (univ ι A).comp (g{%ι}) = f → g = lift ι f := λ hyp,
begin
  ext,
  rcases quot.exists_rep x with ⟨x,rfl⟩,
  unfold_coes,
  dsimp only [],
  erw quotient.lift_beta,
  change _ = (free.lift _ _) x,
  change (g ∘ (fquot _ _)) _ = _,
  apply congr_fun,
  suffices : (fquot ι A).comp g = free.lift L f,
  { replace this := congr_arg  (ralgHom.to_fn) this,
    assumption },
  apply free.lift_unique,
  ext y,
  change ((univ ι A).comp (g{%ι})) y = _,
  rw hyp,
end

end fron

end ralg


import CRT2 CRT lemmas2 defs_lemmas
import data.nat.basic
import data.nat.modeq
import data.nat.gcd
import data.zmod.basic
import tactic
import algebra.euclidean_domain
import data.int.basic
import data.equiv.ring
noncomputable theory

open nat nat.modeq zmod CRT2 CRT lemmas2 defs_lemmas

-------------------------ISOMORPHISM VERSION--------------------------

def proj (n: ℕ) (m: ℕ) : zmod (n*m) → (zmod n) × (zmod m):=
begin
    intro a,
    use (a,a),
end

--def proj' (n:ℕ ) (m : ℕ) : (λ (a: zmod (n*m) ), ( (a : zmod n), (a:zmod m) ))

lemma casting1 {n m : ℕ } {H_cop: coprime n m } {n_pos : 0 < n} {m_pos : 0 < m} (f: zmod n × zmod m → zmod (n*m)) (y: zmod n × zmod m) :
    ((f y) :zmod n) = (((f y):zmod n).val : zmod n):=
begin
    sorry, -- cast_val deprication issues
    --rw @cast_val _  n_pos (f y),
end

lemma casting2 {n m : ℕ } {H_cop: coprime n m} {n_pos : 0 < n} {m_pos : 0 < m} (y: zmod n × zmod m) :
    ((y.fst).val : zmod n) = y.fst ∧ ((y.snd).val : zmod m) = y.snd:=
begin
    split,
    sorry, -- cast_val deprication issues
    --rw @cast_val _ n_pos y.fst,
    sorry, -- cast_val deprication issues
    --rw @cast_val _ m_pos y.snd,
end

lemma casting3 {n m : ℕ } {H_cop: coprime n m } {n_pos : 0 < n} {m_pos : 0 < m} (f: zmod n × zmod m → zmod (n*m)) (y: zmod n × zmod m) :
    (((f y):zmod n).val) ≡ ((f y).val) [MOD n]:=
begin
    sorry,

end

--lemma to use for final step of add/mul homomorphisms.
lemma casting4 {n m: ℕ} (H_cop: coprime n m ) (n_pos : 0 < n) (m_pos : 0 < m) ( x y : zmod (n*m)):
    ((x: zmod n)+ (y : zmod n)).val= ((x + y) : zmod n).val :=
begin
    exact rfl,
end

lemma casting5 {n m : ℕ} (x : ℕ) : ((x : zmod (n*m)) : zmod n) = (x : zmod n) ∧ ((x : zmod (n*m)) : zmod m) = (x : zmod m):=
begin
    sorry,
end

lemma modular_equivalence {n : ℕ} {a b : zmod n} : (a : zmod n) = (b : zmod n) ↔  a.val ≡ b.val [MOD n] :=
begin
    sorry,
end

lemma modular_equivalence_nat {n: ℕ} {a b : ℕ} : (a : zmod n) = (b : zmod n) ↔  a ≡ b [MOD n] :=
begin
    sorry,
end

-- def K {n m :ℕ} {x : zmod n}{y : zmod m} {XY : zmod (n*m) } : Prop :=
-- XY.val ≡ (proj n m y).fst.val [MOD n] ∧ XY.val ≡ (proj n m y).snd.val [MOD m],
-- begin
--     sorry,
-- end

theorem CRTwith2 (n m : ℕ) (H: coprime n m) (npos: n > 0) (mpos: m > 0)  : zmod (n*m) ≃+* zmod n × zmod m :=
begin
    --define maps
      use (λ x, (x, x)),
    intro xy,
    have CRT := CRTwith2exist xy.1.val xy.2.val n m npos mpos H,
    /-theorem CRTwith2exist (a1 a2 M1 M2 : ℕ ) (M1pos : 0 < M1) (M2pos : 0 < M2) (H : coprime M1 M2) :
                         ∃ x : ℕ , modeq M1 x a1 ∧ modeq M2 x a2 -/
    choose x Hx using CRT,
    use x,

    -- show inverses (needs classical.some)
    {
        intro y,
        simp,
        -- Goal here: ⊢ ↑(classical.some _) = y
        sorry,
    },
    --show other proprties...
    sorry, sorry, sorry,
end

theorem CRTwith2' (n m : ℕ) (H: coprime n m) (npos: n > 0) (mpos: m > 0)  : zmod (n*m) ≃+* zmod n × zmod m :=
begin
    --define maps
    use proj n m,
    have choice : ∀ (xy : (zmod n)×(zmod m)),
     ∃ ( XY : (zmod (n*m)) ), modeq n XY.val xy.fst.val ∧ modeq m XY.val xy.snd.val,
    begin
        intro xy,
        have CRT := CRTwith2exist xy.1.val xy.2.val n m npos mpos H,
        choose x Hx using CRT,
        use x,
        have : 0<n*m,
        finish,
        split,
        {
            have key : (x: zmod (n*m)).val ≡  x [MOD n],
            {
                rw ← @modular_equivalence_nat _ (x: zmod (n*m)).val x,
                sorry, -- nat_cast_val 'fact' issues
                -- rw @nat_cast_val _ _ _ this x,
                --rw (casting5 x).left,
            },
            exact modeq.trans key Hx.left,
        },
        {
            have key : (x: zmod (n*m)).val ≡  x [MOD m],
            {
                rw ← @modular_equivalence_nat _ (x: zmod (n*m)).val x,
                sorry, -- nat_cast_val 'fact' issues
                -- rw @nat_cast_val _ _ _ this x,
                --rw (casting5 x).right,
            },
            exact modeq.trans key Hx.right,
        },
    end,
    choose f Hf using choice,
    use f,

    -- show inverses (needs classical.some)
    {
        simp,
        intro y,
        simp,
        rw modular_equivalence,
        rw ← modeq_and_modeq_iff_modeq_mul H,
        split,
        have k : y.val ≡ (proj n m y).fst.val [MOD n],
            sorry,
        apply modeq.trans _ (modeq.symm k),
        have CRT := CRTwith2exist (proj n m y).fst.val (proj n m y).snd.val n m npos mpos H,
        have k' := classical.some_spec CRT,
        have k'_spec := (classical.some_spec CRT).left,
        sorry,
        sorry,
    },
    {
        simp,
        intro xy,
        simp,
        sorry,
    },
    sorry,
    sorry,
end

-- VERSION 2 which runs into classical.some
theorem CRTisowith2' {n m : ℕ} (H_cop: coprime n m ) (n_pos : 0 < n) (m_pos : 0 < m) :
 (zmod (n*m)) ≃+* (zmod n)×(zmod m) :=
begin
    use (λ a, (a,a)),
    intro xy,
    have inv1 := nat_inv n m n_pos m_pos H_cop,
    have inv2 := nat_inv m n m_pos n_pos (coprime.symm H_cop),
    choose b1 Hb1 using inv1,
    choose b2 Hb2 using inv2,
    exact xy.fst * b1* m + xy.snd* b2* n,

    --show inverses
    {
    intro y,
    simp,
    cases CRTwith2exist ((y: zmod n).val) ((y: zmod m).val) n m (n_pos) (m_pos) (H_cop) with x hx,
    have hyn: y.val ≡ (y: zmod n).val [MOD n] ∧ y.val ≡ ((y: zmod m).val) [MOD m],
        begin
            sorry,
        end,
        sorry,
    },
    /-have := nat_inv n m n_pos m_pos H_cop,
    cases this,
    have := nat_inv n m n_pos m_pos (coprime.symm H_cop),
    cases this with b2 Hb2,
    --solution x = a1 b1 m2 + a2 b1 m2
    use (λ (a1,a2), (a1*b1*m + a2*b2*n)),
    -/
    sorry,
    sorry,
    sorry,
end

lemma mini {n m: ℕ} (c : ℕ) (y : zmod (n*m) ) : c ≡ (y : zmod n).val [MOD n] →
                                                (c : zmod (n*m) ).val  ≡ y.val [MOD n] := sorry

--PLAYING AROUND WITH CLASSICAL.SOME AND .SOME_SPEC
theorem isomorphism_test_classical {n m : ℕ} (H_cop: coprime n m ) (n_pos : 0 < n) (m_pos : 0 < m) :
 (zmod (n*m)) ≃+* (zmod n)×(zmod m) :=
begin
    --define function and its inverse
    use (λ a, (a,a)),
    intro xy,
    have CRT := CRTwith2exist xy.fst.val xy.snd.val n m n_pos m_pos H_cop,
    set k := classical.some CRT with H,
    have k' := classical.some_spec CRT,
    use (k : zmod (n*m) ),

    --show these are inverses using classical.some_spec
    {
        intro y,
        dsimp,
        rw modular_equivalence,
        rw ← modeq.modeq_and_modeq_iff_modeq_mul H_cop,
        have k' := classical.some_spec (CRTwith2exist (y:zmod n).val (y : zmod n).val n m n_pos m_pos H_cop),
        split,
        have k1 := k'.left,
        sorry,
        --exact mini _ _ k1,
        sorry,
    },
    sorry,sorry,sorry,
end

theorem CRTadd_hom {n m : ℕ} (H_cop: coprime n m ) (n_pos : 0 < n) (m_pos : 0 < m) (f : zmod (n*m)→ (zmod n × zmod m)) (H : ∀ xy: zmod (n*m), f(xy)=(xy,xy))
   : ∀ (x y : zmod (n*m)), f (x + y) = f x + f y:=
begin
    intros x y,
    have Hx := H x,
    have Hy := H y,
    have Hxy := H (x+y),
    rw Hx,
    rw Hy,
    rw Hxy,
    ext,
        simp,
        rw @zmod.cast_add (n*m) (zmod n) _ n _ (show n ∣ n*m, by exact dvd.intro m rfl)  _ _,
        simp,
        rw @zmod.cast_add (n*m) (zmod m) _ m _ (show m ∣ n*m, by exact dvd_mul_left m n) _ _,
end

theorem CRTmul_hom {n m : ℕ} (H_cop: coprime n m ) (n_pos : 0 < n) (m_pos : 0 < m) (f : zmod (n*m)→ (zmod n × zmod m)) (H : ∀ xy: zmod (n*m), f(xy)=(xy,xy))
   : ∀ (x y : zmod (n*m)), f (x * y) = f x * f y:=
begin
    intros x y,
    have Hx := H x,
    have Hy := H y,
    have Hxy := H (x*y),
    rw Hx,
    rw Hy,
    rw Hxy,
    ext,
        simp,
        rw @zmod.cast_mul (n*m) (zmod n) _ n _ (show n ∣ n*m, by exact dvd.intro m rfl)  _ _,
        simp,
        rw @zmod.cast_mul (n*m) (zmod m) _ m _ (show m ∣ n*m, by exact dvd_mul_left m n) _ _,
end

-- VERSION 1, avoids classical.some but hard to show hom properties
theorem CRTisowith2 {n m : ℕ} (H_cop: coprime n m ) (n_pos : 0 < n) (m_pos : 0 < m) :
  (zmod n)×(zmod m) ≃+* (zmod (n*m)) :=
begin
    -- defining a CRT lift (zmod n)×(zmod m) → (zmod (n*m))
    -- which satisfies the desired congruences
    have choice : ∀ (xy : (zmod n)×(zmod m)),
     ∃ ( XY : (zmod (n*m)) ), modeq n XY.val xy.fst.val ∧ modeq m XY.val xy.snd.val,
    begin
        intro xy,
        have CRT := CRTwith2exist xy.1.val xy.2.val n m n_pos m_pos H_cop,
        choose x Hx using CRT,
        use x,
        split,
        {
            sorry,
        },
        {
            sorry,
        }
    end,
    choose f Hf using choice,
    use f,
    intro x,
    use (x,x),
    intro y,

    -- show inverses
    ext,
    {   simp,
        have thing1 : ((f y) :zmod n) = (((f y):zmod n).val : zmod n), by sorry,
        have thing2 : ((y.fst).val : zmod n) = y.fst, by sorry,
        rw [thing1, ← thing2],
        rw nat_coe_eq_nat_coe_iff _ _ _,
        specialize Hf y,
        have thing3 : (((f y):zmod n).val) ≡ ((f y).val) [MOD n], by sorry,
        exact modeq.trans thing3 Hf.left,
    },
    {   simp,
        have thing1 : ((f y) :zmod m) = (((f y):zmod m).val : zmod m), by sorry,
        have thing2 : ((y.snd).val : zmod m) = y.snd, by sorry,
        rw [thing1, ← thing2],
        rw nat_coe_eq_nat_coe_iff _ _ _,
        specialize Hf y,
        have thing3 : ((f y):zmod m).val ≡ (f y).val [MOD m], by sorry,
        exact modeq.trans thing3 Hf.right,
    },
    {
        intro y,
        rw modular_equivalence,
        apply CRTwith2unique _ _ y.val y.val,
        simpa, simpa,
        exact H_cop,
        specialize Hf (((y:zmod n),(y:zmod m))),
        {
            split,
            have Hf' := Hf.left,
            simp at *,
            have this : (y : zmod n).val ≡ y.val [MOD n], by sorry,
            exact modeq.trans Hf' this,

            have Hf' := Hf.right,
            simp at *,
            have this : (y : zmod m).val ≡ y.val [MOD m], by sorry,
            exact modeq.trans Hf' this,
        },
        split; refl,
    },

    --multiplicative hom
    {
        intros x y,
        rw modular_equivalence,
        rw ← modeq_and_modeq_iff_modeq_mul H_cop,
        split,
        {
            have Hx := (Hf x).left,
            have Hy := (Hf y).left,
            have Hxy := (Hf (x*y)).left,
            have step1 : ((f x)*(f y)).val ≡  (x.fst.val*y.fst.val) [MOD n] :=
            begin
                sorry,
                --rw ← val_mul x.fst y.fst,

            end,
            have step2 : (f (x*y)).val ≡  (x.fst.val*y.fst.val) [MOD n] :=
            begin
                apply modeq.trans Hxy,
                rw prod.fst_mul x y,
                rw val_mul,
                exact modeq.mod_modeq (x.fst.val * y.fst.val) n,
            end,
            exact modeq.trans step2 (modeq.symm step1),
        },
        {
            have Hx := (Hf x).right,
            have Hy := (Hf y).right,
            have Hxy := (Hf (x*y)).right,
            have step1 : ((f x)*(f y)).val ≡  (x.snd.val*y.snd.val) [MOD m] :=
            begin
                sorry,
            end,
            have step2 : (f (x*y)).val ≡  (x.snd.val*y.snd.val) [MOD m] :=
            begin
                apply modeq.trans Hxy,
                rw prod.snd_mul x y,
                rw val_mul,
                exact modeq.mod_modeq (x.snd.val * y.snd.val) m,
            end,
            exact modeq.trans step2 (modeq.symm step1),
        },
    },

    --additive hom
    intros x y,
    rw modular_equivalence,
    rw ← modeq_and_modeq_iff_modeq_mul H_cop,
    split,
    {
        have Hx := (Hf x).left,
        have Hy := (Hf y).left,
        have Hxy := (Hf (x+y)).left,
        have step1 : ((f x)+(f y)).val ≡  (x.fst.val+y.fst.val) [MOD n] :=
        begin
            sorry,
        end,
        have step2 : (f (x+y)).val ≡  (x.fst.val+y.fst.val) [MOD n] :=
        begin
            apply modeq.trans Hxy,
            rw prod.fst_add x y,
            sorry, -- added 'fact' issues
            -- rw @val_add n n_pos,
            --exact modeq.mod_modeq (x.fst.val + y.fst.val) n,
        end,
        exact modeq.trans step2 (modeq.symm step1),
    },
    {
            have Hx := (Hf x).right,
            have Hy := (Hf y).right,
            have Hxy := (Hf (x+y)).right,
            have step1 : ((f x)+(f y)).val ≡  (x.snd.val+y.snd.val) [MOD m] :=
            begin
                sorry,
            end,
            have step2 : (f (x+y)).val ≡  (x.snd.val+y.snd.val) [MOD m] :=
            begin
                apply modeq.trans Hxy,
                rw prod.snd_add x y,
                sorry, -- 'fact' issues added
                --rw @val_add n n_pos,
                --exact modeq.mod_modeq (x.snd.val + y.snd.val) m,
            end,
            exact modeq.trans step2 (modeq.symm step1),
    },
end