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

! This file was ported from Lean 3 source module data.fintype.option
! leanprover-community/mathlib commit 327c3c0d9232d80e250dc8f65e7835b82b266ea5
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Data.Fintype.Card
import Mathbin.Data.Finset.Option

/-!
# fintype instances for option

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

open Function

open Nat

universe u v

variable {α β γ : Type _}

open Finset Function

instance {α : Type _} [Fintype α] : Fintype (Option α) :=
  ⟨univ.insertNone, fun a => by simp⟩

/- warning: univ_option -> univ_option is a dubious translation:
lean 3 declaration is
  forall (α : Type.{u1}) [_inst_1 : Fintype.{u1} α], Eq.{succ u1} (Finset.{u1} (Option.{u1} α)) (Finset.univ.{u1} (Option.{u1} α) (Option.fintype.{u1} α _inst_1)) (coeFn.{succ u1, succ u1} (OrderEmbedding.{u1, u1} (Finset.{u1} α) (Finset.{u1} (Option.{u1} α)) (Preorder.toLE.{u1} (Finset.{u1} α) (PartialOrder.toPreorder.{u1} (Finset.{u1} α) (Finset.partialOrder.{u1} α))) (Preorder.toLE.{u1} (Finset.{u1} (Option.{u1} α)) (PartialOrder.toPreorder.{u1} (Finset.{u1} (Option.{u1} α)) (Finset.partialOrder.{u1} (Option.{u1} α))))) (fun (_x : RelEmbedding.{u1, u1} (Finset.{u1} α) (Finset.{u1} (Option.{u1} α)) (LE.le.{u1} (Finset.{u1} α) (Preorder.toLE.{u1} (Finset.{u1} α) (PartialOrder.toPreorder.{u1} (Finset.{u1} α) (Finset.partialOrder.{u1} α)))) (LE.le.{u1} (Finset.{u1} (Option.{u1} α)) (Preorder.toLE.{u1} (Finset.{u1} (Option.{u1} α)) (PartialOrder.toPreorder.{u1} (Finset.{u1} (Option.{u1} α)) (Finset.partialOrder.{u1} (Option.{u1} α)))))) => (Finset.{u1} α) -> (Finset.{u1} (Option.{u1} α))) (RelEmbedding.hasCoeToFun.{u1, u1} (Finset.{u1} α) (Finset.{u1} (Option.{u1} α)) (LE.le.{u1} (Finset.{u1} α) (Preorder.toLE.{u1} (Finset.{u1} α) (PartialOrder.toPreorder.{u1} (Finset.{u1} α) (Finset.partialOrder.{u1} α)))) (LE.le.{u1} (Finset.{u1} (Option.{u1} α)) (Preorder.toLE.{u1} (Finset.{u1} (Option.{u1} α)) (PartialOrder.toPreorder.{u1} (Finset.{u1} (Option.{u1} α)) (Finset.partialOrder.{u1} (Option.{u1} α)))))) (Finset.insertNone.{u1} α) (Finset.univ.{u1} α _inst_1))
