/-
Copyright (c) 2022 Devon Tuma. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Devon Tuma
-/
import computational_monads.distribution_semantics.prod

/-!
# Oracle Simulation Semantics

Defines the notion of simulating a computation by defining the outputs of oracle query.
A method of simulation is given by `sim_oracle`, which contains an internal state
  as well as a function to return a value and update the state given a query to the oracle.

It also contains a `default_state`, specifying the value to use for the default oracle state.
For example a logging query would use an empty log as the default state.

We define `simulate'` to be simulation followed by discarding the state.
This is useful for things like a random oracle, where the final log isn't relevant in general.
-/

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

/-- Specifies a way to simulate a set of oracles using another set of oracles.
  e.g. using uniform random selection to simulate a hash oracle

  `default_state` can be provided as a standard initial state for simulation.
  Used when calling `default_simulate` or `default_simulate'` -/
structure sim_oracle (spec spec' : oracle_spec) (S : Type) :=
(default_state : S)
(o (i : spec.ι) : (spec.domain i × S) → oracle_comp spec' (spec.range i × S))

namespace sim_oracle

/-- Example of an oracle maintaining in internal incrementing value,
  and returning a fake coin flip based on whether the state is even. -/
example : sim_oracle oracle_spec.coin_spec oracle_spec.coin_spec ℕ :=
{ default_state := 0,
  o := λ i ⟨t, n⟩, return (if even n then tt else ff, n + 1) }

/-- View a simulation oracle as a function corresponding to the internal oracle `o` -/
instance has_coe_to_fun : has_coe_to_fun (sim_oracle spec spec' S)
  (λ so, Π (i : spec.ι), spec.domain i × S → oracle_comp spec' (spec.range i × S)) :=
{ coe := λ so, so.o }

lemma has_coe_to_fun.def (so : sim_oracle spec spec' S) (i : spec.ι)
  (x : spec.domain i × S) : so i x = so.o i x := rfl

def inhabited_state (so : sim_oracle spec spec' S) : inhabited S := ⟨so.default_state⟩

instance inhabited [inhabited S] : inhabited (sim_oracle spec spec' S) :=
⟨{default_state := default, o := λ _ _, return default}⟩

end sim_oracle

namespace oracle_comp

open_locale big_operators ennreal
open oracle_spec

variables (so : sim_oracle spec spec' S) (so' : sim_oracle spec spec'' S')
  (a : α) (i : spec.ι) (t : spec.domain i) (oa oa' : oracle_comp spec α)
  (ob ob' : α → oracle_comp spec β) (oc : β → oracle_comp spec γ) (s : S) (f : α → β)

section simulate

/-- Simulate an oracle comp to an oracle comp with a different spec.
Requires providing a maximum recursion depth for the `repeat` constructor. -/
def simulate {spec spec' : oracle_spec} (so : sim_oracle spec spec' S) :
  Π {α : Type} (oa : oracle_comp spec α), S → oracle_comp spec' (α × S)
| _ (pure' α a) state := return ⟨a, state⟩
| _ (bind' α β oa ob) state := simulate oa state >>= λ x, simulate (ob x.1) x.2
| _ (query i t) state := so i (t, state)

/-- Convenience definition to use the default state as the initial state for `simulate`.
Marked to be reduced and inlined, so the definition is essentially just notation. -/
@[inline, reducible, simp]
def default_simulate (so : sim_oracle spec spec' S) (oa : oracle_comp spec α) :
  oracle_comp spec' (α × S) := simulate so oa so.default_state

@[simp] lemma simulate_return : simulate so (return a) s = return (a, s) := rfl

lemma simulate_pure' : simulate so (pure' α a) s = return (a, s) := rfl

lemma simulate_pure : simulate so (pure a) s = return (a, s) := rfl

@[simp] lemma simulate_bind : simulate so (oa >>= ob) s =
  simulate so oa s >>= λ x, simulate so (ob x.1) x.2 := rfl

lemma simulate_bind' : simulate so (bind' α β oa ob) s =
  simulate so oa s >>= λ x, simulate so (ob x.1) x.2 := rfl

@[simp] lemma simulate_query : simulate so (query i t) s = so i (t, s) := rfl

@[simp] lemma simulate_map : simulate so (f <$> oa) s = prod.map f id <$> simulate so oa s := rfl

instance simulate.decidable [hoa : oa.decidable] [decidable_eq S]
  [h : ∀ i t s, (so i (t, s)).decidable] : (oa.simulate so s).decidable :=
begin
  unfreezingI {induction oa using oracle_comp.induction_on
    with α a α β oa ob hoa' hob' i t generalizing s},
  { haveI : decidable_eq α := decidable_eq_of_decidable' hoa,
    exact oracle_comp.decidable_return (a, s) },
  { haveI : oa.decidable := decidable_of_decidable_bind_fst hoa,
    haveI : ∀ a, (ob a).decidable := λ a, decidable_of_decidable_bind_snd a hoa,
    haveI : (simulate so oa s).decidable := hoa' _,
    haveI : ∀ (x : α × S), (simulate so (ob x.1) x.2).decidable := λ x, hob' _ _,
    refine oracle_comp.decidable_bind' _ _ },
  { exact h i t s }
end

section support

lemma support_simulate_return : (simulate so (return a) s).support = {(a, s)} := rfl

lemma support_simulate_pure' : (simulate so (pure' α a) s).support = {(a, s)} := rfl

lemma support_simulate_pure : (simulate so (pure a) s).support = {(a, s)} := rfl

lemma support_simulate_bind : (simulate so (oa >>= ob) s).support =
  ⋃ x ∈ (simulate so oa s).support, (simulate so (ob $ prod.fst x) x.2).support := rfl

lemma mem_support_simulate_bind_iff (x : β × S) : x ∈ (simulate so (oa >>= ob) s).support ↔
  ∃ (a : α) (s' : S), (a, s') ∈ (simulate so oa s).support ∧ x ∈ (simulate so (ob a) s').support :=
by simp_rw [support_simulate_bind, set.mem_Union, prod.exists, exists_prop]

lemma support_simulate_bind' : (simulate so (bind' α β oa ob) s).support
  = ⋃ x ∈ (simulate so oa s).support, (simulate so (ob $ prod.fst x) x.2).support := rfl

lemma support_simulate_query : (simulate so (query i t) s).support = (so i (t, s)).support := rfl

lemma support_simulate_map : (simulate so (f <$> oa) s).support =
  prod.map f id '' (simulate so oa s).support := by rw [simulate_map, support_map]

end support

section fin_support

end fin_support

section eval_dist

lemma eval_dist_simulate_return : ⁅simulate so (return a) s⁆ = pmf.pure (a, s) := rfl

lemma eval_dist_simulate_pure' : ⁅simulate so (pure' α a) s⁆ = pmf.pure (a, s) := rfl

lemma eval_dist_simulate_pure : ⁅simulate so (pure a) s⁆ = pmf.pure (a, s) := rfl

@[simp] lemma eval_dist_simulate_bind : ⁅simulate so (oa >>= ob) s⁆ =
  (⁅simulate so oa s⁆).bind (λ x, ⁅simulate so (ob x.1) x.2⁆) :=
(congr_arg _ $ simulate_bind so oa ob s).trans (eval_dist_bind _ _)

lemma eval_dist_simulate_bind' : ⁅simulate so (bind' α β oa ob) s⁆ =
  (⁅simulate so oa s⁆).bind (λ x, ⁅simulate so (ob x.1) x.2⁆) :=
eval_dist_simulate_bind so oa ob s

lemma eval_dist_simulate_query : ⁅simulate so (query i t) s⁆ = ⁅so i (t, s)⁆ := rfl

lemma eval_dist_simulate_map : ⁅simulate so (f <$> oa) s⁆ =
  ⁅simulate so oa s⁆.map (prod.map f id) := by rw [simulate_map, eval_dist_map]

/-- Write the `eval_dist` of a simulation as a double summation over the possible
intermediate outputs and states of the computation. -/
lemma eval_dist_simulate_bind_apply_eq_tsum_tsum (x : β × S) : ⁅simulate so (oa >>= ob) s⁆ x =
  ∑' a s', ⁅simulate so oa s⁆ (a, s') * ⁅simulate so (ob a) s'⁆ x :=
by rw [simulate_bind, eval_dist_prod_bind]

lemma eval_dist_simulate_bind_apply_eq_sum_sum [fintype α] [fintype S] (x : β × S) :
  ⁅simulate so (oa >>= ob) s⁆ x = ∑ a s', ⁅simulate so oa s⁆ (a, s') * ⁅simulate so (ob a) s'⁆ x :=
by simp only [simulate_bind, eval_dist_bind_apply_eq_sum, ← @finset.sum_product ℝ≥0∞ S α _
  finset.univ finset.univ (λ y, ⁅simulate so oa s⁆ (y.1, y.2) * ⁅simulate so (ob y.1) y.2⁆ x),
  finset.univ_product_univ, prod.mk.eta]

end eval_dist

section prob_event

lemma prob_event_simulate_return (e : set (α × S)) :
  ⁅e | simulate so (return a) s⁆ = e.indicator (λ _, 1) (a, s) :=
prob_event_return_eq_indicator (a, s) e

lemma prob_event_simulate_bind_eq_tsum_tsum (e : set (β × S)) : ⁅e | simulate so (oa >>= ob) s⁆ =
  ∑' a s', ⁅simulate so oa s⁆ (a, s') * ⁅e | simulate so (ob a) s'⁆ :=
by simp_rw [simulate_bind, prob_event_bind_eq_tsum, ← ennreal.tsum_prod, prod.mk.eta]

lemma prob_event_simulate_bind_eq_sum_sum [fintype α] [fintype S] (e : set (β × S)) :
  ⁅e | simulate so (oa >>= ob) s⁆ =
    ∑ a s', ⁅simulate so oa s⁆ (a, s') * ⁅e | simulate so (ob a) s'⁆ :=
by simp only [simulate_bind, prob_event_bind_eq_sum, ← @finset.sum_product ℝ≥0∞ S α _ finset.univ
  finset.univ (λ x, ⁅simulate so oa s⁆ (x.1, x.2) * ⁅e | simulate so (ob x.1) x.2⁆),
  finset.univ_product_univ, prod.mk.eta]

lemma prob_event_simulate_query (e : set (spec.range i × S)) :
  ⁅e | simulate so (query i t) s⁆ = ⁅e | so i (t, s)⁆ := rfl

lemma prob_event_simulate_map (e : set (β × S)) :
  ⁅e | simulate so (f <$> oa) s⁆ = ⁅prod.map f id ⁻¹' e | simulate so oa s⁆ :=
by rw [simulate_map, prob_event_map]

end prob_event

end simulate

section simulate'

/-- Get the result of simulation without returning the internal oracle state -/
def simulate' (so : sim_oracle spec spec' S) (oa : oracle_comp spec α) (s : S) :
  oracle_comp spec' α := prod.fst <$> oa.simulate so s

/-- Convenience definition to use the default state as the initial state for `simulate'`.
Marked to be reduced and inlined, so the definition is essentially just notation. -/
@[inline, reducible, simp]
def default_simulate' (so : sim_oracle spec spec' S) (oa : oracle_comp spec α) :
  oracle_comp spec' α := oa.simulate' so so.default_state

lemma simulate'_def : simulate' so oa s = prod.fst <$> oa.simulate so s := rfl

-- TODO: these should have a special simp category, to not be eagerly applied
@[simp] lemma simulate'_return : simulate' so (return a) s = prod.fst <$> (return (a, s)) := rfl

lemma simulate'_pure' : simulate' so (pure' α a) s = prod.fst <$> (return (a, s)) := rfl

lemma simulate'_pure : simulate' so (pure a) s = prod.fst <$> (return (a, s)) := rfl

@[simp] lemma simulate'_bind : simulate' so (oa >>= ob) s =
  prod.fst <$> (simulate so oa s >>= λ x, simulate so (ob x.1) x.2) := rfl

lemma simulate'_bind' : simulate' so (bind' α β oa ob) s =
  prod.fst <$> (simulate so oa s >>= λ x, simulate so (ob x.1) x.2) := rfl

@[simp] lemma simulate'_query : simulate' so (query i t) s = prod.fst <$> so i (t, s) := rfl

@[simp] lemma simulate'_map : simulate' so (f <$> oa) s =
  prod.fst <$> (prod.map f id <$> simulate so oa s) := rfl

instance simulate'.decidable [hoa : oa.decidable] [decidable_eq S]
  [h : ∀ i t s, (so i (t, s)).decidable] : (oa.simulate' so s).decidable :=
begin
  haveI : decidable_eq α := decidable_eq_of_decidable oa,
  exact oracle_comp.decidable_map _ _,
end

section support

@[simp] lemma support_simulate' : (simulate' so oa s).support =
  prod.fst '' (simulate so oa s).support := by simp only [simulate', support_map]

lemma mem_support_simulate'_iff_exists_state (a : α) :
  a ∈ (simulate' so oa s).support ↔ ∃ (s' : S), (a, s') ∈ (simulate so oa s).support :=
by simp only [support_simulate', set.mem_image, prod.exists,
  exists_and_distrib_right, exists_eq_right]

lemma support_simulate'_return (a : α) : (simulate' so (return a) s).support = {a} :=
by simp only [simulate'_return, support_map, support_return, set.image_singleton]

lemma support_simulate'_pure' (a : α) : (simulate' so (pure' α a) s).support = {a} :=
support_simulate'_return so s a

lemma support_simulate'_pure (a : α) : (simulate' so (pure a) s).support = {a} :=
support_simulate'_return so s a

@[simp] lemma support_simulate'_bind : (simulate' so (oa >>= ob) s).support =
  ⋃ x ∈ (simulate so oa s).support, (simulate' so (ob $ prod.fst x) x.snd).support :=
by simp [set.image_Union]

lemma support_simulate'_bind' : (simulate' so (bind' α β oa ob) s).support =
  ⋃ x ∈ (simulate so oa s).support, (simulate' so (ob $ prod.fst x) x.snd).support :=
support_simulate'_bind so oa ob s

lemma support_simulate'_query : (simulate' so (query i t) s).support =
  prod.fst '' (so i (t, s)).support := by simp only [simulate'_query, support_map]

@[simp] lemma support_simulate'_map : (simulate' so (f <$> oa) s).support =
  f '' (simulate' so oa s).support :=
by simp only [simulate', support_map, support_simulate_map, set.image_image, prod.map_fst]

end support

section eval_dist

@[simp] lemma eval_dist_simulate' : ⁅simulate' so oa s⁆ = ⁅simulate so oa s⁆.map prod.fst :=
eval_dist_map _ prod.fst

/-- Express the probability of `simulate'` returning a specific value
as the sum over all possible output states of the probability of `simulate` return it -/
lemma eval_dist_simulate'_apply : ⁅simulate' so oa s⁆ a = ∑' s', ⁅simulate so oa s⁆ (a, s') :=
begin
  rw [eval_dist_simulate', pmf.map_apply],
  refine (tsum_prod_eq_tsum_snd a $ λ s a' ha', _).trans (tsum_congr (λ s', _)),
  { simp only [ne.symm ha', if_false] },
  { simp only [eq_self_iff_true, if_true] }
end

lemma eval_dist_simulate'_return : ⁅simulate' so (return a) s⁆ = pmf.pure a :=
by simp only [simulate'_return, eval_dist_map, eval_dist_return, pmf.map_pure]

lemma eval_dist_simulate'_pure' : ⁅simulate' so (pure' α a) s⁆ = pmf.pure a :=
eval_dist_simulate'_return so a s

lemma eval_dist_simulate'_pure : ⁅simulate' so (pure a) s⁆ = pmf.pure a :=
eval_dist_simulate'_return so a s

lemma eval_dist_simulate'_bind : ⁅simulate' so (oa >>= ob) s⁆ =
  ⁅simulate so oa s⁆.bind (λ x, ⁅simulate' so (ob x.1) x.2⁆) :=
by simp only [simulate'_bind, eval_dist_map_bind, eval_dist_bind, eval_dist_map,
  eval_dist_simulate', eq_self_iff_true, pmf.map_bind]

lemma eval_dist_simulate'_bind_apply (b : β) : ⁅simulate' so (oa >>= ob) s⁆ b
  = ∑' (a : α) (s' : S), ⁅simulate so oa s⁆ (a, s') * ⁅simulate' so (ob a) s'⁆ b :=
by rw [eval_dist_simulate'_bind, pmf.bind_apply, tsum_prod'
  ennreal.summable (λ _, ennreal.summable)]

lemma eval_dist_simulate'_bind' : ⁅simulate' so (bind' α β oa ob) s⁆ =
  ⁅simulate so oa s⁆.bind (λ x, ⁅simulate' so (ob x.1) x.2⁆) := eval_dist_simulate'_bind _ _ _ s

lemma eval_dist_simulate'_query : ⁅simulate' so (query i t) s⁆ = ⁅so i (t, s)⁆.map prod.fst :=
by simp only [simulate'_query, eval_dist_map]

@[simp] lemma eval_dist_simulate'_map : ⁅simulate' so (f <$> oa) s⁆ = ⁅simulate' so oa s⁆.map f :=
by simp_rw [eval_dist_simulate', eval_dist_simulate_map, pmf.map_comp, prod.map_fst']

end eval_dist

section prob_event

lemma prob_event_simulate' (e : set α) :
  ⁅e | simulate' so oa s⁆ = ⁅prod.fst ⁻¹' e | simulate so oa s⁆ :=
by rw [simulate', prob_event_map]

lemma prob_event_simulate'_return_eq_indicator (e : set α) :
  ⁅e | simulate' so (return a) s⁆ = e.indicator (λ _, 1) a :=
begin
  rw [prob_event_simulate', prob_event_simulate_return],
  by_cases ha : a ∈ e,
  { have : (a, s) ∈ (prod.fst ⁻¹' e : set (α × S)) := ha,
    rw [set.indicator_of_mem ha, set.indicator_of_mem this] },
  { have : (a, s) ∉ (prod.fst ⁻¹' e : set (α × S)) := ha,
    rw [set.indicator_of_not_mem ha, set.indicator_of_not_mem this] }
end

lemma prob_event_simulate'_return_eq_ite (e : set α) [decidable_pred (∈ e)] :
  ⁅e | simulate' so (return a) s⁆ = ite (a ∈ e) 1 0 :=
by {rw [prob_event_simulate'_return_eq_indicator, set.indicator], congr}

lemma prob_event_simulate'_bind_eq_tsum_tsum (e : set β) : ⁅e | simulate' so (oa >>= ob) s⁆ =
  ∑' a s', ⁅simulate so oa s⁆ (a, s') * ⁅e | simulate' so (ob a) s'⁆ :=
by simp_rw [prob_event_simulate', prob_event_simulate_bind_eq_tsum_tsum]

lemma prob_event_simulate'_bind_eq_sum_sum [fintype α] [fintype S] (e : set β) :
  ⁅e | simulate' so (oa >>= ob) s⁆ =
    ∑ a s', ⁅simulate so oa s⁆ (a, s') * ⁅e | simulate' so (ob a) s'⁆ :=
by simp_rw [prob_event_simulate', prob_event_simulate_bind_eq_sum_sum]

lemma prob_event_simulate'_query (e : set (spec.range i)) :
  ⁅e | simulate' so (query i t) s⁆ = ⁅prod.fst ⁻¹' e | so i (t, s)⁆ :=
by rw [prob_event_simulate', prob_event_simulate_query]

lemma prob_event_simulate'_map (e : set β) :
  ⁅e | simulate' so (f <$> oa) s⁆ = ⁅(f ∘ prod.fst) ⁻¹' e | simulate so oa s⁆ :=
by simpa only [prob_event_simulate', prob_event_simulate_map, ← set.preimage_comp]

end prob_event

end simulate'

end oracle_comp


/- refl: reflexive
proves goals of form x=x -/
theorem example1 (x y z : Nat) : x * y + z = x * y + z :=
  rfl

/- rw: rewrite (substitution)

-/


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

Transferring `traversable` instances using isomorphisms.
-/
import data.equiv.basic category.traversable.lemmas

universes u

namespace equiv

section functor
parameters {t t' : Type u → Type u}
parameters (eqv : Π α, t α ≃ t' α)
variables [functor t]

open functor

protected def map {α β : Type u} (f : α → β) (x : t' α) : t' β :=
eqv β $ map f ((eqv α).symm x)

protected def functor : functor t' :=
{ map := @equiv.map _ }

variables [is_lawful_functor t]

protected lemma id_map {α : Type u} (x : t' α) : equiv.map id x = x :=
by simp [equiv.map, id_map]

protected lemma comp_map {α β γ : Type u} (g : α → β) (h : β → γ) (x : t' α) :
  equiv.map (h ∘ g) x = equiv.map h (equiv.map g x) :=
by simp [equiv.map]; apply comp_map

protected def is_lawful_functor : @is_lawful_functor _ equiv.functor :=
{ id_map := @equiv.id_map _ _,
  comp_map := @equiv.comp_map _ _ }

protected def is_lawful_functor' [F : _root_.functor t']
  (h₀ : ∀ {α β} (f : α → β), _root_.functor.map f = equiv.map f)
  (h₁ : ∀ {α β} (f : β), _root_.functor.map_const f = (equiv.map ∘ function.const α) f) :
  _root_.is_lawful_functor t' :=
begin
  have : F = equiv.functor,
  { unfreezeI, cases F, dsimp [equiv.functor],
    congr; ext; [rw ← h₀, rw ← h₁] },
  constructor; intros;
  haveI F' := equiv.is_lawful_functor,
  { simp, intros, ext,
    rw [h₁], rw ← this at F',
    have k := @map_const_eq t' _ _ α β, rw this at ⊢ k, rw ← k, refl },
  { rw [h₀], rw ← this at F',
    have k := id_map x, rw this at k, apply k },
  { rw [h₀], rw ← this at F',
    have k := comp_map g h x, revert k, rw this, exact id },
end

end functor

section traversable
parameters {t t' : Type u → Type u}
parameters (eqv : Π α, t α ≃ t' α)
variables [traversable t]
variables {m : Type u → Type u} [applicative m]
variables {α β : Type u}

protected def traverse (f : α → m β) (x : t' α) : m (t' β) :=
eqv β <$> traverse f ((eqv α).symm x)

protected def traversable : traversable t' :=
{ to_functor := equiv.functor eqv,
  traverse := @equiv.traverse _ }

end traversable

section equiv
parameters {t t' : Type u → Type u}
parameters (eqv : Π α, t α ≃ t' α)
variables [traversable t] [is_lawful_traversable t]
variables {F G : Type u → Type u} [applicative F] [applicative G]
variables [is_lawful_applicative F] [is_lawful_applicative G]
variables (η : applicative_transformation F G)
variables {α β γ : Type u}

open is_lawful_traversable functor

protected lemma id_traverse (x : t' α) :
  equiv.traverse eqv id.mk x = x :=
by simp! [equiv.traverse,id_bind,id_traverse,functor.map] with functor_norm

protected lemma traverse_eq_map_id (f : α → β) (x : t' α) :
  equiv.traverse eqv (id.mk ∘ f) x = id.mk (equiv.map eqv f x) :=
by simp [equiv.traverse, traverse_eq_map_id] with functor_norm; refl

protected lemma comp_traverse (f : β → F γ) (g : α → G β) (x : t' α) :
  equiv.traverse eqv (comp.mk ∘ functor.map f ∘ g) x =
  comp.mk (equiv.traverse eqv f <$> equiv.traverse eqv g x) :=
by simp [equiv.traverse,comp_traverse] with functor_norm; congr; ext; simp

protected lemma naturality (f : α → F β) (x : t' α) :
  η (equiv.traverse eqv f x) = equiv.traverse eqv (@η _ ∘ f) x :=
by simp [equiv.traverse] with functor_norm

protected def is_lawful_traversable :
  @is_lawful_traversable t' (equiv.traversable eqv) :=
{ to_is_lawful_functor := @equiv.is_lawful_functor _ _ eqv _ _,
  id_traverse := @equiv.id_traverse _ _,
  comp_traverse := @equiv.comp_traverse _ _,
  traverse_eq_map_id := @equiv.traverse_eq_map_id _ _,
  naturality := @equiv.naturality _ _ }

protected def is_lawful_traversable' [_i : traversable t']
  (h₀ : ∀ {α β} (f : α → β),
         map f = equiv.map eqv f)
  (h₁ : ∀ {α β} (f : β),
         map_const f = (equiv.map eqv ∘ function.const α) f)
  (h₂ : ∀ {F : Type u → Type u} [applicative F] [is_lawful_applicative F]
          {α β} (f : α → F β),
         traverse f = equiv.traverse eqv f) :
  _root_.is_lawful_traversable t' :=
begin
    -- we can't use the same approach as for `is_lawful_functor'` because
    -- h₂ needs a `is_lawful_applicative` assumption
  refine {to_is_lawful_functor :=
    equiv.is_lawful_functor' eqv @h₀ @h₁, ..}; intros; resetI,
  { rw [h₂, equiv.id_traverse], apply_instance },
  { rw [h₂, equiv.comp_traverse f g x, h₂], congr,
    rw [h₂], all_goals { apply_instance } },
  { rw [h₂, equiv.traverse_eq_map_id, h₀]; apply_instance },
  { rw [h₂, equiv.naturality, h₂]; apply_instance }
end

end equiv
end equiv


/-
Copyright (c) 2020 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon
-/
import control.monad.basic
import control.monad.cont
import control.monad.writer
import data.equiv.basic
import tactic.interactive

/-!
# Universe lifting for type families

Some functors such as `option` and `list` are universe polymorphic. Unlike
type polymorphism where `option α` is a function application and reasoning and
generalizations that apply to functions can be used, `option.{u}` and `option.{v}`
are not one function applied to two universe names but one polymorphic definition
instantiated twice. This means that whatever works on `option.{u}` is hard
to transport over to `option.{v}`. `uliftable` is an attempt at improving the situation.

`uliftable option.{u} option.{v}` gives us a generic and composable way to use
`option.{u}` in a context that requires `option.{v}`. It is often used in tandem with
`ulift` but the two are purposefully decoupled.

## Main definitions
  * `uliftable` class

## Tags

universe polymorphism functor

-/

universes u₀ u₁ v₀ v₁ v₂ w w₀ w₁

/-- Given a universe polymorphic type family `M.{u} : Type u₁ → Type
u₂`, this class convert between instantiations, from
`M.{u} : Type u₁ → Type u₂` to `M.{v} : Type v₁ → Type v₂` and back -/
class uliftable (f : Type u₀ → Type u₁) (g : Type v₀ → Type v₁) :=
(congr [] {α β} : α ≃ β → f α ≃ g β)

namespace uliftable

/-- The most common practical use `uliftable` (together with `up`), this function takes
`x : M.{u} α` and lifts it to M.{max u v} (ulift.{v} α) -/
@[reducible]
def up {f : Type u₀ → Type u₁} {g : Type (max u₀ v₀) → Type v₁} [uliftable f g]
  {α} : f α → g (ulift α) :=
(uliftable.congr f g equiv.ulift.symm).to_fun

/-- The most common practical use of `uliftable` (together with `up`), this function takes
`x : M.{max u v} (ulift.{v} α)` and lowers it to `M.{u} α` -/
@[reducible]
def down {f : Type u₀ → Type u₁} {g : Type (max u₀ v₀) → Type v₁} [uliftable f g]
  {α} : g (ulift α) → f α :=
(uliftable.congr f g equiv.ulift.symm).inv_fun

/-- convenient shortcut to avoid manipulating `ulift` -/
def adapt_up (F : Type v₀ → Type v₁) (G : Type (max v₀ u₀) → Type u₁)
  [uliftable F G] [monad G] {α β}
  (x : F α) (f : α → G β) : G β :=
up x >>= f ∘ ulift.down

/-- convenient shortcut to avoid manipulating `ulift` -/
def adapt_down {F : Type (max u₀ v₀) → Type u₁} {G : Type v₀ → Type v₁}
  [L : uliftable G F] [monad F] {α β}
  (x : F α) (f : α → G β) : G β :=
@down.{v₀ v₁ (max u₀ v₀)} G F L β $ x >>= @up.{v₀ v₁ (max u₀ v₀)} G F L β ∘ f

/-- map function that moves up universes -/
def up_map {F : Type u₀ → Type u₁} {G : Type.{max u₀ v₀} → Type v₁} [inst : uliftable F G]
  [functor G] {α β} (f : α → β) (x : F α) : G β :=
functor.map (f ∘ ulift.down) (up x)

/-- map function that moves down universes -/
def down_map {F : Type.{max u₀ v₀} → Type u₁} {G : Type → Type v₁} [inst : uliftable G F]
  [functor F] {α β} (f : α → β) (x : F α) : G β :=
down (functor.map (ulift.up ∘ f) x : F (ulift β))

@[simp]
lemma up_down  {f : Type u₀ → Type u₁} {g : Type (max u₀ v₀) → Type v₁} [uliftable f g]
  {α} (x : g (ulift α)) : up (down x : f α) = x :=
(uliftable.congr f g equiv.ulift.symm).right_inv _

@[simp]
lemma down_up  {f : Type u₀ → Type u₁} {g : Type (max u₀ v₀) → Type v₁} [uliftable f g]
  {α} (x : f α) : down (up x : g _) = x :=
(uliftable.congr f g equiv.ulift.symm).left_inv _

end uliftable

open ulift

instance : uliftable id id :=
{ congr := λ α β F, F }

/-- for specific state types, this function helps to create a uliftable instance -/
def state_t.uliftable' {s : Type u₀} {s' : Type u₁}
  {m : Type u₀ → Type v₀} {m' : Type u₁ → Type v₁}
  [uliftable m m']
  (F : s ≃ s') :
  uliftable (state_t s m) (state_t s' m') :=
{ congr :=
    λ α β G, state_t.equiv $ equiv.Pi_congr F $
      λ _, uliftable.congr _ _ $ equiv.prod_congr G F }

instance {s m m'}
  [uliftable m m'] :
  uliftable (state_t s m) (state_t (ulift s) m') :=
state_t.uliftable' equiv.ulift.symm

/-- for specific reader monads, this function helps to create a uliftable instance -/
def reader_t.uliftable' {s s' m m'}
  [uliftable m m']
  (F : s ≃ s') :
  uliftable (reader_t s m) (reader_t s' m') :=
{ congr :=
    λ α β G, reader_t.equiv $ equiv.Pi_congr F $
      λ _, uliftable.congr _ _ G }

instance {s m m'} [uliftable m m'] : uliftable (reader_t s m) (reader_t (ulift s) m') :=
reader_t.uliftable' equiv.ulift.symm

/-- for specific continuation passing monads, this function helps to create a uliftable instance -/
def cont_t.uliftable' {r r' m m'}
  [uliftable m m']
  (F : r ≃ r') :
  uliftable (cont_t r m) (cont_t r' m') :=
{ congr :=
    λ α β, cont_t.equiv (uliftable.congr _ _ F)  }

instance {s m m'} [uliftable m m'] : uliftable (cont_t s m) (cont_t (ulift s) m') :=
cont_t.uliftable' equiv.ulift.symm

/-- for specific writer monads, this function helps to create a uliftable instance -/
def writer_t.uliftable' {w w' m m'}
  [uliftable m m']
  (F : w ≃ w') :
  uliftable (writer_t w m) (writer_t w' m') :=
{ congr :=
    λ α β G, writer_t.equiv $ uliftable.congr _ _ $ equiv.prod_congr G F }

instance {s m m'} [uliftable m m'] : uliftable (writer_t s m) (writer_t (ulift s) m') :=
writer_t.uliftable' equiv.ulift.symm


import Iris.BI
import Iris.Std

namespace Iris.Proofmode
open Iris.BI Iris.Std
open Lean

/-- Single separation logic context, implemented as a list of hypotheses. A custom datatype is used
instead of the standard `List` to ensure that all operations are `reducible`. -/
inductive Env (α : Type)
  | nil  : Env α
  | cons : α → Env α → Env α

-- Env Operations
namespace Env

/-- Append a hypothesis to the end of the environment. -/
@[reducible]
def append : Env α → α → Env α
  | .nil, b       => .cons b .nil
  | .cons a as, b => .cons a <| as.append b

/-- Return whether the environment is empty, i.e. it contains no hypotheses. -/
@[reducible]
def isEmpty : Env α → Bool
  | .nil      => true
  | .cons _ _ => false

/-- Return the length of the environment, i.e. the number of contained hypotheses. -/
@[reducible]
def length : Env α → Nat
  | .nil       => 0
  | .cons _ as => as.length + 1

theorem length_cons_list_cons {a : α} {as : List α} {b : β} {bs : Env β} :
  (a :: as).length = (Env.cons b bs).length →
  as.length = bs.length
:= by
  intro h
  simp only [length, List.length] at h
  rw' [Nat.add_right_cancel h]

/-- Delete the hypothesis at the given index. -/
@[reducible]
def delete : (Γ : Env α) → Fin (Γ.length) → Env α
  | .cons _ as, ⟨0    , _⟩ => as
  | .cons a as, ⟨i + 1, h⟩ => .cons a <| as.delete ⟨i, Nat.lt_of_succ_lt_succ h⟩

/-- Return the hypothesis at a given index without removing it. -/
@[reducible]
def get : (Γ : Env α) → Fin (Γ.length) → α
  | .cons a _ , ⟨0    , _⟩ => a
  | .cons _ as, ⟨i + 1, h⟩ => as.get ⟨i, Nat.lt_of_succ_lt_succ h⟩

/-- Split the environment into two disjoint environments. The given boolean mask must have the same
length as the environment. If the boolean mask contains the value `true` at a given index, the
hypothesis at the same index in the original environment is contained in the left environment in
the result. If the value is `false`, the hypothesis is contained in the right environment. -/
@[reducible]
def split : (Γ : Env α) → (mask : List Bool) → (mask.length = Γ.length) → Env α × Env α
  | .nil, .nil, _ => (.nil, .nil)
  | .cons a as, b :: bs, h =>
    let (ls, rs) := split as bs (length_cons_list_cons h)
    if b then (.cons a ls, rs) else (ls, .cons a rs)

/-- Return a list with exactly the hypotheses from the environment in the same order as in
the environment. -/
@[reducible]
def toList : Env α → List α
  | .nil       => []
  | .cons a as => a :: toList as

/-- Proposition of membership for an hypothesis in an environment. -/
inductive Mem : α → Env α → Prop
  | head (a : α) (as : Env α)         : Mem a (.cons a as)
  | tail (a : α) {b : α} (as : Env α) : Mem b as → Mem b (.cons a as)

instance : Membership α (Env α) where
  mem := Mem

instance : Coe (Env α) (List α) where
  coe := toList

delab_rule toList
  | `($_ $env) => `($env)

instance [ToString α] : ToString <| Env α where
  toString e := e.toList.toString

end Env

-- Env Theorems
theorem env_mem_cons_1 [BI PROP] {P : PROP} {Ps : Env PROP} : P ∈ Env.cons P Ps := by
  simp [Membership.mem, Env.Mem.head]

theorem env_mem_cons_2 [BI PROP] {P Q : PROP} {Ps : Env PROP} : P ∈ Ps → P ∈ Env.cons Q Ps := by
  intro h_Ps
  apply Env.Mem.tail
  exact h_Ps

theorem env_delete_cons [BI PROP] {P : PROP} {Ps : Env PROP} {i : Nat} {h : i + 1 < (Env.cons P Ps).length} :
  (Env.cons P Ps).delete ⟨i + 1, h⟩ = (Env.cons P <| Ps.delete ⟨i, Nat.lt_of_succ_lt_succ h⟩)
:= by
  rw' [Env.delete]
  · exact P
  · exact Nat.zero_lt_succ _

theorem env_get_cons [BI PROP] {P : PROP} {Ps : Env PROP} {i : Nat} {h : i + 1 < (Env.cons P Ps).length} :
  (Env.cons P Ps).get ⟨i + 1, h⟩ = Ps.get ⟨i, Nat.lt_of_succ_lt_succ h⟩
:= by
  rw' [Env.get]
  · exact Ps
  · exact Nat.zero_lt_succ _

theorem env_big_op_sep_append [BI PROP] {Γ : Env PROP} {P : PROP} : [∗] (Γ.append P) ⊣⊢ [∗] Γ ∗ P := by
  induction Γ
  <;> simp only [Env.append, Env.toList]
  case nil =>
    simp only [big_op]
    rw' [(left_id : emp ∗ _ ⊣⊢ _)]
  case cons P' _ h_ind =>
    rw' [
      !big_op_sep_cons,
      h_ind,
      ← (assoc : _ ⊣⊢ (P' ∗ _) ∗ P)]

theorem env_big_op_and_append [BI PROP] {Γ : Env PROP} {P : PROP} : □ [∧] (Γ.append P) ⊣⊢ □ [∧] Γ ∗ □ P := by
  induction Γ
  <;> simp only [Env.append, Env.toList]
  case nil =>
    simp only [big_op]
    rw' [
      intuitionistically_True_emp,
      (left_id : emp ∗ _ ⊣⊢ _)]
  case cons P' _ h_ind =>
    rw' [
      !big_op_and_cons,
      !intuitionistically_and,
      !and_sep_intuitionistically,
      h_ind,
      ← (assoc : _ ⊣⊢ (□ P' ∗ _) ∗ □ P)]

theorem env_idx_rec [BI PROP] (P : (Γ : Env PROP) → Fin Γ.length → Prop)
  (zero : ∀ {P'} {Γ'} {is_lt}, P (.cons P' Γ') ⟨0, is_lt⟩)
  (succ : ∀ {P'} {Γ'} {val} {is_lt} {is_lt'}, P Γ' ⟨val, is_lt⟩ → P (.cons P' Γ') ⟨Nat.succ val, is_lt'⟩) :
  ∀ Γ i, P Γ i
:= by
  intro Γ i
  let ⟨val, is_lt⟩ := i
  induction val generalizing Γ
  case zero =>
    cases Γ with
    | nil =>
      contradiction
    | cons P' Γ' =>
      exact zero
  case succ val h_ind =>
    cases Γ with
    | nil =>
      contradiction
    | cons P' Γ' =>
      let is_lt := Nat.lt_of_succ_lt_succ is_lt
      specialize h_ind Γ' ⟨val, is_lt⟩ is_lt
      exact succ h_ind

theorem env_big_op_sep_delete_get [BI PROP] {Γ : Env PROP} (i : Fin Γ.length) :
  [∗] Γ ⊣⊢ [∗] (Γ.delete i) ∗ (Γ.get i)
:= by
  induction Γ, i using env_idx_rec
  case zero P' _ _ =>
    rw' [
      Env.delete,
      Env.get,
      big_op_sep_cons,
      (comm : P' ∗ _ ⊣⊢ _)]
  case succ P' _ _ _ _ h_ind =>
    rw' [
      env_delete_cons,
      env_get_cons,
      !big_op_sep_cons,
      ← (assoc : _ ⊣⊢ (P' ∗ _) ∗ _),
      ← h_ind]

theorem env_big_op_and_delete_get [BI PROP] {Γ : Env PROP} (i : Fin Γ.length) :
  □ [∧] Γ ⊣⊢ □ [∧] (Γ.delete i) ∗ □ (Γ.get i)
:= by
  induction Γ, i using env_idx_rec
  case zero P' _ _ =>
    rw' [
      Env.delete,
      Env.get,
      big_op_and_cons,
      intuitionistically_and,
      and_sep_intuitionistically,
      (comm : □ P' ∗ _ ⊣⊢ _)]
  case succ P' _ _ _ _ h_ind =>
    rw' [
      env_delete_cons,
      env_get_cons,
      !big_op_and_cons,
      !intuitionistically_and,
      !and_sep_intuitionistically,
      ← (assoc : _ ⊣⊢ (□ P' ∗ _) ∗ _),
      ← h_ind]

theorem env_delete_length [BI PROP] {Γ : Env PROP} {i : Fin Γ.length} : (Γ.delete i).length = Γ.length - 1 := by
  induction Γ, i using env_idx_rec
  case zero =>
    rw [Env.delete, Env.length, Nat.add_sub_cancel]
  case succ _ _ is_lt _ h_ind =>
    rw [
      env_delete_cons,
      Env.length,
      h_ind,
      Env.length,
      Nat.add_sub_cancel,
      Nat.sub_add_cancel ?_]
    · apply Nat.succ_le_of_lt
      exact Nat.zero_lt_of_lt is_lt

theorem env_delete_idx_length [BI PROP] {Γ : Env PROP} {i : Fin Γ.length} : i ≤ (Γ.delete i).length := by
  let ⟨val, is_lt⟩ := i
  rw [env_delete_length]
  apply Nat.le_of_lt_succ
  rw [Nat.succ_eq_add_one, Nat.sub_add_cancel ?_]
  exact is_lt
  · apply Nat.succ_le_of_lt
    exact Nat.zero_lt_of_lt is_lt

theorem env_delete_idx_length_of_lt [BI PROP] {Γ : Env PROP} {i : Fin Γ.length} {j : Nat} : j < i → j < (Γ.delete i).length := by
  intro h
  apply Nat.lt_of_lt_of_le h ?_
  exact env_delete_idx_length

theorem env_delete_idx_pred_length [BI PROP] {Γ : Env PROP} (i : Fin Γ.length) (h : 0 < i.val) : ∀ {j}, (i - 1) < (Γ.delete j).length := by
  intro j
  let ⟨val, is_lt⟩ := i
  rw [env_delete_length]
  apply Nat.lt_sub_of_add_lt
  rw [Nat.sub_add_cancel]
  exact is_lt
  · apply Nat.succ_le_of_lt
    exact h

theorem env_split_cons_false [BI PROP] {P : PROP} {Ps : Env PROP} {bs : List Bool} {Γ₁ Γ₂ : Env PROP} {h : (false :: bs).length = (Env.cons P Ps).length} :
  (Γ₁, Γ₂) = (Env.cons P Ps).split (false :: bs) h →
  ∃ (Γ₂' : Env PROP), Γ₂ = Env.cons P Γ₂' ∧
  ∃ (h' : bs.length = Ps.length), (Γ₁, Γ₂') = Ps.split bs h'
:= by
  intro h_split
  simp only [Env.split] at h_split
  cases h_split
  apply Exists.intro _
  apply And.intro rfl ?_
  apply Exists.intro (Env.length_cons_list_cons h)
  simp

theorem env_split_cons_true [BI PROP] {P : PROP} {Ps : Env PROP} {bs : List Bool} {Γ₁ Γ₂ : Env PROP} {h : (true :: bs).length = (Env.cons P Ps).length} :
  (Γ₁, Γ₂) = (Env.cons P Ps).split (true :: bs) h →
  ∃ (Γ₁' : Env PROP), Γ₁ = Env.cons P Γ₁' ∧
  ∃ (h' : bs.length = Ps.length), (Γ₁', Γ₂) = Ps.split bs h'
:= by
  intro h_split
  simp only [Env.split] at h_split
  cases h_split
  apply Exists.intro _
  apply And.intro rfl ?_
  apply Exists.intro (Env.length_cons_list_cons h)
  simp

theorem env_big_op_sep_split [BI PROP] {Γ Γ₁ Γ₂ : Env PROP} {mask : List Bool} {h : mask.length = Γ.length} :
  (Γ₁, Γ₂) = Γ.split mask h →
  ([∗] Γ : PROP) ⊢ [∗] Γ₁ ∗ [∗] Γ₂
:= by
  intro h_split
  induction Γ generalizing mask Γ₁ Γ₂
  case nil =>
    cases mask
    case nil =>
      simp only [Env.split] at h_split
      cases h_split
      simp only [big_op]
      rw' [(left_id : emp ∗ _ ⊣⊢ _)]
    case cons =>
      simp only [List.length, Env.length] at h
      contradiction
  case cons P Ps h_ind =>
    cases mask
    case nil =>
      simp only [List.length, Env.length] at h
      contradiction
    case cons b bs =>
      cases b
      case false =>
        let ⟨_, h_split_P, _, h_split_Ps⟩ := env_split_cons_false h_split
        rw' [h_split_P]
        simp only [Env.toList]
        rw' [
          !big_op_sep_cons,
          (assoc : _ ∗ (P ∗ _) ⊣⊢ _),
          (comm : _ ∗ P ⊣⊢ _),
          ← (assoc : _ ⊣⊢ (P ∗ _) ∗ _),
          h_ind h_split_Ps]
      case true =>
        let ⟨_, h_split_P, _, h_split_Ps⟩ := env_split_cons_true h_split
        rw' [h_split_P]
        simp only [Env.toList]
        rw' [
          !big_op_sep_cons,
          ← (assoc : _ ⊣⊢ (P ∗ _) ∗ _),
          h_ind h_split_Ps]

/-- Combined separation logic context with two `Env` objects for the intuitionistic and
spatial context. -/
structure Envs (PROP : Type) [BI PROP] where
  intuitionistic : Env PROP
  spatial        : Env PROP

/-- Embedding of a separation logic context in form of an `Envs` object in a separation
logic proposition. -/
def of_envs [BI PROP] : Envs PROP → PROP
  | ⟨Γₚ, Γₛ⟩ => `[iprop| □ [∧] Γₚ ∗ [∗] Γₛ]

/-- Embedding of a separation logic context in form of an `Envs` object together with a separation
logic proposition in one separation logic proposition. This embedding is used in the Iris Proof
Mode where the embedded proposition is the goal of the proof. -/
def envs_entails [BI PROP] (Δ : Envs PROP) (Q : PROP) : Prop :=
  of_envs Δ ⊢ Q

/-- Types of hypotheses. -/
inductive HypothesisType
  | intuitionistic | spatial
  deriving BEq

/-- Unbounded index of a hypothesis in a combined separation logic context.

This datatype is used for convenience on the meta level only - environment operations and theorems
use the bounded dataype `EnvsIndex` instead. -/
structure HypothesisIndex where
  type : HypothesisType
  index : Nat
  length : Nat
  deriving BEq

/-- Bounded index of a hypothesis in a combined separation logic context.

The lengths of the individual contexts are used as type arguments instead of an `Envs` object to
allow for an easier syntax generation on the meta level. -/
inductive EnvsIndex (lₚ lₛ : Nat)
  | p : Fin lₚ → EnvsIndex lₚ lₛ
  | s : Fin lₛ → EnvsIndex lₚ lₛ

/-- Return the hypothesis type of the hypothesis referenced by the given index. -/
@[reducible]
def EnvsIndex.type : EnvsIndex lₚ lₛ → HypothesisType
  | .p _ => .intuitionistic
  | .s _ => .spatial

/-- Return the unbounded index value of the given index. -/
@[reducible]
def EnvsIndex.val : EnvsIndex lₚ lₛ → Nat
  | .p ⟨val, _⟩ => val
  | .s ⟨val, _⟩ => val

/-- `EnvsIndex` type for the given `Envs` object. -/
abbrev EnvsIndex.of [BI PROP] (Δ : Envs PROP) := EnvsIndex Δ.intuitionistic.length Δ.spatial.length

/-- Generate the syntax of a (bounded) `EnvsIndex` object based on an unbounded `HypothesisIndex`.
The proofs of the index bounds are generated using the tactic `decide`. -/
def HypothesisIndex.quoteAsEnvsIndex : HypothesisIndex → MetaM (TSyntax `term)
  | ⟨.intuitionistic, index, length⟩ =>
    ``(EnvsIndex.p ⟨$(quote index), by show $(quote index) < $(quote length) ; decide⟩)
  | ⟨.spatial, index, length⟩ =>
    ``(EnvsIndex.s ⟨$(quote index), by show $(quote index) < $(quote length) ; decide⟩)

-- Envs Operations
namespace Envs

/-- Append a hypothesis to the end of one of the separation logic contexts. The boolean flag
indicates whether the hypothesis should be appended to the intuitionistic (`true`) or spatial
(`false`) context. -/
@[reducible]
def append [BI PROP] : Bool → PROP → Envs PROP → Envs PROP
  | true,  P, ⟨Γₚ, Γₛ⟩ => ⟨Γₚ.append P, Γₛ⟩
  | false, P, ⟨Γₚ, Γₛ⟩ => ⟨Γₚ, Γₛ.append P⟩

/-- Delete the hypothesis at the given (combined) index. The boolean flag indicates whether the
hypothesis should be deleted even if it is part of the intuitionistic context. -/
@[reducible]
def delete [BI PROP] : Bool → (Δ : Envs PROP) → EnvsIndex.of Δ → Envs PROP
  | true , ⟨Γₚ, Γₛ⟩, .p i => ⟨Γₚ.delete i, Γₛ⟩
  | false, ⟨Γₚ, Γₛ⟩, .p _ => ⟨Γₚ, Γₛ⟩
  | _    , ⟨Γₚ, Γₛ⟩, .s i => ⟨Γₚ, Γₛ.delete i⟩

/-- Return the hypothesis at the given index. -/
@[reducible]
def lookup [BI PROP] : (Δ : Envs PROP) → EnvsIndex.of Δ → Bool × PROP
  | ⟨Γₚ, _⟩, .p i => (true, Γₚ.get i)
  | ⟨_, Γₛ⟩, .s i => (false, Γₛ.get i)

/-- Replace the hypothesis at index `i` with the hypothesis `P`. The boolean flag `p` indicates
whether the new hypothesis should be placed in the intuitionistic (`true`) or spatial (`false`)
context. If the boolean flag `rp` is set, the original hypothesis is removed even if it is part of
the intuitionistic context. If it is not set, the original hypothesis is kept. The new hypothesis
is added in both cases. -/
@[reducible]
def replace [BI PROP] (Δ : Envs PROP) (rp : Bool) (i : EnvsIndex.of Δ) (p : Bool) (P : PROP) : Envs PROP :=
  Δ.delete rp i |>.append p P

/-- Split the spatial context into two disjoint parts. See `Env.split` for details. -/
@[reducible]
def split [BI PROP] : (Δ : Envs PROP) → (mask : List Bool) → (mask.length = Δ.spatial.length) → Envs PROP × Envs PROP
  | ⟨Γₚ, Γₛ⟩, mask, h =>
    let ⟨Γₛ₁, Γₛ₂⟩ := Γₛ.split mask h
    (⟨Γₚ, Γₛ₁⟩, ⟨Γₚ, Γₛ₂⟩)

/-- Update an index `j` of `Δ` to reference the same hypothesis in `Δ.delete rp i`, i.e. after the
hypothesis at index `i` has been deleted. The indices `i` and `j` must reference
different hypotheses. -/
@[reducible]
def updateIndexAfterDelete [BI PROP] (Δ : Envs PROP) : (rp : Bool) → (i : EnvsIndex.of Δ) → (j : EnvsIndex.of Δ) → (i.type = j.type → i.val ≠ j.val) → EnvsIndex.of (Δ.delete rp i)
  | rp, .p i, .s ⟨val, is_lt⟩, _ =>
    .s ⟨val, by cases rp <;> simp [is_lt]⟩
  | _, .s i, .p ⟨val, is_lt⟩, _ =>
    .p ⟨val, by simp [delete, is_lt]⟩
  | false, .p _, .p ⟨val, is_lt⟩, _ =>
    .p ⟨val, by simp [delete, is_lt]⟩
  | true, .p ⟨val_d, is_lt_d⟩, .p ⟨val, is_lt⟩, h_ne =>
    if h_lt : val < val_d then
      EnvsIndex.p ⟨val, env_delete_idx_length_of_lt h_lt⟩
    else if h_gt : val_d < val then
      EnvsIndex.p ⟨val - 1, env_delete_idx_pred_length ⟨val, is_lt⟩ (Nat.zero_lt_of_lt h_gt)⟩
    else by
      let h_ne := h_ne (by simp)
      let h_eq := Nat.eq_of_not_lt_not_lt h_gt h_lt
      contradiction
  | rp, .s ⟨val_d, is_lt_d⟩, .s ⟨val, is_lt⟩, h_ne =>
    if h_lt : val < val_d then
      EnvsIndex.s ⟨val, by simp only [delete] ; exact env_delete_idx_length_of_lt h_lt⟩
    else if h_gt : val_d < val then
      EnvsIndex.s ⟨val - 1, by simp only [delete] ; exact env_delete_idx_pred_length ⟨val, is_lt⟩ (Nat.zero_lt_of_lt h_gt)⟩
    else by
      let h_ne := h_ne (by simp)
      let h_eq := Nat.eq_of_not_lt_not_lt h_gt h_lt
      contradiction

end Envs

-- Envs Theorems
theorem envs_append_sound [BI PROP] {Δ : Envs PROP} (p : Bool) (Q : PROP) :
  of_envs Δ ⊢ □?p Q -∗ of_envs (Δ.append p Q)
:= by
  apply wand_intro_l ?_
  cases p
  <;> simp only [bi_intuitionistically_if, ite_true, ite_false, of_envs]
  case false =>
    rw' [
      env_big_op_sep_append,
      (assoc : _ ∗ (_ ∗ Q) ⊣⊢ _),
      (comm : _ ∗ Q ⊣⊢ _)]
  case true =>
    rw' [
      env_big_op_and_append,
      (comm : _ ∗ □ Q ⊣⊢ _),
      ← (assoc : _ ⊣⊢ (□ Q ∗ _) ∗ _)]

theorem envs_lookup_delete_sound [BI PROP] {Δ : Envs PROP} {i : EnvsIndex.of Δ} {p : Bool} {P : PROP} (rp : Bool) :
  Δ.lookup i = (p, P) →
  of_envs Δ ⊢ □?p P ∗ of_envs (Δ.delete rp i)
:= by
  cases i
  all_goals
    simp only [Envs.lookup]
    intro h_lookup
    cases h_lookup
    simp only [Envs.delete, of_envs, bi_intuitionistically_if, ite_true, ite_false]
  case s i =>
    rw' [
      (comm : Δ.spatial.get i ∗ _ ⊣⊢ _),
      ← (assoc : _ ⊣⊢ _ ∗ _),
      ← env_big_op_sep_delete_get]
  case p i =>
    cases rp
    <;> simp only
    case true =>
      rw' [
        (assoc : _ ∗ _ ⊣⊢ _),
        (comm : □ Δ.intuitionistic.get i ∗ _ ⊣⊢ _),
        ← env_big_op_and_delete_get i]
    case false =>
      rw' [
        (assoc : _ ∗ _ ⊣⊢ _),
        (comm : □ Δ.intuitionistic.get i ∗ _ ⊣⊢ _),
        env_big_op_and_delete_get i,
        ← (assoc : _ ⊣⊢ (_ ∗ _) ∗ □ Δ.intuitionistic.get i),
        ← intuitionistically_sep_dup]

theorem envs_lookup_replace_sound [BI PROP] {Δ : Envs PROP} {i : EnvsIndex.of Δ} {p : Bool} {P : PROP} (rp : Bool) (q : Bool) (Q : PROP) :
  Δ.lookup i = (p, P) →
  of_envs Δ ⊢ □?p P ∗ (□?q Q -∗ of_envs (Δ.replace rp i q Q))
:= by
  intro h_lookup
  simp only [Envs.replace]
  rw' [
    ← envs_append_sound q Q,
    ← envs_lookup_delete_sound rp h_lookup]

theorem envs_split_env_spatial_split [BI PROP] {Δ Δ₁ Δ₂ : Envs PROP} {mask : List Bool} {h : mask.length = Δ.spatial.length} :
  Envs.split Δ mask h = (Δ₁, Δ₂) →
  Δ₁.intuitionistic = Δ.intuitionistic ∧
  Δ₂.intuitionistic = Δ.intuitionistic ∧
  (Δ₁.spatial, Δ₂.spatial) = Env.split Δ.spatial mask h
:= by
  simp only [Envs.split]
  intro h_split
  cases h_split
  <;> simp

theorem envs_split_sound [BI PROP] {Δ Δ₁ Δ₂ : Envs PROP} {mask : List Bool} {h : mask.length = Δ.spatial.length} :
  Δ.split mask h = (Δ₁, Δ₂) →
  of_envs Δ ⊢ of_envs Δ₁ ∗ of_envs Δ₂
:= by
  intro h_split_Δ
  let ⟨h_split_Γₚ₁, h_split_Γₚ₂, h_split_Γₛ⟩ := envs_split_env_spatial_split h_split_Δ
  simp only [of_envs]
  rw' [
    h_split_Γₚ₁,
    h_split_Γₚ₂,
    env_big_op_sep_split h_split_Γₛ,
    (assoc : _ ∗ (□ _ ∗ _) ⊣⊢ _),
    (comm : _ ∗ □ _ ⊣⊢ _),
    (assoc : □ _ ∗ (□ _ ∗ _) ⊣⊢ _),
    ← intuitionistically_sep_dup,
    ← (assoc : _ ⊣⊢ (_ ∗ _) ∗ _)]

theorem envs_spatial_is_empty_intuitionistically [BI PROP] {Δ : Envs PROP} :
  Δ.spatial.isEmpty = true →
  of_envs Δ ⊢ □ of_envs Δ
:= by
  simp only [Env.isEmpty, of_envs]
  cases Δ.spatial
  <;> simp [big_op]
  rw' [
    (right_id : _ ∗ emp ⊣⊢ _),
    intuitionistically_idemp]

-- AffineEnv
class AffineEnv [BI PROP] (Γ : Env PROP) where
  affineEnv : ∀ P, P ∈ Γ → Affine P
export AffineEnv (affineEnv)

instance affineEnvNil [BI PROP] :
  AffineEnv (PROP := PROP) .nil
where
  affineEnv := by
    intro _ h
    cases h

instance affineEnvConcat [BI PROP] (P : PROP) (Γ : Env PROP) :
  [Affine P] →
  [AffineEnv Γ] →
  AffineEnv (.cons P Γ)
where
  affineEnv := by
    intro P h
    cases h
    case head =>
      exact ⟨affine⟩
    case tail h =>
      exact affineEnv P h

instance (priority := default + 10) affineEnvBi (Γ : Env PROP) :
  [BIAffine PROP] →
  AffineEnv Γ
where
  affineEnv := by
    intro P _
    exact BIAffine.affine P

scoped instance affineEnvSpatial [BI PROP] (Γ : Env PROP)
  [inst : AffineEnv Γ] :
  Affine (`[iprop| [∗] Γ] : PROP)
where
  affine := by
    induction Γ generalizing inst
    case nil =>
      rw' [big_op_sep_nil]
    case cons P Ps h_ind =>
      have : AffineEnv Ps := ⟨by
        intro P h_Ps
        exact inst.affineEnv P (env_mem_cons_2 h_Ps)⟩
      have : Affine P := inst.affineEnv P env_mem_cons_1
      rw' [big_op_sep_cons, h_ind, affine]

end Iris.Proofmode


import .love05_inductive_predicates_demo

/-! # LoVe Demo 7: Metaprogramming

Users can extend Lean with custom tactics and tools. This kind of
programming—programming the prover—is called metaprogramming.

Lean's metaprogramming framework uses mostly the same notions and syntax as
Lean's input language itself. Abstract syntax trees __reflect__ internal data
structures, e.g., for expressions (terms). The prover's C++ internals are
exposed through Lean interfaces, which we can use for

* accessing the current context and goal;
* unifying expressions;
* querying and modifying the environment;
* setting attributes.

Most of Lean's predefined tactics are implemented in Lean (and not in C++).

Example applications:

* proof goal transformations;
* heuristic proof search;
* decision procedures;
* definition generators;
* advisor tools;
* exporters;
* ad hoc automation.

Advantages of Lean's metaprogramming framework:

* Users do not need to learn another programming language to write
  metaprograms; they can work with the same constructs and notation used to
  define ordinary objects in the prover's library.

* Everything in that library is available for metaprogramming purposes.

* Metaprograms can be written and debugged in the same interactive environment,
  encouraging a style where formal libraries and supporting automation are
  developed at the same time. -/

set_option pp.beta true
set_option pp.generalized_field_notation false

namespace LoVe

/-! ## Tactics and Tactic Combinators

When programming our own tactics, we often need to repeat some actions on
several goals, or to recover if a tactic fails. Tactic combinators help in such
case.

`repeat` applies its argument repeatedly on all (sub…sub)goals until it cannot
be applied any further. -/

lemma repeat_example :
  even 4 ∧ even 7 ∧ even 3 ∧ even 0 :=
begin
  repeat { apply and.intro },
  repeat { apply even.add_two },
  repeat { sorry }
end

/-! The "orelse" combinator `<|>` tries its first argument and applies its
second argument in case of failure. -/

lemma repeat_orelse_example :
  even 4 ∧ even 7 ∧ even 3 ∧ even 0 :=
begin
  repeat { apply and.intro },
  repeat {
    apply even.add_two
    <|> apply even.zero },
  repeat { sorry }
end

/-! `iterate` works repeatedly on the first goal until it fails; then it
stops. -/

lemma iterate_orelse_example :
  even 4 ∧ even 7 ∧ even 3 ∧ even 0 :=
begin
  repeat { apply and.intro },
  iterate {
    apply even.add_two
    <|> apply even.zero },
  repeat { sorry }
end

/-! `all_goals` applies its argument exactly once to each goal. It succeeds only
if the argument succeeds on **all** goals. -/

lemma all_goals_example :
  even 4 ∧ even 7 ∧ even 3 ∧ even 0 :=
begin
  repeat { apply and.intro },
  all_goals { apply even.add_two },   -- fails
  repeat { sorry }
end

/-! `try` transforms its argument into a tactic that never fails. -/

lemma all_goals_try_example :
  even 4 ∧ even 7 ∧ even 3 ∧ even 0 :=
begin
  repeat { apply and.intro },
  all_goals { try { apply even.add_two } },
  repeat { sorry }
end

/-! `any_goals` applies its argument exactly once to each goal. It succeeds
if the argument succeeds on **any** goal. -/

lemma any_goals_example :
  even 4 ∧ even 7 ∧ even 3 ∧ even 0 :=
begin
  repeat { apply and.intro },
  any_goals { apply even.add_two },
  repeat { sorry }
end

/-! `solve1` transforms its argument into an all-or-nothing tactic. If the
argument does not prove the goal, `solve1` fails. -/

lemma any_goals_solve1_repeat_orelse_example :
  even 4 ∧ even 7 ∧ even 3 ∧ even 0 :=
begin
  repeat { apply and.intro },
  any_goals { solve1 { repeat {
    apply even.add_two
    <|> apply even.zero } } },
  repeat { sorry }
end

/-! The combinators `repeat`, `iterate`, `all_goals`, and `any_goals` can easily
lead to infinite looping: -/

/-
lemma repeat_not_example :
  ¬ even 1 :=
begin
  repeat { apply not.intro },
  sorry
end
-/

/-! Let us start with the actual metaprogramming, by coding a custom tactic. The
tactic embodies the behavior we hardcoded in the `solve1` example above: -/

meta def intro_and_even : tactic unit :=
do
  tactic.repeat (tactic.applyc ``and.intro),
  tactic.any_goals (tactic.solve1 (tactic.repeat
    (tactic.applyc ``even.add_two
     <|> tactic.applyc ``even.zero))),
  pure ()

/-! The `meta` keyword makes it possible for the function to call other
metafunctions. The `do` keyword enters a monad, and the `<|>` operator is the
"orelse" operator of alternative monads. At the end, we return `()`, of type
`unit`, to ensure the metaprogram has the desired type.

Any executable Lean definition can be used as a metaprogram. In addition, we can
put `meta` in front of a definition to indicate that is a metadefinition. Such
definitions need not terminate but cannot be used in non-`meta` contexts.

Let us apply our custom tactic: -/

lemma any_goals_solve1_repeat_orelse_example₂ :
  even 4 ∧ even 7 ∧ even 3 ∧ even 0 :=
begin
  intro_and_even,
  repeat { sorry }
end

/-! ## The Metaprogramming Monad

Tactics have access to

* the list of **goals** as metavariables (each metavariables has a type and a
  local context (hypothesis); they can optionally be instantiated);

* the **elaborator** (to elaborate expressions and compute their type);

* the **environment**, containing all declarations and inductive types;

* the **attributes** (e.g., the list of `@[simp]` rules).

The tactic monad is an alternative monad, with `fail` and `<|>`. Tactics can
also produce trace messages. -/

lemma even_14 :
  even 14 :=
by do
  tactic.trace "Proving evenness …",
  intro_and_even

meta def hello_then_intro_and_even : tactic unit :=
do
  tactic.trace "Proving evenness …",
  intro_and_even

lemma even_16 :
  even 16 :=
by hello_then_intro_and_even

run_cmd tactic.trace "Hello, Metaworld!"

meta def trace_goals : tactic unit :=
do
  tactic.trace "local context:",
  ctx ← tactic.local_context,
  tactic.trace ctx,
  tactic.trace "target:",
  P ← tactic.target,
  tactic.trace P,
  tactic.trace "all missing proofs:",
  Hs ← tactic.get_goals,
  tactic.trace Hs,
  τs ← list.mmap tactic.infer_type Hs,
  tactic.trace τs

lemma even_18_and_even_20 (α : Type) (a : α) :
  even 18 ∧ even 20 :=
by do
  tactic.applyc ``and.intro,
  trace_goals,
  intro_and_even

lemma triv_imp (a : Prop) (h : a) :
  a :=
by do
  h ← tactic.get_local `h,
  tactic.trace "h:",
  tactic.trace h,
  tactic.trace "raw h:",
  tactic.trace (expr.to_raw_fmt h),
  tactic.trace "type of h:",
  τ ← tactic.infer_type h,
  tactic.trace τ,
  tactic.trace "type of type of h:",
  υ ← tactic.infer_type τ,
  tactic.trace υ,
  tactic.apply h

meta def exact_list : list expr → tactic unit
| []        := tactic.fail "no matching expression found"
| (h :: hs) :=
  do {
    tactic.trace "trying",
    tactic.trace h,
    tactic.exact h }
  <|> exact_list hs

meta def hypothesis : tactic unit :=
do
  hs ← tactic.local_context,
  exact_list hs

lemma app_of_app {α : Type} {p : α → Prop} {a : α}
    (h : p a) :
  p a :=
by hypothesis

/-! ## Names, Expressions, Declarations, and Environments

The metaprogramming framework is articulated around five main types:

* `tactic` manages the proof state, the global context, and more;

* `name` represents a structured name (e.g., `x`, `even.add_two`);

* `expr` represents an expression (a term) as an abstract syntax tree;

* `declaration` represents a constant declaration, a definition, an axiom, or a
  lemma;

* `environment` stores all the declarations and notations that make up the
  global context. -/

#print expr

#check expr tt  -- elaborated expressions
#check expr ff  -- unelaborated expressions (pre-expressions)

#print name

#check (expr.const `ℕ [] : expr)
#check expr.sort level.zero  -- Sort 0, i.e., Prop
#check expr.sort (level.succ level.zero)
  -- Sort 1, i.e., Type
#check expr.var 0  -- bound variable with De Bruijn index 0
#check (expr.local_const `uniq_name `pp_name binder_info.default
  `(ℕ) : expr)
#check (expr.mvar `uniq_name `pp_name `(ℕ) : expr)
#check (expr.pi `pp_name binder_info.default `(ℕ)
  (expr.sort level.zero) : expr)
#check (expr.lam `pp_name binder_info.default `(ℕ)
  (expr.var 0) : expr)
#check expr.elet
#check expr.macro

/-! We can create literal expressions conveniently using backticks and
parentheses:

* Expressions with a single backtick must be fully elaborated.

* Expressions with two backticks are __pre-expressions__: They may contain some
  holes to be filled in later, based on some context.

* Expressions with three backticks are pre-expressions without name checking. -/

run_cmd do
  let e : expr := `(list.map (λn : ℕ, n + 1) [1, 2, 3]),
  tactic.trace e

run_cmd do
  let e : expr := `(list.map _ [1, 2, 3]),   -- fails
  tactic.trace e

run_cmd do
  let e₁ : pexpr := ``(list.map (λn, n + 1) [1, 2, 3]),
  let e₂ : pexpr := ``(list.map _ [1, 2, 3]),
  tactic.trace e₁,
  tactic.trace e₂

run_cmd do
  let e : pexpr := ```(seattle.washington),
  tactic.trace e

/-! We can also create literal names with backticks:

* Names with a single backtick, `n, are not checked for existence.

* Names with two backticks, ``n, are resolved and checked. -/

run_cmd tactic.trace `and.intro
run_cmd tactic.trace `intro_and_even
run_cmd tactic.trace `seattle.washington

run_cmd tactic.trace ``and.intro
run_cmd tactic.trace ``intro_and_even
run_cmd tactic.trace ``seattle.washington   -- fails

/-! __Antiquotations__ embed an existing expression in a larger expression. They
are announced by the prefix `%%` followed by a name from the current context.
Antiquotations are available with one, two, and three backticks: -/

run_cmd do
  let x : expr := `(2 : ℕ),
  let e : expr := `(%%x + 1),
  tactic.trace e

run_cmd do
  let x : expr  := `(@id ℕ),
  let e : pexpr := ``(list.map %%x),
  tactic.trace e

run_cmd do
  let x : expr  := `(@id ℕ),
  let e : pexpr := ```(a _ %%x),
  tactic.trace e

lemma one_add_two_eq_three :
  1 + 2 = 3 :=
by do
  `(%%a + %%b = %%c) ← tactic.target,
  tactic.trace a,
  tactic.trace b,
  tactic.trace c,
  `(@eq %%α %%l %%r) ← tactic.target,
  tactic.trace α,
  tactic.trace l,
  tactic.trace r,
  tactic.exact `(refl _ : 3 = 3)

#print declaration

/-! The `environment` type is presented as an abstract type, equipped with some
operations to query and modify it. The `environment.fold` metafunction iterates
over all declarations making up the environment. -/

run_cmd do
  env ← tactic.get_env,
  tactic.trace (environment.fold env 0 (λdecl n, n + 1))

/-! ## First Example: A Conjuction-Destructing Tactic

We define a `destruct_and` tactic that automates the elimination of `∧` in
premises, automating proofs such as these: -/

lemma abcd_a (a b c d : Prop) (h : a ∧ (b ∧ c) ∧ d) :
  a :=
and.elim_left h

lemma abcd_b (a b c d : Prop) (h : a ∧ (b ∧ c) ∧ d) :
  b :=
and.elim_left (and.elim_left (and.elim_right h))

lemma abcd_bc (a b c d : Prop) (h : a ∧ (b ∧ c) ∧ d) :
  b ∧ c :=
and.elim_left (and.elim_right h)

/-! Our tactic relies on a helper metafunction, which takes as argument the
hypothesis `h` to use as an expression rather than as a name: -/

meta def destruct_and_helper : expr → tactic unit
| h :=
  do
    t ← tactic.infer_type h,
    match t with
    | `(%%a ∧ %%b) :=
      tactic.exact h
      <|>
      do {
        ha ← tactic.to_expr ``(and.elim_left %%h),
        destruct_and_helper ha }
      <|>
      do {
        hb ← tactic.to_expr ``(and.elim_right %%h),
        destruct_and_helper hb }
    | _            := tactic.exact h
    end

meta def destruct_and (nam : name) : tactic unit :=
do
  h ← tactic.get_local nam,
  destruct_and_helper h

/-! Let us check that our tactic works: -/

lemma abc_a (a b c : Prop) (h : a ∧ b ∧ c) :
  a :=
by destruct_and `h

lemma abc_b (a b c : Prop) (h : a ∧ b ∧ c) :
  b :=
by destruct_and `h

lemma abc_bc (a b c : Prop) (h : a ∧ b ∧ c) :
  b ∧ c :=
by destruct_and `h

lemma abc_ac (a b c : Prop) (h : a ∧ b ∧ c) :
  a ∧ c :=
by destruct_and `h   -- fails

/-! ## Second Example: A Provability Advisor

Next, we implement a `prove_direct` tool that traverses all lemmas in the
database and checks whether one of them can be used to prove the current goal. A
similar tactic is available in `mathlib` under the name `library_search`. -/

meta def is_theorem : declaration → bool
| (declaration.defn _ _ _ _ _ _) := ff
| (declaration.thm _ _ _ _)      := tt
| (declaration.cnst _ _ _ _)     := ff
| (declaration.ax _ _ _)         := tt

meta def get_all_theorems : tactic (list name) :=
do
  env ← tactic.get_env,
  pure (environment.fold env [] (λdecl nams,
    if is_theorem decl then declaration.to_name decl :: nams
    else nams))

meta def prove_with_name (nam : name) : tactic unit :=
do
  tactic.applyc nam
    ({ md := tactic.transparency.reducible, unify := ff }
     : tactic.apply_cfg),
  tactic.all_goals tactic.assumption,
  pure ()

meta def prove_direct : tactic unit :=
do
  nams ← get_all_theorems,
  list.mfirst (λnam,
      do
        prove_with_name nam,
        tactic.trace ("directly proved by " ++ to_string nam))
    nams

lemma nat.eq_symm (x y : ℕ) (h : x = y) :
  y = x :=
by prove_direct

lemma nat.eq_symm₂ (x y : ℕ) (h : x = y) :
  y = x :=
by library_search

lemma list.reverse_twice (xs : list ℕ) :
  list.reverse (list.reverse xs) = xs :=
by prove_direct

lemma list.reverse_twice_symm (xs : list ℕ) :
  xs = list.reverse (list.reverse xs) :=
by prove_direct   -- fails

/-! As a small refinement, we propose a version of `prove_direct` that also
looks for equalities stated in symmetric form. -/

meta def prove_direct_symm : tactic unit :=
prove_direct
<|>
do {
  tactic.applyc `eq.symm,
  prove_direct }

lemma list.reverse_twice₂ (xs : list ℕ) :
  list.reverse (list.reverse xs) = xs :=
by prove_direct_symm

lemma list.reverse_twice_symm₂ (xs : list ℕ) :
  xs = list.reverse (list.reverse xs) :=
by prove_direct_symm

/-! ## A Look at Two Predefined Tactics

Quite a few of Lean's predefined tactics are implemented as metaprograms and
not in C++. We can find these definitions by clicking the name of a construct
in Visual Studio Code while holding the control or command key. -/

#check tactic.intro
#check tactic.assumption

end LoVe


/-
Copyright (c) 2018 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Simon Hudon

Lemmas about traversing collections.

Inspired by:

    The Essence of the Iterator Pattern
    Jeremy Gibbons and Bruno César dos Santos Oliveira
    In Journal of Functional Programming. Vol. 19. No. 3&4. Pages 377−402. 2009.
    <http://www.cs.ox.ac.uk/jeremy.gibbons/publications/iterator.pdf>
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.control.traversable.basic
import Mathlib.control.applicative
import Mathlib.PostPort

universes u

namespace Mathlib

namespace traversable

/-- The natural applicative transformation from the identity functor
to `F`, defined by `pure : Π {α}, α → F α`. -/
def pure_transformation (F : Type u → Type u) [Applicative F] [is_lawful_applicative F] : applicative_transformation id F :=
  applicative_transformation.mk pure sorry sorry

@[simp] theorem pure_transformation_apply (F : Type u → Type u) [Applicative F] [is_lawful_applicative F] {α : Type u} (x : id α) : coe_fn (pure_transformation F) α x = pure x :=
  rfl

theorem map_eq_traverse_id {t : Type u → Type u} [traversable t] [is_lawful_traversable t] {β : Type u} {γ : Type u} (f : β → γ) : Functor.map f = traverse (id.mk ∘ f) :=
  funext fun (y : t β) => Eq.symm (is_lawful_traversable.traverse_eq_map_id f y)

theorem map_traverse {t : Type u → Type u} [traversable t] [is_lawful_traversable t] {F : Type u → Type u} [Applicative F] [is_lawful_applicative F] {α : Type u} {β : Type u} {γ : Type u} (g : α → F β) (f : β → γ) (x : t α) : Functor.map f <$> traverse g x = traverse (Functor.map f ∘ g) x := sorry

theorem traverse_map {t : Type u → Type u} [traversable t] [is_lawful_traversable t] {F : Type u → Type u} [Applicative F] [is_lawful_applicative F] {α : Type u} {β : Type u} {γ : Type u} (f : β → F γ) (g : α → β) (x : t α) : traverse f (g <$> x) = traverse (f ∘ g) x := sorry

theorem pure_traverse {t : Type u → Type u} [traversable t] [is_lawful_traversable t] {F : Type u → Type u} [Applicative F] [is_lawful_applicative F] {α : Type u} (x : t α) : traverse pure x = pure x :=
  eq.mp (Eq._oldrec (Eq.refl (traverse pure x = pure (traverse id.mk x))) (is_lawful_traversable.id_traverse x))
    (Eq.symm (is_lawful_traversable.naturality (pure_transformation F) id.mk x))

theorem id_sequence {t : Type u → Type u} [traversable t] [is_lawful_traversable t] {α : Type u} (x : t α) : sequence (id.mk <$> x) = id.mk x := sorry

theorem comp_sequence {t : Type u → Type u} [traversable t] [is_lawful_traversable t] {F : Type u → Type u} {G : Type u → Type u} [Applicative F] [is_lawful_applicative F] [Applicative G] [is_lawful_applicative G] {α : Type u} (x : t (F (G α))) : sequence (functor.comp.mk <$> x) = functor.comp.mk (sequence <$> sequence x) := sorry

theorem naturality' {t : Type u → Type u} [traversable t] [is_lawful_traversable t] {F : Type u → Type u} {G : Type u → Type u} [Applicative F] [is_lawful_applicative F] [Applicative G] [is_lawful_applicative G] {α : Type u} (η : applicative_transformation F G) (x : t (F α)) : coe_fn η (t α) (sequence x) = sequence (coe_fn η α <$> x) := sorry

theorem traverse_id {t : Type u → Type u} [traversable t] [is_lawful_traversable t] {α : Type u} : traverse id.mk = id.mk := sorry

theorem traverse_comp {t : Type u → Type u} [traversable t] [is_lawful_traversable t] {F : Type u → Type u} {G : Type u → Type u} [Applicative F] [is_lawful_applicative F] [Applicative G] [is_lawful_applicative G] {α : Type u} {β : Type u} {γ : Type u} (g : α → F β) (h : β → G γ) : traverse (functor.comp.mk ∘ Functor.map h ∘ g) = functor.comp.mk ∘ Functor.map (traverse h) ∘ traverse g := sorry

theorem traverse_eq_map_id' {t : Type u → Type u} [traversable t] [is_lawful_traversable t] {β : Type u} {γ : Type u} (f : β → γ) : traverse (id.mk ∘ f) = id.mk ∘ Functor.map f := sorry

-- @[functor_norm]

theorem traverse_map' {t : Type u → Type u} [traversable t] [is_lawful_traversable t] {G : Type u → Type u} [Applicative G] [is_lawful_applicative G] {α : Type u} {β : Type u} {γ : Type u} (g : α → β) (h : β → G γ) : traverse (h ∘ g) = traverse h ∘ Functor.map g := sorry

theorem map_traverse' {t : Type u → Type u} [traversable t] [is_lawful_traversable t] {G : Type u → Type u} [Applicative G] [is_lawful_applicative G] {α : Type u} {β : Type u} {γ : Type u} (g : α → G β) (h : β → γ) : traverse (Functor.map h ∘ g) = Functor.map (Functor.map h) ∘ traverse g := sorry

theorem naturality_pf {t : Type u → Type u} [traversable t] [is_lawful_traversable t] {F : Type u → Type u} {G : Type u → Type u} [Applicative F] [is_lawful_applicative F] [Applicative G] [is_lawful_applicative G] {α : Type u} {β : Type u} (η : applicative_transformation F G) (f : α → F β) : traverse (coe_fn η β ∘ f) = coe_fn η (t β) ∘ traverse f := sorry


import .apply_fun

meta def my_first_tactic : tactic unit := tactic.trace "Hello, World."

example : true :=
begin
  my_first_tactic,
  trivial
end
meta def my_second_tactic : tactic unit :=
tactic.trace "Hello," >> tactic.trace "World."
    example : true :=
begin
  my_second_tactic,
  trivial
end
meta def my_failing_tactic  : tactic unit := tactic.failed

meta def my_failing_tactic' : tactic unit :=
tactic.fail "This tactic failed, we apologize for the inconvenience."
example : true :=
begin
  my_failing_tactic',
  trivial
end
open tactic
/-
When chaining instructions, the first failure interrupts the process.
However the orelse combinator,
 denoted by an infix <|> allows to try its right-hand side if its left-hand
 side failed. The following will successfully deliver its message.
-/

meta def my_orelse : tactic unit :=
fail "this tactic fail" <|> trace "hello"

example : true := begin
    my_orelse,
    trivial,
    end
meta def trace_goal : tactic unit :=
 tactic.target >>= tactic.trace
example (a b  : ℤ) : a = b → (a+1 = b+1)  := begin
    trace_goal, intro hyp, apply_fun  (λ t, 1+ t) at hyp,
    exact hyp,
    end


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Lucas Allen, Scott Morrison
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.tactic.interactive
import Mathlib.tactic.converter.interactive
import Mathlib.PostPort

namespace Mathlib

/-!
## Introduce the `apply_congr` conv mode tactic.

`apply_congr` will apply congruence lemmas inside `conv` mode.
It is particularly useful when the automatically generated congruence lemmas
are not of the optimal shape. An example, described in the doc-string is
rewriting inside the operand of a `finset.sum`.
-/

namespace conv.interactive

/--
Apply a congruence lemma inside `conv` mode.

When called without an argument `apply_congr` will try applying all lemmas marked with `@[congr]`.
Otherwise `apply_congr e` will apply the lemma `e`.

Recall that a goal that appears as `∣ X` in `conv` mode
represents a goal of `⊢ X = ?m`,
i.e. an equation with a metavariable for the right hand side.

To successfully use `apply_congr e`, `e` will need to be an equation
(possibly after function arguments),
which can be unified with a goal of the form `X = ?m`.
The right hand side of `e` will then determine the metavariable,
and `conv` will subsequently replace `X` with that right hand side.

As usual, `apply_congr` can create new goals;
any of these which are _not_ equations with a metavariable on the right hand side
will be hard to deal with in `conv` mode.
Thus `apply_congr` automatically calls `intros` on any new goals,
and fails if they are not then equations.

In particular it is useful for rewriting inside the operand of a `finset.sum`,
as it provides an extra hypothesis asserting we are inside the domain.

For example:

```lean
example (f g : ℤ → ℤ) (S : finset ℤ) (h : ∀ m ∈ S, f m = g m) :
  finset.sum S f = finset.sum S g :=
begin
  conv_lhs {
    -- If we just call `congr` here, in the second goal we're helpless,
    -- because we are only given the opportunity to rewrite `f`.
    -- However `apply_congr` uses the appropriate `@[congr]` lemma,
    -- so we get to rewrite `f x`, in the presence of the crucial `H : x ∈ S` hypothesis.
    apply_congr,
    skip,
    simp [h, H],
  }
end
```

In the above example, when the `apply_congr` tactic is called it gives the hypothesis `H : x ∈ S`
which is then used to rewrite the `f x` to `g x`.
-/
end Mathlib


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

Standard identity and composition functors
-/
import tactic.ext tactic.cache category.basic

universe variables u v w

section functor

variables {F : Type u → Type v}
variables {α β γ : Type u}
variables [functor F] [is_lawful_functor F]

lemma functor.map_id : (<$>) id = (id : F α → F α) :=
by apply funext; apply id_map

lemma functor.map_comp_map (f : α → β) (g : β → γ) :
  ((<$>) g ∘ (<$>) f : F α → F γ) = (<$>) (g ∘ f) :=
by apply funext; intro; rw comp_map

theorem functor.ext {F} : ∀ {F1 : functor F} {F2 : functor F}
  [@is_lawful_functor F F1] [@is_lawful_functor F F2]
  (H : ∀ α β (f : α → β) (x : F α),
    @functor.map _ F1 _ _ f x = @functor.map _ F2 _ _ f x),
  F1 = F2
| ⟨m, mc⟩ ⟨m', mc'⟩ H1 H2 H :=
begin
  cases show @m = @m', by funext α β f x; apply H,
  congr, funext α β,
  have E1 := @map_const_eq _ ⟨@m, @mc⟩ H1,
  have E2 := @map_const_eq _ ⟨@m, @mc'⟩ H2,
  exact E1.trans E2.symm
end

end functor

def id.mk {α : Sort u} : α → id α := id

namespace functor

def const (α : Type*) (β : Type*) := α

@[pattern] def const.mk {α β} (x : α) : const α β := x

def const.mk' {α} (x : α) : const α punit := x

def const.run {α β} (x : const α β) : α := x

namespace const

protected lemma ext {α β} {x y : const α β} (h : x.run = y.run) : x = y := h

protected def map {γ α β} (f : α → β) (x : const γ β) : const γ α := x

instance {γ} : functor (const γ) :=
{ map := @const.map γ }

instance {γ} : is_lawful_functor (const γ) :=
by constructor; intros; refl

end const

def add_const (α : Type*) := const α

@[pattern]
def add_const.mk {α β} (x : α) : add_const α β := x

def add_const.run {α β} : add_const α β → α := id

instance add_const.functor {γ} : functor (add_const γ) :=
@const.functor γ

instance add_const.is_lawful_functor {γ} : is_lawful_functor (add_const γ) :=
@const.is_lawful_functor γ

/-- `functor.comp` is a wrapper around `function.comp` for types.
    It prevents Lean's type class resolution mechanism from trying
    a `functor (comp F id)` when `functor F` would do. -/
def comp (F : Type u → Type w) (G : Type v → Type u) (α : Type v) : Type w :=
F $ G α

@[pattern] def comp.mk {F : Type u → Type w} {G : Type v → Type u} {α : Type v}
  (x : F (G α)) : comp F G α := x

def comp.run {F : Type u → Type w} {G : Type v → Type u} {α : Type v}
  (x : comp F G α) : F (G α) := x

namespace comp

variables {F : Type u → Type w} {G : Type v → Type u}

protected lemma ext
  {α} {x y : comp F G α} : x.run = y.run → x = y := id

variables [functor F] [functor G]

protected def map {α β : Type v} (h : α → β) : comp F G α → comp F G β
| (comp.mk x) := comp.mk ((<$>) h <$> x)

instance : functor (comp F G) := { map := @comp.map F G _ _ }

@[functor_norm] lemma map_mk {α β} (h : α → β) (x : F (G α)) :
  h <$> comp.mk x = comp.mk ((<$>) h <$> x) := rfl

variables [is_lawful_functor F] [is_lawful_functor G]
variables {α β γ : Type v}

protected lemma id_map : ∀ (x : comp F G α), comp.map id x = x
| (comp.mk x) := by simp [comp.map, functor.map_id]

protected lemma comp_map (g' : α → β) (h : β → γ) : ∀ (x : comp F G α),
           comp.map (h ∘ g') x = comp.map h (comp.map g' x)
| (comp.mk x) := by simp [comp.map, functor.map_comp_map g' h] with functor_norm

@[simp] protected lemma run_map (h : α → β) (x : comp F G α) :
  (h <$> x).run = (<$>) h <$> x.run := rfl

instance : is_lawful_functor (comp F G) :=
{ id_map := @comp.id_map F G _ _ _ _,
  comp_map := @comp.comp_map F G _ _ _ _ }

theorem functor_comp_id {F} [AF : functor F] [is_lawful_functor F] :
  @comp.functor F id _ _ = AF :=
@functor.ext F _ AF (@comp.is_lawful_functor F id _ _ _ _) _ (λ α β f x, rfl)

theorem functor_id_comp {F} [AF : functor F] [is_lawful_functor F] :
  @comp.functor id F _ _ = AF :=
@functor.ext F _ AF (@comp.is_lawful_functor id F _ _ _ _) _ (λ α β f x, rfl)

end comp

end functor

namespace ulift

instance : functor ulift :=
{ map := λ α β f, up ∘ f ∘ down }

end ulift


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

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

/-!
# The `simp_rw` tactic

This module defines a tactic `simp_rw` which functions as a mix of `simp` and
`rw`. Like `rw`, it applies each rewrite rule in the given order, but like
`simp` it repeatedly applies these rules and also under binders like `∀ x, ...`,
`∃ x, ...` and `λ x, ...`.

## Implementation notes

The tactic works by taking each rewrite rule in turn and applying `simp only` to
it. Arguments to `simp_rw` are of the format used by `rw` and are translated to
their equivalents for `simp`.
-/

namespace Tactic.Interactive

open Interactive Interactive.Types Tactic

/-- `simp_rw` functions as a mix of `simp` and `rw`. Like `rw`, it applies each
rewrite rule in the given order, but like `simp` it repeatedly applies these
rules and also under binders like `∀ x, ...`, `∃ x, ...` and `λ x, ...`.

Usage:
  - `simp_rw [lemma_1, ..., lemma_n]` will rewrite the goal by applying the
    lemmas in that order. A lemma preceded by `←` is applied in the reverse direction.
  - `simp_rw [lemma_1, ..., lemma_n] at h₁ ... hₙ` will rewrite the given hypotheses.
  - `simp_rw [...] at ⊢ h₁ ... hₙ` rewrites the goal as well as the given hypotheses.
  - `simp_rw [...] at *` rewrites in the whole context: all hypotheses and the goal.

Lemmas passed to `simp_rw` must be expressions that are valid arguments to `simp`.

For example, neither `simp` nor `rw` can solve the following, but `simp_rw` can:
```lean
example {α β : Type} {f : α → β} {t : set β} :
  (∀ s, f '' s ⊆ t) = ∀ s : set α, ∀ x ∈ s, x ∈ f ⁻¹' t :=
by simp_rw [set.image_subset_iff, set.subset_def]
```
-/
unsafe def simp_rw (q : parse rw_rules) (l : parse location) : tactic Unit :=
  q.rules.mapM' fun rule => do
    let simp_arg :=
      if rule.symm then simp_arg_type.symm_expr rule.rule else simp_arg_type.expr rule.rule
    save_info rule
    simp none none tt [simp_arg] [] l
#align tactic.interactive.simp_rw tactic.interactive.simp_rw

-- equivalent to `simp only [rule] at l`
add_tactic_doc
  { Name := "simp_rw"
    category := DocCategory.tactic
    declNames := [`tactic.interactive.simp_rw]
    tags := ["simplification"] }

end Tactic.Interactive


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

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

open Tactic

namespace Tactic.Interactive

/-- `show_term { tac }` runs the tactic `tac`,
and then prints the term that was constructed.

This is useful for
* constructing term mode proofs from tactic mode proofs, and
* understanding what tactics are doing, and how metavariables are handled.

As an example, in
```
example {P Q R : Prop} (h₁ : Q → P) (h₂ : R) (h₃ : R → Q) : P ∧ R :=
by show_term { tauto }
```
the term mode proof `⟨h₁ (h₃ h₂), eq.mpr rfl h₂⟩` produced by `tauto` will be printed.

As another example, if the goal is `ℕ × ℕ`, `show_term { split, exact 0 }` will
print `refine (0, _)`, and afterwards there will be one remaining goal (of type `ℕ`).
This indicates that `split, exact 0` partially filled in the original metavariable,
but created a new metavariable for the resulting sub-goal.
-/
unsafe def show_term (t : itactic) : itactic := do
  let g :: _ ← get_goals
  t
  let g ← tactic_statement g
  trace g
#align tactic.interactive.show_term tactic.interactive.show_term

add_tactic_doc
  { Name := "show_term"
    category := DocCategory.tactic
    declNames := [`` show_term]
    tags := ["debugging"] }

end Tactic.Interactive


/-!
# Functor

A `Functor` is any type that can act as a generic container that allows you to transform the
underlying values inside the container using a function, so that the values are all updated, but the
structure of the container is the same. This is called "mapping".

A List is one of the most basic examples of a `Functor`.

A list contains zero or more elements of the same, underlying type.  When you `map` a function over
a list, you create a new list with the same number of elements, where each has been transformed by
the function:
-/
#eval List.map (λ x => toString x) [1,2,3] -- ["1", "2", "3"]

-- you can also write this using dot notation on the List object
#eval [1,2,3].map (λ x => toString x)  -- ["1", "2", "3"]

/-!
Here we converted a list of natural numbers (Nat) to a list of strings where the lambda function
here used `toString` to do the transformation of each element. Notice that when you apply `map` the
"structure" of the object remains the same, in this case the result is always a `List` of the same
size.

Note that in Lean a lambda function can be written using `fun` keyword or the unicode
symbol `λ` which you can type in VS code using `\la `.

List has a specialized version of `map` defined as follows:
-/
def map (f : α → β) : List α → List β
  | []    => []
  | a::as => f a :: map f as

/-!
This is a very generic `map` function that can take any function that converts `(α → β)` and use it
to convert `List α → List β`. Notice the function call `f a` above, this application of `f` is
producing the converted items for the new list.

Let's look at some more examples:

-/
-- List String → List Nat
#eval ["elephant", "tiger", "giraffe"].map (fun s => s.length)
-- [8, 5, 7]

-- List Nat → List Float
#eval [1,2,3,4,5].map (fun s => (s.toFloat) ^ 3.0)
-- [1.000000, 8.000000, 27.000000, 64.000000, 125.000000]

--- List String → List String
#eval ["chris", "david", "mark"].map (fun s => s.capitalize)
-- ["Chris", "David", "Mark"]
/-!

Another example of a functor is the `Option` type. Option contains a value or nothing and is handy
for code that has to deal with optional values, like optional command line arguments.

Remember you can construct an Option using the type constructors `some` or `none`:

-/
#check some 5 -- Option Nat
#eval some 5  -- some 5
#eval (some 5).map (fun x => x + 1) -- some 6
#eval (some 5).map (fun x => toString x) -- some "5"
/-!

Lean also provides a convenient short hand syntax for `(fun x => x + 1)`, namely `(· + 1)`
using the middle dot unicode character which you can type in VS code using `\. `.

-/
#eval (some 4).map (· * 5)  -- some 20
/-!

The `map` function preserves the `none` state of the Option, so again
map preserves the structure of the object.

-/
def x : Option Nat := none
#eval x.map (fun x => toString x) -- none
#check x.map (fun x => toString x) -- Option String
/-!

Notice that even in the `none` case it has transformed `Option Nat` into `Option String` as
you see in the `#check` command.

## How to make a Functor Instance?

The `List` type is made an official `Functor` by the following type class instance:

-/
instance : Functor List where
  map := List.map
/-!

Notice all you need to do is provide the `map` function implementation.  For a quick
example, let's supposed you create a new type describing the measurements of a home
or apartment:

-/
structure LivingSpace (α : Type) where
  totalSize : α
  numBedrooms : Nat
  masterBedroomSize : α
  livingRoomSize : α
  kitchenSize : α
  deriving Repr, BEq
/-!

Now you can construct a `LivingSpace` in square feet using floating point values:
-/
abbrev SquareFeet := Float

def mySpace : LivingSpace SquareFeet :=
  { totalSize := 1800, numBedrooms := 4, masterBedroomSize := 500,
    livingRoomSize := 900, kitchenSize := 400 }
/-!

Now, suppose you want anyone to be able to map a `LivingSpace` from one type of measurement unit to
another.  Then you would provide a `Functor` instance as follows:

-/
def LivingSpace.map (f : α → β) (s : LivingSpace α) : LivingSpace β :=
  { totalSize := f s.totalSize
    numBedrooms := s.numBedrooms
    masterBedroomSize := f s.masterBedroomSize
    livingRoomSize := f s.livingRoomSize
    kitchenSize := f s.kitchenSize }

instance : Functor LivingSpace where
  map := LivingSpace.map
/-!

Notice this functor instance takes `LivingSpace` and not the fully qualified type `LivingSpace SquareFeet`.
Notice below that `LivingSpace` is a function from Type to Type.  For example, if you give it type `SquareFeet`
it gives you back the fully qualified type `LivingSpace SquareFeet`.

-/
#check LivingSpace -- Type → Type
/-!

So the `instance : Functor` then is operating on the more abstract, or generic `LivingSpace` saying
for the whole family of types `LivingSpace α` you can map to `LivingSpace β` using the generic
`LivingSpace.map` map function by simply providing a function that does the more primitive mapping
from `(f : α → β)`.  So `LivingSpace.map` is a sort of function applicator.
This is called a "higher order function" because it takes a function as input
`(α → β)` and returns another function as output `F α → F β`.

Notice that `LivingSpace.map` applies a function `f` to convert the units of all the LivingSpace
fields, except for `numBedrooms` which is a count (and therefore is not a measurement that needs
converting).

So now you can define a simple conversion function, let's say you want square meters instead:

-/
abbrev SquareMeters := Float
def squareFeetToMeters (ft : SquareFeet ) : SquareMeters := (ft / 10.7639104)
/-!

and now bringing it all together you can use the simple function `squareFeetToMeters` to map
`mySpace` to square meters:

-/
#eval mySpace.map squareFeetToMeters
/-
{ totalSize := 167.225472,
  numBedrooms := 4,
  masterBedroomSize := 46.451520,
  livingRoomSize := 83.612736,
  kitchenSize := 37.161216 }
  -/
/-!

Lean also defines custom infix operator `<$>` for `Functor.map` which allows you to write this:
-/
#eval (fun s => s.length) <$> ["elephant", "tiger", "giraffe"] -- [8, 5, 7]
#eval (fun x => x + 1) <$> (some 5) -- some 6
/-!

Note that the infix operator is left associative which means it binds more tightly to the
function on the left than to the expression on the right, this means you can often drop the
parentheses on the right like this:

-/
#eval (fun x => x + 1) <$> some 5 -- some 6
/-!

Note that Lean lets you define your own syntax, so `<$>` is nothing special.
You can define your own infix operator like this:

-/
infixr:100 " doodle " => Functor.map

#eval (· * 5) doodle [1, 2, 3]  -- [5, 10, 15]

/-!
Wow, this is pretty powerful.  By providing a functor instance on `LivingSpace` with an
implementation of the `map` function it is now super easy for anyone to come along and
transform the units of a `LivingSpace` using very simple functions like `squareFeetToMeters`. Notice
that squareFeetToMeters knows nothing about `LivingSpace`.

## How do Functors help with Monads ?

Functors are an abstract mathematical structure that is represented in Lean with a type class. The
Lean functor defines both `map` and a special case for working on constants more efficiently called
`mapConst`:

```lean
class Functor (f : Type u → Type v) : Type (max (u+1) v) where
  map : {α β : Type u} → (α → β) → f α → f β
  mapConst : {α β : Type u} → α → f β → f α
```

Note that `mapConst` has a default implementation, namely:
`mapConst : {α β : Type u} → α → f β → f α := Function.comp map (Function.const _)` in the `Functor`
type class.  So you can use this default implementation and you only need to replace it if
your functor has a more specialized variant than this (usually the custom version is more performant).

In general then, a functor is a function on types `F : Type u → Type v` equipped with an operator
called `map` such that if you have a function `f` of type `α → β` then `map f` will convert your
container type from `F α → F β`. This corresponds to the category-theory notion of
[functor](https://en.wikipedia.org/wiki/Functor) in the special case where the category is the
category of types and functions between them.

Understanding abstract mathematical structures is a little tricky for most people. So it helps to
start with a simpler idea like functors before you try to understand monads.  Building on
functors is the next abstraction called [Applicatives](applicatives.lean.md).
-/


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

/-!
# Monoidal opposites

We write `Cᵐᵒᵖ` for the monoidal opposite of a monoidal category `C`.
-/

universes v₁ v₂ u₁ u₂

variables {C : Type u₁}

namespace category_theory

open category_theory.monoidal_category

/-- A type synonym for the monoidal opposite. Use the notation `Cᴹᵒᵖ`. -/
@[nolint has_inhabited_instance]
def monoidal_opposite (C : Type u₁) := C

namespace monoidal_opposite

notation C `ᴹᵒᵖ`:std.prec.max_plus := monoidal_opposite C

/-- Think of an object of `C` as an object of `Cᴹᵒᵖ`. -/
@[pp_nodot]
def mop (X : C) : Cᴹᵒᵖ := X

/-- Think of an object of `Cᴹᵒᵖ` as an object of `C`. -/
@[pp_nodot]
def unmop (X : Cᴹᵒᵖ) : C := X

lemma op_injective : function.injective (mop : C → Cᴹᵒᵖ) := λ _ _, id
lemma unop_injective : function.injective (unmop : Cᴹᵒᵖ → C) := λ _ _, id

@[simp] lemma op_inj_iff (x y : C) : mop x = mop y ↔ x = y := iff.rfl
@[simp] lemma unop_inj_iff (x y : Cᴹᵒᵖ) : unmop x = unmop y ↔ x = y := iff.rfl

attribute [irreducible] monoidal_opposite

@[simp] lemma mop_unmop (X : Cᴹᵒᵖ) : mop (unmop X) = X := rfl
@[simp] lemma unmop_mop (X : C) : unmop (mop X) = X := rfl

instance monoidal_opposite_category [I : category.{v₁} C] : category Cᴹᵒᵖ :=
{ hom := λ X Y, unmop X ⟶ unmop Y,
  id := λ X, 𝟙 (unmop X),
  comp := λ X Y Z f g, f ≫ g, }

end monoidal_opposite

end category_theory

open category_theory
open category_theory.monoidal_opposite

variables [category.{v₁} C]

/-- The monoidal opposite of a morphism `f : X ⟶ Y` is just `f`, thought of as `mop X ⟶ mop Y`. -/
def quiver.hom.mop {X Y : C} (f : X ⟶ Y) : @quiver.hom Cᴹᵒᵖ _ (mop X) (mop Y) := f
/-- We can think of a morphism `f : mop X ⟶ mop Y` as a morphism `X ⟶ Y`. -/
def quiver.hom.unmop {X Y : Cᴹᵒᵖ} (f : X ⟶ Y) : unmop X ⟶ unmop Y := f

namespace category_theory

lemma mop_inj {X Y : C} :
  function.injective (quiver.hom.mop : (X ⟶ Y) → (mop X ⟶ mop Y)) :=
λ _ _ H, congr_arg quiver.hom.unmop H

lemma unmop_inj {X Y : Cᴹᵒᵖ} :
  function.injective (quiver.hom.unmop : (X ⟶ Y) → (unmop X ⟶ unmop Y)) :=
λ _ _ H, congr_arg quiver.hom.mop H

@[simp] lemma unmop_mop {X Y : C} {f : X ⟶ Y} : f.mop.unmop = f := rfl
@[simp] lemma mop_unmop {X Y : Cᴹᵒᵖ} {f : X ⟶ Y} : f.unmop.mop = f := rfl

@[simp] lemma mop_comp {X Y Z : C} {f : X ⟶ Y} {g : Y ⟶ Z} :
  (f ≫ g).mop = f.mop ≫ g.mop := rfl
@[simp] lemma mop_id {X : C} : (𝟙 X).mop = 𝟙 (mop X) := rfl

@[simp] lemma unmop_comp {X Y Z : Cᴹᵒᵖ} {f : X ⟶ Y} {g : Y ⟶ Z} :
  (f ≫ g).unmop = f.unmop ≫ g.unmop := rfl
@[simp] lemma unmop_id {X : Cᴹᵒᵖ} : (𝟙 X).unmop = 𝟙 (unmop X) := rfl

@[simp] lemma unmop_id_mop {X : C} : (𝟙 (mop X)).unmop = 𝟙 X := rfl
@[simp] lemma mop_id_unmop {X : Cᴹᵒᵖ} : (𝟙 (unmop X)).mop = 𝟙 X := rfl

namespace iso

variables {X Y : C}

/-- An isomorphism in `C` gives an isomorphism in `Cᴹᵒᵖ`. -/
@[simps]
def mop (f : X ≅ Y) : mop X ≅ mop Y :=
{ hom := f.hom.mop,
  inv := f.inv.mop,
  hom_inv_id' := unmop_inj f.hom_inv_id,
  inv_hom_id' := unmop_inj f.inv_hom_id }

end iso

variables [monoidal_category.{v₁} C]

open opposite monoidal_category

instance monoidal_category_op : monoidal_category Cᵒᵖ :=
{ tensor_obj := λ X Y, op (unop X ⊗ unop Y),
  tensor_hom := λ X₁ Y₁ X₂ Y₂ f g, (f.unop ⊗ g.unop).op,
  tensor_unit := op (𝟙_ C),
  associator := λ X Y Z, (α_ (unop X) (unop Y) (unop Z)).symm.op,
  left_unitor := λ X, (λ_ (unop X)).symm.op,
  right_unitor := λ X, (ρ_ (unop X)).symm.op,
  associator_naturality' := by { intros, apply quiver.hom.unop_inj, simp, },
  left_unitor_naturality' := by { intros, apply quiver.hom.unop_inj, simp, },
  right_unitor_naturality' := by { intros, apply quiver.hom.unop_inj, simp, },
  triangle' := by { intros, apply quiver.hom.unop_inj, coherence, },
  pentagon' := by { intros, apply quiver.hom.unop_inj, coherence, }, }

lemma op_tensor_obj (X Y : Cᵒᵖ) : X ⊗ Y = op (unop X ⊗ unop Y) := rfl
lemma op_tensor_unit : (𝟙_ Cᵒᵖ) = op (𝟙_ C) := rfl

instance monoidal_category_mop : monoidal_category Cᴹᵒᵖ :=
{ tensor_obj := λ X Y, mop (unmop Y ⊗ unmop X),
  tensor_hom := λ X₁ Y₁ X₂ Y₂ f g, (g.unmop ⊗ f.unmop).mop,
  tensor_unit := mop (𝟙_ C),
  associator := λ X Y Z, (α_ (unmop Z) (unmop Y) (unmop X)).symm.mop,
  left_unitor := λ X, (ρ_ (unmop X)).mop,
  right_unitor := λ X, (λ_ (unmop X)).mop,
  associator_naturality' := by { intros, apply unmop_inj, simp, },
  left_unitor_naturality' := by { intros, apply unmop_inj, simp, },
  right_unitor_naturality' := by { intros, apply unmop_inj, simp, },
  triangle' := by { intros, apply unmop_inj, coherence, },
  pentagon' := by { intros, apply unmop_inj, coherence, }, }

lemma mop_tensor_obj (X Y : Cᴹᵒᵖ) : X ⊗ Y = mop (unmop Y ⊗ unmop X) := rfl
lemma mop_tensor_unit : (𝟙_ Cᴹᵒᵖ) = mop (𝟙_ C) := rfl

end category_theory


lemma subsingleton_injective {α β : Sort*} [subsingleton α] (f : α → β) :
  function.injective f :=
by { intros _ _, cc }


/-
Copyright (c) 2022 Devon Tuma. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Devon Tuma
-/
import computational_monads.simulation_semantics.oracle_append

/-!
# Coercions Between Simulation Oracles With Target Spec Coercions

This file provides a number of `has_coe` instances for `sim_oracle`, when the
target `oracle_spec` already defines computations with coercions,
using the coercion to respond to oracle queries in the new set of oracles.
-/

namespace oracle_comp

open oracle_spec

variables (spec spec' spec'' spec''' : oracle_spec)
  (coe_spec coe_spec' coe_spec'' coe_spec''' : oracle_spec)
  (S S' : Type) {α : Type}

section coe_sim_oracle

/-- Use a coercion on the resulting type of a simulation to coerce the simulation oracle itself.
  This allows for greater flexibility when specifying the simulation oracle when
    both the initial and final `oracle_spec` are some appended set of oracles -/
instance [coe_spec ⊂ₒ coe_spec'] :
  has_coe (sim_oracle spec coe_spec S) (sim_oracle spec coe_spec' S) :=
{ coe := λ so, {default_state := so.default_state, o := λ i x, ↑(so i x)} }

/-- Coerce a simulation oracle to include an additional number of resulting oracles -/
example (so : sim_oracle coe_spec coe_spec' S) :
  sim_oracle coe_spec (coe_spec' ++ spec ++ spec') S := ↑so

/-- Can use coercions to seperately simulate both sides of appended oracle specs -/
example (so : sim_oracle spec spec'' S) (so' : sim_oracle spec' spec''' S') :
  sim_oracle (spec ++ spec') (spec'' ++ spec''') (S × S') :=
↑so ++ₛ ↑so'

end coe_sim_oracle

end oracle_comp