/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl (CMU)

! This file was ported from Lean 3 source module meta.coinductive_predicates
! leanprover-community/mathlib commit 3d7987cda72abc473c7cdbbb075170e9ac620042
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Tactic.Core

section

universe u

@[user_attribute]
unsafe def monotonicity : user_attribute
    where
  Name := `monotonicity
  descr := "Monotonicity rules for predicates"
#align monotonicity monotonicity

theorem Monotonicity.pi {α : Sort u} {p q : α → Prop} (h : ∀ a, Implies (p a) (q a)) :
    Implies (∀ a, p a) (∀ a, q a) := fun h' a => h a (h' a)
#align monotonicity.pi Monotonicity.pi

theorem Monotonicity.imp {p p' q q' : Prop} (h₁ : Implies p' q') (h₂ : Implies q p) :
    Implies (p → p') (q → q') := fun h => h₁ ∘ h ∘ h₂
#align monotonicity.imp Monotonicity.imp

@[monotonicity]
theorem Monotonicity.const (p : Prop) : Implies p p :=
  id
#align monotonicity.const Monotonicity.const

@[monotonicity]
theorem Monotonicity.true (p : Prop) : Implies p True := fun _ => trivial
#align monotonicity.true Monotonicity.true

@[monotonicity]
theorem Monotonicity.false (p : Prop) : Implies False p :=
  False.elim
#align monotonicity.false Monotonicity.false

@[monotonicity]
theorem Monotonicity.exists {α : Sort u} {p q : α → Prop} (h : ∀ a, Implies (p a) (q a)) :
    Implies (∃ a, p a) (∃ a, q a) :=
  Exists.imp h
#align monotonicity.exists Monotonicity.exists

@[monotonicity]
theorem Monotonicity.and {p p' q q' : Prop} (hp : Implies p p') (hq : Implies q q') :
    Implies (p ∧ q) (p' ∧ q') :=
  And.imp hp hq
#align monotonicity.and Monotonicity.and

@[monotonicity]
theorem Monotonicity.or {p p' q q' : Prop} (hp : Implies p p') (hq : Implies q q') :
    Implies (p ∨ q) (p' ∨ q') :=
  Or.imp hp hq
#align monotonicity.or Monotonicity.or

@[monotonicity]
theorem Monotonicity.not {p q : Prop} (h : Implies p q) : Implies (¬q) ¬p :=
  mt h
#align monotonicity.not Monotonicity.not

end

namespace Tactic

open Expr Tactic

-- TODO: use backchaining
private unsafe def mono_aux (ns : List Name) (hs : List expr) : tactic Unit := do
  intros
  (do
        let q(Implies $(p) $(q)) ← target
        (do
              is_def_eq p q
              eapplyc `monotone.const) <|>
            do
            let expr.pi pn pbi pd pb ← whnf p
            let expr.pi qn qbi qd qb ← whnf q
            let sort u ← infer_type pd
            (do
                  is_def_eq pd qd
                  let p' := expr.lam pn pbi pd pb
                  let q' := expr.lam qn qbi qd qb
                  eapply ((const `monotonicity.pi [u] : expr) pd p' q')
                  skip) <|>
                do
                guard <| u = level.zero ∧ is_arrow p ∧ is_arrow q
                let p' := pb 0 1
                let q' := qb 0 1
                eapply ((const `monotonicity.imp [] : expr) pd p' qd q')
                skip) <|>
      first
          (hs fun h =>
            apply_core h
                { md := transparency.none
                  NewGoals := new_goals.non_dep_only } >>
              skip) <|>
        first
          (ns fun n => do
            let c ← mk_const n
            apply_core c
                { md := transparency.none
                  NewGoals := new_goals.non_dep_only }
            skip)
  all_goals' mono_aux
#align tactic.mono_aux tactic.mono_aux