but is expected to have type
  forall (α : Type.{u1}) [_inst_1 : Fintype.{u1} α], Eq.{succ u1} (Finset.{u1} (Option.{u1} α)) (Finset.univ.{u1} (Option.{u1} α) (instFintypeOption.{u1} α _inst_1)) (FunLike.coe.{succ u1, succ u1, succ u1} (Function.Embedding.{succ u1, succ u1} (Finset.{u1} α) (Finset.{u1} (Option.{u1} α))) (Finset.{u1} α) (fun (_x : Finset.{u1} α) => (fun (x._@.Mathlib.Data.FunLike.Embedding._hyg.19 : Finset.{u1} α) => Finset.{u1} (Option.{u1} α)) _x) (EmbeddingLike.toFunLike.{succ u1, succ u1, succ u1} (Function.Embedding.{succ u1, succ u1} (Finset.{u1} α) (Finset.{u1} (Option.{u1} α))) (Finset.{u1} α) (Finset.{u1} (Option.{u1} α)) (Function.instEmbeddingLikeEmbedding.{succ u1, succ u1} (Finset.{u1} α) (Finset.{u1} (Option.{u1} α)))) (RelEmbedding.toEmbedding.{u1, u1} (Finset.{u1} α) (Finset.{u1} (Option.{u1} α)) (fun (x._@.Mathlib.Order.Hom.Basic._hyg.680 : Finset.{u1} α) (x._@.Mathlib.Order.Hom.Basic._hyg.682 : Finset.{u1} α) => LE.le.{u1} (Finset.{u1} α) (Preorder.toLE.{u1} (Finset.{u1} α) (PartialOrder.toPreorder.{u1} (Finset.{u1} α) (Finset.partialOrder.{u1} α))) x._@.Mathlib.Order.Hom.Basic._hyg.680 x._@.Mathlib.Order.Hom.Basic._hyg.682) (fun (x._@.Mathlib.Order.Hom.Basic._hyg.695 : Finset.{u1} (Option.{u1} α)) (x._@.Mathlib.Order.Hom.Basic._hyg.697 : Finset.{u1} (Option.{u1} α)) => LE.le.{u1} (Finset.{u1} (Option.{u1} α)) (Preorder.toLE.{u1} (Finset.{u1} (Option.{u1} α)) (PartialOrder.toPreorder.{u1} (Finset.{u1} (Option.{u1} α)) (Finset.partialOrder.{u1} (Option.{u1} α)))) x._@.Mathlib.Order.Hom.Basic._hyg.695 x._@.Mathlib.Order.Hom.Basic._hyg.697) (Finset.insertNone.{u1} α)) (Finset.univ.{u1} α _inst_1))
Case conversion may be inaccurate. Consider using '#align univ_option univ_optionₓ'. -/
theorem univ_option (α : Type _) [Fintype α] : (univ : Finset (Option α)) = insertNone univ :=
  rfl
#align univ_option univ_option

/- warning: fintype.card_option -> Fintype.card_option is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} [_inst_1 : Fintype.{u1} α], Eq.{1} Nat (Fintype.card.{u1} (Option.{u1} α) (Option.fintype.{u1} α _inst_1)) (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) (Fintype.card.{u1} α _inst_1) (OfNat.ofNat.{0} Nat 1 (OfNat.mk.{0} Nat 1 (One.one.{0} Nat Nat.hasOne))))
but is expected to have type
  forall {α : Type.{u1}} [_inst_1 : Fintype.{u1} α], Eq.{1} Nat (Fintype.card.{u1} (Option.{u1} α) (instFintypeOption.{u1} α _inst_1)) (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) (Fintype.card.{u1} α _inst_1) (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1)))
Case conversion may be inaccurate. Consider using '#align fintype.card_option Fintype.card_optionₓ'. -/
@[simp]
theorem Fintype.card_option {α : Type _} [Fintype α] :
    Fintype.card (Option α) = Fintype.card α + 1 :=
  (Finset.card_cons _).trans <| congr_arg₂ _ (card_map _) rfl
#align fintype.card_option Fintype.card_option

#print fintypeOfOption /-
/-- If `option α` is a `fintype` then so is `α` -/
def fintypeOfOption {α : Type _} [Fintype (Option α)] : Fintype α :=
  ⟨Finset.eraseNone (Fintype.elems (Option α)), fun x =>
    mem_eraseNone.mpr (Fintype.complete (some x))⟩
#align fintype_of_option fintypeOfOption
-/

#print fintypeOfOptionEquiv /-
/-- A type is a `fintype` if its successor (using `option`) is a `fintype`. -/
def fintypeOfOptionEquiv [Fintype α] (f : α ≃ Option β) : Fintype β :=
  haveI := Fintype.ofEquiv _ f
  fintypeOfOption
#align fintype_of_option_equiv fintypeOfOptionEquiv
-/

namespace Fintype

