import Smt.Reconstruction.Defs
import Smt.Reconstruction.Term

open Types
open proof
open term
open sort
open Nat

namespace Rules

syntax "absurdHyp" ident "(" ident,+ ")" : tactic
macro_rules
  | `(tactic| absurdHyp $h:ident ($n:ident)) => `(tactic| rewrite [($n)] at ($h); have z: False := ($h); cases z)
  | `(tactic| absurdHyp $h:ident ($n:ident, $m:ident)) => `(tactic| rewrite [($n), ($m)] at ($h); have z: False := ($h); simp at z)

open Classical

theorem notImplies1 : ∀ {t₁ t₂ : term},
  followsFrom (not $ implies t₁ t₂) t₁ :=
  by intros t₁ t₂ Γ Δ h
     simp at h
     split at h
     case h_1 _ k h' =>
       split at h'
       case h_1 _ k' h'' =>
         split at h''
         case h_1 _ k₁ k₂ rt₁ rt₂ =>
           simp
           rewrite [rt₁]
           have ek : (fun Γ Δ => ¬ k' Γ Δ) = k :=
             by injection h' with h'; injection h' with _ h'; exact h';
           have fe : (fun Γ Δ => k₁ Γ Δ → k₂ Γ Δ) = k' :=
             by injection h'' with h''; injection h'' with _ h''; exact h''
           rewrite [← ek, ← fe] at h
           apply byContradiction
           exact (λ hf => h (λ k₁w => False.elim (hf k₁w)))
         case h_2 => simp at h''
       case h_2 => simp at h'
     case h_2 => exact (False.elim h)

theorem notImplies2 : ∀ {t₁ t₂ : term},
  followsFrom (not $ implies t₁ t₂) (not t₂) :=
    by intros t₁ t₂ Γ Δ h
       simp at h
       match r₁: interpTerm t₁, r₂: interpTerm t₂ with
       | some ⟨ atom 1, k₁ ⟩, some ⟨ atom 1, k₂ ⟩ =>
           simp
           rewrite [r₂]
           show ¬ k₂ Γ Δ
           rewrite [r₁, r₂] at h
           have h₂ : ¬ ((k₁ Γ Δ) → (k₂ Γ Δ)) := h
           match em (k₂ Γ Δ) with
           | Or.inl r  => exact False.elim (h₂ (λ _ => r))
           | Or.inr r  => exact r
       | some ⟨ atom 0, _ ⟩, _  => rewrite [r₁] at h; simp at h
       | some ⟨ atom 1, k₁ ⟩, some ⟨ atom 0, _ ⟩  => absurdHyp h (r₁, r₂)
       | some ⟨ atom 1, k₁ ⟩, some ⟨ atom (succ (succ _)), _ ⟩ => absurdHyp h (r₁, r₂)
       | some ⟨ atom 1, k₁ ⟩, some ⟨ sort.undef, _ ⟩           => absurdHyp h (r₁, r₂)
       | some ⟨ atom 1, k₁ ⟩, some ⟨ sort.array _ _, _ ⟩       => absurdHyp h (r₁, r₂)
       | some ⟨ atom 1, k₁ ⟩, some ⟨ sort.bv _, _ ⟩            => absurdHyp h (r₁, r₂)
       | some ⟨ atom 1, k₁ ⟩, some ⟨ sort.arrow _ _, _ ⟩       => absurdHyp h (r₁, r₂)
       | some ⟨ atom 1, k₁ ⟩, some ⟨ sort.dep, _ ⟩             => absurdHyp h (r₁, r₂)
       | some ⟨ atom 1, k₁ ⟩, none                             => absurdHyp h (r₁, r₂)
       | some ⟨ atom (succ (succ _)), _ ⟩, _ => absurdHyp h (r₁)
       | some ⟨ sort.undef, _ ⟩, _           => absurdHyp h (r₁)
       | some ⟨ sort.array _ _, _ ⟩, _       => absurdHyp h (r₁)
       | some ⟨ sort.bv _, _ ⟩, _            => absurdHyp h (r₁)
       | some ⟨ sort.arrow _ _, _ ⟩, _       => absurdHyp h (r₁)
       | some ⟨ sort.dep, _ ⟩, _             => absurdHyp h (r₁)
       | none, _                             => absurdHyp h (r₁)

theorem impliesElim : ∀ {t₁ t₂ : term},
  followsFrom (implies t₁ t₂) (or (not t₁) t₂)
  | t₁, t₂, Γ, Δ, h =>
    by simp at h
       match r₁: interpTerm t₁, r₂: interpTerm t₂ with
       | some ⟨ atom 1, k₁ ⟩, some ⟨ atom 1, k₂ ⟩ =>
           simp
           rewrite [r₁, r₂]
           rewrite [r₁, r₂] at h
           show (¬ k₁ Γ Δ) ∨ (k₂ Γ Δ)
           have h₂ : k₁ Γ Δ → k₂ Γ Δ := h
           match em (k₁ Γ Δ), em (k₂ Γ Δ) with
           | Or.inl _, Or.inl k₂W => exact Or.inr k₂W
           | Or.inl k₁W, Or.inr nk₂W => have k₂W := h₂ k₁W
                                        exact (False.elim (nk₂W k₂W))
           | Or.inr _, Or.inl k₂W => exact Or.inr k₂W
           | Or.inr nk₁W, Or.inr _ => exact Or.inl nk₁W
       | some ⟨ atom 0, _ ⟩, _  => absurdHyp h (r₁)
       | some ⟨ atom 1, k₁ ⟩, some ⟨ atom 0, _ ⟩  => absurdHyp h (r₁, r₂)
       | some ⟨ atom 1, k₁ ⟩, some ⟨ atom (succ (succ _)), _ ⟩ => absurdHyp h (r₁, r₂)
       | some ⟨ atom 1, k₁ ⟩, some ⟨ sort.undef, _ ⟩           => absurdHyp h (r₁, r₂)
       | some ⟨ atom 1, k₁ ⟩, some ⟨ sort.array _ _, _ ⟩       => absurdHyp h (r₁, r₂)
       | some ⟨ atom 1, k₁ ⟩, some ⟨ sort.bv _, _ ⟩            => absurdHyp h (r₁, r₂)
       | some ⟨ atom 1, k₁ ⟩, some ⟨ sort.arrow _ _, _ ⟩       => absurdHyp h (r₁, r₂)
       | some ⟨ atom 1, k₁ ⟩, some ⟨ sort.dep, _ ⟩             => absurdHyp h (r₁, r₂)
       | some ⟨ atom 1, k₁ ⟩, none                             => absurdHyp h (r₁, r₂)
       | some ⟨ atom (succ (succ _)), _ ⟩, _ => absurdHyp h (r₁)
       | some ⟨ sort.undef, _ ⟩, _           => absurdHyp h (r₁)
       | some ⟨ sort.array _ _, _ ⟩, _       => absurdHyp h (r₁)
       | some ⟨ sort.bv _, _ ⟩, _            => absurdHyp h (r₁)
       | some ⟨ sort.arrow _ _, _ ⟩, _       => absurdHyp h (r₁)
       | some ⟨ sort.dep, _ ⟩, _             => absurdHyp h (r₁)
       | none, _                             => absurdHyp h (r₁)

theorem contradiction: ∀ {t: term},
  followsFrom (and (not t) t) bot
  | t, Γ, Δ, h => by
    simp at h
    match r: interpTerm t with
    | some ⟨ atom 1, k ⟩ =>
        rewrite [r] at h;
        simp at h
        have ⟨nkW, kW⟩ : ¬ (k Γ Δ) ∧ k Γ Δ := h
        exact False.elim (nkW kW)
    | some ⟨ atom 0, _ ⟩               => absurdHyp h (r)
    | some ⟨ atom (succ (succ _)), _ ⟩ => absurdHyp h (r)
    | some ⟨ sort.undef, _ ⟩           => absurdHyp h (r)
    | some ⟨ sort.array _ _, _ ⟩       => absurdHyp h (r)
    | some ⟨ sort.bv _, _ ⟩            => absurdHyp h (r)
    | some ⟨ sort.arrow _ _, _ ⟩       => absurdHyp h (r)
    | some ⟨ sort.dep, _ ⟩             => absurdHyp h (r)
    | none                             => absurdHyp h (r)

theorem R1 : ∀ {t₁ t₂ : term},
  followsFrom (and (or (not t₁) t₂) t₁) t₂
  | t₁, t₂, Γ, Δ, h => by
    simp at h
    match r₁: interpTerm t₁, r₂: interpTerm t₂ with
    | some ⟨ atom 1, k₁ ⟩, some ⟨ atom 1, k₂ ⟩ =>
        simp at *
        rewrite [r₁, r₂] at h
        rewrite [r₂]
        have ⟨ H, k₁W ⟩: ((¬ (k₁ Γ Δ)) ∨ (k₂ Γ Δ)) ∧ (k₁ Γ Δ) := h
        match em (k₂ Γ Δ) with
        | Or.inl k₂W  => exact k₂W
        | Or.inr _    => match em (k₁ Γ Δ) with
                         | Or.inl k₁W  => match H with
                                          | Or.inl nk₁W => exact (False.elim (nk₁W k₁W))
                                          | Or.inr k₂W  => exact k₂W
                         | Or.inr nk₁W => exact (False.elim (nk₁W k₁W))
    | some ⟨ atom 1, _ ⟩, some ⟨ atom 0, _ ⟩               => absurdHyp h (r₁, r₂)
    | some ⟨ atom 1, _ ⟩, some ⟨ atom (succ (succ _)), _ ⟩ => absurdHyp h (r₁, r₂)
    | some ⟨ atom 1, _ ⟩, some ⟨ sort.undef, _ ⟩           => absurdHyp h (r₁, r₂)
    | some ⟨ atom 1, _ ⟩, some ⟨ sort.array _ _, _ ⟩       => absurdHyp h (r₁, r₂)
    | some ⟨ atom 1, _ ⟩, some ⟨ sort.bv _, _ ⟩            => absurdHyp h (r₁, r₂)
    | some ⟨ atom 1, _ ⟩, some ⟨ sort.arrow _ _, _ ⟩       => absurdHyp h (r₁, r₂)
    | some ⟨ atom 1, _ ⟩, some ⟨ sort.dep, _ ⟩             => absurdHyp h (r₁, r₂)
    | some ⟨ atom 1, _ ⟩, none                             => absurdHyp h (r₁, r₂)
    | some ⟨ atom 0, _ ⟩, _               => absurdHyp h (r₁)
    | some ⟨ atom (succ (succ _)), _ ⟩, _ => absurdHyp h (r₁)
    | some ⟨ sort.undef, _ ⟩, _           => absurdHyp h (r₁)
    | some ⟨ sort.array _ _, _ ⟩, _       => absurdHyp h (r₁)
    | some ⟨ sort.bv _, _ ⟩, _            => absurdHyp h (r₁)
    | some ⟨ sort.arrow _ _, _ ⟩, _       => absurdHyp h (r₁)
    | some ⟨ sort.dep, _ ⟩, _             => absurdHyp h (r₁)
    | none, _                             => absurdHyp h (r₁)

theorem conjunction: ∀ {t₁ t₂: term} {Γ: Environment} {Δ : SEnvironment},
  validWith Γ Δ t₁ → validWith Γ Δ t₂ → validWith Γ Δ (and t₁ t₂)
  | t₁, t₂, Γ, Δ, h₁, h₂ => by
    simp at *
    match r₁: interpTerm t₁, r₂: interpTerm t₂ with
    | some ⟨ atom 1, k₁ ⟩, some ⟨ atom 1, k₂ ⟩ =>
        show (k₁ Γ Δ) ∧ (k₂ Γ Δ)
        simp
        rewrite [r₁] at h₁
        rewrite [r₂] at h₂
        have k₁W: (k₁ Γ Δ) := h₁
        have k₂W: (k₂ Γ Δ) := h₂
        exact And.intro k₁W k₂W
    | some ⟨ atom 1, _ ⟩, some ⟨ atom 0, _ ⟩               => absurdHyp h₂ (r₂)
    | some ⟨ atom 1, _ ⟩, some ⟨ atom (succ (succ _)), _ ⟩ => absurdHyp h₂ (r₂)
    | some ⟨ atom 1, _ ⟩, some ⟨ sort.undef, _ ⟩           => absurdHyp h₂ (r₂)
    | some ⟨ atom 1, _ ⟩, some ⟨ sort.array _ _, _ ⟩       => absurdHyp h₂ (r₂)
    | some ⟨ atom 1, _ ⟩, some ⟨ sort.bv _, _ ⟩            => absurdHyp h₂ (r₂)
    | some ⟨ atom 1, _ ⟩, some ⟨ sort.arrow _ _, _ ⟩       => absurdHyp h₂ (r₂)
    | some ⟨ atom 1, _ ⟩, some ⟨ sort.dep, _ ⟩             => absurdHyp h₂ (r₂)
    | some ⟨ atom 1, _ ⟩, none                             => absurdHyp h₂ (r₂)
    | some ⟨ atom 0, _ ⟩, _                                => absurdHyp h₁ (r₁)
    | some ⟨ atom (succ (succ _)), _ ⟩ , _ => absurdHyp h₁ (r₁)
    | some ⟨ sort.undef, _ ⟩, _            => absurdHyp h₁ (r₁)
    | some ⟨ sort.array _ _, _ ⟩, _        => absurdHyp h₁ (r₁)
    | some ⟨ sort.bv _, _ ⟩, _             => absurdHyp h₁ (r₁)
    | some ⟨ sort.arrow _ _, _ ⟩, _        => absurdHyp h₁ (r₁)
    | some ⟨ sort.dep, _ ⟩, _              => absurdHyp h₁ (r₁)
    | none, _                              => absurdHyp h₁ (r₁)

theorem followsBot: ∀ {t: term},
  followsFrom t bot → ∀ {Γ : Environment} {Δ : SEnvironment}, ¬ validWith Γ Δ t
  | t, h, Γ, Δ => by
    intro validT
    have validBot := @h Γ Δ validT
    simp at validBot
    cases validBot

@[simp] def isBool : term → Bool
  | t => match interpTerm t with
         | some ⟨ atom 1, _ ⟩ => true
         | _ => false

theorem interpNotTerm: ∀ {Γ: Environment} {Δ: SEnvironment} {t: term},
  isBool t → ¬ validWith Γ Δ (not t) → validWith Γ Δ t
  | Γ, Δ, t, bt, h => by
    simp
    match r: interpTerm t with
    | some ⟨ atom 1, k ⟩ => match em (k Γ Δ) with
                            | Or.inl kW  => exact kW
                            | Or.inr nkW => simp at h
                                            rewrite [r] at h
                                            have nnkW : ¬ (¬ (k Γ Δ)) := h
                                            exact (False.elim (nnkW nkW))
    | some ⟨ atom 0, _ ⟩               => simp at bt; rewrite [r] at bt; cases bt
    | some ⟨ atom (succ (succ _)), _ ⟩ => simp at bt; rewrite [r] at bt; cases bt
    | some ⟨ sort.undef, _ ⟩           => simp at bt; rewrite [r] at bt; cases bt
    | some ⟨ sort.array _ _, _ ⟩       => simp at bt; rewrite [r] at bt; cases bt
    | some ⟨ sort.bv _, _ ⟩            => simp at bt; rewrite [r] at bt; cases bt
    | some ⟨ sort.arrow _ _, _ ⟩       => simp at bt; rewrite [r] at bt; cases bt
    | some ⟨ sort.dep, _ ⟩             => simp at bt; rewrite [r] at bt; cases bt
    | none                             => simp at bt; rewrite [r] at bt; cases bt

end Rules


/-
Copyright (c) 2021 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
import Lean.Meta.AppBuilder
import Lean.Class

namespace Lean.Meta

inductive CongrArgKind where
  /-- It is a parameter for the congruence theorem, the parameter occurs in the left and right hand sides. -/
  | fixed
  /--
  It is not a parameter for the congruence theorem, the theorem was specialized for this parameter.
  This only happens if the parameter is a subsingleton/proposition, and other parameters depend on it. -/
  | fixedNoParam
  /--
  The lemma contains three parameters for this kind of argument `a_i`, `b_i` and `eq_i : a_i = b_i`.
  `a_i` and `b_i` represent the left and right hand sides, and `eq_i` is a proof for their equality. -/
  | eq
  /--
  The congr-simp theorems contains only one parameter for this kind of argument, and congr theorems contains two.
  They correspond to arguments that are subsingletons/propositions. -/
  | cast
  /--
  The lemma contains three parameters for this kind of argument `a_i`, `b_i` and `eq_i : HEq a_i b_i`.
  `a_i` and `b_i` represent the left and right hand sides, and `eq_i` is a proof for their heterogeneous equality. -/
  | heq
  /--
  For congr-simp theorems only.  Indicates a decidable instance argument.
  The lemma contains two arguments [a_i : Decidable ...] [b_i : Decidable ...] -/
  | subsingletonInst
  deriving Inhabited, Repr

structure CongrTheorem where
  type     : Expr
  proof    : Expr
  argKinds : Array CongrArgKind

private def addPrimeToFVarUserNames (ys : Array Expr) (lctx : LocalContext) : LocalContext := Id.run do
  let mut lctx := lctx
  for y in ys do
    let decl := lctx.getFVar! y
    lctx := lctx.setUserName decl.fvarId (decl.userName.appendAfter "'")
  return lctx

private def setBinderInfosD (ys : Array Expr) (lctx : LocalContext) : LocalContext := Id.run do
  let mut lctx := lctx
  for y in ys do
    let decl := lctx.getFVar! y
    lctx := lctx.setBinderInfo decl.fvarId BinderInfo.default
  return lctx

partial def mkHCongrWithArity (f : Expr) (numArgs : Nat) : MetaM CongrTheorem := do
  let fType ← inferType f
  forallBoundedTelescope fType numArgs fun xs _ =>
  forallBoundedTelescope fType numArgs fun ys _ => do
    if xs.size != numArgs then
      throwError "failed to generate hcongr theorem, insufficient number of arguments"
    else
      let lctx := addPrimeToFVarUserNames ys (← getLCtx) |> setBinderInfosD ys |> setBinderInfosD xs
      withLCtx lctx (← getLocalInstances) do
      withNewEqs xs ys fun eqs argKinds => do
        let mut hs := #[]
        for x in xs, y in ys, eq in eqs do
          hs := hs.push x |>.push y |>.push eq
        let lhs := mkAppN f xs
        let rhs := mkAppN f ys
        let congrType ← mkForallFVars hs (← mkHEq lhs rhs)
        return {
          type  := congrType
          proof := (← mkProof congrType)
          argKinds
        }
where
  withNewEqs {α} (xs ys : Array Expr) (k : Array Expr → Array CongrArgKind → MetaM α) : MetaM α :=
    let rec loop (i : Nat) (eqs : Array Expr) (kinds : Array CongrArgKind) := do
      if  i < xs.size then
        let x := xs[i]!
        let y := ys[i]!
        let xType := (← inferType x).consumeTypeAnnotations
        let yType := (← inferType y).consumeTypeAnnotations
        if xType == yType then
          withLocalDeclD ((`e).appendIndexAfter (i+1)) (← mkEq x y) fun h =>
            loop (i+1) (eqs.push h) (kinds.push CongrArgKind.eq)
        else
          withLocalDeclD ((`e).appendIndexAfter (i+1)) (← mkHEq x y) fun h =>
            loop (i+1) (eqs.push h) (kinds.push CongrArgKind.heq)
      else
        k eqs kinds
    loop 0 #[] #[]

  mkProof (type : Expr) : MetaM Expr := do
    if let some (_, lhs, _) := type.eq? then
      mkEqRefl lhs
    else if let some (_, lhs, _, _) := type.heq? then
      mkHEqRefl lhs
    else
      forallBoundedTelescope type (some 1) fun a type =>
      let a := a[0]!
      forallBoundedTelescope type (some 1) fun b motive =>
      let b := b[0]!
      let type := type.bindingBody!.instantiate1 a
      withLocalDeclD motive.bindingName! motive.bindingDomain! fun eqPr => do
      let type := type.bindingBody!
      let motive := motive.bindingBody!
      let minor ← mkProof type
      let mut major := eqPr
      if (← whnf (← inferType eqPr)).isHEq then
        major ← mkEqOfHEq major
      let motive ← mkLambdaFVars #[b] motive
      mkLambdaFVars #[a, b, eqPr] (← mkEqNDRec motive minor major)

def mkHCongr (f : Expr) : MetaM CongrTheorem := do
  mkHCongrWithArity f (← getFunInfo f).getArity

/--
  Ensure that all dependencies for `congr_arg_kind::Eq` are `congr_arg_kind::Fixed`.
-/
private def fixKindsForDependencies (info : FunInfo) (kinds : Array CongrArgKind) : Array CongrArgKind := Id.run do
  let mut kinds := kinds
  for i in [:info.paramInfo.size] do
    for j in [i+1:info.paramInfo.size] do
      if info.paramInfo[j]!.backDeps.contains i then
        if kinds[j]! matches CongrArgKind.eq || kinds[j]! matches CongrArgKind.fixed then
          -- We must fix `i` because there is a `j` that depends on `i` and `j` is not cast-fixed.
          kinds := kinds.set! i CongrArgKind.fixed
          break
  return kinds

/--
  (Try to) cast expression `e` to the given type using the equations `eqs`.
  `deps` contains the indices of the relevant equalities.
  Remark: deps is sorted. -/
private partial def mkCast (e : Expr) (type : Expr) (deps : Array Nat) (eqs : Array (Option Expr)) : MetaM Expr := do
  let rec go (i : Nat) (type : Expr) : MetaM Expr := do
     if i < deps.size then
       match eqs[deps[i]!]! with
       | none => go (i+1) type
       | some major =>
         let some (_, lhs, rhs) := (← inferType major).eq? | unreachable!
         if (← dependsOn type major.fvarId!) then
           let motive ← mkLambdaFVars #[rhs, major] type
           let typeNew := type.replaceFVar rhs lhs |>.replaceFVar major (← mkEqRefl lhs)
           let minor ← go (i+1) typeNew
           mkEqRec motive minor major
         else
           let motive ← mkLambdaFVars #[rhs] type
           let typeNew := type.replaceFVar rhs lhs
           let minor ← go (i+1) typeNew
           mkEqNDRec motive minor major
     else
       return e
  go 0 type

private def hasCastLike (kinds : Array CongrArgKind) : Bool :=
  kinds.any fun kind => kind matches CongrArgKind.cast || kind matches CongrArgKind.subsingletonInst

private def withNext (type : Expr) (k : Expr → Expr → MetaM α) : MetaM α := do
  forallBoundedTelescope type (some 1) fun xs type => k xs[0]! type

/--
  Test whether we should use `subsingletonInst` kind for instances which depend on `eq`.
  (Otherwise `fixKindsForDependencies`will downgrade them to Fixed -/
private def shouldUseSubsingletonInst (info : FunInfo) (kinds : Array CongrArgKind) (i : Nat) : Bool := Id.run do
  if info.paramInfo[i]!.isDecInst then
    for j in info.paramInfo[i]!.backDeps do
      if kinds[j]! matches CongrArgKind.eq then
        return true
  return false

/--
If `f` is a class constructor, return a bitmask `m` s.t. `m[i]` is true if the `i`-th parameter
corresponds to a subobject field.

We use this function to implement the special support for class constructors at `getCongrSimpKinds`.
See issue #1808
-/
private def getClassSubobjectMask? (f : Expr) : MetaM (Option (Array Bool)) := do
  let .const declName _ := f | return none
  let .ctorInfo val ← getConstInfo declName | return none
  unless isClass (← getEnv) val.induct do return none
  forallTelescopeReducing val.type fun xs _ => do
    let env ← getEnv
    let mut mask := #[]
    for i in [:xs.size] do
      if i < val.numParams then
        mask := mask.push false
      else
        let localDecl ← xs[i]!.fvarId!.getDecl
        mask := mask.push (isSubobjectField? env val.induct localDecl.userName).isSome
    return some mask

/-- Compute `CongrArgKind`s for a simp congruence theorem. -/
def getCongrSimpKinds (f : Expr) (info : FunInfo) : MetaM (Array CongrArgKind) := do
  /-
  The default `CongrArgKind` is `eq`, which allows `simp` to rewrite this
  argument. However, if there are references from `i` to `j`, we cannot
  rewrite both `i` and `j`. So we must change the `CongrArgKind` at
  either `i` or `j`. In principle, if there is a dependency with `i`
  appearing after `j`, then we set `j` to `fixed` (or `cast`). But there is
  an optimization: if `i` is a subsingleton, we can fix it instead of
  `j`, since all subsingletons are equal anyway. The fixing happens in
  two loops: one for the special cases, and one for the general case.

  This method has special support for class constructors.
  For this kind of function, we treat subobject fields as regular parameters instead of instance implicit ones.
  We added this feature because of issue #1808
  -/
  let mut result := #[]
  let mask? ← getClassSubobjectMask? f
  for i in [:info.paramInfo.size] do
    if info.resultDeps.contains i then
      result := result.push .fixed
    else if info.paramInfo[i]!.isProp then
      result := result.push .cast
    else if info.paramInfo[i]!.isInstImplicit then
      if let some mask := mask? then
        if h : i < mask.size then
          if mask[i] then
            -- Parameter is a subobect field of a class constructor. See comment above.
            result := result.push .eq
            continue
      if shouldUseSubsingletonInst info result i then
        result := result.push .subsingletonInst
      else
        result := result.push .fixed
    else
      result := result.push .eq
  return fixKindsForDependencies info result

/--
  Create a congruence theorem that is useful for the simplifier and `congr` tactic.
-/
partial def mkCongrSimpCore? (f : Expr) (info : FunInfo) (kinds : Array CongrArgKind) (subsingletonInstImplicitRhs : Bool := true) : MetaM (Option CongrTheorem) := do
  if let some result ← mk? f info kinds then
    return some result
  else if hasCastLike kinds then
    -- Simplify kinds and try again
    let kinds := kinds.map fun kind =>
      if kind matches CongrArgKind.cast || kind matches CongrArgKind.subsingletonInst then CongrArgKind.fixed else kind
    mk? f info kinds
  else
    return none
where
  /--
    Create a congruence theorem that is useful for the simplifier.
    In this kind of theorem, if the i-th argument is a `cast` argument, then the theorem
    contains an input `a_i` representing the i-th argument in the left-hand-side, and
    it appears with a cast (e.g., `Eq.drec ... a_i ...`) in the right-hand-side.
    The idea is that the right-hand-side of this theorem "tells" the simplifier
    how the resulting term looks like. -/
  mk? (f : Expr) (info : FunInfo) (kinds : Array CongrArgKind) : MetaM (Option CongrTheorem) := do
    try
      let fType ← inferType f
      forallBoundedTelescope fType kinds.size fun lhss _ => do
        if lhss.size != kinds.size then return none
        let rec go (i : Nat) (rhss : Array Expr) (eqs : Array (Option Expr)) (hyps : Array Expr) : MetaM CongrTheorem := do
          if i == kinds.size then
            let lhs := mkAppN f lhss
            let rhs := mkAppN f rhss
            let type ← mkForallFVars hyps (← mkEq lhs rhs)
            let proof ← mkProof type kinds
            return { type, proof, argKinds := kinds }
          else
            let hyps := hyps.push lhss[i]!
            match kinds[i]! with
            | .heq | .fixedNoParam => unreachable!
            | .eq =>
              let localDecl ← lhss[i]!.fvarId!.getDecl
              withLocalDecl localDecl.userName localDecl.binderInfo localDecl.type fun rhs => do
              withLocalDeclD (localDecl.userName.appendBefore "e_") (← mkEq lhss[i]! rhs) fun eq => do
                go (i+1) (rhss.push rhs) (eqs.push eq) (hyps.push rhs |>.push eq)
            | .fixed => go (i+1) (rhss.push lhss[i]!) (eqs.push none) hyps
            | .cast =>
              let rhsType := (← inferType lhss[i]!).replaceFVars (lhss[:rhss.size]) rhss
              let rhs ← mkCast lhss[i]! rhsType info.paramInfo[i]!.backDeps eqs
              go (i+1) (rhss.push rhs) (eqs.push none) hyps
            | .subsingletonInst =>
              -- The `lhs` does not need to instance implicit since it can be inferred from the LHS
              withNewBinderInfos #[(lhss[i]!.fvarId!, .implicit)] do
                let rhsType := (← inferType lhss[i]!).replaceFVars (lhss[:rhss.size]) rhss
                let rhsBi   := if subsingletonInstImplicitRhs then .instImplicit else .implicit
                withLocalDecl (← lhss[i]!.fvarId!.getDecl).userName rhsBi rhsType fun rhs =>
                  go (i+1) (rhss.push rhs) (eqs.push none) (hyps.push rhs)
        return some (← go 0 #[] #[] #[])
    catch _ =>
      return none

  mkProof (type : Expr) (kinds : Array CongrArgKind) : MetaM Expr := do
    let rec go (i : Nat) (type : Expr) : MetaM Expr := do
      if i == kinds.size then
        let some (_, lhs, _) := type.eq? | unreachable!
        mkEqRefl lhs
      else
        withNext type fun lhs type => do
        match kinds[i]! with
        | .heq | .fixedNoParam => unreachable!
        | .fixed => mkLambdaFVars #[lhs] (← go (i+1) type)
        | .cast => mkLambdaFVars #[lhs] (← go (i+1) type)
        | .eq =>
          let typeSub := type.bindingBody!.bindingBody!.instantiate #[(← mkEqRefl lhs), lhs]
          withNext type fun rhs type =>
          withNext type fun heq type => do
            let motive ← mkLambdaFVars #[rhs, heq] type
            let proofSub ← go (i+1) typeSub
            mkLambdaFVars #[lhs, rhs, heq] (← mkEqRec motive proofSub heq)
        | .subsingletonInst =>
          let typeSub := type.bindingBody!.instantiate #[lhs]
          withNext type fun rhs type => do
            let motive ← mkLambdaFVars #[rhs] type
            let proofSub ← go (i+1) typeSub
            let heq ← mkAppM ``Subsingleton.elim #[lhs, rhs]
            mkLambdaFVars #[lhs, rhs] (← mkEqNDRec motive proofSub heq)
     go 0 type

/--
Create a congruence theorem for `f`. The theorem is used in the simplifier.

If `subsingletonInstImplicitRhs = true`, the the `rhs` corresponding to `[Decidable p]` parameters
is marked as instance implicit. It forces the simplifier to compute the new instance when applying
the congruence theorem.
For the `congr` tactic we set it to `false`.
-/
def mkCongrSimp? (f : Expr) (subsingletonInstImplicitRhs : Bool := true) : MetaM (Option CongrTheorem) := do
  let f := (← instantiateMVars f).cleanupAnnotations
  let info ← getFunInfo f
  mkCongrSimpCore? f info (← getCongrSimpKinds f info) (subsingletonInstImplicitRhs := subsingletonInstImplicitRhs)

end Lean.Meta


structure X := ( a : Type )
definition x : X := { a := unit }
definition y : X := { a := unit }
lemma t : x^.a = unit := begin
                           dsimp [ y ],
                           dsimp [ x ],
                           refl
                         end


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

Properties of the multivariate Gaussian distribution.
-/
import .tfacts .tgrads

namespace certigrad
namespace T

axiom is_integrable_mvn_of_sub_exp {shape₁ shape₂ : S} (μ σ : T shape₁) (f : T shape₁ → T shape₂) :
  is_btw_exp₂ f → is_integrable (λ x, mvn_pdf μ σ x ⬝ f x)

axiom is_uintegrable_mvn_of_bounded_exp₂_around {shape₁ shape₂ shape₃ : S} (pdf : T shape₁ → ℝ) (f : T shape₁ → T shape₂ → T shape₃) (θ : T shape₂) :
  is_bounded_btw_exp₂_around f θ → is_uniformly_integrable_around (λ θ₀ x, pdf x ⬝ f x θ₀) θ

end T

section tactic
open tactic

meta def prove_is_mvn_integrable_core : tactic unit :=
first [
       applyc `certigrad.T.is_btw_id
     , applyc `certigrad.T.is_btw_const
     , applyc `certigrad.T.is_btw_sigmoid
     , applyc `certigrad.T.is_btw_softplus
     , applyc `certigrad.T.is_btw_sum
     , applyc `certigrad.T.is_btw_log_sigmoid
     , applyc `certigrad.T.is_btw_log_1msigmoid
     , applyc `certigrad.T.is_btw_gemm
     , applyc `certigrad.T.is_btw_transpose
     , applyc `certigrad.T.is_btw_neg
     , applyc `certigrad.T.is_btw_inv
     , applyc `certigrad.T.is_btw_add
     , applyc `certigrad.T.is_btw_mul
     , applyc `certigrad.T.is_btw_sub
     , applyc `certigrad.T.is_btw_div
     , applyc `certigrad.T.is_btw_exp

     , applyc `certigrad.T.is_sub_quadratic_id
     , applyc `certigrad.T.is_sub_quadratic_const
     , applyc `certigrad.T.is_sub_quadratic_gemm
     , applyc `certigrad.T.is_sub_quadratic_transpose
     , applyc `certigrad.T.is_sub_quadratic_neg
     , applyc `certigrad.T.is_sub_quadratic_add
     , applyc `certigrad.T.is_sub_quadratic_softplus
     , applyc `certigrad.T.is_sub_quadratic_mul₁
     , applyc `certigrad.T.is_sub_quadratic_mul₂
     , applyc `certigrad.T.is_sub_quadratic_sub
     , prove_preconditions_core
]

meta def prove_is_mvn_integrable : tactic unit :=
do applyc `certigrad.T.is_integrable_mvn_of_sub_exp,
   repeat prove_is_mvn_integrable_core

meta def prove_is_mvn_uintegrable_core_helper : tactic unit :=
first [applyc `certigrad.T.is_bbtw_of_btw
     , applyc `certigrad.T.is_bbtw_id
     , applyc `certigrad.T.is_bbtw_bernoulli_neglogpdf
     , applyc `certigrad.T.is_bbtw_softplus
     , applyc `certigrad.T.is_bbtw_sum
     , applyc `certigrad.T.is_bbtw_log_sigmoid
     , applyc `certigrad.T.is_bbtw_log_1msigmoid
     , applyc `certigrad.T.is_bbtw_gemm
     , applyc `certigrad.T.is_bbtw_neg
     , applyc `certigrad.T.is_bbtw_inv
     , applyc `certigrad.T.is_bbtw_mul
     , applyc `certigrad.T.is_bbtw_sub
     , applyc `certigrad.T.is_bbtw_add
     , applyc `certigrad.T.is_bbtw_exp
] <|> (intro1 >> skip)

meta def prove_is_mvn_uintegrable_core : tactic unit :=
do try T.simplify_grad,
   applyc `certigrad.T.is_uintegrable_mvn_of_bounded_exp₂_around,
   repeat (prove_is_mvn_uintegrable_core_helper <|> prove_is_mvn_integrable_core)

meta def prove_is_mvn_uintegrable : tactic unit :=
-- TODO(dhs): why do I need the `try`?
(split >> focus [prove_is_mvn_uintegrable, prove_is_mvn_uintegrable]) <|> try prove_is_mvn_uintegrable_core

end tactic

namespace T
axiom mvn_const_int {shape oshape : S} (μ σ : T shape) : σ > 0 → ∀ (y : T oshape), is_integrable (λ (x : T shape), mvn_pdf μ σ x ⬝ y)
axiom mvn_moment₁_int {shape : S} (μ σ : T shape) : σ > 0 → is_integrable (λ (x : T shape), mvn_pdf μ σ x ⬝ x)
axiom mvn_moment₂_int {shape : S} (μ σ : T shape) : σ > 0 → is_integrable (λ (x : T shape), mvn_pdf μ σ x ⬝ square x)
axiom mvn_cmoment₂_int {shape : S} (μ σ : T shape) (H_σ : σ > 0) : is_integrable (λ (x : T shape), T.mvn_pdf μ σ x ⬝ square (x - μ))

axiom mvn_logpdf_int {shape : S} (μ μ' σ σ' : T shape) (H_σ : σ > 0) (H_σ' : σ' > 0) : is_integrable (λ (x : T shape), T.mvn_pdf μ σ x ⬝ mvn_logpdf μ' σ' x)

-- TODO(dhs): prove in terms of primitives (possibly for concrete p)
axiom mvn_bernoulli_neglogpdf_int {shape₁ shape₂ : S} (μ σ : T shape₁) (H_σ : σ > 0) (p : T shape₁ → T shape₂)
                                      (H_p_cont : ∀ x, is_continuous p x) (H_p : ∀ x, p x > 0 ∧ p x < 1) (z : T shape₂) :
  is_integrable (λ (x : T shape₁), T.mvn_pdf μ σ x ⬝ bernoulli_neglogpdf (p x) z)

axiom mvn_mvn_empirical_kl_int {shape : S} (μ σ : T shape) (H_σ : σ > 0) (μ' σ' : T shape) :
  is_integrable (λ (x : T shape), T.mvn_pdf μ σ x ⬝ mvn_empirical_kl μ' σ' x)

axiom mvn_mvn_kl_int {shape : S} (μ σ : T shape) (H_σ : σ > 0) (μ' σ' : T shape) :
  is_integrable (λ (x : T shape), T.mvn_pdf μ σ x ⬝ mvn_kl μ' σ')

-- mvn is a distribution (provable from first principles)
axiom mvn_pdf_pos {shape : S} (μ σ : T shape) : σ > 0 → ∀ (x : T shape), mvn_pdf μ σ x > 0
axiom mvn_pdf_int1 {shape : S} (μ σ : T shape) : σ > 0 → ∫ (λ (x : T shape), mvn_pdf μ σ x) = 1

lemma mvn_expected {shape oshape : S} (μ σ : T shape) : σ > 0 → ∀ (y : T oshape), ∫ (λ (x : T shape), mvn_pdf μ σ x ⬝ y) = y :=
by { intros H_σ y, rw [integral_fscale, (mvn_pdf_int1 _ _ H_σ), one_smul] }

-- moments (provable from first principles)
axiom mvn_moment₁ {shape : S} (μ σ : T shape) (H_σ : σ > 0) : ∫ (λ (x : T shape), T.mvn_pdf μ σ x ⬝ x) = μ
axiom mvn_moment₂ {shape : S} (μ σ : T shape) (H_σ : σ > 0) : ∫ (λ (x : T shape), T.mvn_pdf μ σ x ⬝ square x) = square μ + square σ

-- central moments (provable in terms of moments)
lemma mvn_cmoment₁ {shape : S} (μ σ : T shape) (H_σ : σ > 0) : ∫ (λ (x : T shape), T.mvn_pdf μ σ x ⬝ (x - μ)) = 0 :=
have H_int_x : is_integrable (λ x, mvn_pdf μ σ x ⬝ x), from mvn_moment₁_int μ σ H_σ,
have H_int_μ : is_integrable (λ x, - (mvn_pdf μ σ x ⬝ μ)), from iff.mp (is_integrable_neg _) (mvn_const_int μ σ H_σ μ),
calc  ∫ (λ (x : T shape), T.mvn_pdf μ σ x ⬝ (x - μ))
    = ∫ (λ (x : T shape), T.mvn_pdf μ σ x ⬝ x + - (T.mvn_pdf μ σ x ⬝ μ)) : begin simp [smul_addr, smul_neg], end
... = ∫ (λ (x : T shape), T.mvn_pdf μ σ x ⬝ x) - ∫ (λ (x : T shape), T.mvn_pdf μ σ x ⬝ μ)
        : begin simp [integral_add, H_int_x, H_int_μ, integral_neg] end
... = μ - μ : by { rw [mvn_expected _ _ H_σ, mvn_moment₁ _ _ H_σ],  }
... = 0 : by simp

-- Exercise for the reader: prove
axiom mvn_cmoment₂ {shape : S} (μ σ : T shape) (H_σ : σ > 0) : ∫ (λ (x : T shape), T.mvn_pdf μ σ x ⬝ square (x - μ)) = square σ

-- central scaled moments (provable in terms of central moments)
lemma mvn_csmoment₁ {shape : S} (μ σ : T shape) (H_σ : σ > 0) : ∫ (λ (x : T shape), T.mvn_pdf μ σ x ⬝ ((x - μ) / σ)) = 0 :=
have H_int_xσ : is_integrable (λ (x : T shape), T.mvn_pdf μ σ x ⬝ (x / σ)),
  by { simp [smul_div], exact iff.mp (is_integrable_div _ _ H_σ) (mvn_moment₁_int _ _ H_σ) },

have H_int_μσ : is_integrable (λ (x : T shape), -(T.mvn_pdf μ σ x ⬝ (μ / σ))),
 by { apply iff.mp (is_integrable_neg _), simp [smul_div], exact iff.mp (is_integrable_div _ _ H_σ) (mvn_const_int _ _ H_σ _) },

calc  ∫ (λ (x : T shape), T.mvn_pdf μ σ x ⬝ ((x - μ) / σ))
    = ∫ (λ (x : T shape), T.mvn_pdf μ σ x ⬝ (x / σ) - (T.mvn_pdf μ σ x ⬝ (μ / σ)))
        : by simp [T.div_add_div_same_symm, smul_addr, sum_add, neg_div, smul_neg, integral_neg]
... = ∫ (λ (x : T shape), T.mvn_pdf μ σ x ⬝ (x / σ)) - ∫ (λ (x : T shape), T.mvn_pdf μ σ x ⬝ (μ / σ))
        : begin simp [integral_add, H_int_xσ, H_int_μσ, integral_neg] end
... = ∫ (λ (x : T shape), T.mvn_pdf μ σ x ⬝ x) / σ - ∫ (λ (x : T shape), T.mvn_pdf μ σ x ⬝ (μ / σ))
        : by simp [smul_div, integral_div]
... = μ / σ - μ / σ : by rw [mvn_moment₁ _ _ H_σ, mvn_expected _ _ H_σ]
... = 0 : by simp

-- Exercise for the reader: prove
axiom mvn_csmoment₂ {shape : S} (μ σ : T shape) (H_σ : σ > 0) : ∫ (λ (x : T shape), T.mvn_pdf μ σ x ⬝ square ((x - μ) / σ)) = (1 : T shape)

lemma mvn_logpdf_correct {shape : S} (μ σ x : T shape) (H_σ : σ > 0) : log (mvn_pdf μ σ x) = mvn_logpdf μ σ x :=
have H_σ₂ : square σ > 0, from square_pos_of_pos H_σ,
have H_mul : (2 * pi shape) * square σ > 0, from mul_pos_of_pos_pos two_pi_pos H_σ₂,
have H_sqrt : (sqrt ((2 * pi shape) * square σ))⁻¹ > 0, from inv_pos (sqrt_pos H_mul),
have H_exp : exp ((- 2⁻¹) * (square $ (x - μ) / σ)) > 0, from exp_pos,
have H_mul₂ : (sqrt ((2 * pi shape) * square σ))⁻¹ * exp ((- 2⁻¹) * (square $ (x - μ) / σ)) > 0,
from mul_pos_of_pos_pos H_sqrt H_exp,
calc  log (mvn_pdf μ σ x)
    = log (prod ((sqrt ((2 * pi shape) * square σ))⁻¹ * exp ((- 2⁻¹) * (square $ (x - μ) / σ)))) : rfl
... = sum (log ((sqrt ((2 * pi shape) * square σ))⁻¹) + ((- 2⁻¹) * (square $ (x - μ) / σ))) : by simp only [log_prod H_mul₂, log_mul H_sqrt H_exp, log_exp]
... = sum ((- 2⁻¹) * log ((2 * pi shape) * square σ) + ((- 2⁻¹) * (square $ (x - μ) / σ))) : by simp [log_inv, log_sqrt]
... = sum ((- 2⁻¹) * (log (2 * pi shape) + log (square σ)) + (- 2⁻¹) * (square $ (x - μ) / σ)) : by simp only [log_mul two_pi_pos H_σ₂]
... = sum ((- 2⁻¹) * (log (2 * pi shape) + log (square σ) + (square $ (x - μ) / σ))) : by simp only [left_distrib]
... = sum ((- (2 : ℝ)⁻¹) ⬝ (log (2 * pi shape) + log (square σ) + (square $ (x - μ) / σ))) : by simp only [smul.def, const_neg, const_inv, const_bit0, const_one]
... = (- 2⁻¹) * sum (square ((x - μ) / σ) + log (2 * pi shape) + log (square σ)) : by simp [sum_smul]
... = mvn_logpdf μ σ x : rfl

lemma mvn_int_const {shape : S} (μ σ : T shape) (H_σ : σ > 0) (y : ℝ) :
  ∫ (λ (x : T shape), T.mvn_pdf μ σ x ⬝ y) = y :=
by { rw [integral_fscale, (mvn_pdf_int1 _ _ H_σ), one_smul] }

lemma mvn_integral₁ {shape : S} (μ σ : T shape) (H_σ : σ > 0) :
∫ (λ (x : T shape), T.mvn_pdf μ σ x ⬝ T.mvn_logpdf 0 1 x)
=
(- 2⁻¹) * sum (square μ + square σ) + (- 2⁻¹) * sum (log (2 * pi shape)) :=
have H_sq_x_int : is_integrable (λ (x : T shape), T.mvn_pdf μ σ x ⬝ square x), from mvn_moment₂_int _ _ H_σ,
have H_log_pi_int : is_integrable (λ (x : T shape), T.mvn_pdf μ σ x ⬝ log (2 * pi shape)), from mvn_const_int _ _ H_σ _,
have H_sum_int : is_integrable (λ (x : T shape), T.mvn_pdf μ σ x ⬝ (square x + log (2 * pi shape))),
  begin simp only [smul_addr], exact iff.mp (is_integrable_add _ _) (and.intro H_sq_x_int H_log_pi_int) end,
calc  ∫ (λ (x : T shape), T.mvn_pdf μ σ x ⬝ ((- 2⁻¹) * sum (square ((x - 0) / 1) + log (2 * pi shape) + log (square 1))))
    = ∫ (λ (x : T shape), T.mvn_pdf μ σ x ⬝ ((- 2⁻¹) * sum (square x + log (2 * pi shape)))) : by simp [log_one, square, T.div_one]
... = ∫ (λ (x : T shape), (- (2 : ℝ)⁻¹) ⬝ (T.mvn_pdf μ σ x ⬝ sum (square x + log (2 * pi shape)))) : by simp only [smul_mul_scalar_right]
... = (- 2⁻¹) * ∫ (λ (x : T shape), T.mvn_pdf μ σ x ⬝ sum (square x + log (2 * pi shape))) : by { simp only [integral_scale], simp [smul.def] }
... = (- 2⁻¹) * sum (∫ (λ (x : T shape), T.mvn_pdf μ σ x ⬝ (square x + log (2 * pi shape)))) : by { simp only [integral_sum, H_sum_int, smul_sum] }
... = (- 2⁻¹) * sum (∫ (λ (x : T shape), T.mvn_pdf μ σ x ⬝ square x + T.mvn_pdf μ σ x ⬝ log (2 * pi shape))) : by { simp only [smul_addr] }
... = (- 2⁻¹) * sum (∫ (λ (x : T shape), T.mvn_pdf μ σ x ⬝ square x) + ∫ (λ (x : T shape), T.mvn_pdf μ σ x ⬝ log (2 * pi shape)))
       : by { simp only [integral_add, H_sq_x_int, H_log_pi_int] }
... = (- 2⁻¹) * (sum (square μ + square σ) + sum (log (2 * pi shape))) : by rw [mvn_moment₂ _ _ H_σ, mvn_expected _ _ H_σ, sum_add]
... = (- 2⁻¹) * sum (square μ + square σ) + (- 2⁻¹) * sum (log (2 * pi shape)) : by rw left_distrib

lemma mvn_integral₂ {shape : S} (μ σ : T shape) (H_σ : σ > 0) :
∫ (λ (x : T shape), T.mvn_pdf μ σ x ⬝ T.mvn_logpdf μ σ x)
=
(- 2⁻¹) * sum (1 : T shape) + (- 2⁻¹) * sum (log (2 * pi shape)) + (- 2⁻¹) * sum (log (square σ)) :=
have H_int₁ : is_integrable (λ (x : T shape), mvn_pdf μ σ x ⬝ (-2⁻¹ * sum (square ((x - μ) / σ)))),
begin
simp only [smul_mul_scalar_right, integral_scale],
apply iff.mp (is_integrable_scale _ _),
simp only [smul_sum],
apply iff.mp (is_integrable_sum _),
simp only [square_div, smul_div],
apply iff.mp (is_integrable_div _ _ (square_pos_of_pos H_σ)),
exact mvn_cmoment₂_int _ _ H_σ,
end,

have H_int₂ : is_integrable (λ (x : T shape), mvn_pdf μ σ x ⬝ (-2⁻¹ * sum (log (2 * pi shape)))),
begin
simp only [smul_mul_scalar_right, integral_scale],
apply iff.mp (is_integrable_scale _ _),
simp only [smul_sum],
apply iff.mp (is_integrable_sum _),
exact mvn_const_int _ _ H_σ _
end,

have H_int₁₂ : is_integrable (λ (x : T shape), mvn_pdf μ σ x ⬝ (-2⁻¹ * sum (square ((x - μ) / σ))) + mvn_pdf μ σ x ⬝ (-2⁻¹ * sum (log (2 * pi shape)))),
from iff.mp (is_integrable_add _ _) (and.intro H_int₁ H_int₂),

have H_int₃ : is_integrable (λ (x : T shape), mvn_pdf μ σ x ⬝ (-2⁻¹ * sum (log (square σ)))),
begin
simp only [smul_mul_scalar_right, integral_scale],
apply iff.mp (is_integrable_scale _ _),
simp only [smul_sum],
apply iff.mp (is_integrable_sum _),
exact mvn_const_int _ _ H_σ _
end,

have H_int₄ : is_integrable (λ (x : T shape), T.mvn_pdf μ σ x ⬝ square ((x - μ) / σ)),
begin
simp only [square_div, smul_div],
apply iff.mp (is_integrable_div _ _ (square_pos_of_pos H_σ)),
exact mvn_cmoment₂_int _ _ H_σ,
end,

have H₁ : ∫ (λ (x : T shape), T.mvn_pdf μ σ x ⬝ ((- 2⁻¹) * sum (square ((x - μ) / σ)))) = (- 2⁻¹) * sum (1 : T shape), from
calc  ∫ (λ (x : T shape), T.mvn_pdf μ σ x ⬝ ((- 2⁻¹) * sum (square ((x - μ) / σ))))
    = ∫ (λ (x : T shape), (- (2 : ℝ)⁻¹) ⬝ (T.mvn_pdf μ σ x ⬝ sum (square ((x - μ) / σ)))) : by simp only [smul_mul_scalar_right]
... = (- 2⁻¹) * ∫ (λ (x : T shape), T.mvn_pdf μ σ x ⬝ sum (square ((x - μ) / σ))) : by { simp only [integral_scale], simp [smul.def] }
... = (- 2⁻¹) * sum (∫ (λ (x : T shape), T.mvn_pdf μ σ x ⬝ square ((x - μ) / σ))) : by simp only [smul_sum, integral_sum, H_int₄]
... = (- 2⁻¹) * sum (1 : T shape) : by rw (mvn_csmoment₂ _ _ H_σ),

have H₂ : ∫ (λ (x : T shape), T.mvn_pdf μ σ x ⬝ ((- 2⁻¹) * sum (log (2 * pi shape)))) = (- 2⁻¹) * sum (log (2 * pi shape)), by rw (mvn_int_const μ _ H_σ),

have H₃ : ∫ (λ (x : T shape), T.mvn_pdf μ σ x ⬝ ((- 2⁻¹) * sum (log (square σ)))) = (- 2⁻¹) * sum (log (square σ)), by rw mvn_int_const μ _ H_σ,
begin
dunfold mvn_logpdf,
simp only [sum_add, left_distrib, smul_addr, integral_add, H₁, H₂, H₃, H_int₁₂, H_int₁, H_int₂, H_int₃],
end

lemma mvn_kl_identity {shape : S} (μ σ : T shape) (H_σ : σ > 0) :
∫ (λ (x : T shape), T.mvn_pdf μ σ x ⬝ T.mvn_empirical_kl μ σ x)
=
T.mvn_kl μ σ :=
have H_logpdf_int : is_integrable (λ (x : T shape), T.mvn_pdf μ σ x ⬝ mvn_logpdf μ σ x),
from mvn_logpdf_int μ μ σ σ H_σ H_σ,

have H_std_logpdf_int : is_integrable (λ (x : T shape), - (T.mvn_pdf μ σ x ⬝ mvn_logpdf 0 1 x)),
from iff.mp (is_integrable_neg _) (mvn_logpdf_int μ 0 σ 1 H_σ one_pos),

calc  ∫ (λ (x : T shape), T.mvn_pdf μ σ x ⬝ T.mvn_empirical_kl μ σ x)
    = ∫ (λ (x : T shape), T.mvn_pdf μ σ x ⬝ (mvn_logpdf μ σ x - mvn_logpdf 0 1 x)) : rfl
... = ∫ (λ (x : T shape), T.mvn_pdf μ σ x ⬝ mvn_logpdf μ σ x + - (T.mvn_pdf μ σ x ⬝ mvn_logpdf 0 1 x)) : by simp [smul_addr, smul_neg]
... = ∫ (λ (x : T shape), T.mvn_pdf μ σ x ⬝ mvn_logpdf μ σ x) - ∫ (λ (x : T shape), T.mvn_pdf μ σ x ⬝ mvn_logpdf 0 1 x)
      : by simp [integral_add, H_logpdf_int, H_std_logpdf_int, integral_neg]
... = ((- 2⁻¹) * sum (1 : T shape) + (- 2⁻¹) * sum (log (2 * pi shape)) + (- 2⁻¹) * sum (log (square σ))) - ((- 2⁻¹) * sum (square μ + square σ) + (- 2⁻¹) * sum (log (2 * pi shape))) : by rw [mvn_integral₁ μ σ H_σ, mvn_integral₂ μ σ H_σ]
... = (- 2⁻¹) * sum ((1 : T shape) + log (2 * pi shape) + log (square σ) - square μ - square σ - log (2 * pi shape)) : by simp [sum_add, left_distrib, sum_neg]
... = (- 2⁻¹) * sum ((1 : T shape) + log (square σ) - square μ - square σ + (log (2 * pi shape) - log (2 * pi shape))) : by simp
... = (- 2⁻¹) * sum ((1 : T shape) + log (square σ) - square μ - square σ) : by simp
... = T.mvn_kl μ σ : rfl

end T
end certigrad


import aux
import parlang.def
import parlang.lemmas_exec
import data.bool

namespace parlang

variables {σ : Type} {ι : Type} {τ : ι → Type} [decidable_eq ι]

/-

    because this holds for all n and ac the pre- and postcondition probably contain ite or forall quantifiers
-/
def hoare (P : thread_state σ τ → Prop) (k : kernel σ τ) (Q : thread_state σ τ → Prop) : Prop :=
∀ {n} {s u : state n σ τ} {ac : vector bool n}, (∀i : fin n, ac.nth i → P (s.threads.nth i)) → exec_state k ac s u → (∀i : fin n, ac.nth i → Q (u.threads.nth i))

notation `{* ` P : 1 ` *} ` k : 1 ` {* ` Q : 1 ` *}` := hoare P k Q

example (P Q : thread_state σ τ → Prop) (k₁ k₂ : kernel σ τ) (c : σ → bool) :
    {* λ (t : thread_state σ τ), P t ∧ c t.tlocal *} k₁ {* Q *} → -- how is it possible that by loosening up the assumptions (i. e. and something to P) the proof gets possible?
    {* λ (t : thread_state σ τ), P t ∧ ¬c t.tlocal *} k₂ {* Q *} →
    {* P *} kernel.ite c k₁ k₂ {* Q *} :=
begin
    intros h_then h_else n s u ac hp he i hac,
    cases he,
    have : _ := exec_state_comm_distinct_ac _ he_a he_a_1,
    cases this with t' this,
    -- we reorder the execution (and state transition respectively) to macht the hoare triplets using exec_state_comm_distinct_ac
    -- either the condition holds or not for any thread i
    -- ?? in either case we have to go through both executions ??
    by_cases hc : (c (vector.nth (s.threads) i).tlocal = tt),
    {
        apply h_then,
        tactic.swap,
        exact this.right,
        intros i' hh,
        have hh' : _ := deactivate_threads_alive hh,
        have heqst' : vector.nth (s.threads) i' = vector.nth (t'.threads) i' := begin
            apply exec_state_inactive_threads_untouched this.left,
            apply deactivate_threads_complement hh,
        end,
        rw ← heqst',
        apply and.intro,
        {
            exact hp i' hh',
        }, {
            exact deactivate_threads_condition hh,
        }, {
            apply active_map_deactivate_threads hac (bool.eq_tt_coe.mpr hc),
        },
    }, {
        apply h_else,
        tactic.swap,
        exact he_a_1,
        intros i' hh,
        have hh' : _ := deactivate_threads_alive hh,
        have heqst' : vector.nth (s.threads) i' = vector.nth (he_t.threads) i' := begin
            apply exec_state_inactive_threads_untouched he_a,
            apply deactivate_threads_complement,
            rw bool.bnot_bnot,
            exact hh,
        end,
        rw ← heqst',
        apply and.intro,
        {
            exact hp i' hh',
        }, {
            exact deactivate_threads_condition' hh,
        }, {
            rw ← bool.eq_tt_coe at hc,
            apply active_map_deactivate_threads' hac hc,
        }
    }, {
        sorry,
    }
end

example :
    {* λ (t : thread_state (ℕ × ℕ) τ), t.tlocal.1 = 0 ∧ t.tlocal.1 = 0 *} kernel.compute (λ l, (l.1, 1)) {* λ (t : thread_state (ℕ × ℕ) τ), t.tlocal.2 = 1 *} →
    {* λ (t : thread_state (ℕ × ℕ) τ), t.tlocal.1 = 0 ∧ ¬t.tlocal.1 = 0 *} kernel.compute (λ l, (l.1, 2)) {* λ (t : thread_state (ℕ × ℕ) τ), t.tlocal.2 = 1 *} →
    {* λ (t : thread_state (ℕ × ℕ) τ), t.tlocal.1 = 0 *} kernel.ite (λt, t.1 = 0) (kernel.compute (λ l, (l.1, 1))) (kernel.compute (λ l, (l.1, 2))) {* λ (t : thread_state (ℕ × ℕ) τ), t.tlocal.2 = 1 *} := begin
    intros h_then h_else n s u ac hp he i hac,
    cases he,
    sorry,
end

end parlang


example : mynat → mynat :=
begin
intro n, exact 3*n+2,
end


import condensed.top_comparison

open category_theory

namespace Condensed

universes u
variables {X Y : Condensed.{u} Ab.{u+1}} (f : X ⟶ Y)

lemma is_iso_iff_ExtrDisc :
  is_iso f ↔ (∀ S : ExtrDisc, is_iso (f.val.app (opposite.op S.val))) :=
begin
  split,
  { introsI h S,
    change is_iso ((Condensed.evaluation _ _).map f),
    apply_instance },
  { introsI h,
    suffices : is_iso ((Condensed_ExtrSheafProd_equiv Ab).functor.map f),
    { resetI,
      apply is_iso_of_fully_faithful (Condensed_ExtrSheafProd_equiv Ab.{u+1}).functor f },
    suffices : is_iso (((ExtrSheafProd_to_presheaf Ab.{u+1})).map
      ((Condensed_ExtrSheafProd_equiv Ab.{u+1}).functor.map f)),
    { resetI,
      apply is_iso_of_fully_faithful (ExtrSheafProd_to_presheaf Ab.{u+1}) },
    apply_with nat_iso.is_iso_of_is_iso_app { instances := ff },
    intros S, apply h }
end

end Condensed


import for_mathlib.algebraic_topology.homotopical_algebra.bifibrant_object
import for_mathlib.category_theory.localization.equivalence

noncomputable theory

open category_theory category_theory.limits category_theory.category category_theory

namespace algebraic_topology

namespace model_category

variables {C : Type*} [category C] [model_category C]

namespace bifibrant_replacement

def obj (X : cofibrant_object C) : bifibrant_object C :=
bifibrant_object.mk (CM5a.obj (terminal.from X.obj))

def app (X : cofibrant_object C) : X ⟶ cofibrant_object.mk (obj X).obj :=
CM5a.i (terminal.from X.obj)

instance (X : cofibrant_object C) : cofibration ((cofibrant_object.forget C).map (app X)) :=
by { dsimp [app], apply_instance, }
instance weak_eq_forget_map_app (X : cofibrant_object C) : weak_eq ((cofibrant_object.forget C).map (app X)) :=
by { dsimp [app], apply_instance, }

def app' (X : bifibrant_object C) : X ⟶ obj (cofibrant_object.mk X.obj) :=
app (cofibrant_object.mk X.obj)

def map' {X Y : cofibrant_object C} (f : X ⟶ Y) : obj X ⟶ obj Y :=
begin
  have sq : comm_sq ((cofibrant_object.forget C).map (f ≫ app Y))
    ((cofibrant_object.forget C).map (app X))
      (terminal.from (obj Y).obj) (terminal.from (obj X).obj) := by tidy,
  exact sq.lift,
end

instance (X : bifibrant_object C) : weak_eq ((bifibrant_object.forget C).map (app' X)) :=
begin
  change weak_eq ((cofibrant_object.forget C).map (app ((bifibrant_object.forget_fib C).obj X))),
  apply_instance,
end

@[reassoc]
lemma fac {X Y : cofibrant_object C} (f : X ⟶ Y) :
  app X ≫ (bifibrant_object.forget_fib C).map (map' f) = f ≫ app Y :=
by apply comm_sq.fac_left

lemma fac' {X Y : bifibrant_object C} (f : X ⟶ Y) :
  app' X ≫ map' ((bifibrant_object.forget_fib C).map f) = f ≫ app' Y :=
by apply fac

def map {X Y : cofibrant_object C} (f : X ⟶ Y) :
  bifibrant_object.homotopy_category.Q.obj (obj X) ⟶
  bifibrant_object.homotopy_category.Q.obj (obj Y) :=
bifibrant_object.homotopy_category.Q.map (map' f)

lemma map_eq {X Y : cofibrant_object C} (f : X ⟶ Y) (f' : obj X ⟶ obj Y)
  (sq : comm_sq (app X) f ((bifibrant_object.forget_fib C).map f') (app Y)) :
  map f = bifibrant_object.homotopy_category.Q.map f' :=
begin
  dsimp only [map],
  let P := path_object.some (obj Y).obj,
  rw bifibrant_object.homotopy_category.Q_map_eq_iff' P,
  have sq : comm_sq ((cofibrant_object.forget C).map (f ≫ app Y) ≫ P.σ)
    ((cofibrant_object.forget C).map (app X)) P.π
    (prod.lift ((bifibrant_object.forget C).map (map' f))
      ((bifibrant_object.forget C).map f')),
  { refine comm_sq.mk _,
    ext,
    { simpa only [pre_path_object.π, cofibrant_object.forget_map, assoc, pre_path_object.d₀σ,
        comp_id, prod.lift_fst, bifibrant_object.forget_map] using (fac f).symm, },
    { simpa only [pre_path_object.π, cofibrant_object.forget_map, assoc, comp_id,
        pre_path_object.d₁σ, prod.lift_snd, bifibrant_object.forget_map] using sq.w.symm, }, },
  exact nonempty.intro
  { h := sq.lift,
    h₀' := by simpa using congr_arg (λ f, f ≫ limits.prod.fst) sq.fac_right,
    h₁' := by simpa using congr_arg (λ f, f ≫ limits.prod.snd) sq.fac_right, },
end

end bifibrant_replacement

variable (C)

@[simps]
def bifibrant_replacement : cofibrant_object C ⥤ bifibrant_object.homotopy_category C :=
{ obj := λ X, bifibrant_object.homotopy_category.Q.obj (bifibrant_replacement.obj X),
  map := λ X Y f, bifibrant_replacement.map f,
  map_id' := λ X, begin
    rw [bifibrant_replacement.map_eq _ (𝟙 _), bifibrant_object.homotopy_category.Q.map_id],
    exact comm_sq.mk (by { simpa only [bifibrant_object.forget_fib_map, id_comp] using comp_id _,})
  end,
  map_comp' := λ X Y Z f g, begin
    rw [bifibrant_replacement.map_eq (f ≫ g)
      (bifibrant_replacement.map' f ≫ bifibrant_replacement.map' g), functor.map_comp],
    { refl, },
    { refine comm_sq.mk _,
      rw [functor.map_comp, assoc, bifibrant_replacement.fac_assoc f,
        bifibrant_replacement.fac g], },
  end, }

variables {C} {Hocof : Type*} [category Hocof] (Lcof : cofibrant_object C ⥤ Hocof)
  [Lcof.is_localization cofibrant_object.weq]
  {Hobif : Type*} [category Hobif] (Lbif : bifibrant_object C ⥤ Hobif)
  [Lbif.is_localization bifibrant_object.weq]

namespace bifibrant_replacement

@[simps]
def π : bifibrant_object.homotopy_category C ⥤ Hobif :=
bifibrant_object.homotopy_category.lift Lbif (localization.inverts Lbif bifibrant_object.weq)

lemma forget_comp_Lcof_inverts_weq :
  bifibrant_object.weq.is_inverted_by (bifibrant_object.forget_fib C ⋙ Lcof) :=
λ X Y f hf, by convert localization.inverts Lcof cofibrant_object.weq f hf

def R : cofibrant_object C ⥤ Hobif := bifibrant_replacement C ⋙ π Lbif

lemma R_inverts_weq : cofibrant_object.weq.is_inverted_by (R Lbif) := λ X Y f hf,
begin
  dsimp only [R, functor.comp_map],
  haveI : is_iso ((bifibrant_replacement C).map f),
  { dsimp only [bifibrant_replacement],
    apply bifibrant_object.homotopy_category.Q_inverts_weq,
    change model_category.weq ((bifibrant_object.forget C).map (map' f)),
    have h : weq ((cofibrant_object.forget C).map f ≫ (cofibrant_object.forget C).map (app Y)) :=
      CM2.of_comp _ _ hf weak_eq.property,
    have eq := (cofibrant_object.forget C).congr_map (fac f),
    simp only [functor.map_comp] at eq,
    rw ← eq at h,
    exact CM2.of_comp_left _ _ weak_eq.property h, },
  apply_instance,
end

def forget_comp_R_iso : bifibrant_object.forget_fib C ⋙ R Lbif ≅ Lbif :=
begin
  symmetry,
  exact nat_iso.of_components
    (λ X, localization.iso_of_hom' Lbif bifibrant_object.weq (app' X) weak_eq.property)
    (λ X Y f, by { rw [localization.iso_of_hom'_hom, ← Lbif.map_comp, ← fac', Lbif.map_comp], refl, }),
end

def R_comp_I'_iso {I' : Hobif ⥤ Hocof} (sq : Comm_sq (bifibrant_object.forget_fib C) Lbif Lcof I') :
  R Lbif ⋙ I' ≅ Lcof :=
begin
  symmetry,
  exact nat_iso.of_components (λ X, localization.iso_of_hom' Lcof cofibrant_object.weq
    (app X) weak_eq.property ≪≫ sq.iso.symm.app _) (λ X Y f, begin
    simp only [iso.trans_hom, localization.iso_of_hom'_hom, iso.app_hom, iso.symm_hom,
      functor.comp_map, assoc, ← Lcof.map_comp_assoc],
    simp only [← fac, functor.map_comp, assoc],
    congr' 1,
    apply sq.iso.inv.naturality,
  end),
end

def is_equivalence (I' : Hobif ⥤ Hocof)
  (sq : Comm_sq (bifibrant_object.forget_fib C) Lbif Lcof I') : is_equivalence I' :=
localization.lifting_is_equivalence sq bifibrant_object.weq cofibrant_object.weq
  (R Lbif) (localization.lift (R Lbif) (R_inverts_weq Lbif) Lcof)
  (R_comp_I'_iso Lcof Lbif sq) (forget_comp_R_iso Lbif)

end bifibrant_replacement

def Hobif_to_Hocof : Hobif ⥤ Hocof :=
localization.lift ((bifibrant_object.forget_fib C) ⋙ Lcof)
  (bifibrant_replacement.forget_comp_Lcof_inverts_weq Lcof) Lbif

def Lbif_comp_Hobif_to_Hocof_iso : Lbif ⋙ Hobif_to_Hocof Lcof Lbif ≅
  bifibrant_object.forget_fib C ⋙ Lcof := localization.fac _ _ _

instance : is_equivalence (Hobif_to_Hocof Lcof Lbif) :=
bifibrant_replacement.is_equivalence Lcof Lbif (Hobif_to_Hocof Lcof Lbif)
  ⟨Lbif_comp_Hobif_to_Hocof_iso Lcof Lbif⟩

instance : full (bifibrant_object.forget_fib C ⋙ Lcof) :=
full.of_iso (Lbif_comp_Hobif_to_Hocof_iso Lcof bifibrant_object.homotopy_category.Q)

end model_category

end algebraic_topology


import tactic.induction
import data.int.basic
import data.set.basic
import logic.function.iterate

import .defs .game .played_move

noncomputable theory
open_locale classical

lemma not_A_hws_at_of {pw : ℕ} {s : State}
  (h : D_hws_at pw s) : ¬A_hws_at pw s :=
begin
  cases h with d h, change ¬∃ _, _, push_neg,
  intro a, use d, rw not_A_wins_at, apply h,
end

lemma not_D_hws_at_of {pw : ℕ} {s : State}
  (h : A_hws_at pw s) : ¬D_hws_at pw s :=
begin
  cases h with d h, change ¬∃ _, _, push_neg,
  intro a, use d, rw not_D_wins_at, apply h,
end

-----

lemma act_of_not_D_hws {pw : ℕ} {s : State}
  (h : ¬D_hws_at pw s) : s.act :=
by { contrapose! h, use default, intro a, use 0 }

lemma A_hvm_of_not_D_hws {pw : ℕ} {s : State}
  (h : ¬D_hws_at pw s) :
  ∀ (md : Valid_D_move s.board),
  A_has_valid_move pw (apply_D_move s md.m).board :=
begin
  intro md, rw D_hws_at at h, push_neg at h,
  let d := (default : D).set_move s md, specialize h d,
  cases h with a h, rw not_D_wins_at at h, specialize h 1, rw play_1 at h,
  rw Game.play_move at h, split_ifs at h with h₁, swap, { contradiction },
  rw play_A_move_at at h, split_ifs at h with h₂, swap, { cases h },
  cases h₂ with h₂ h₃, convert h₃, change _ = dite _ _ _, rw dif_pos; refl,
end

lemma exi_moves_hws_of_not_D_hws {pw : ℕ} {s : State}
  (h : ¬D_hws_at pw s) :
  ∀ (md : Valid_D_move s.board) (d : D),
  ∃ (ma : Valid_A_move pw (apply_D_move s md.m).board) (a : A pw),
  (init_game a d (apply_A_move (apply_D_move s md.m) ma.m)).A_wins :=
begin
  have hs : s.act := act_of_not_D_hws h,
  have h₁ : ¬∃ _, _ := h, push_neg at h₁,
  simp_rw not_D_wins_at at h₁, rintro md d₀, let md₀ := d₀.f s hs,
  let d := d₀.set_move s md, let s' := apply_D_move s md.m,
  change apply_D_move s md.m with s',
  have h₂ : A_has_valid_move pw s'.board,
  { apply A_hvm_of_not_D_hws h },
  specialize h₁ d, cases h₁ with a h₁, let ma := a.f s' hs h₂, use [ma, a],
  have hh : d₀ = d.set_move s md₀,
  { change d₀ = (d₀.set_move s md).set_move s md₀,
    rw [D_set_move_set_move_eq, D_set_move_self] },
  rw hh, have h₃ : (init_game a d (apply_A_move s' ma.m)).A_wins,
  { convert A_wins_at_play_move_of h₁,
    rw init_game_play_move hs, change _ = dite _ _ _,
    have h₃ : (play_D_move_at (init_game a d s) hs).s = s',
    { change apply_D_move s _ = apply_D_move s _,
      congr, change dite _ _ _ = md, change (init_game a d s).s with s,
      rw dif_pos rfl },
    simp_rw h₃, rw dif_pos, swap, { split; assumption },
    ext; try {refl}, rw play_A_move_at', dsimp,

    sorry
    -- simp_rw h₃, change (play_D_move_at (init_game a d s) hs).a with a,
    -- generalize_proofs h₄, convert_to _ = apply_A_move s' (a.f s' hs h₂).m,
    -- { congr; try {exact h₃}, convert_to trivial == trivial,
    --   { exact eq_true_intro h₄ }, { exact eq_true_intro h₂ }, refl
  },
  let g : Game pw := _, change g.A_wins at h₃,
  let g₁ : Game pw := _, change g₁.A_wins,
  have h₄ : g₁ = g.set_D (d.set_move s md₀) := rfl, rw h₄, clear h₄,
  have h₄ : s.len < (g.set_D d).s.len,
  { exact length_lt_length_snoc₂ },
  apply (D_set_move_A_wins_iff h₄).mpr, exact h₃,
end

def mk_D_st_for_ma_exi_D_st {pw : ℕ} {s' : State}
  (h : ∀ (ma : Valid_A_move pw s'.board),
    ∃ (d : D), ∀ (a : A pw),
    (init_game a d (apply_A_move s' ma.m)).D_wins) :
  D :=
begin
  refine ⟨λ sx, _⟩,
  apply dite (∃ (ma : Valid_A_move pw s'.board),
    A_played_move_at sx s' ma); rintro h₁,
  { exact (h h₁.some).some.f sx },
  { exact default },
end

-- Lemma 3.1.1
-- Ross Bryant - Borel determinacy and metamathematics
-- Master's thesis, University of North Texas, 2001
lemma exi_A_move_hws_of_not_D_hws {pw : ℕ} {s : State}
  (h : ¬D_hws_at pw s) :
  ∀ (md : Valid_D_move s.board),
  ∃ (ma : Valid_A_move pw (apply_D_move s md.m).board),
  ¬D_hws_at pw (apply_A_move (apply_D_move s md.m) ma.m) :=
begin
  have hs := act_of_not_D_hws h,
  have h₁ := exi_moves_hws_of_not_D_hws h,
  intro md, specialize h₁ md, simp_rw D_hws_at, contrapose! h₁,
  simp_rw not_A_wins_at at h₁ ⊢,
  let D := mk_D_st_for_ma_exi_D_st h₁, use D,
  rintro ma a, have h₂ := h₁ ma, let s' := apply_D_move s md.m,
  change apply_D_move s md.m with s' at ma h₁ h₂ ⊢,
  let s₁ := apply_A_move s' ma.m,
  change apply_A_move s' ma.m with s₁ at h₁ h₂ ⊢,
  let d := h₂.some, have h₃ := h₂.some_spec,
  change ∀ (a : A pw), (init_game a d s₁).D_wins at h₃,
  specialize h₃ a, contrapose! h₃, rw not_D_wins_at at h₃ ⊢,
  intro n, specialize h₃ n, suffices h₄ : (init_game a D s₁).play n =
    ((init_game a d s₁).play n).set_D D, { rwa h₄ at h₃ }, clear h₃,
  induction n with n ih, { refl }, simp_rw [play_at_succ', ih], clear ih,
  let g : Game pw := _, change (init_game a d s₁).play n with g,
  simp_rw Game.play_move, change (g.set_D D).act with g.act,
  split_ifs with h₃, swap, { refl }, have h₅ : g.d = d := play_at_players_eq.2,
  simp_rw play_D_move_at, change (g.set_D D).s with g.s,
  change (g.set_D D).d with D, rw h₅,
  suffices h₆ : apply_D_move g.s (D.f g.s h₃).m =
    apply_D_move g.s (d.f g.s h₃).m,
  { rw [h₆, ←play_A_move_at_set_D], refl },
  simp_rw apply_D_move, congr' 3,
  have h₆ : ∃ (ma : Valid_A_move pw s'.board),
    A_played_move_at g.s s' ma,
  { exact ⟨_, A_played_move_at_play
    (A_played_move_at_apply_move hs rfl)⟩ },
  change (mk_D_st_for_ma_exi_D_st _).f _ _ = _,
  rw mk_D_st_for_ma_exi_D_st, dsimp,
  split_ifs with hx, swap, { contradiction }, clear hx,
  generalize_proofs h₇, change apply_D_move s md.m with s' at h₇,
  have h₈ := h₇.some_spec, change d with h₂.some, congr,
  suffices h₉ : apply_A_move (apply_D_move s md.m) h₆.some.m = s₁,
  { rw h₉ }, change apply_A_move s' _ = apply_A_move _ _, congr,
  apply A_played_move_at_eq h₆.some_spec,
  exact A_played_move_at_play (A_played_move_at_apply_move hs rfl),
end

def mk_A_st_for_not_D_hws (pw : ℕ) : A pw :=
begin
  refine ⟨λ s' h, _⟩,
  apply dite (∃ (s : State) (md : Valid_D_move s.board),
    ¬D_hws_at pw s ∧ s' = apply_D_move s md.m); rintro h₁ h₂,
  { refine (_ : ∃ (ma : Valid_A_move pw s'.board),
      ¬D_hws_at pw (apply_A_move s' ma.m)).some,
    rcases h₁ with ⟨s, md, h₁, rfl⟩,
    use (exi_A_move_hws_of_not_D_hws h₁ _).some,
    generalize_proofs h₂, exact h₂.some_spec },
  { exact ⟨_, h₂.some_spec⟩ },
end

lemma not_D_hws_at_play_of_not_D_hws {pw n : ℕ} {g : Game pw}
  (h₁ : g.a = mk_A_st_for_not_D_hws pw)
  (h₂ : ¬D_hws_at pw g.s) :
  ¬D_hws_at pw (g.play n).s :=
begin
  rename g g₀, induction n with n ih, { exact h₂ }, clear h₂,
  rw play_at_succ', let g : Game pw := _,
  change ¬D_hws_at pw g.s at ih,
  change ¬D_hws_at pw g.play_move.s,
  change g.play_move with dite _ _ _,
  split_ifs, swap, { exact ih },
  let d := g.d, let s := g.s, let md := d.f s h,
  let s' := apply_D_move s md.m,
  have h₃ : ∃ (ma : Valid_A_move pw s'.board),
    ¬D_hws_at pw (apply_A_move s' ma.m),
  { exact exi_A_move_hws_of_not_D_hws ih md },
  have ma := h₃.some, have h₄ := h₃.some_spec,
  convert h₄, change Game.s (dite _ _ _) = _,
  have h₅ : A_has_valid_move pw s'.board := ⟨_, ma.h⟩,
  change (play_D_move_at g h).s with s',
  rw dif_pos, swap, { split; assumption },
  change apply_A_move _ _ = _, congr,
  change g.a.f s' h h₅ = _, let A : A pw := _, change g₀.a = A at h₁,
  have h₆ : g.a = A := by { rw ←h₁, exact play_at_players_eq.1 },
  rw h₆, change (mk_A_st_for_not_D_hws pw).f _ _ _ = _,
  rw mk_A_st_for_not_D_hws, dsimp, rw dif_pos, exact ⟨s, md, ih, rfl⟩,
end

lemma A_hws_at_of {pw : ℕ} {s : State}
  (h : ¬D_hws_at pw s) : A_hws_at pw s :=
begin
  have hs : s.act := act_of_not_D_hws h,
  let A := mk_A_st_for_not_D_hws pw, use A, rintro d n,
  induction n with n ih, { exact hs }, rw play_at_succ',
  let g : Game pw := _, change g.act at ih, change g.play_move.act,
  let s := g.s, let md := d.f s ih, let s' := apply_D_move s md.m,
  rw play_move_at_act ih, have h₁ : play_D_move_at g ih = g.set_state s',
  { convert play_D_move_eq, change apply_D_move _ (d.f s ih).m = _,
    congr, symmetry, exact play_at_players_eq.2 },
  rw h₁, clear h₁, have h₁ : A_has_valid_move pw s'.board,
  { have h₁ : ¬D_hws_at pw s := not_D_hws_at_play_of_not_D_hws rfl h,
    exact ⟨_, (exi_A_move_hws_of_not_D_hws h₁ md).some.h⟩ },
  change Game.act (dite _ _ _), change (g.set_state s').s with s',
  rw dif_pos, swap, { split; assumption }, exact ih,
end

-----

lemma D_hws_at_of {pw : ℕ} {s : State}
  (h : ¬A_hws_at pw s) : D_hws_at pw s :=
by { contrapose! h, exact A_hws_at_of h }

lemma not_A_hws_at_iff {pw : ℕ} {s : State} :
  ¬A_hws_at pw s ↔ D_hws_at pw s :=
⟨D_hws_at_of, not_A_hws_at_of⟩

lemma not_D_hws_at_iff {pw : ℕ} {s : State} :
  ¬D_hws_at pw s ↔ A_hws_at pw s :=
⟨A_hws_at_of, not_D_hws_at_of⟩


import category_theory.adjunction.basic
import category_theory.limits.has_limits
import category_theory.limits.preserves.basic

noncomputable theory

namespace category_theory

open category

lemma adjunction.compatibility {C D : Type*} [category C] [category D]
  {G : C ⥤ D} {F : D ⥤ C} (adj : G ⊣ F) {X : C} {Y : D}
  (f : G.obj X ⟶ Y) : G.map (adj.unit.app X) ≫ (F ⋙ G).map f ≫ adj.counit.app Y = f :=
by simp only [functor.comp_map, adjunction.counit_naturality, adjunction.left_triangle_components_assoc]

section

variables {C₁ C₂ D₁ D₂ : Type*} [category C₁] [category C₂]
  [category D₁] [category D₂] {G₁ : C₁ ⥤ D₁} {F₁ : D₁ ⥤ C₁}
  {G₂ : C₂ ⥤ D₂} {F₂ : D₂ ⥤ C₂}
  (adj₁ : G₁ ⊣ F₁) (adj₂ : G₂ ⊣ F₂)
  {L : C₁ ⥤ C₂} {L' : D₁ ⥤ D₂}

include adj₁ adj₂

def adjunction.adjoint_nat_trans_equiv :
  (L ⋙ G₂ ⟶ G₁ ⋙ L') ≃ (F₁ ⋙ L ⟶ L' ⋙ F₂) :=
{ to_fun := λ τ, begin
    let α := 𝟙 (F₁ ⋙ L) ◫ adj₂.unit,
    let β := (𝟙 F₁) ◫ τ ◫ (𝟙 F₂),
    let γ := adj₁.counit ◫ 𝟙 (L' ⋙ F₂),
    exact α ≫ β ≫ γ,
  end,
  inv_fun := λ τ', begin
    let α := adj₁.unit ◫ (𝟙 (L ⋙ G₂)),
    let β := (𝟙 G₁) ◫ τ' ◫ (𝟙 G₂),
    let γ := 𝟙 (G₁ ⋙ L') ◫ adj₂.counit,
    exact α ≫ β ≫ γ,
  end,
  left_inv := λ τ, begin
    ext X,
    dsimp,
    simp only [id_comp, functor.map_id, comp_id, assoc, functor.map_comp,
      adjunction.counit_naturality, adjunction.counit_naturality_assoc,
      adjunction.left_triangle_components_assoc],
    erw τ.naturality_assoc,
    dsimp,
    rw [← L'.map_comp, adj₁.left_triangle_components, L'.map_id,
      comp_id],
  end,
  right_inv := λ τ', begin
    ext Y,
    dsimp,
    simp only [functor.map_id, id_comp, assoc, functor.map_comp,
      adjunction.unit_naturality_assoc, adjunction.right_triangle_components_assoc],
    erw ← τ'.naturality,
    dsimp,
    rw [← L.map_comp_assoc, adj₁.right_triangle_components, L.map_id, id_comp],
  end, }

@[simp]
lemma adjunction.adjoint_nat_trans_equiv_app (τ : L ⋙ G₂ ⟶ G₁ ⋙ L') (Y₁ : D₁) :
  (adjunction.adjoint_nat_trans_equiv adj₁ adj₂ τ).app Y₁ =
    adj₂.unit.app (L.obj (F₁.obj Y₁)) ≫
      F₂.map (τ.app (F₁.obj Y₁)) ≫
      F₂.map (L'.map (adj₁.counit.app Y₁)) :=
begin
  dsimp [adjunction.adjoint_nat_trans_equiv],
  simp only [functor.map_id, comp_id, id_comp],
end

@[simp]
lemma adjunction.adjoint_nat_trans_equiv_symm_app (τ : F₁ ⋙ L ⟶ L' ⋙ F₂) (X₁ : C₁) :
  ((adjunction.adjoint_nat_trans_equiv adj₁ adj₂).symm τ).app X₁ =
  G₂.map (L.map (adj₁.unit.app X₁)) ≫
      G₂.map (τ.app (G₁.obj X₁)) ≫ adj₂.counit.app (L'.obj (G₁.obj X₁)) :=
begin
  dsimp [adjunction.adjoint_nat_trans_equiv],
  simp only [id_comp, functor.map_id, comp_id],
end

end

def functor.comp_const {C D : Type*} [category C] [category D]
  (F : C ⥤ D) (J : Type*) [category J] :
  F ⋙ (functor.const J) ≅ (functor.const J) ⋙ (whiskering_right J C D).obj F :=
nat_iso.of_components (λ X, nat_iso.of_components (λ j, iso.refl _) (by tidy)) (by tidy)

namespace limits

section

variables {J : Type*} {C : Type*} [category J] [category C]
  {F : (J ⥤ C) ⥤ C} (adj : functor.const J ⊣ F)

include adj

lemma is_limit_of_is_iso_adj {X : J ⥤ C} (c : cone X)
  (h : is_iso ((adj.hom_equiv _ _) c.π)) : is_limit c :=
begin
  haveI := h,
  exact
  { lift := λ s, (adj.hom_equiv _ _) s.π ≫ inv ((adj.hom_equiv _ _) c.π),
    fac' := λ s, begin
      suffices : (functor.const J).map ((adj.hom_equiv s.X X) s.π ≫ inv ((adj.hom_equiv c.X X) c.π)) ≫ c.π = s.π,
      { exact nat_trans.congr_app this, },
      apply (adj.hom_equiv _ _).injective,
      rw [adjunction.hom_equiv_naturality_left, assoc, is_iso.inv_hom_id, comp_id],
    end,
    uniq' := λ s m hm, begin
      rw [← cancel_mono ((adj.hom_equiv c.X X) c.π), assoc, is_iso.inv_hom_id, comp_id],
      apply (adj.hom_equiv _ _).symm.injective,
      simp only [adjunction.hom_equiv_naturality_left_symm, equiv.symm_apply_apply],
      ext j,
      exact hm j,
    end, },
end

lemma is_iso_adj_of_is_limit {X : J ⥤ C} {c : cone X} (hc : is_limit c) :
  is_iso ((adj.hom_equiv _ _) c.π) :=
begin
  refine is_iso.mk ⟨hc.lift (cone.mk (F.obj X) (adj.counit.app X)), _, _⟩,
  { apply hc.hom_ext,
    intro j,
    simpa only [adjunction.hom_equiv_unit, assoc, is_limit.fac, id_comp]
      using nat_trans.congr_app (adj.compatibility c.π) j, },
  { apply (adj.hom_equiv _ _).symm.injective,
    rw [adjunction.hom_equiv_naturality_left_symm, equiv.symm_apply_apply,
      adjunction.hom_equiv_counit, functor.map_id],
    ext j,
    rw id_comp,
    apply hc.fac, },
end

@[simps]
def limit_cone_of_adj (X : J ⥤ C) : limit_cone X :=
⟨cone.mk (F.obj X) (adj.counit.app X), is_limit_of_is_iso_adj adj _ (by tidy)⟩

lemma has_limits_of_shape_of_adj : has_limits_of_shape J C :=
⟨λ X, ⟨nonempty.intro (limit_cone_of_adj adj X)⟩⟩

end

section

variables {C₁ C₂ J : Type*} [category C₁] [category C₂] [category J]
  {F₁ : (J ⥤ C₁) ⥤ C₁} {F₂ : (J ⥤ C₂) ⥤ C₂} (adj₁ : functor.const J ⊣ F₁)
  (adj₂ : functor.const J ⊣ F₂) (L : C₁ ⥤ C₂)

include adj₁ adj₂

@[simp]
def limit_comparison_of_adj : F₁ ⋙ L ⟶ (whiskering_right J _ _).obj L ⋙ F₂ :=
(adjunction.adjoint_nat_trans_equiv adj₁ adj₂)(L.comp_const J).hom

lemma preserves_limit_of_adj (X : J ⥤ C₁)
  (hX : is_iso ((limit_comparison_of_adj adj₁ adj₂ L).app X)) : preserves_limit X L :=
begin
  refine preserves_limit_of_preserves_limit_cone (limit_cone_of_adj adj₁ X).is_limit _,
  refine is_limit_of_is_iso_adj adj₂ _ _,
  convert hX,
  apply (adj₂.hom_equiv _ _).symm.injective,
  ext j,
  dsimp [limit_cone_of_adj, functor.map_cone],
  rw [equiv.symm_apply_apply, cones.functoriality_obj_π_app,
    adjunction.adjoint_nat_trans_equiv_app, whiskering_right_obj_map, ← assoc,
    adjunction.hom_equiv_naturality_right_symm, nat_trans.comp_app, whisker_right_app,
    adjunction.hom_equiv_naturality_right_symm, adjunction.hom_equiv_counit,
    adjunction.left_triangle_components],
  dsimp [functor.comp_const],
  simp only [id_comp],
end

lemma preserves_limits_of_shape_of_adj
  [is_iso (limit_comparison_of_adj adj₁ adj₂ L)] : preserves_limits_of_shape J L :=
⟨λ X, preserves_limit_of_adj adj₁ adj₂ L X infer_instance⟩

end

end limits

end category_theory


import for_mathlib.exact_functor
import for_mathlib.ab4
import for_mathlib.abelian_sheaves.functor_category
import for_mathlib.homological_complex2
import category_theory.limits.preserves.filtered
import for_mathlib.short_complex_colimits

namespace category_theory

open category_theory.limits

universes v u
variables (A : Type u) [category.{v} A] [abelian A] [has_colimits A]

instance colim_additive (J : Type v) [small_category J]:
  functor.additive (limits.colim : ((J ⥤ A) ⥤ A)) := ⟨⟩ .

/-
TODO: Change `AB5` from this definition to saying that `colim : (J ⥤ A) ⥤ A`
preserves finite limits and colimits whenever `J` is filtered.
-/
class AB5 : Prop :=
(cond [] : ∀ (J : Type v) [small_category J] [is_filtered J],
  functor.exact (limits.colim : (J ⥤ A) ⥤ A))

variables (J : Type v) [small_category J] [is_filtered J]

lemma AB5.colim_exact [AB5 A] :
  functor.exact (limits.colim : (J ⥤ A) ⥤ A) :=
AB5.cond A J

variables
  [preserves_finite_limits (limits.colim : (J ⥤ A) ⥤ A)]
  [preserves_finite_colimits (limits.colim : (J ⥤ A) ⥤ A)]

noncomputable
def colimit_homology_functor_iso
  {M : Type} (c : complex_shape M) (i : M) :
  homology_functor (J ⥤ A) c i ⋙ limits.colim ≅
  (limits.colim.map_homological_complex _) ⋙ homology_functor _ _ i :=
functor.homology_functor_iso _ _ _

noncomputable
def eval_functor_colimit_iso
  {M : Type} (c : complex_shape M)
  (F : J ⥤ homological_complex A c) :
  colimit F ≅ (limits.colim.map_homological_complex c).obj
  (homological_complex.eval_functor.obj F) :=
homological_complex.hom.iso_of_components
(λ i, preserves_colimit_iso (homological_complex.eval A c i) _)
begin
  intros i j hij,
  rw ←iso.eq_inv_comp,
  apply colimit.hom_ext,
  intro k,
  dsimp,
  simp only [colimit.ι_map, whisker_left_app, ι_preserves_colimits_iso_inv_assoc,
    homological_complex.eval_map, homological_complex.hom.comm_assoc],
  congr,
  rw [preserves_colimit_iso, ← limits.colimit.iso_colimit_cocone_ι_inv
    ⟨_, preserves_colimit.preserves (colimit.is_colimit F)⟩],
  refl
end

noncomputable
instance homology_functor_preserves_filtered_colimit
  {M : Type} (c : complex_shape M) (i : M)
  (F : J ⥤ homological_complex A c) :
  preserves_colimit F (homology_functor A c i) :=
preserves_colimit_of_nat_iso F (short_complex.homology_functor_iso A c i).symm

noncomputable
instance homology_functor_preserves_filtered_colimits
  {M : Type} (c : complex_shape M) (i : M)
  [∀ (J : Type v) [hJ : small_category J]
    [@is_filtered J hJ],
    by exactI preserves_finite_limits (limits.colim : (J ⥤ A) ⥤ A)]
  [∀ (J : Type v) [hJ : small_category J]
    [@is_filtered J hJ],
    by exactI preserves_finite_colimits (limits.colim : (J ⥤ A) ⥤ A)] :
  preserves_filtered_colimits
  (homology_functor A c i : homological_complex A c ⥤ A) :=
begin
  constructor, introsI J _ _, constructor,
end

end category_theory


import Lean

namespace Lean.Meta.Match

private def isMatchValue (e : Expr) : Bool :=
  e.isNatLit || e.isCharLit || e.isStringLit

partial def mkEquationsFor (matchDeclName : Name) :  MetaM Unit := do
  let constInfo ← getConstInfo matchDeclName
  let us := constInfo.levelParams.map mkLevelParam
  let some matchInfo ← getMatcherInfo? matchDeclName | throwError "'{matchDeclName}' is not a matcher function"
  forallTelescopeReducing constInfo.type fun xs _ => do
    let params := xs[:matchInfo.numParams]
    let motive := xs[matchInfo.getMotivePos]
    let alts   := xs[xs.size - matchInfo.numAlts:]
    let firstDiscrIdx := matchInfo.numParams + 1
    let discrs := xs[firstDiscrIdx : firstDiscrIdx + matchInfo.numDiscrs]
    let mut notAlts := #[]
    for alt in alts do
      let altType ← inferType alt
      trace[Meta.debug] ">> {altType}"
      notAlts ← forallTelescopeReducing altType fun ys altResultType => do
        let (ys, rhsArgs) ← toFVarsRHSArgs ys
        let patterns := altResultType.getAppArgs
        let mut hs := #[]
        for notAlt in notAlts do
          hs := hs.push (← instantiateForall notAlt patterns)
        hs ← simpHs hs patterns.size
        trace[Meta.debug] "hs: {hs}"
        -- Create a proposition for representing terms that do not match `patterns`
        let mut notAlt := mkConst ``False
        for discr in discrs.toArray.reverse, pattern in patterns.reverse do
          notAlt ← mkArrow (← mkEq discr pattern) notAlt
        notAlt ← mkForallFVars (discrs ++ ys) notAlt
        trace[Meta.debug] "notAlt: {notAlt}"
        let lhs := mkAppN (mkConst constInfo.name us) (params ++ #[motive] ++ patterns ++ alts)
        let rhs := mkAppN alt rhsArgs
        let thmType ← mkEq lhs rhs
        let thmType ← hs.foldrM (init := thmType) mkArrow
        let thmType ← mkForallFVars (params ++ #[motive] ++ alts ++ ys) thmType
        let thmVal ← prove thmType
        trace[Meta.debug] ">> {thmType}"
        return notAlts.push notAlt
where
  toFVarsRHSArgs (ys : Array Expr) : MetaM (Array Expr × Array Expr) := do
    if ys.size == 1 && (← inferType ys[0]).isConstOf ``Unit then
      return (#[], #[mkConst ``Unit.unit])
    else
      return (ys, ys)

  simpEq (lhs : Expr) (rhs : Expr) : OptionT (StateRefT (Array Expr) MetaM) Unit := do
    if isMatchValue lhs && isMatchValue rhs then
      unless (← isDefEq lhs rhs) do
        failure
    else if rhs.isFVar then
      -- Ignore case since it matches anything
      pure ()
    else match lhs.arrayLit?, rhs.arrayLit? with
      | some (_, lhsArgs), some (_, rhsArgs) =>
        if lhsArgs.length != rhsArgs.length then
          failure
        else
          for lhsArg in lhsArgs, rhsArg in rhsArgs do
            simpEq lhsArg rhsArg
      | _, _ =>
        match toCtorIfLit lhs |>.constructorApp? (← getEnv), toCtorIfLit rhs |>.constructorApp? (← getEnv) with
        | some (lhsCtor, lhsArgs), some (rhsCtor, rhsArgs) =>
          if lhsCtor.name == rhsCtor.name then
            for lhsArg in lhsArgs[lhsCtor.numParams:], rhsArg in rhsArgs[lhsCtor.numParams:] do
              simpEq lhsArg rhsArg
          else
            failure
        | _, _ =>
          let newEq ← mkEq lhs rhs
          modify fun eqs => eqs.push newEq

  simpEqs (eqs : Array Expr) : OptionT (StateRefT (Array Expr) MetaM) Unit := do
    eqs.forM fun eq =>
      match eq.eq? with
      | some (_, lhs, rhs) => simpEq lhs rhs
      | _ => throwError "failed to generate equality theorems for 'match', equality expected{indentExpr eq}"

  simpHs (hs : Array Expr) (numPatterns : Nat) : MetaM (Array Expr) :=
    hs.filterMapM fun h => forallTelescope h fun ys _ => do
      trace[Meta.debug] "ys: {ys}"
      let xs  := ys[:ys.size - numPatterns].toArray
      let eqs ← ys[ys.size - numPatterns : ys.size].toArray.mapM inferType
      if let some eqsNew ← simpEqs eqs *> get |>.run |>.run' #[] then
        let newH ← eqsNew.foldrM (init := mkConst ``False) mkArrow
        let xs ← xs.filterM fun x => dependsOn newH x.fvarId!
        return some (← mkForallFVars xs newH)
      else
        none

  proveLoop (mvarId : MVarId) : MetaM Unit := do
    let mvarId ← modifyTargetEqLHS mvarId whnfCore
    (applyRefl mvarId)
    <|>
    (do trace[Meta.debug] "TODO{indentD <| MessageData.ofGoal mvarId}"
        -- TODO
        admit mvarId)

  prove (type : Expr) : MetaM Expr :=
    withLCtx {} {} <| forallTelescope type fun ys target => do
      let mvar0  ← mkFreshExprSyntheticOpaqueMVar target
      let mvarId ← deltaTarget mvar0.mvarId! (. == matchDeclName)
      proveLoop mvarId
      mkLambdaFVars ys (← instantiateMVars mvar0)

end Lean.Meta.Match

def f (xs ys : List String) : Nat :=
  match xs, ys with
  | [], []      => 0
  | _,  ["abc"] => 1
  | _, x::xs    => xs.length
  | _,  _       => 2

def h (x y : Nat) : Nat :=
  match x, y with
  | 10000, _ => 0
  | 10001, _ => 5
  | _, 20000 => 4
  | x+1, _   => 3
  | Nat.zero, y+1 => 44
  | _, _     => 1

theorem ex1 : h 10000 1 = 0 :=
  rfl

theorem ex2 : h 10002 1 = 3 :=
  rfl

def g (xs ys : Array Nat) : Nat :=
  match xs, ys with
  | #[], #[]     => 0
  | _, #[0, y+1] => 1
  | _, #[x, y]   => 2
  | _,  _        => 3

-- #print f.match_1

set_option trace.Meta.debug true
#eval Lean.Meta.Match.mkEquationsFor ``f.match_1
#eval Lean.Meta.Match.mkEquationsFor ``h.match_1
#eval Lean.Meta.Match.mkEquationsFor ``g.match_1