unsafe def mono (e : expr) (hs : List expr) : tactic Unit := do
  let t ← target
  let t' ← infer_type e
  let ns ← attribute.get_instances `monotonicity
  let ((), p) ← solve_aux q(Implies $(t') $(t)) (mono_aux ns hs)
  exact (p e)
#align tactic.mono tactic.mono

end Tactic

/-
The coinductive predicate `pred`:

  coinductive {u} pred (A) : a → Prop
  | r : ∀A b, pred A p

where
  `u` is a list of universe parameters
  `A` is a list of global parameters
  `pred` is a list predicates to be defined
  `a` are the indices for each `pred`
  `r` is a list of introduction rules for each `pred`
  `b` is a list of parameters for each rule in `r` and `pred`
  `p` is are the instances of `a` using `A` and `b`

`pred` is compiled to the following defintions:

  inductive {u} pred.functional (A) ([pred'] : a → Prop) : a → Prop
  | r : ∀a [f], b[pred/pred'] → pred.functional a [f] p

  lemma {u} pred.functional.mono (A) ([pred₁] [pred₂] : a → Prop) [(h : ∀b, pred₁ b → pred₂ b)] :
    ∀p, pred.functional A pred₁ p → pred.functional A pred₂ p

  def {u} pred_i (A) (a) : Prop :=
  ∃[pred'], (Λi, ∀a, pred_i a → pred_i.functional A [pred] a) ∧ pred'_i a

  lemma {u} pred_i.corec_functional (A) [Λi, C_i : a_i → Prop]
    [Λi, h : ∀a, C_i a → pred_i.functional A C_i a] :
    ∀a, C_i a → pred_i A a

  lemma {u} pred_i.destruct (A) (a) : pred A a → pred.functional A [pred A] a

  lemma {u} pred_i.construct (A) : ∀a, pred_i.functional A [pred A] a → pred_i A a

  lemma {u} pred_i.cases_on (A) (C : a → Prop) {a} (h : pred_i a) [Λi, ∀a, b → C p] → C a

  lemma {u} pred_i.corec_on (A) [(C : a → Prop)] (a) (h : C_i a)
    [Λi, h_i : ∀a, C_i a → [V j ∃b, a = p]] : pred_i A a

  lemma {u} pred.r (A) (b) : pred_i A p
-/
namespace Tactic

open Level Expr Tactic

namespace AddCoinductivePredicate

-- private
unsafe structure coind_rule : Type where
  orig_nm : Name
  func_nm : Name
  type : expr
  loc_type : expr
  args : List expr
  loc_args : List expr
  concl : expr
  insts : List expr
#align tactic.add_coinductive_predicate.coind_rule tactic.add_coinductive_predicate.coind_rule

-- private
unsafe structure coind_pred : Type where
  u_names : List Name
  params : List expr
  pd_name : Name
  type : expr
  intros : List coind_rule
  locals : List expr
  (f₁ f₂ : expr)
  u_f : level
#align tactic.add_coinductive_predicate.coind_pred tactic.add_coinductive_predicate.coind_pred

namespace CoindPred

unsafe def u_params (pd : coind_pred) : List level :=
  pd.u_names.map param
#align tactic.add_coinductive_predicate.coind_pred.u_params tactic.add_coinductive_predicate.coind_pred.u_params

unsafe def f₁_l (pd : coind_pred) : expr :=
  pd.f₁.app_of_list pd.locals
#align tactic.add_coinductive_predicate.coind_pred.f₁_l tactic.add_coinductive_predicate.coind_pred.f₁_l

unsafe def f₂_l (pd : coind_pred) : expr :=
  pd.f₂.app_of_list pd.locals
#align tactic.add_coinductive_predicate.coind_pred.f₂_l tactic.add_coinductive_predicate.coind_pred.f₂_l

unsafe def pred (pd : coind_pred) : expr :=
  const pd.pd_name pd.u_params
#align tactic.add_coinductive_predicate.coind_pred.pred tactic.add_coinductive_predicate.coind_pred.pred

unsafe def func (pd : coind_pred) : expr :=
  const (pd.pd_name ++ "functional") pd.u_params
#align tactic.add_coinductive_predicate.coind_pred.func tactic.add_coinductive_predicate.coind_pred.func

unsafe def func_g (pd : coind_pred) : expr :=
  pd.func.app_of_list <| pd.params
#align tactic.add_coinductive_predicate.coind_pred.func_g tactic.add_coinductive_predicate.coind_pred.func_g

unsafe def pred_g (pd : coind_pred) : expr :=
  pd.pred.app_of_list <| pd.params
#align tactic.add_coinductive_predicate.coind_pred.pred_g tactic.add_coinductive_predicate.coind_pred.pred_g

unsafe def impl_locals (pd : coind_pred) : List expr :=
  pd.locals.map to_implicit_binder
#align tactic.add_coinductive_predicate.coind_pred.impl_locals tactic.add_coinductive_predicate.coind_pred.impl_locals

unsafe def impl_params (pd : coind_pred) : List expr :=
  pd.params.map to_implicit_binder
#align tactic.add_coinductive_predicate.coind_pred.impl_params tactic.add_coinductive_predicate.coind_pred.impl_params

unsafe def le (pd : coind_pred) (f₁ f₂ : expr) : expr :=
  (imp (f₁.app_of_list pd.locals) (f₂.app_of_list pd.locals)).pis pd.impl_locals
#align tactic.add_coinductive_predicate.coind_pred.le tactic.add_coinductive_predicate.coind_pred.le

unsafe def corec_functional (pd : coind_pred) : expr :=
  const (pd.pd_name ++ "corec_functional") pd.u_params
#align tactic.add_coinductive_predicate.coind_pred.corec_functional tactic.add_coinductive_predicate.coind_pred.corec_functional

unsafe def mono (pd : coind_pred) : expr :=
  const (pd.func.const_name ++ "mono") pd.u_params
#align tactic.add_coinductive_predicate.coind_pred.mono tactic.add_coinductive_predicate.coind_pred.mono

unsafe def rec' (pd : coind_pred) : tactic expr := do
  let c := pd.func.const_name ++ "rec"
  let env ← get_env
  let decl ← env.get c
  let num := decl.univ_params.length
  return (const c <| if Num = pd then pd else level.zero :: pd)
#align tactic.add_coinductive_predicate.coind_pred.rec' tactic.add_coinductive_predicate.coind_pred.rec'

-- ^^ `rec`'s universes are not always `u_params`, e.g. eq, wf, false
unsafe def construct (pd : coind_pred) : expr :=
  const (pd.pd_name ++ "construct") pd.u_params
#align tactic.add_coinductive_predicate.coind_pred.construct tactic.add_coinductive_predicate.coind_pred.construct

unsafe def destruct (pd : coind_pred) : expr :=
  const (pd.pd_name ++ "destruct") pd.u_params
#align tactic.add_coinductive_predicate.coind_pred.destruct tactic.add_coinductive_predicate.coind_pred.destruct

unsafe def add_theorem (pd : coind_pred) (n : Name) (type : expr) (tac : tactic Unit) :
    tactic expr :=
  add_theorem_by n pd.u_names type tac
#align tactic.add_coinductive_predicate.coind_pred.add_theorem tactic.add_coinductive_predicate.coind_pred.add_theorem

end CoindPred

end AddCoinductivePredicate

open AddCoinductivePredicate

/-- compact_relation bs as_ps: Product a relation of the form:
  R := λ as, ∃ bs, Λ_i a_i = p_i[bs]
This relation is user visible, so we compact it by removing each `b_j` where a `p_i = b_j`, and
hence `a_i = b_j`. We need to take care when there are `p_i` and `p_j` with `p_i = p_j = b_k`. -/
unsafe def compact_relation : List expr → List (expr × expr) → List expr × List (expr × expr)
  | [], ps => ([], ps)
  | List.cons b bs, ps =>
    match ps.spanₓ fun ap : expr × expr => ¬ap.2 == b with
    | (_, []) =>
      let (bs, ps) := compact_relation bs ps
      (b :: bs, ps)
    | (ps₁, List.cons (a, _) ps₂) =>
      let i := a.instantiate_local b.local_uniq_name
      compact_relation (bs.map i) ((ps₁ ++ ps₂).map fun ⟨a, p⟩ => (a, i p))
#align tactic.compact_relation tactic.compact_relation

unsafe def add_coinductive_predicate (u_names : List Name) (params : List expr)
    (preds : List <| expr × List expr) : Tactic := do
  let params_names := params.map local_pp_name
  let u_params := u_names.map param
  let pre_info ←
    preds.mapM fun ⟨c, is⟩ => do
        let (ls, t) ← open_pis c.local_type
        is_def_eq t q(Prop) <|>
            fail
              ((f! "Type of {c} is not Prop. Currently only ") ++
                "coinductive predicates are supported.")
        let n := if preds.length = 1 then "" else "_" ++ c.local_pp_name.lastString
        let f₁ ← mk_local_def (mkSimpleName <| "C" ++ n) c.local_type
        let f₂ ← mk_local_def (mkSimpleName <| "C₂" ++ n) c.local_type
        return (ls, (f₁, f₂))
  let fs := pre_info.map Prod.snd
  let fs₁ := fs.map Prod.fst
  let fs₂ := fs.map Prod.snd
  let pds ←
    (preds.zip pre_info).mapM fun ⟨⟨c, is⟩, ls, f₁, f₂⟩ => do
        let sort u_f ← infer_type f₁ >>= infer_type
        let pred_g := fun c : expr => (const c.local_uniq_name u_params : expr).app_of_list params
        let intros ←
          is.mapM fun i => do
              let (args, t') ← open_pis i.local_type
              let Name.mk_string sub p ← return i.local_uniq_name
              let loc_args :=
                args.map fun e =>
                  (fs₁.zip preds).foldl (fun (e : expr) ⟨f, c, _⟩ => e.replace_with (pred_g c) f) e
              let t' := t'.replace_with (pred_g c) f₂
              return
                  { orig_nm := i
                    func_nm := p ++ "functional" ++ sub
                    type := i
                    loc_type := t' loc_args
                    concl := t'
                    loc_args
                    args
                    insts := t' }
        return
            { pd_name := c
              type := c
              f₁
              f₂
              u_f
              intros
              locals := ls
              params
              u_names }
  -- Introduce all functionals
      pds
      fun pd : coind_pred => do
      let func_f₁ := pd <| fs₁
      let func_f₂ := pd <| fs₂
      let func_intros
        ←-- Define functional for `pd` as inductive predicate
            pd
            fun r : coind_rule => do
            let t := instantiate_local pd (pd fs₁) r
            return (r, r, t <| params ++ fs₁)
      add_inductive pd u_names (params + preds) (pd <| params ++ fs₁)
          (func_intros fun ⟨t, _, r⟩ => (t, r))
      let mono_params
        ←-- Prove monotonicity rule
            pds
            fun pd => do
            let h ← mk_local_def `h <| pd pd pd
            return [pd, pd, h]
      pd (pd ++ "mono") ((pd func_f₁ func_f₂).pis <| params ++ mono_params) do
          let ps ← intro_lst <| params expr.local_pp_name
          let fs ←
            pds fun pd => do
                let [f₁, f₂, h] ← intro_lst [pd, pd, `h]
                let-- the type of h' reduces to h
                h' :=
                  local_const h h h <|
                    (((const `implies [] : expr) (f₁ pd) (f₂ pd)).pis pd).instantiate_locals <|
                      (ps params).map fun ⟨lv, p⟩ => (p, lv)
                return (f₂, h')
          let m ← pd
          eapply <| m ps
          -- somehow `induction` / `cases` doesn't work?
              func_intros
              fun ⟨n, pp_n, t⟩ =>
              solve1 do
                let bs ← intros
                let ms ←
                  apply_core ((const n u_params).app_of_list <| ps ++ fs Prod.fst)
                      { NewGoals := new_goals.all }
                let params ← (ms bs).enum.filterM fun ⟨n, m, d⟩ => not <$> is_assigned m.2
                params fun ⟨n, m, d⟩ =>
                    mono d (fs Prod.snd) <|>
                      fail
                        f!"failed to prove montonoicity of {(n +
                            1)}. parameter of intro-rule {pp_n}"
  pds fun pd => do
      let func_f := fun pd : coind_pred => pd <| pds coind_pred.f₁
      let pred_body
        ←-- define final predicate
              mk_exists_lst
              (pds coind_pred.f₁) <|
            mk_and_lst <| (pds fun pd => pd pd (func_f pd)) ++ [pd pd]
      add_decl <| mk_definition pd u_names (pd <| params) <| pred_body <| params ++ pd
      let hs
        ←-- prove `corec_functional` rule
            pds
            fun pd : coind_pred => mk_local_def `hc <| pd pd (func_f pd)
      pd (pd ++ "corec_functional") ((pd pd pd).pis <| params ++ fs₁ ++ hs) do
          intro_lst <| params local_pp_name
          let fs ← intro_lst <| fs₁ local_pp_name
          let hs ← intro_lst <| hs local_pp_name
          let ls ← intro_lst <| pd local_pp_name
          let h ← intro `h
          whnf_target
          fs existsi
          hs fun f => econstructor >> exact f
          exact h
  let func_f := fun pd : coind_pred => pd.func_g.app_of_list <| pds.map coind_pred.pred_g
  -- prove `destruct` rules
      pds
      fun ⟨n, pd⟩ => do
      let destruct := pd pd (func_f pd)
      pd (pd ++ "destruct") (destruct params) do
          let ps ← intro_lst <| params local_pp_name
          let ls ← intro_lst <| pd local_pp_name
          let h ← intro `h
          let (fs, h, _) ← elim_gen_prod pds h [] []
          let (hs, h, _) ← elim_gen_prod pds h [] []
          eapply <| pd ps
          pds fun pd : coind_pred =>
              focus1 do
                eapply <| pd
                focus <| hs exact
          let some h' ← return <| hs n
          eapply h'
          exact h
  -- prove `construct` rules
      pds
      fun pd =>
      pd (pd ++ "construct") ((pd (func_f pd) pd).pis params) do
        let ps ← intro_lst <| params local_pp_name
        let func_pred_g := fun pd : coind_pred => pd <| ps ++ pds fun pd : coind_pred => pd ps
        eapply <| pd <| ps ++ pds func_pred_g
        pds fun pd : coind_pred =>
            solve1 do
              eapply <| pd ps
              pds fun pd => solve1 <| eapply (pd ps) >> skip
  -- prove `cases_on` rules
      pds
      fun pd => do
      let C := pd
      let h ← mk_local_def `h <| pd pd
      let rules ←
        pd fun r : coind_rule => do
            mk_local_def (mkSimpleName r) <| (C r).pis r
      let cases_on ←
        pd (pd ++ "cases_on") ((C pd).pis <| params ++ [C] ++ pd ++ [h] ++ rules) do
            let ps ← intro_lst <| params local_pp_name
            let C ← intro `C
            let ls ← intro_lst <| pd local_pp_name
            let h ← intro `h
            let rules ← intro_lst <| rules local_pp_name
            let func_rec ← pd
            eapply <| func_rec <| (ps ++ pds fun pd => pd ps) ++ [C] ++ rules
            eapply <| pd
            exact h
      set_basic_attribute `elab_as_eliminator cases_on
  -- prove `corec_on` rules
      pds
      fun pd => do
      let rules ←
        pds fun pd => do
            let intros ←
              pd fun r => do
                  let (bs, eqs) := compact_relation r <| pd r
                  let eqs ←
                    eqs fun ⟨l, i⟩ => do
                        let sort u ← infer_type l
                        return <| (const `eq [u] : expr) l i l
                  match bs, eqs with
                    | [], [] => return ((0, 0), mk_true)
                    | _, [] => Prod.mk (bs, 0) <$> mk_exists_lst bs bs
                    | _, _ => Prod.mk (bs, eqs) <$> mk_exists_lst bs (mk_and_lst eqs)
            let shape := intros Prod.fst
            let intros := intros Prod.snd
            Prod.mk shape <$>
                mk_local_def (mkSimpleName <| "h_" ++ pd) (((pd pd).imp (mk_or_lst intros)).pis pd)
      let shape := rules Prod.fst
      let rules := rules Prod.snd
      let h ← mk_local_def `h <| pd pd
      pd (pd ++ "corec_on") ((pd <| pd).pis <| params ++ fs₁ ++ pd ++ [h] ++ rules) do
          let ps ← intro_lst <| params local_pp_name
          let fs ← intro_lst <| fs₁ local_pp_name
          let ls ← intro_lst <| pd local_pp_name
          let h ← intro `h
          let rules ← intro_lst <| rules local_pp_name
          eapply <| pd <| ps ++ fs
          (pds <| rules shape).mapM fun ⟨pd, hr, s⟩ =>
              solve1 do
                let ls ← intro_lst <| pd local_pp_name
                let h' ← intro `h
                let h' ← note `h' none <| hr ls h'
                match s with
                  | 0 => induction h' >> skip
                  |-- h' : false
                      n +
                      1 =>
                    do
                    let hs ← elim_gen_sum n h'
                    (hs <| pd s).mapM' fun ⟨h, r, n_bs, n_eqs⟩ =>
                        solve1 do
                          let (as, h, _) ← elim_gen_prod (n_bs - if n_eqs = 0 then 1 else 0) h [] []
                          if n_eqs > 0 then do
                              let (eqs, eq', _) ← elim_gen_prod (n_eqs - 1) h [] []
                              (eqs ++ [eq']).mapM' subst
                            else skip
                          eapply ((const r u_params).app_of_list <| ps ++ fs)
                          iterate assumption
          exact h
  -- prove constructors
      pds
      fun pd =>
      pd fun r =>
        pd r (r params) do
          let ps ← intro_lst <| params local_pp_name
          let bs ← intros
          eapply <| pd
          exact <| (const r u_params).app_of_list <| (ps ++ pds fun pd => pd ps) ++ bs
  pds fun pd : coind_pred => set_basic_attribute `irreducible pd
  try triv
#align tactic.add_coinductive_predicate tactic.add_coinductive_predicate

/- ./././Mathport/Syntax/Translate/Tactic/Mathlib/Core.lean:38:34: unsupported: setup_tactic_parser -/
-- we setup a trivial goal for the tactic framework
@[user_command]
unsafe def coinductive_predicate (meta_info : decl_meta_info) (_ : parse <| tk "coinductive") :
    lean.parser Unit := do
  let decl ← inductive_decl.parse meta_info
  add_coinductive_predicate decl decl <| decl fun d => (d, d)
  decl fun d => do
      get_env >>= fun env => set_env <| env d
      meta_info d
      d d
      let some doc_string ← pure meta_info |
        skip
      add_doc_string d doc_string
#align tactic.coinductive_predicate tactic.coinductive_predicate

/- ./././Mathport/Syntax/Translate/Expr.lean:207:4: warning: unsupported notation `hs -/
/-- Prepares coinduction proofs. This tactic constructs the coinduction invariant from
the quantifiers in the current goal.

Current version: do not support mutual inductive rules -/
unsafe def coinduction (rule : expr) (ns : List Name) : tactic Unit :=
  focus1 do
    let ctxts' ← intros
    let ctxts ←
      ctxts'.mapM fun v =>
          local_const v.local_uniq_name v.local_pp_name v.local_binding_info <$> infer_type v
    let mvars ←
      apply_core rule
          { approx := false
            NewGoals := NewGoals.all }
    let g
      ←-- analyse relation
          List.headI <$>
          get_goals
    let List.cons _ m_is ← return <| mvars.dropWhileₓ fun v => v.2 ≠ g
    let tgt ← target
    let (is, ty) ← open_pis tgt
    let-- construct coinduction predicate
      (bs, eqs)
      ←
      compact_relation ctxts <$>
          (is.zip m_is).mapM fun ⟨i, m⟩ => Prod.mk i <$> instantiate_mvars m.2
    solve1 do
        let eqs ←
          (mk_and_lst <$> eqs fun ⟨i, m⟩ => mk_app `eq [m, i] >>= instantiate_mvars) <|> do
              let x ← mk_psigma (eqs Prod.fst)
              let y ← mk_psigma (eqs Prod.snd)
              let t ← infer_type x
              mk_mapp `eq [t, x, y]
        let rel ← mk_exists_lst bs eqs
        exact (Rel is)
    -- prove predicate
        solve1
        do
        target >>= instantiate_mvars >>= change
        -- TODO: bug in existsi & constructor when mvars in hyptohesis
            bs
            existsi
        iterate' (econstructor >> skip)
    -- clean up remaining coinduction steps
        all_goals'
        do
        ctxts' clear
        target >>= instantiate_mvars >>= change
        let is
          ←-- TODO: bug in subst when mvars in hyptohesis
              intro_lst <|
              is expr.local_pp_name
        let h ← intro1
        let (_, h, ns) ← elim_gen_prod (bs - if eqs = 0 then 1 else 0) h [] ns
        match eqs with
          | [] => clear h
          | e :: eqs => do
            let (hs, h, ns) ← elim_gen_prod eqs h [] ns
            (h :: hs hs.reverse : List _).foldlM
                (fun (hs : List Name) (h : expr) => do
                  let [(_, hs', σ)] ← cases_core h hs
                  clear (h σ)
                  pure <| hs hs')
                ns
            skip
#align tactic.coinduction tactic.coinduction

namespace Interactive

open Interactive Interactive.Types Expr Lean.Parser

-- mathport name: «expr ?»
local postfix:1024 "?" => optional

-- mathport name: parser.many
local postfix:1024 "*" => many

unsafe def coinduction (corec_name : parse ident) (ns : parse with_ident_list)
    (revert : parse <| (tk "generalizing" *> ident*)?) : tactic Unit := do
  let rule ← mk_const corec_name
  let locals ← mapM tactic.get_local <| revert.getD []
  revert_lst locals
  tactic.coinduction rule ns
  skip
#align tactic.interactive.coinduction tactic.interactive.coinduction

end Interactive

end Tactic


/-
Copyright (c) 2022 Devon Tuma. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Devon Tuma
-/
import data.vector.mem
import computational_monads.constructions.product
import computational_monads.distribution_semantics.defs.prob_event

/-!
# Repeated Independent Runs of an Oracle Computation

This file defines a construction `repeat oa n` to represent running `oa` independently `n` times,
returning the result as a `vector` of length `n`, by using induction on the input `n`.

`support_repeat_eq_all₂` shows that the possible outputs of `oa.repeat n` are exactly the
vectors such that each element in the vector are possible outputs of `oa`.
`eval_dist_repeat_apply` shows that the probability of getting a given output from `oa.repeat n`
is the product over the vector of the probabilities of getting the individual outputs from `oa`.
-/

namespace oracle_comp

open oracle_spec

variables {α β γ : Type} {spec spec' : oracle_spec}

/-- Repeat the computation `oa` independently `n` times to get a length `n` vector of results. -/
def repeat (oa : oracle_comp spec α) : Π (n : ℕ), oracle_comp spec (vector α n)
| 0 := return vector.nil
| (n + 1) := do { a ← oa, as ← repeat n, return (a ::ᵥ as) }

variables (oa : oracle_comp spec α) (n : ℕ) {m : ℕ} (x x' : α) (xs : vector α m)
  (xs₀ : vector α 0) (xsₛ : vector α m.succ)

lemma repeat_zero : oa.repeat 0 = return vector.nil := rfl

lemma repeat_succ : oa.repeat n.succ = do {a ← oa, as ← oa.repeat n, return (a ::ᵥ as)} := rfl

instance repeat.decidable [hoa : oa.decidable] : (oa.repeat n).decidable :=
begin
  induction n with n hn,
  { exact oracle_comp.decidable_return vector.nil },
  { haveI : decidable_eq α := decidable_eq_of_decidable oa,
    refine decidable.decidable_bind' _ _ _ _ hoa (λ _, decidable.decidable_bind' _ _ _ _ hn
      (λ _, decidable.decidable_pure' _ _ (by apply_instance))) }
end

section support

/-- The support of `oa.repeat n` is the set of vectors where every element is in `oa.support`. -/
@[simp] theorem support_repeat_eq_all₂ :
  (oa.repeat n).support = {xs | xs.to_list.all₂ (∈ oa.support)} :=
begin
  induction n with n hn,
  { exact set.ext (λ x, by simp only [list.all₂, repeat_zero, support_return, set.set_of_true,
      set.mem_singleton_iff, eq_iff_true_of_subsingleton, vector.to_list_empty, set.mem_univ]) },
  { ext xs,
    obtain ⟨x, xs, rfl⟩ := vector.exists_eq_cons xs,
    simp only [hn, vector.eq_cons_iff, repeat_succ, support_bind, support_bind_return,
      set.mem_Union, set.mem_image, set.mem_set_of_eq, vector.cons_head, vector.cons_tail,
      exists_eq_right_right, exists_prop, vector.to_list_cons, list.all₂_cons] }
end

lemma support_repeat_eq_forall : (oa.repeat n).support = {xs | ∀ x ∈ xs.to_list, x ∈ oa.support} :=
by simp_rw [support_repeat_eq_all₂, list.all₂_iff_forall]

lemma mem_support_repeat_iff_all₂ : xs ∈ (oa.repeat m).support ↔ xs.to_list.all₂ (∈ oa.support) :=
by rw [support_repeat_eq_all₂, set.mem_set_of_eq]

lemma mem_support_repeat_iff_forall :
  xs ∈ (oa.repeat m).support ↔ ∀ x ∈ xs.to_list, x ∈ oa.support :=
by rw [support_repeat_eq_forall, set.mem_set_of_eq]

@[simp] lemma support_repeat_zero : (oa.repeat 0).support = {vector.nil} :=
by rw [repeat_zero, support_return]

/-- Any empty vector is in the support of a computation that is run zero times. -/
lemma mem_support_repeat_zero : xs₀ ∈ (oa.repeat 0).support :=
by simp only [repeat_zero, support_return, set.mem_singleton_iff, eq_iff_true_of_subsingleton]

/-- The support of running a computation `n + 1` is the set of vectors where the head is in
the computation's support and the tail is in the support of running it `n` times. -/
@[simp] lemma support_repeat_succ : (oa.repeat n.succ).support =
  {xs | xs.head ∈ oa.support ∧ xs.tail ∈ (oa.repeat n).support} :=
begin
  refine set.ext (λ xs, _),
  obtain ⟨x, xs, rfl⟩ := vector.exists_eq_cons xs,
  simpa only [support_repeat_eq_all₂, set.mem_set_of_eq, vector.to_list_cons,
    vector.head_cons, vector.tail_cons, list.all₂_cons]
end

lemma support_repeat_succ_eq_Union_image : (oa.repeat n.succ).support =
  ⋃ x ∈ oa.support, (vector.cons x) '' (oa.repeat n).support :=
begin
  refine set.ext (λ xs, _),
  obtain ⟨x, xs, rfl⟩ := vector.exists_eq_cons xs,
  simp_rw [set.mem_Union, support_repeat_succ, set.mem_set_of,
    vector.head_cons, vector.tail_cons, set.mem_image],
  refine ⟨λ h, ⟨x, h.1, xs, h.2, rfl⟩, λ h, _⟩,
  obtain ⟨y, hy, ys, hys, h⟩ := h,
  rw [vector.cons_eq_cons] at h,
  refine ⟨h.1 ▸ hy, h.2 ▸ hys⟩,
end

lemma mem_support_repeat_succ_iff : xsₛ ∈ (oa.repeat m.succ).support ↔
  xsₛ.head ∈ oa.support ∧ xsₛ.tail ∈ (oa.repeat m).support :=
by rw [support_repeat_succ, set.mem_set_of_eq]

lemma cons_mem_support_repeat_succ_iff : (x ::ᵥ xs) ∈ (oa.repeat m.succ).support ↔
  x ∈ oa.support ∧ xs ∈ (oa.repeat m).support :=
by rw [mem_support_repeat_succ_iff oa, vector.head_cons, vector.tail_cons]

/-- If a vector is in the support of `oa.repeat m` then any of its members is in `oa.support`. -/
lemma mem_support_of_mem_of_support_repeat {oa : oracle_comp spec α} {x : α} {xs : vector α m}
  (hxs : xs ∈ (oa.repeat m).support) (hx : x ∈ xs.to_list) : x ∈ oa.support :=
by { rw mem_support_repeat_iff_forall at hxs, exact hxs x hx }

lemma repeat_mem_support_repeat {oa : oracle_comp spec α} {x : α} (n : ℕ) (hx : x ∈ oa.support) :
  vector.repeat x n ∈ (oa.repeat n).support :=
by { rw [mem_support_repeat_iff_forall], exact (λ y hy, (list.eq_of_mem_repeat hy).symm ▸ hx) }

end support

section fin_support

lemma mem_fin_support_repeat_iff_all₂ [oa.decidable] :
  xs ∈ (oa.repeat m).fin_support ↔ xs.to_list.all₂ (∈ oa.fin_support) :=
by simp only [mem_fin_support_iff_mem_support, mem_support_repeat_iff_all₂]

lemma mem_fin_support_repeat_iff_forall [oa.decidable] :
  xs ∈ (oa.repeat m).fin_support ↔ ∀ x ∈ xs.to_list, x ∈ oa.fin_support :=
by simp only [mem_fin_support_iff_mem_support, mem_support_repeat_iff_forall]

end fin_support

section eval_dist

/-- The probability of getting `xs` after `oa.repeat n` is the product of the probability
of getting each individual output, since each computation runs independently. -/
@[simp] theorem eval_dist_repeat_apply : ⁅oa.repeat m⁆ xs = (xs.map ⁅oa⁆).to_list.prod :=
begin
  induction m with m hm,
  { simp only [vector.eq_nil xs, repeat_zero oa, eval_dist_return, pmf.pure_apply,
      if_true, vector.map_nil, vector.to_list_nil, list.prod_nil, eq_self_iff_true] },
  { obtain ⟨x, xs, rfl⟩ := vector.exists_eq_cons xs,
    calc ⁅oa.repeat m.succ⁆ (x ::ᵥ xs) =
      ∑' y ys, ⁅oa⁆ y * ⁅oa.repeat m⁆ ys * set.indicator {y ::ᵥ ys} (λ _, 1) (x ::ᵥ xs) :
        by simp only [repeat_succ, eval_dist_bind_apply_eq_tsum, ← ennreal.tsum_mul_left,
          eval_dist_return_apply_eq_indicator, hm, list.map, vector.to_list_map,
          vector.to_list_cons, list.prod_cons, mul_assoc]
      ... = ⁅oa⁆ x * ⁅oa.repeat m⁆ xs * set.indicator {x ::ᵥ xs} (λ _, 1) (x ::ᵥ xs) :
        begin
          refine tsum_tsum_eq_single _ x xs (λ y hy, mul_eq_zero_of_right _ $
            set.indicator_apply_eq_zero.2 (λ h, (hy _).elim)) (λ y ys hys, mul_eq_zero_of_right _ $
            set.indicator_apply_eq_zero.2 (λ h, (hys _).elim)),
          { rw [set.mem_singleton_iff, vector.cons_eq_cons] at h,
            exact h.1.symm },
          { rw [set.mem_singleton_iff, vector.cons_eq_cons] at h,
            exact h.2.symm }
        end
      ... = ⁅oa⁆ x * ⁅oa.repeat m⁆ xs :
        by simp only [set.indicator_of_mem, set.mem_singleton, mul_one]
      ... = (vector.map ⁅oa⁆ (x ::ᵥ xs)).to_list.prod :
        by rw [vector.map_cons, vector.to_list_cons, list.prod_cons, hm] }
end

lemma eval_dist_repeat_zero' : ⁅oa.repeat 0⁆ = ⁅(return vector.nil : oracle_comp spec _)⁆ := rfl

@[simp] lemma eval_dist_repeat_zero : ⁅oa.repeat 0⁆ = pmf.pure vector.nil :=
by simp only [repeat_zero, eval_dist_return]

lemma eval_dist_repeat_zero_apply : ⁅oa.repeat 0⁆ xs₀ = 1 :=
by simp only [repeat_zero, eval_dist_return, pmf.pure_apply, eq_iff_true_of_subsingleton, if_true]

lemma eval_dist_repeat_succ' :
  ⁅oa.repeat n.succ⁆ = ⁅(λ (x : α × vector α n), x.1 ::ᵥ x.2) <$> (oa ×ₘ oa.repeat n)⁆ :=
by rw [repeat_succ, map_eq_bind_return_comp, (prod_bind_equiv_bind_bind _ _ _).eval_dist_eq]

@[simp] lemma eval_dist_repeat_succ :
  ⁅oa.repeat n.succ⁆ = ⁅oa ×ₘ oa.repeat n⁆.map (λ x, x.1 ::ᵥ x.2) :=
(oa.eval_dist_repeat_succ' n).trans (eval_dist_map _ _)

lemma eval_dist_repeat_succ_apply :
  ⁅oa.repeat m.succ⁆ xsₛ = ⁅oa⁆ xsₛ.head * ⁅oa.repeat m⁆ xsₛ.tail :=
calc ⁅oa.repeat m.succ⁆ xsₛ = ⁅(λ (x : α × vector α m), x.1 ::ᵥ x.2) <$> (oa ×ₘ oa.repeat m)⁆ xsₛ :
    by rw eval_dist_repeat_succ' oa m
  ... = ⁅oa ×ₘ oa.repeat m⁆ (xsₛ.head, xsₛ.tail) :
    eval_dist_map_apply_eq_single' _ _ xsₛ (xsₛ.head, xsₛ.tail) (xsₛ.cons_head_tail)
      (λ x hx hx', by rw [← hx', vector.head_cons, vector.tail_cons, prod.mk.eta])
  ... = ⁅oa⁆ xsₛ.head * ⁅oa.repeat m⁆ xsₛ.tail : by rw eval_dist_product_apply

lemma eval_dist_map_nth_repeat (i : fin m) :
  ⁅(λ xs, vector.nth xs i) <$> oa.repeat m⁆ = ⁅oa⁆ :=
begin
  induction m with m hm,
  {
    refine fin.elim0 i,
  },
  {
    rw [eval_dist_map, eval_dist_repeat_succ, pmf.map_comp],
    by_cases hi : i = 0,
    {
      simp [hi], sorry,
    },
    {
      sorry,
    }
  }
end

end eval_dist

section prob_event

lemma prob_event_succ_thing (e : set (vector α m.succ)) :
  ⁅e | oa.repeat m.succ⁆ = ∑' (x : α) (xs : vector α m), e.indicator ⁅oa.repeat m.succ⁆ (x ::ᵥ xs) :=
begin
  sorry
end

/-- After repeating a computation the probability of an event holding on any single
result is the same as the probability of the event holding after running the computation once. -/
@[simp] lemma prob_event_nth_repeat (e : set α) (i : fin m) :
  ⁅λ xs, xs.nth i ∈ e | oa.repeat m⁆ = ⁅e | oa⁆ :=
trans (by simpa only [prob_event_map])
  (prob_event_eq_of_eval_dist_eq (eval_dist_map_nth_repeat oa i) e)

@[simp] lemma prob_event_head_repeat (e : set α) :
  ⁅λ xs, xs.head ∈ e | oa.repeat m.succ⁆ = ⁅e | oa⁆ :=
calc ⁅λ xs, xs.head ∈ e | oa.repeat m.succ⁆ = ⁅λ xs, xs.nth 0 ∈ e | oa.repeat m.succ⁆ :
    by simp only [vector.nth_zero]
  ... = ⁅e | oa⁆ : prob_event_nth_repeat oa e 0

lemma prob_event_all₂ (p : α → Prop) :
  ⁅λ xs, xs.to_list.all₂ p | oa.repeat m⁆ = ⁅p | oa⁆ ^ m :=
begin
  sorry
end

end prob_event

end oracle_comp