#print Fintype.truncRecEmptyOption /-
/-- A recursor principle for finite types, analogous to `nat.rec`. It effectively says
that every `fintype` is either `empty` or `option α`, up to an `equiv`. -/
def truncRecEmptyOption {P : Type u → Sort v} (of_equiv : ∀ {α β}, α ≃ β → P α → P β)
    (h_empty : P PEmpty) (h_option : ∀ {α} [Fintype α] [DecidableEq α], P α → P (Option α))
    (α : Type u) [Fintype α] [DecidableEq α] : Trunc (P α) :=
  by
  suffices ∀ n : ℕ, Trunc (P (ULift <| Fin n))
    by
    apply Trunc.bind (this (Fintype.card α))
    intro h
    apply Trunc.map _ (Fintype.truncEquivFin α)
    intro e
    exact of_equiv (equiv.ulift.trans e.symm) h
  intro n
  induction' n with n ih
  · have : card PEmpty = card (ULift (Fin 0)) := by simp only [card_fin, card_pempty, card_ulift]
    apply Trunc.bind (trunc_equiv_of_card_eq this)
    intro e
    apply Trunc.mk
    refine' of_equiv e h_empty
  · have : card (Option (ULift (Fin n))) = card (ULift (Fin n.succ)) := by
      simp only [card_fin, card_option, card_ulift]
    apply Trunc.bind (trunc_equiv_of_card_eq this)
    intro e
    apply Trunc.map _ ih
    intro ih
    refine' of_equiv e (h_option ih)
#align fintype.trunc_rec_empty_option Fintype.truncRecEmptyOption
-/

/- warning: fintype.induction_empty_option -> Fintype.induction_empty_option is a dubious translation:
lean 3 declaration is
  forall {P : forall (α : Type.{u1}) [_inst_1 : Fintype.{u1} α], Prop}, (forall (α : Type.{u1}) (β : Type.{u1}) [_inst_2 : Fintype.{u1} β] (e : Equiv.{succ u1, succ u1} α β), (P α (Fintype.ofEquiv.{u1, u1} α β _inst_2 (Equiv.symm.{succ u1, succ u1} α β e))) -> (P β _inst_2)) -> (P PEmpty.{succ u1} (Fintype.ofIsEmpty.{u1} PEmpty.{succ u1} PEmpty.isEmpty.{succ u1})) -> (forall (α : Type.{u1}) [_inst_3 : Fintype.{u1} α], (P α _inst_3) -> (P (Option.{u1} α) (Option.fintype.{u1} α _inst_3))) -> (forall (α : Type.{u1}) [_inst_4 : Fintype.{u1} α], P α _inst_4)
but is expected to have type
  forall {P : forall (α : Type.{u1}) [_inst_1 : Fintype.{u1} α], Prop}, (forall (α : Type.{u1}) (β : Type.{u1}) [_inst_2 : Fintype.{u1} β] (e : Equiv.{succ u1, succ u1} α β), (P α (Fintype.ofEquiv.{u1, u1} α β _inst_2 (Equiv.symm.{succ u1, succ u1} α β e))) -> (P β _inst_2)) -> (P PEmpty.{succ u1} (Fintype.ofIsEmpty.{u1} PEmpty.{succ u1} instIsEmptyPEmpty.{succ u1})) -> (forall (α : Type.{u1}) [_inst_3 : Fintype.{u1} α], (P α _inst_3) -> (P (Option.{u1} α) (instFintypeOption.{u1} α _inst_3))) -> (forall (α : Type.{u1}) [_inst_4 : Fintype.{u1} α], P α _inst_4)
Case conversion may be inaccurate. Consider using '#align fintype.induction_empty_option Fintype.induction_empty_optionₓ'. -/
/-- An induction principle for finite types, analogous to `nat.rec`. It effectively says
that every `fintype` is either `empty` or `option α`, up to an `equiv`. -/
@[elab_as_elim]
theorem induction_empty_option {P : ∀ (α : Type u) [Fintype α], Prop}
    (of_equiv : ∀ (α β) [Fintype β] (e : α ≃ β), @P α (@Fintype.ofEquiv α β ‹_› e.symm) → @P β ‹_›)
    (h_empty : P PEmpty) (h_option : ∀ (α) [Fintype α], P α → P (Option α)) (α : Type u)
    [Fintype α] : P α :=
  by
  obtain ⟨p⟩ :=
    @trunc_rec_empty_option (fun α => ∀ h, @P α h) (fun α β e hα hβ => @of_equiv α β hβ e (hα _))
      (fun _i => by convert h_empty) _ α _ (Classical.decEq α)
  · exact p _
  · rintro α hα - Pα hα'
    skip
    convert h_option α (Pα _)
#align fintype.induction_empty_option Fintype.induction_empty_option

end Fintype

#print Finite.induction_empty_option /-
/-- An induction principle for finite types, analogous to `nat.rec`. It effectively says
that every `fintype` is either `empty` or `option α`, up to an `equiv`. -/
theorem Finite.induction_empty_option {P : Type u → Prop} (of_equiv : ∀ {α β}, α ≃ β → P α → P β)
    (h_empty : P PEmpty) (h_option : ∀ {α} [Fintype α], P α → P (Option α)) (α : Type u)
    [Finite α] : P α := by
  cases nonempty_fintype α
  refine' Fintype.induction_empty_option _ _ _ α
  exacts[fun α β _ => of_equiv, h_empty, @h_option]
#align finite.induction_empty_option Finite.induction_empty_option
-/


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

import tactic.linarith.elimination
import tactic.linarith.parsing

/-!
# Deriving a proof of false

`linarith` uses an untrusted oracle to produce a certificate of unsatisfiability.
It needs to do some proof reconstruction work to turn this into a proof term.
This file implements the reconstruction.

## Main declarations

The public facing declaration in this file is `prove_false_by_linarith`.
-/

namespace linarith

open ineq tactic native

/-! ### Auxiliary functions for assembling proofs -/

/--
`mul_expr n e` creates a `pexpr` representing `n*e`.
When elaborated, the coefficient will be a native numeral of the same type as `e`.
-/
meta def mul_expr (n : ℕ) (e : expr) : pexpr :=
if n = 1 then ``(%%e) else
``(%%(nat.to_pexpr n) * %%e)

private meta def add_exprs_aux : pexpr → list pexpr → pexpr
| p [] := p
| p [a] := ``(%%p + %%a)
| p (h::t) := add_exprs_aux ``(%%p + %%h) t

/--
`add_exprs l` creates a `pexpr` representing the sum of the elements of `l`, associated left.
If `l` is empty, it will be the `pexpr` 0. Otherwise, it does not include 0 in the sum.
-/
meta def add_exprs : list pexpr → pexpr
| [] := ``(0)
| (h::t) := add_exprs_aux h t

/--
If our goal is to add together two inequalities `t1 R1 0` and `t2 R2 0`,
`ineq_const_nm R1 R2` produces the strength of the inequality in the sum `R`,
along with the name of a lemma to apply in order to conclude `t1 + t2 R 0`.
-/
meta def ineq_const_nm : ineq → ineq → (name × ineq)
| eq eq := (``eq_of_eq_of_eq, eq)
| eq le := (``le_of_eq_of_le, le)
| eq lt := (``lt_of_eq_of_lt, lt)
| le eq := (``le_of_le_of_eq, le)
| le le := (`add_nonpos, le)
| le lt := (`add_neg_of_nonpos_of_neg, lt)
| lt eq := (``lt_of_lt_of_eq, lt)
| lt le := (`add_neg_of_neg_of_nonpos, lt)
| lt lt := (`add_neg, lt)

/--
`mk_lt_zero_pf_aux c pf npf coeff` assumes that `pf` is a proof of `t1 R1 0` and `npf` is a proof
of `t2 R2 0`. It uses `mk_single_comp_zero_pf` to prove `t1 + coeff*t2 R 0`, and returns `R`
along with this proof.
-/
meta def mk_lt_zero_pf_aux (c : ineq) (pf npf : expr) (coeff : ℕ) : tactic (ineq × expr) :=
do (iq, h') ← mk_single_comp_zero_pf coeff npf,
   let (nm, niq) := ineq_const_nm c iq,
   prod.mk niq <$> mk_app nm [pf, h']

/--
`mk_lt_zero_pf coeffs pfs` takes a list of proofs of the form `tᵢ Rᵢ 0`,
paired with coefficients `cᵢ`.
It produces a proof that `∑cᵢ * tᵢ R 0`, where `R` is as strong as possible.
-/
meta def mk_lt_zero_pf : list (expr × ℕ) → tactic expr
| [] := fail "no linear hypotheses found"
| [(h, c)] := prod.snd <$> mk_single_comp_zero_pf c h
| ((h, c)::t) :=
  do (iq, h') ← mk_single_comp_zero_pf c h,
     prod.snd <$> t.mfoldl (λ pr ce, mk_lt_zero_pf_aux pr.1 pr.2 ce.1 ce.2) (iq, h')

/-- If `prf` is a proof of `t R s`, `term_of_ineq_prf prf` returns `t`. -/
meta def term_of_ineq_prf (prf : expr) : tactic expr :=
prod.fst <$> (infer_type prf >>= get_rel_sides)

/-- If `prf` is a proof of `t R s`, `ineq_prf_tp prf` returns the type of `t`. -/
meta def ineq_prf_tp (prf : expr) : tactic expr :=
term_of_ineq_prf prf >>= infer_type

/--
`mk_neg_one_lt_zero_pf tp` returns a proof of `-1 < 0`,
where the numerals are natively of type `tp`.
-/
meta def mk_neg_one_lt_zero_pf (tp : expr) : tactic expr :=
do zero_lt_one ← mk_mapp `zero_lt_one [tp, none, none],
   mk_app `neg_neg_of_pos [zero_lt_one]

/--
If `e` is a proof that `t = 0`, `mk_neg_eq_zero_pf e` returns a proof that `-t = 0`.
-/
meta def mk_neg_eq_zero_pf (e : expr) : tactic expr :=
to_expr ``(neg_eq_zero.mpr %%e)

/--
`prove_eq_zero_using tac e` tries to use `tac` to construct a proof of `e = 0`.
-/
meta def prove_eq_zero_using (tac : tactic unit) (e : expr) : tactic expr :=
do tgt ← to_expr ``(%%e = 0),
   prod.snd <$> solve_aux tgt (tac >> done)

/--
`add_neg_eq_pfs l` inspects the list of proofs `l` for proofs of the form `t = 0`. For each such
proof, it adds a proof of `-t = 0` to the list.
-/
meta def add_neg_eq_pfs : list expr → tactic (list expr)
| [] := return []
| (h::t) :=
  do some (iq, tp) ← parse_into_comp_and_expr <$> infer_type h,
  match iq with
  | ineq.eq := do nep ← mk_neg_eq_zero_pf h, tl ← add_neg_eq_pfs t, return $ h::nep::tl
  | _ := list.cons h <$> add_neg_eq_pfs t
  end

/-! #### The main method -/

/--
`prove_false_by_linarith` is the main workhorse of `linarith`.
Given a list `l` of proofs of `tᵢ Rᵢ 0`,
it tries to derive a contradiction from `l` and use this to produce a proof of `false`.

An oracle is used to search for a certificate of unsatisfiability.
In the current implementation, this is the Fourier Motzkin elimination routine in
`elimination.lean`, but other oracles could easily be swapped in.

The returned certificate is a map `m` from hypothesis indices to natural number coefficients.
If our set of hypotheses has the form  `{tᵢ Rᵢ 0}`,
then the elimination process should have guaranteed that
1.\ `∑ (m i)*tᵢ = 0`,
with at least one `i` such that `m i > 0` and `Rᵢ` is `<`.

We have also that
2.\ `∑ (m i)*tᵢ < 0`,
since for each `i`, `(m i)*tᵢ ≤ 0` and at least one is strictly negative.
So we conclude a contradiction `0 < 0`.

It remains to produce proofs of (1) and (2). (1) is verified by calling the `discharger` tactic
of the `linarith_config` object, which is typically `ring`. We prove (2) by folding over the
set of hypotheses.
-/
meta def prove_false_by_linarith (cfg : linarith_config) : list expr → tactic expr
| [] := fail "no args to linarith"
| l@(h::t) := do
    -- for the elimination to work properly, we must add a proof of `-1 < 0` to the list,
    -- along with negated equality proofs.
    l' ← add_neg_eq_pfs l,
    hz ← ineq_prf_tp h >>= mk_neg_one_lt_zero_pf,
    let inputs := hz::l',
    -- perform the elimination and fail if no contradiction is found.
    (comps, max_var) ← linear_forms_and_max_var cfg.transparency inputs,
    certificate ← cfg.oracle.get_or_else fourier_motzkin.produce_certificate comps max_var
      <|> fail "linarith failed to find a contradiction",
    linarith_trace "linarith has found a contradiction",
    let enum_inputs := inputs.enum,
    -- construct a list pairing nonzero coeffs with the proof of their corresponding comparison
    let zip := enum_inputs.filter_map $ λ ⟨n, e⟩, prod.mk e <$> certificate.find n,
    mls ← zip.mmap (λ ⟨e, n⟩, do e ← term_of_ineq_prf e, return (mul_expr n e)),
    -- `sm` is the sum of input terms, scaled to cancel out all variables.
    sm ← to_expr $ add_exprs mls,
    pformat! "The expression\n  {sm}\nshould be both 0 and negative" >>= linarith_trace,
    -- we prove that `sm = 0`, typically with `ring`.
    sm_eq_zero ← prove_eq_zero_using cfg.discharger sm,
    linarith_trace "We have proved that it is zero",
    -- we also prove that `sm < 0`.
    sm_lt_zero ← mk_lt_zero_pf zip,
    linarith_trace "We have proved that it is negative",
    -- this is a contradiction.
    pftp ← infer_type sm_lt_zero,
    (_, nep, _) ← rewrite_core sm_eq_zero pftp,
    pf' ← mk_eq_mp nep sm_lt_zero,
    mk_app `lt_irrefl [pf']

end linarith


/-
Copyright (c) 2021 Eric Wieser. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Eric Wieser
-/
import algebra.direct_sum.ring
import data.fin.tuple.basic

/-! # Tuples `fin n → α` form a graded monoid with `*` as `fin.append`

Defining multiplication as concatenation isn't particularly canonical, so we do not provide
this in mathlib. We could safely provide this instance on a type alias, but for now we just put
this in `tests` to verify that this definition is possible. -/

namespace fin

variables {α : Type*} {α' : Type*} {na nb nc : ℕ}

example {α : Type*} : graded_monoid.gmonoid (λ n, fin n → α) :=
{ mul := λ i j, fin.append,
  one := fin.elim0,
  one_mul := λ b, sigma_eq_of_eq_comp_cast _ (elim0'_append _),
  mul_one := λ a, sigma_eq_of_eq_comp_cast _ (append_elim0' _),
  mul_assoc := λ a b c,
    sigma_eq_of_eq_comp_cast (add_assoc _ _ _) $ (append_assoc a.2 b.2 c.2).trans rfl,
  gnpow := λ n i a, repeat n a,
  gnpow_zero' := λ a, sigma_eq_of_eq_comp_cast _ (repeat_zero _),
  gnpow_succ' := λ a n, sigma_eq_of_eq_comp_cast _ (repeat_succ _ _) }

end fin


variable {α : Type _} [Mul α] [Inhabited α]

abbrev Left (a : α) : α := a * default
abbrev Right (a : α): α := default * a

theorem mul_comm (a b : α) : a * b = b * a := sorry

set_option trace.Meta.Tactic.simp true
example (a : α) : Left a = Right a := by
  simp [mul_comm]