import TBA.Eulerian.Nat

open BEq Nat List Decidable

namespace Eq

protected theorem symm_iff {a b : α} : b = a ↔ a = b := ⟨Eq.symm, Eq.symm⟩

end Eq

namespace List

@[simp] theorem length_append {as bs : List α} :
  length (as ++ bs) = length as + length bs :=
  match as with
  | []      => by simp
  | a :: as => by simp [Nat.succ_add, length_append]

theorem length_zero_iff_nil {as : List α} : length as = 0 ↔ as = [] :=
⟨fun e => by cases as; rfl; simp [length_cons] at e, fun e => by rw [e]; rfl⟩

theorem length_cons_ne_zero {as : List α} {a : α} : length (a :: as) ≠ 0 := by
  rw [List.length_cons]; exact Nat.succNeZero _

-- Some lemmas about filters

@[simp] theorem filter_nil {p : α → Bool} : filter p [] = [] := by
  simp [filter, filterAux, reverse, reverseAux]

theorem cons_eq_append (a : α) (as : List α) : a :: as = [a] ++ as := rfl

theorem reverseAux_append {rs as : List α} : reverseAux rs as = reverseAux rs [] ++ as :=
  match rs with
  | []      => rfl
  | r :: rs => by
    simp only [reverseAux]
    rw [reverseAux_append, reverseAux_append (as := [r]), cons_eq_append r as, append_assoc]

theorem filterAux_aux {p : α → Bool} (as : List α) :
  (rs : List α) → filterAux p as rs = rs.reverse ++ (filterAux p as []) :=
  match as with
  | [] => by intros; simp [filterAux, reverse, reverseAux];
  | a :: as => by
    intro rs
    simp only [filterAux]
    cases p a
    case false => simp [filterAux_aux as rs]
    case true =>
      rw [filterAux_aux as (a :: rs), filterAux_aux as [a]]
      simp only [reverse, reverseAux, List.append, List.cons_append, List.nil_append]
      rw [reverseAux_append, cons_eq_append _ (filterAux p as []), append_assoc]

theorem filter_cons (a : α) (as : List α) :
  filter p (a :: as) = if p a then a :: filter p as else filter p as := by
  simp only [filter, filterAux]
  cases p a
  simp
  rw [filterAux_aux]; simp [reverse, reverseAux]

@[simp] theorem filter_append {as bs : List α} {p : α → Bool} :
  filter p (as ++ bs) = filter p as ++ filter p bs := by
  induction as with
  | nil      => simp
  | cons a as ih =>
    rw [filter_cons, cons_append, filter_cons]
    cases p a <;> simp [ih]

-- A membership predicate

inductive Mem : α → List α → Prop where
  | head (a : α) (as : List α)   : Mem a (a::as)
  | tail (a b : α) (bs : List α) : Mem a bs → Mem a (b::bs)

infix:50 " ∈ " => Mem

@[simp] theorem beq_refl [DecidableEq α] : ((a : α) == a) = true :=
  decideEqTrue rfl

@[simp] theorem beq_neq [DecidableEq α] {a b : α} (h : ¬ a = b) : (a == b) = false :=
  decideEqFalse h

theorem length_erase_mem [DecidableEq α] {a : α} {as : List α} (h : a ∈ as) :
  length (List.erase as a) + 1 = length as :=
  match a, as, h with
  | _, _, Mem.head a bs => by simp [List.erase]
  | _, _, Mem.tail a b bs h => by
    simp only [List.erase]
    match b == a with
    | true => simp
    | false => { simp only [length_cons]; rw [←length_erase_mem h] }

theorem mem_singleton [DecidableEq α] {a b : α} (h : a ∈ [b]) : a = b := by
  cases h with
  | head h       => rfl
  | tail _ _ _ h => cases h

def mem_of_nonzero_length [DecidableEq α] {as : List α} :
  (h : length as > 0) → { a // a ∈ as } :=
  match as with
  | []      => by { simp only [length_nil]; intro fa; cases fa }
  | a :: as => by { intros; apply Subtype.mk; apply Mem.head }

theorem mem_append {as bs : List α} : ∀ a, a ∈ (as ++ bs) → a ∈ as ∨ a ∈ bs :=
  match as with
  | [] => by intros; apply Or.inr; assumption
  | a :: as => by
    simp only [List.cons_append]
    intros a h
    cases h with
    | head h => apply Or.inl; apply Mem.head
    | tail _ _ _ h =>
      cases mem_append (as := as) (bs := bs) a h
      case inl => apply Or.inl; apply Mem.tail; assumption
      case inr => apply Or.inr; assumption

theorem mem_of_mem_filter {as : List α} {a : α} {p : α → Bool} : a ∈ filter p as → a ∈ as :=
  match as with
  | [] => by intros; assumption
  | a' :: as => by
      rw [filter_cons]; cases p a'
      case false => intro h; apply Mem.tail; apply mem_of_mem_filter h
      case true =>
        intro h
        cases h with
        | head => apply Mem.head
        | tail _ _ _ h => apply Mem.tail; apply mem_of_mem_filter h

theorem mem_filter_of_prop {as : List α} {a : α} {p : α → Bool} (ha : a ∈ as) (hpa : p a = true) :
  a ∈ filter p as := by
  induction ha with
  | head a as => rw [filter_cons, hpa]; simp; apply Mem.head
  | tail a b as ha' ih =>
    rw [filter_cons]
    cases hpb : p b
    case false => simp; exact ih hpa
    case true  => simp; apply Mem.tail; exact ih hpa

theorem filterProp_of_mem {as : List α} {p : α → Bool} {a : α} : a ∈ filter p as → p a = true :=
  match as with
  | [] => by intro h; cases h
  | a' :: as => by
      rw [filter_cons]; byCases hpa : p a'
      case inr => simp [hpa]; exact filterProp_of_mem
      case inl => simp [hpa]; intro h; cases h; assumption; apply filterProp_of_mem; assumption

theorem mem_split {a : α} {as : List α} (h : a ∈ as) : ∃ s t, as = s ++ a :: t :=
  match a, as, h with
  | _, _, Mem.head a bs     => ⟨[], ⟨bs, rfl⟩⟩
  | _, _, Mem.tail a b bs h =>
    match bs, mem_split h with
    | _, ⟨s, ⟨t, rfl⟩⟩ => ⟨b::s, ⟨t, List.cons_append .. ▸ rfl⟩⟩

-- Couting elements

section Count
variable [DecidableEq α] (as bs as' bs' : List α) (a b : α)

def count : Nat := (as.filter $ fun b => b == a).length

@[simp] theorem count_empty : count [] a = 0 := by simp [count]

@[simp] theorem count_self_cons : (a :: as).count a = Nat.succ (as.count a) := by
  simp [count, filter_cons]

theorem count_neq_cons {as} {a b : α} (h : ¬ b = a) : (b :: as).count a = as.count a := by
  simp [count, filter_cons, h]

@[simp] theorem count_append : (as ++ bs).count a = as.count a + bs.count a :=
  by simp [count]

--set_option trace.Meta.Tactic.simp true
theorem count_erase {as : List α} {a b : α} :
  (as.erase a).count b = if (a == b) then (as.count b) - 1 else as.count b :=
  match as with
  | [] => by simp only [List.erase]; cases (a == b) <;> simp
  | a' :: as => by
    simp only [List.erase]
    byCases h : a' = a
    case inl =>
      cases h
      simp only [beq_refl]
      byCases h' : a = b
      case inl => cases h'; simp only [beq_refl, Lean.Simp.ite_True, Nat.succ_sub_succ, count_self_cons]; apply Nat.sub_zero
      case inr => rw [beq_neq h']; simp [count_neq_cons h']
    case inr =>
      rw [beq_neq h]
      byCases h' : a' = b
      case inl => cases h'; simp [count_erase (as := as), beq_neq (Ne.symm h)]
      case inr => simp [count_neq_cons h', count_neq_cons h', count_erase]

theorem count_le_cons : as.count a ≤ (b :: as).count a := by
  byCases h : (b = a)
  case inl => cases h; simp [count_self_cons, Nat.leSucc]
  case inr => rw [count_neq_cons h]; simp [Nat.leRefl]

theorem mem_nonzeroCount {as : List α} {a : α}: a ∈ as ↔ as.count a > 0 := by
  apply Iff.intro
  case mp =>
    intro h
    induction h with
    | head a => simp [Nat.zeroLtSucc]
    | tail _ _ _ h ih => apply Nat.ltOfLtOfLe ih; apply count_le_cons
  case mpr =>
    intro h
    let ⟨a', ha'⟩ := mem_of_nonzero_length h
    let foo := filterProp_of_mem ha'
    cases ofDecideEqTrue foo
    apply mem_of_mem_filter ha'

-- Erasing elements from lists

theorem erase_comm {as : List α} : (as.erase a).erase b  = (as.erase b).erase a :=
  match as with
  | [] => rfl
  | a' :: as => by
    byCases h : a' = a
    case inl =>
      cases h; simp only [List.erase]
      byCases h' : b = a
      case inl => cases h'; simp
      case inr => rw [beq_neq (Ne.symm h')]; simp [List.erase]
    case inr =>
      simp only [List.erase]
      rw [beq_neq h]
      byCases h' : a' = b
      case inl => cases h'; simp [List.erase]
      case inr => simp [List.erase, beq_neq h', beq_neq h, erase_comm (as := as)]

theorem filter_erase_false {as : List α} {a : α} {p : α → Bool} (h : p a = false) :
  filter p (as.erase a) = filter p as :=
  match as with
  | [] => by simp [List.erase]
  | b :: as => by
    simp only [List.erase, filter_cons]
    byCases h' : b = a
    case inl => cases h'; simp [h]
    case inr => simp [h', filter_cons]; rw [filter_erase_false h]

theorem filter_erase_true {as : List α} {a : α} {p : α → Bool} (hpa : p a = true) :
  filter p (as.erase a) = (filter p as).erase a :=
  match as with
  | [] => rfl
  | b :: as => by
    simp
    byCases h : b = a
    case inl => cases h; simp [List.erase, filter_cons, hpa]
    case inr =>
      simp only [List.erase, beq_neq h, filter_cons]
      cases hpb : p b
      case false => exact filter_erase_true hpa
      case true => rw [filter_erase_true hpa]; simp [List.erase, h]

def eraseAll (as bs : List α) : List α :=
  match bs with
  | []      => as
  | b :: bs => eraseAll (as.erase b) bs

infixl:55 " -l " => eraseAll

theorem erase_eraseAll {as bs : List α} {a : α} : (as.erase a) -l bs = (as -l bs).erase a :=
  match bs with
  | [] => rfl
  | b :: bs => by simp only [eraseAll]; rw [←erase_eraseAll, erase_comm]

@[simp] theorem count_eraseAll (as bs : List α) (a : α) :
  (as -l bs).count a = as.count a - bs.count a :=
  match bs with
  | [] => rfl
  | b :: bs => by
    simp only [eraseAll]; rw [erase_eraseAll]; simp
    byCases hba : b = a;
    case inl => cases hba; rw [count_self_cons, count_erase, count_eraseAll as bs a, beq_refl]; rfl
    case inr => rw [count_erase, beq_neq hba, count_eraseAll as bs a, count_neq_cons]; repeat simp_all

-- Lists which are permutations of each other, and sublists modulo permutation

def isPermEqvTo : Prop := ∀ a, as.count a = bs.count a
infixl:50 " ≃ " => isPermEqvTo -- Type as \simeq

def isPermSubOf : Prop := ∀ a, as.count a ≤ bs.count a
infixl:50 " ⊆ " => isPermSubOf -- Type as \sub

theorem permSubOfEraseSub : (as -l bs) ⊆ as := fun a => by simp [Nat.subLe]

theorem mem_of_mem_eraseAll {as bs : List α} {a : α} : a ∈ (as -l bs) → a ∈ as := by
  rw [mem_nonzeroCount, mem_nonzeroCount, count_eraseAll]
  intro h; exact Nat.ltOfLtOfLe h (Nat.subLe _ _)

theorem permSubEraseAllLength {as bs : List α} : bs ⊆ as → length (as -l bs) = length as - length bs :=
  match bs with
  | [] => fun _ => rfl
  | b :: bs => fun hsub => by
    simp only [eraseAll, length_cons]
    have hbas : b ∈ as := by
      have hb := hsub b
      rw [count_self_cons] at hb
      rw [mem_nonzeroCount]
      exact Nat.ltOfLeOfLt (zeroLe _) (ltOfSuccLe hb)
    have hsub' : bs.isPermSubOf (as.erase b) := fun c => by
      have hc := hsub c
      byCases h : b = c
      case inl =>
        cases h
        rw [count_self_cons] at hc
        rw [count_erase]
        simp [leOfSuccLeSucc (Nat.leTrans hc leSuccSubOne)]
      case inr =>
        rw [count_neq_cons h] at hc
        apply Nat.leTrans hc
        rw [count_erase, beq_neq h]
        simp [Nat.leRefl]
    rw [permSubEraseAllLength hsub', ←length_erase_mem hbas, Nat.succ_sub_succ]

theorem permSubExtend {as bs : List α} {b} (hsub : bs ⊆ as) (ha : b ∈ (as -l bs)) : (b :: bs) ⊆ as := by
  intro a
  rw [mem_nonzeroCount, count_eraseAll, ←zeroLtIffSub] at ha
  byCases h : b = a
  case inl => cases h; simp; assumption
  case inr => rw [count_neq_cons h]; apply hsub

def permSubObtainComplement {as bs : List α} (hsub : bs ⊆ as)
    (hlength : bs.length < as.length) : { e // e ∈ as -l bs} := by
  have hl : (as -l bs).length > 0 := by rw [permSubEraseAllLength hsub, ←zeroLtIffSub]; assumption
  revert hl; cases as -l bs
  case nil => simp only [length_nil]; intro hl'; cases hl'
  case cons => intros; exact ⟨_, Mem.head _ _⟩

theorem permSubEqvClosed {as bs bs' : List α} (heqv : bs ≃ bs') (hsub : bs ⊆ as) : bs' ⊆ as :=
  fun a => by rw [←heqv a]; exact hsub a

theorem permSubSingleton {as : List α} {a : α} : a ∈ as → [a] ⊆ as := by
  intros ha b
  rw [mem_nonzeroCount] at ha
  byCases h : a = b
  case inl => cases h; simp [count_self_cons]; assumption
  case inr => rw [count_neq_cons h]; simp [Nat.zeroLe]

theorem permEqvRotate : (as ++ bs) ≃ (bs ++ as) :=
  fun a => by simp [Nat.add_comm];

theorem permEqvRefl {as : List α} : as ≃ as :=
  fun a => rfl

theorem permEqvTrans {as bs cs : List α} (h : as ≃ bs) (h' : bs ≃ cs) : as ≃ cs :=
  fun a => Eq.trans (h a) (h' a)

theorem permEqvSymm {as bs : List α} (h : as ≃ bs) : bs ≃ as :=
  fun a => by simp [Nat.add_comm, h a]

theorem permEqvToEraseAppend {as bs : List α} (ps : bs ⊆ as) : as ≃ ((as -l bs) ++ bs) :=
  fun a => by simp only [count_append, count_eraseAll]; rw [←Nat.le_subAdd (ps a)]

theorem permEqvToEraseCons {as : List α} {a : α} (h : a ∈ as) : as ≃ (a :: (as.erase a)) := by
  exact permEqvTrans (permEqvToEraseAppend (permSubSingleton h)) (permEqvRotate _ _)

theorem permEqvCons {as bs : List α} {a : α} (h : as ≃ bs) : (a :: as) ≃ (a :: bs) := by
  intro b
  byCases hba : (a = b)
  case inl => cases hba; simp [count_self_cons, h a];
  case inr => rw [count_neq_cons hba, count_neq_cons hba, h b]

theorem permSubEraseOfpermEqvCons {as bs : List α} {a : α} (h : (a :: as) ⊆ bs) :
  as ⊆ (bs.erase a) := fun b => by
  let ha := h a
  byCases h' : a = b
  case inl =>
    cases h'
    rw [count_erase]
    rw [count_self_cons] at ha
    simp [Nat.leOfSuccLeSucc (Nat.leTrans ha leSuccSubOne)]
  case inr =>
    let hb := h b
    rw [count_neq_cons h'] at hb
    rw [count_erase, beq_neq h']
    exact hb

theorem permEqvOfPermSub {as bs : List α} : as ⊆ bs → as.length = bs.length → as ≃ bs :=
  match as with
  | [] => fun hsub hl => by
    rw [length_nil, Eq.symm_iff, length_zero_iff_nil] at hl
    rw [hl]; intro b; rfl
  | a :: as => fun hsub hl => by
    have habs : a ∈ bs := by
      rw [mem_nonzeroCount]
      let hsuba := hsub a
      simp only [count_self_cons] at hsuba
      exact Nat.ltOfLtOfLe (Nat.zeroLtSucc _) hsuba
    have hsub' : as.isPermSubOf (bs.erase a) := permSubEraseOfpermEqvCons hsub
    have hl' : as.length = (bs.erase a).length := by
      apply Nat.add_right_cancel (m := 1)
      rw [length_erase_mem habs, ←hl, length_cons]
    have hp : bs.isPermEqvTo (a :: (bs.erase a)) := permEqvToEraseCons habs
    exact permEqvTrans (permEqvCons (permEqvOfPermSub hsub' hl')) (permEqvSymm hp)

theorem permEqvMemClosed {as bs : List α} {a : α} (hp : as ≃ bs) : a ∈ as → a ∈ bs := by
  rw [mem_nonzeroCount, mem_nonzeroCount, hp a]; intros; assumption

theorem permEqvEraseOfpermEqvCons {as bs : List α} {a : α} (h : (a :: as) ≃ bs) : as ≃ (bs.erase a) := fun a' => by
  let ha := h a
  byCases h' : a = a'
  case inl =>
    cases h'
    rw [count_erase]
    simp only [beq_refl, Lean.Simp.ite_True]
    rw [←ha, count_self_cons, succ_sub_succ,  Nat.sub_zero]
  case inr =>
    let ha' := h a'
    rw [count_neq_cons h'] at ha'
    rw [count_erase, beq_neq h']
    exact ha'

theorem permEqvLength {as bs : List α} : as ≃ bs → as.length = bs.length :=
  match as with
  | [] =>
    match bs with
    | [] => fun _ => rfl
    | b :: bs => fun h => by
      let hb := h b
      simp only [count] at hb; rw [filter_cons, beq_refl] at hb
      simp at hb
  | a :: as => fun h => by
    let ha := h a
    rw [count_self_cons] at ha
    rw [length_cons, permEqvLength (permEqvEraseOfpermEqvCons h)]
    exact length_erase_mem (mem_nonzeroCount.mpr (Nat.ltOfLtOfEq (Nat.zeroLtSucc (count as a)) ha))

theorem permEqv_filter_erase_true {as : List α} {a : α} {p : α → Bool} (hpa : p a = true) (ha : a ∈ as) :
  (a :: filter p (List.erase as a)) ≃ (filter p as) := by
  intro b
  byCases h : a = b
  case inl =>
    cases h
    rw [count_self_cons, filter_erase_true hpa, count_erase]
    simp only [beq_refl, Lean.Simp.ite_True]
    have h' : 1 ≤ count (filter p as) a := by
      apply Nat.succLeOfLt
      apply mem_nonzeroCount.mp
      apply mem_filter_of_prop ha hpa
    exact Eq.symm (le_subAdd h')
  case inr =>
    rw [count_neq_cons h, filter_erase_true hpa, count_erase, beq_neq h]
    simp

theorem permEqvFilter {as bs : List α} (p : α → Bool) : as ≃ bs → (filter p as) ≃ (filter p bs) :=
  match as with
  | [] => by
    intro h
    rw [length_zero_iff_nil.mp $ Eq.symm (permEqvLength h)]
    exact permEqvRefl
  | a :: as => by
    intro h
    rw [filter_cons]
    have h' := permEqvFilter p (permEqvEraseOfpermEqvCons h)
    cases hpa : p a with
    | true =>
      simp only [beq_refl, Lean.Simp.ite_True]
      apply permEqvTrans (permEqvCons h')
      have ha : a ∈ bs := by rw [mem_nonzeroCount, ←h a]; simp [zeroLtSucc]
      exact permEqv_filter_erase_true (as := bs) hpa ha
    | false =>
      refine permEqvTrans h' ?_
      rw [filter_erase_false hpa]
      exact permEqvRefl

end Count

end List


/-
Copyright (c) 2021 Rémy Degenne. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Rémy Degenne
-/
import measure_theory.measure.measure_space_def
import tactic.auto_cases
import tactic.tidy
import tactic.with_local_reducibility
/-!
# Tactics for measure theory

Currently we have one domain-specific tactic for measure theory: `measurability`.

This tactic is to a large extent a copy of the `continuity` tactic by Reid Barton.
-/

/-!
### `measurability` tactic

Automatically solve goals of the form `measurable f`, `ae_measurable f μ` and `measurable_set s`.

Mark lemmas with `@[measurability]` to add them to the set of lemmas
used by `measurability`. Note: `to_additive` doesn't know yet how to
copy the attribute to the additive version.
-/

/-- User attribute used to mark tactics used by `measurability`. -/
@[user_attribute]
meta def measurability : user_attribute :=
{ name := `measurability,
  descr := "lemmas usable to prove (ae)-measurability" }

/- Mark some measurability lemmas already defined in `measure_theory.measurable_space_def` and
`measure_theory.measure_space_def` -/
attribute [measurability]
  measurable_id
  measurable_id'
  ae_measurable_id
  ae_measurable_id'
  measurable_const
  ae_measurable_const
  ae_measurable.measurable_mk
  measurable_set.empty
  measurable_set.univ
  measurable_set.compl
  subsingleton.measurable_set
  measurable_set.Union
  measurable_set.Inter
  measurable_set.union
  measurable_set.inter
  measurable_set.diff
  measurable_set.symm_diff
  measurable_set.ite
  measurable_set.cond
  measurable_set.disjointed
  measurable_set.const
  measurable_set.insert
  measurable_set_eq
  finset.measurable_set
  measurable_space.measurable_set_top

namespace tactic

/--
Tactic to apply `measurable.comp` when appropriate.

Applying `measurable.comp` is not always a good idea, so we have some
extra logic here to try to avoid bad cases.

* If the function we're trying to prove measurable is actually
  constant, and that constant is a function application `f z`, then
  measurable.comp would produce new goals `measurable f`, `measurable
  (λ _, z)`, which is silly. We avoid this by failing if we could
  apply `measurable_const`.

* measurable.comp will always succeed on `measurable (λ x, f x)` and
  produce new goals `measurable (λ x, x)`, `measurable f`. We detect
  this by failing if a new goal can be closed by applying
  measurable_id.
-/
meta def apply_measurable.comp : tactic unit :=
`[fail_if_success { exact measurable_const };
  refine measurable.comp _ _;
  fail_if_success { exact measurable_id }]

/--
Tactic to apply `measurable.comp_ae_measurable` when appropriate.

Applying `measurable.comp_ae_measurable` is not always a good idea, so we have some
extra logic here to try to avoid bad cases.

* If the function we're trying to prove measurable is actually
  constant, and that constant is a function application `f z`, then
  `measurable.comp_ae_measurable` would produce new goals `measurable f`, `ae_measurable
  (λ _, z) μ`, which is silly. We avoid this by failing if we could
  apply `ae_measurable_const`.

* `measurable.comp_ae_measurable` will always succeed on `ae_measurable (λ x, f x) μ` and
  can produce new goals (`measurable (λ x, x)`, `ae_measurable f μ`) or
  (`measurable f`, `ae_measurable (λ x, x) μ`). We detect those by failing if a new goal can be
  closed by applying `measurable_id` or `ae_measurable_id`.
-/
meta def apply_measurable.comp_ae_measurable : tactic unit :=
`[fail_if_success { exact ae_measurable_const };
  refine measurable.comp_ae_measurable _ _;
  fail_if_success { exact measurable_id };
  fail_if_success { exact ae_measurable_id }]

/--
We don't want the intro1 tactic to apply to a goal of the form `measurable f`, `ae_measurable f μ`
or `measurable_set s`. This tactic tests the target to see if it matches that form.
 -/
meta def goal_is_not_measurable : tactic unit :=
do t ← tactic.target,
  match t with
  | `(measurable %%l) := failed
  | `(ae_measurable %%l %%r) := failed
  | `(measurable_set %%l) := failed
  | _ := skip
  end

/-- List of tactics used by `measurability` internally. The option `use_exfalso := ff` is passed to
the tactic `apply_assumption` in order to avoid loops in the presence of negated hypotheses in
the context. -/
meta def measurability_tactics (md : transparency := semireducible) : list (tactic string) :=
[
  propositional_goal >> tactic.interactive.apply_assumption none {use_exfalso := ff}
                        >> pure "apply_assumption {use_exfalso := ff}",
  goal_is_not_measurable >> intro1
                        >>= λ ns, pure ("intro " ++ ns.to_string),
  apply_rules [] [``measurability] 50 { md := md }
                        >> pure "apply_rules with measurability",
  apply_measurable.comp >> pure "refine measurable.comp _ _",
  apply_measurable.comp_ae_measurable
                        >> pure "refine measurable.comp_ae_measurable _ _",
  `[ refine measurable.ae_measurable _ ]
                        >> pure "refine measurable.ae_measurable _",
  `[ refine measurable.ae_strongly_measurable _ ]
                        >> pure "refine measurable.ae_strongly_measurable _"
]

namespace interactive
setup_tactic_parser

/--
Solve goals of the form `measurable f`, `ae_measurable f μ`, `ae_strongly_measurable f μ` or
`measurable_set s`. `measurability?` reports back the proof term it found.
-/
meta def measurability
  (bang : parse $ optional (tk "!")) (trace : parse $ optional (tk "?")) (cfg : tidy.cfg := {}) :
  tactic unit :=
let md                 := if bang.is_some then semireducible else reducible,
    measurability_core := tactic.tidy { tactics := measurability_tactics md, ..cfg },
    trace_fn           := if trace.is_some then show_term else id in
trace_fn measurability_core

/-- Version of `measurability` for use with auto_param. -/
meta def measurability' : tactic unit := measurability none none {}

/--
`measurability` solves goals of the form `measurable f`, `ae_measurable f μ`,
`ae_strongly_measurable f μ` or `measurable_set s` by applying lemmas tagged with the
`measurability` user attribute.

You can also use `measurability!`, which applies lemmas with `{ md := semireducible }`.
The default behaviour is more conservative, and only unfolds `reducible` definitions
when attempting to match lemmas with the goal.

`measurability?` reports back the proof term it found.
-/
add_tactic_doc
{ name := "measurability / measurability'",
  category := doc_category.tactic,
  decl_names := [`tactic.interactive.measurability, `tactic.interactive.measurability'],
  tags := ["lemma application"] }

end interactive

end tactic


import category_theory.category
import category_theory.isomorphism
import category_theory.types
import data.fintype.basic
import data.real.basic
import magma

open category_theory

namespace exercises

variables  {C: Type*} [category C]
variables (A B D A' B' D' X T : C)

-- Exercise 1 page 40
-- the inverse of identity is itself
example : is_iso(𝟙 A) := { inv := 𝟙 A}
-- given two morphisms, if f is isomorphic and has a reverse g, then g is iso and has reverse f
example (f : A ⟶ B) (g : B ⟶ A) (isof : is_iso f) (i : inv f = g) : is_iso g := {inv := f}
-- composition of isomorphisms are isomorphisms
example (f : A ⟶ B) (k : B ⟶ D) (isof : is_iso f) (isok : is_iso k) : is_iso (f ≫ k) :=
{inv := inv k ≫ inv f}

-- Exercise 2 page 42
lemma unique_inverse  (f : A ≅ B) (f' : A ≅ B) (g k : B ⟶ A) :
    f.hom = f'.hom -> f.inv = g → f'.inv = k → g = k :=
begin
    intros ff' finv f'inv,

    calc g = f.inv : by {rw finv}
    ... = f.inv ≫ f'.hom ≫ f'.inv : by {simp}
    ... = f.inv ≫ f.hom ≫ f'.inv : by {rw ← ff'}
    ... = 𝟙 B ≫ f'.inv : by {simp}
    ... = f'.inv : by simp
    ... = k : by {rw f'inv},
end

section alternative_unique_inverse

    lemma unique_inverse2 (g k: B ⟶ A)(f: A ⟶ B) (h1: f ≫ g = 𝟙 A)(h1a: g ≫ f = 𝟙 B)(h2: f ≫ k = 𝟙 A): g = k :=
    begin
        calc g = g ≫ 𝟙 A : by rw [category.comp_id]
        ... = g ≫ (f ≫ k) : by rw ← h2
        ... = (g ≫ f) ≫ k : by rw [category.assoc]
        ... = k : by rw [h1a, category.id_comp]
    end

    lemma unique_inverse3 (g k: B ⟶ A)(f: A ⟶ B) [is_iso f] (h1: inv f = g)(h2: inv f = k): g = k :=
    begin
        calc g = g ≫ 𝟙 A : by rw category.comp_id
        ... = g ≫ (f ≫ inv f) : by rw is_iso.hom_inv_id
        ... = g ≫ (f ≫ k) : by rw h2
        ... = (g ≫ f) ≫ k : by rw category.assoc
        ... = (inv f ≫ f) ≫ k : by rw h1
        ... = (𝟙 B) ≫ k : by rw is_iso.inv_hom_id
        ... = k : by rw category.id_comp,
    end
end alternative_unique_inverse

-- Exercise 3a page 43
lemma iso_cancel_left  (f : A ≅ B) (h k : D ⟶ A) :
h ≫ f.hom = k ≫ f.hom → h = k :=
begin
    intros fhfk,
    calc h = (h ≫ f.hom) ≫ f.inv : by {simp}
    ... = (k ≫ f.hom) ≫ f.inv : by {rw fhfk}
    ... = k : by {simp}
end

section alternative_ex3_page43
    lemma iso_cancel_left2 (f: A ⟶ B) [is_iso f](h k: D ⟶ A): h ≫ f = k ≫ f → h = k :=
    begin
        let g: B ⟶ A := is_iso.inv f,
        intros given,
        /- given : h ≫ f = k ≫ f -/
        calc h = h ≫ 𝟙 A : by rw category.comp_id
        ... = h ≫ (f ≫ g) : by rw is_iso.hom_inv_id
        ... = (h ≫ f) ≫ g: by rw category.assoc
        ... = (k ≫ f) ≫ g: by rw given
        ... = k ≫ (f ≫ g): by rw category.assoc
        ... = k ≫ 𝟙 A : by rw is_iso.hom_inv_id
        ... = k : by rw category.comp_id
    end
end alternative_ex3_page43

-- Exercise 3b page 43
lemma iso_cancel_right (f : A ≅ B) (h k : B ⟶ D) :
f.hom ≫ h = f.hom ≫ k → h = k :=
begin
    intros fhfk,
    calc h = f.inv ≫ (f.hom ≫ h)  : by {simp}
    ... = f.inv ≫ (f.hom ≫ k) : by {rw fhfk}
    ... = k : by {simp}
end

inductive Two : Type
| one | two

def swap : Two → Two
| Two.one := Two.two
| Two.two := Two.one

-- Exercise 3c page 43
lemma iso_cant_cancel_right_left :
∃ (A : Type) (f : A ≅ A) (h k : A ⟶ A), f.hom ≫ h = k ≫ f.hom ∧ h ≠ k :=
begin
    --let swap := ↾ swap,

    let swapswap : swap ∘ swap = id, {apply funext, intro x, cases x, refl, refl },
    --let swapswap : swap ≫ swap = 𝟙 Two, {funext ,},

    let f : Two ≅ Two := ⟨ swap, swap, swapswap, swapswap ⟩ ,
    let h := λ (n: Two), Two.one,
    let k := λ (n: Two), Two.two,
    have prop : f.hom ≫ h = k ≫ f.hom, {apply funext, intro x, cases x, refl, refl,},

    use [Two,f, h, k],

    split,
    {exact prop},

    have foo : h Two.one ≠ k Two.one, {change Two.one ≠ Two.two, simp,},

    --apply funext at H,
    intro H,

--rw funext at H,

    rw H at foo,
    exact foo (by refl),
end

--local attribute classical.prop_decidable

 lemma point_diff {α β : Type} {f1 f2 : α → β} (dif: ∃ x, f1 x ≠ f2 x) : f1 ≠ f2 :=
 begin
 simp,
 by_contradiction H,
 rw H at dif,
 cases dif with x hx,
 exact hx rfl ,
 end

lemma iso_cant_cancel_right_left' :
∃ (A : Type) (f : A ≅ A) (h k : A ⟶ A), f.hom ≫ h = k ≫ f.hom ∧ h ≠ k :=
begin
    have swapinv : swap ∘ swap = id, {funext, cases x; refl},

    let f : Two ≅ Two := ⟨ swap, swap, swapinv, swapinv ⟩ ,
    let h := λ (n: Two), Two.one,
    let k := λ (n: Two), Two.two,

    use [Two, f, h, k],

    split,
    { refl },
    { apply point_diff,
      use Two.one}
end

open bool

lemma iso_cant_cancel_right_left'' :
∃ (A : Type) (f : A ≅ A) (h k : A ⟶ A), f.hom ≫ h = k ≫ f.hom ∧ h ≠ k :=
begin
    have selfinv : bnot ∘ bnot = id, {funext, simp},

    -- have f : bool ≅ bool := ⟨ bnot, bnot, selfinv, selfinv ⟩,
    have f : iso bool bool , {exact ⟨ bnot, bnot, selfinv, selfinv ⟩},
    let h := (λ (n: bool), tt),
    let k := (λ (n: bool), ff),

    -- fixme if I pass f as second argument instead of the expansion, things break
    -- f for some reason doesn't see the "contents" like in iso_cant_cancel_right_left'
    --use [bool, f, h, k],
    use [bool, ⟨ bnot, bnot, selfinv, selfinv ⟩, h, k],

    split,
    { refl },
    { apply point_diff,
      use tt}
end

def has_retraction {A B : C} (f : A ⟶ B) := ∃ r, f ≫ r = 𝟙 A
def has_section {A B : C} (f : A ⟶ B) := ∃ s, s ≫ f = 𝟙 B

-- Exercise 6 page 52
lemma retraction_divides {T: C} (f : A ⟶ B) (ret: has_retraction f) (g: A ⟶ T) :
∃ t : B ⟶ T, f ≫ t = g :=
begin
    cases ret with s hS,
    let t := s ≫ g,
    use t,
    calc f ≫ t = f ≫ (s ≫ g) : by {refl}
    ... = (f ≫ s) ≫ g : by {simp}
    ... = 𝟙 A ≫ g : by {rw hS}
    ... = g : by {simp}
end

-- Exercise 7 page 53
lemma section_cancels_right {T: C} (f : A ⟶ B) (sec: has_section f)  (t₁ t₂: B ⟶ T):
f ≫ t₁ = f ≫ t₂ → t₁ = t₂ :=
begin
    intros h,
    cases sec with s hS,

    calc t₁ = 𝟙 B ≫ t₁ : by {rw category.id_comp}
    ... = (s ≫ f) ≫ t₁ : by {rw ← hS}
    ... = s ≫ f ≫ t₁ : by {apply category.assoc}
    ... = s ≫ f ≫ t₂ : by {rw h}
    ... = (s ≫ f) ≫ t₂ : by {rw category.assoc}
    ... = 𝟙 B ≫ t₂ : by {rw hS}
    ... = t₂ : by {apply category.id_comp},
end

-- Exercise 8 page 54
lemma section_comp_section_has_section (f : A ⟶ B) (g : B ⟶ D) (secf: has_section f) (secg: has_section g) :
has_section (f ≫ g) :=
begin
    cases secf with sf hsf,
    cases secg with sg hsg,

    use (sg ≫ sf),
    calc (sg ≫ sf ) ≫ f ≫ g = sg ≫ (sf ≫ f) ≫ g : by {simp}
    ... = sg ≫ 𝟙 B  ≫ g : by {rw hsf,}
    ... = sg ≫ g : by {simp}
    ... = 𝟙 D : by {rw hsg}
end

class idempotent {X: C} (endo : X ⟶ X) : Prop :=
(repeat : endo ≫ endo = endo)

@[reducible]
def is_retraction {A B : C} (f : A ⟶ B) (r : B ⟶ A) := f ≫ r = 𝟙 A

lemma is_retraction_retracts (f : A ⟶ B) (r : B ⟶ A) (ret: is_retraction f r) :
has_retraction f := ⟨ r, ret ⟩

-- Exercise 9a page 54
lemma retraction_section_is_idemp {f : A ⟶ B} {r : B ⟶ A} (ret: is_retraction f r)
: idempotent (r ≫ f) :=
begin
    split, -- this applies the constructor
    unfold is_retraction at ret, -- this is ugly, i shouldn't need it

    calc (r ≫ f) ≫ r ≫ f = r ≫ (f ≫ r) ≫ f : by {simp}
    ... = r ≫ f : by simp [ret]
end

open category_theory.iso

-- Exercise 9b page 54
lemma retraction_with_iso_is_id (I : A ≅ B) (r : B ⟶ A) (ret: is_retraction I.hom r) :
r ≫ I.hom = 𝟙 B :=
begin
    let f := I.hom,
    let g := I.inv,
    unfold is_retraction at ret,  -- this is ugly, i shouldn't need it

    calc r ≫ f = 𝟙 B ≫ r ≫ f : by rw category.id_comp
    ... = (g ≫ f) ≫ r ≫ f : by rw inv_hom_id
    ... = g ≫ (f ≫ r) ≫ f : by simp
    ... = g ≫ 𝟙 A ≫ f : by {rw ret}
    ... = g ≫ f : by {simp}
    ... = 𝟙 B : by {simp}
end

-- Exercise 10 page 55
lemma exercise_10 (If : A ≅ B) (Ig : B ≅ D) :
  inv (If.hom ≫ Ig.hom) = Ig.inv ≫ If.inv :=
begin
    split, --why is this enough?
end

@[derive decidable_eq]
inductive People11 : Type
| Fatima | Omer | Alysia

@[derive decidable_eq]
inductive Drinks11 : Type
| Coffee | Tea | Cocoa

-- Exercise 11a page 55
example : People11 ≅ Drinks11 :=
begin
    let f : People11 → Drinks11 :=
     λ p, match p with
            | People11.Fatima := Drinks11.Coffee
            | People11.Omer := Drinks11.Tea
            | People11.Alysia := Drinks11.Cocoa
            end,

    let g : Drinks11 → People11 :=
     λ d, match d with
            | Drinks11.Coffee := People11.Fatima
            | Drinks11.Tea := People11.Omer
            | Drinks11.Cocoa := People11.Alysia
            end,

    have id1 : f ∘ g = id, {funext, cases x; refl},
    have id2 : g ∘ f = id, {funext, cases x; refl},
    exact ⟨ ↾f, ↾g ⟩,
end

universes v u

-- this is ugly, why do I need to define this?
abbreviation from_hom {α β : Type} (f : α ⟶ β) : α → β := f

lemma type_isos_are_injective {A B: Type} (i: A ≅ B) :
∀ (a1 a2 : A), a1 ≠ a2 → i.hom a1 ≠ i.hom a2 :=
begin
    intros a1 a2 ne h,
    suffices H: a1 = a2,
    {exact ne H},
    { calc a1 = from_hom (𝟙 A) a1 : by {refl}
        ... = (i.hom ≫ i.inv) a1 : by {rw i.hom_inv_id}
        ... = i.inv (i.hom a1) : by {refl}
        ... = i.inv (i.hom a2) : by {rw h,}
        ... = (i.hom ≫ i.inv) a2 : by {simp}
        ... = from_hom (𝟙 A) a2 : by {rw i.hom_inv_id}
        ... = a2 : by {refl},
    }
end

lemma type_isos_are_surjective {A B: Type} (i: A ≅ B) :
∀ (b : B), ∃ (a : A), i.hom a = b :=
begin
    intros b,
    use i.inv b,
    calc i.hom (i.inv b) = (i.inv ≫ i.hom) b : by {simp}
        ... = from_hom (𝟙 B) b : by {rw i.inv_hom_id}
        ... = b : by {refl}
end

-- Exercise 11b page 55
example :  (People11 ≅ bool) → false :=
begin
    intros i,
    by_cases i.inv tt = i.inv ff,
    {
        -- when i.inv tt = i.inv ff
        apply type_isos_are_injective (symm i) _ _ _ h,
        simp,
    },
    {
        -- when i.inv tt ≠ i.inv ff
        have ugly : ∃ (p : People11), p ≠ i.inv tt ∧ p ≠ i.inv ff,
        {   cases i.inv tt,
            cases i.inv ff,
            use People11.Alysia,
            use People11.Alysia, simp,
            use People11.Omer, simp,
            cases i.inv ff,
            use People11.Alysia, simp, simp,
            use People11.Alysia,
            use People11.Fatima, simp,
            cases i.inv ff,
            use People11.Omer, simp,
            use People11.Fatima, simp,
            use People11.Omer
        },

        cases ugly with u hu,
        cases type_isos_are_surjective (symm i) u with a ha,
        change i.inv a = u at ha,
        cases a,
        exact hu.2 ha.symm,
        exact hu.1 ha.symm,
    }
end

open fintype

instance people_fintype: fintype People11 := {
    elems := [People11.Alysia, People11.Fatima, People11.Omer].to_finset,
    complete := by { intro x, cases x; simp }
}

-- Exercise 11b page 55
example  : (People11 ≃ bool) → false :=
begin
suffices cards : card People11 ≠ card bool,
{ intros h,
  exact cards (card_congr h)
},

{ change 3 ≠ 2, finish,}
end

-- Exercise 1 page 66
example :
 (λ x: ℝ, 2 * x) ∘ (λ x: ℝ, 1/2 * x) = id
 ∧
 (λ x: ℝ, 1/2 * x) ∘ (λ x: ℝ, 2 * x) = id :=
begin
split;
{ funext,
  simp,
  ring}
end

-- Exercise 2 page 66

inductive OddEven : Type
| odd | even

def add_odd_even : OddEven → OddEven → OddEven
| OddEven.odd OddEven.odd := OddEven.even
| OddEven.even OddEven.even := OddEven.even
| OddEven.odd OddEven.even := OddEven.odd
| OddEven.even OddEven.odd := OddEven.odd

inductive PosNeg : Type
| pos | neg

def mul_pos_neg : PosNeg → PosNeg → PosNeg
| PosNeg.pos PosNeg.pos := PosNeg.pos
| PosNeg.neg PosNeg.neg := PosNeg.pos
| PosNeg.pos PosNeg.neg := PosNeg.neg
| PosNeg.neg PosNeg.pos := PosNeg.neg

open magma

instance magma_oddeven: magma OddEven := {mul := add_odd_even}
instance magma_posneg: magma PosNeg := {mul := mul_pos_neg}

def OddEvenMagma : Magma := bundled.of OddEven
def PosNegMagma : Magma := bundled.of PosNeg

def oddeven2posneg : OddEven -> PosNeg
| OddEven.odd := PosNeg.neg
| OddEven.even := PosNeg.pos

def posneg2oddeven : PosNeg -> OddEven
| PosNeg.neg := OddEven.odd
| PosNeg.pos := OddEven.even

def oe2pn :  OddEvenMagma ⟶ PosNegMagma :=
{ to_fun := oddeven2posneg,
  preserves :=  λ x y, by {cases x; cases y; refl} }

def pn2oe :  PosNegMagma ⟶ OddEvenMagma :=
{ to_fun := posneg2oddeven,
  preserves :=  λ x y, by {cases x; cases y; refl} }

example : OddEvenMagma ≅ PosNegMagma :=
begin
    refine ⟨oe2pn, pn2oe, _, _ ⟩ ;
    { apply magma_hom_ext, intros x, cases x; refl}
end

-- Exercise 3 page 70

instance r_plus_magma_alpha_has_neg : has_neg r_plus_Magma.α :=  {
    neg := by {
        intros x,
        have isR : r_plus_Magma.α = ℝ, refl,
        rw isR at *,
        exact -x,
    }
}

def rplus_negate : r_plus_Magma ⟶ r_plus_Magma :=
{to_fun := has_neg.neg,
 preserves := by {
    intros x y,
    have isR : r_plus_Magma.α = ℝ, refl,
    rw isR at *,
    have isP : r_plus_Magma.str.mul = real.has_add.add, refl,
    rw isP,
    norm_num,
    rw add_comm,
 }
}

lemma rplus_negate_iso : rplus_negate ≫ rplus_negate = 𝟙 r_plus_Magma :=
begin
unfold rplus_negate category_struct.comp magma_hom_comp category_struct.id magma_id,
simp,
apply magma_hom_ext,
intros x,
have isR : r_plus_Magma.α = ℝ, refl,
rw isR at *,
simp,
rw neg_neg,
end

-- Exercise 1a page 70
example (A B C: Type) (f: A ⟶ B) (g: B ⟶ C) (a1 a2 : unit ⟶ A) :
a1 ≫ f = a2 ≫ f → a1 ≫ f ≫ g = a2 ≫ f ≫ g :=
begin
    intros h ,
    rw ← category.assoc,
    rw h,
    simp,
end

-- Exercise 2 page 71
example (A B C: Type) (f: A ⟶ B) (g: B ⟶ C) (h: A ⟶ C) (hcomp: h = f ≫ g):
∀ a : unit ⟶ A, ∃ b : unit ⟶ B, a ≫ f ≫ g = b ≫ g :=
begin
intros a,
exact ⟨ a ≫ f, by simp ⟩
end

def aba (A : Type u) (B : Type u) : Prop := nonempty (A ⟶ B)
def has_point (A : Type u) : Prop := nonempty (unit → A)

local infix <| := aba

-- Exercise 1 page 99
example {A : Type*} {B : Type*}  (h: ¬ (has_point A ∧  ¬ has_point B)) : A <| B :=
begin
push_neg at h,
by_cases has:has_point A,
    exact ⟨ λ _, (h has).some unit.star ⟩,
    exact ⟨ λ a, false.elim (has ⟨λ _, a⟩) ⟩
end

-- Exercise 1 page 99 (another approach)
example(A B : Type*)[category Type*] (h: ¬(has_point A ∧ ¬ has_point B )) : A <| B:=
begin
    push_neg at h,
    use  λ (a), (h(nonempty.intro (λ(x),a))).some unit.star,
end

def retractable (A : C) (B : C) := ∃ (s : A ⟶ B) (r : B ⟶ A), s ≫ r = 𝟙 A

infix ` ≤R `:50 := retractable

-- Exercise 2R page 100
example : A ≤R A := ⟨ 𝟙 A, 𝟙 A, category.id_comp _⟩

-- Exercise 2T page 100
example : A ≤R B → B ≤R D → A ≤R D :=
begin
intros ab bd,
rcases ab with ⟨abs, abr, hab⟩,
rcases bd with ⟨bds, bdr, hbd⟩,
use abs ≫ bds,
use bdr ≫ abr,
calc (abs ≫ bds) ≫ bdr ≫ abr = abs ≫ (bds ≫ bdr) ≫ abr : by simp
... = 𝟙 A : by simp [hab, hbd],
end

structure splitting {B: C} (e : B ⟶ B) [idempotent e] :=
(From: C)
(s : From ⟶ B)
(r : B ⟶ From)
(ret: is_retraction s r)
(is_idem: r ≫ s = e)

-- Exercise 3 page 102
lemma two_splittings_iso (e : B ⟶ B) [idempotent e]
(sp: splitting e) (sp': splitting e) : sp.From ≅ sp'.From :=
begin
rcases sp with  ⟨A,  s,  r,  ret,  is_idem ⟩,
rcases sp' with ⟨A', s', r', ret', is_idem'⟩,
unfold is_retraction at ret ret',

let f  : A  ⟶ A' := s ≫ e ≫ r',
let f' : A' ⟶ A := s' ≫ e ≫ r,

have id1 : f ≫ f' = 𝟙 A,
    {
        calc f ≫ f' = s ≫ e ≫ (r' ≫ s') ≫ e ≫ r : by simp
        ... = s ≫ e ≫ e ≫ e ≫ r : by rw is_idem'
        ... = s ≫ (e ≫ e) ≫ e ≫ r : by simp
        ... = s ≫ e ≫ e ≫ r : by simp [idempotent.repeat]
        ... = s ≫ (e ≫ e) ≫ r : by simp
        ... = s ≫ e ≫ r : by rw idempotent.repeat
        ... = s ≫ r ≫ s ≫ r : by {rw ← is_idem, simp}
        ... = 𝟙 A : by simp [ret]
    },

have id2 : f' ≫ f = 𝟙 A',
    {
        calc f' ≫ f = s' ≫ e ≫ r ≫ s ≫ e ≫ r' : by simp
        ... = s' ≫ e ≫ (r ≫ s) ≫ e ≫ r' : by simp
        ... = s' ≫ e ≫ e ≫ e ≫ r' : by rw is_idem
        ... = s' ≫ (e ≫ e) ≫ e ≫ r' : by simp
        ... = s' ≫ e ≫ e ≫ r' : by rw idempotent.repeat
        ... = s' ≫ (e ≫ e) ≫ r' : by simp
        ... = s' ≫ e ≫ r' : by rw idempotent.repeat
        ... = s' ≫ r' ≫ s' ≫ r' : by {rw ← is_idem', simp}
        ... = 𝟙 A' : by simp [ret']
    },

exact ⟨f, f'⟩
end

-- Exercise 2 page 108
example  (p : A ⟶ B) (q : B ⟶ A) (h: p ≫ q ≫ p = p) : idempotent (p ≫ q) :=
begin
split,
calc (p ≫ q) ≫ p ≫ q = (p ≫ q ≫ p) ≫ q : by simp
    ... = p ≫ q : by rw h
end

example  (p : A ⟶ B) (q : B ⟶ A) (h: p ≫ q ≫ p = p) : idempotent (q ≫ p) :=
begin
split,
calc (q ≫ p) ≫ q ≫ p = q ≫ (p ≫ q ≫ p) : by simp
    ... = q ≫ p : by rw h
end

-- Exercise 2* page 108
example  (p : A ⟶ B) (q : B ⟶ A) (h: p ≫ q ≫ p = p) :
∃ (q' : B ⟶ A), (p ≫ q' ≫ p = p)  ∧  (q' ≫ p ≫ q' = q') :=
begin
use q ≫ p ≫ q,
split,

    calc p ≫ (q ≫ p ≫ q) ≫ p = (p ≫ q ≫ p) ≫ q ≫ p : by simp
        ... = p : by rw [h, h],

    calc (q ≫ p ≫ q) ≫ p ≫ q ≫ p ≫ q = q ≫ (p ≫ q ≫ p) ≫ q ≫ p ≫ q : by simp
        ... = q ≫ p ≫ q ≫ p ≫ q : by rw h
        ... = q ≫ (p ≫ q ≫ p) ≫ q : by simp
        ... = q ≫ p ≫ q : by rw h
end

-- Exercise 1* page 108
def inclusionNZ : ℕ ⟶ ℤ := λ n:ℕ, int.of_nat n
def retractionZN : ℤ ⟶ ℕ := λ i:ℤ, int.to_nat i

example : is_retraction inclusionNZ retractionZN :=
begin
unfold is_retraction,
unfold inclusionNZ,
unfold retractionZN,
funext,
simp
end

example (f : ℤ ⟶ ℕ): ¬ is_retraction f inclusionNZ :=
begin
unfold is_retraction,
intros h,
rewrite [types_id, types_comp] at h,
have neg : id (-5 : ℤ) < 0 , by norm_num,
have isnat : f (-5) >= 0, by {apply zero_le},
have pos : (inclusionNZ ∘ f) (-5) >= 0, by simp [isnat],

rw h at pos,
linarith,
end

-- Exercise 2 page 126
lemma fp_of_retraction_fp
    {T : C} {s : A ⟶ X} {r : X ⟶ A} (ret : is_retraction s r)
    (h : ∀ (f : X ⟶ X), ∃ (x : T ⟶ X), x ≫ f = x) :
    ∀ (g : A ⟶ A), ∃ (x : T ⟶ A), x ≫ g = x :=
begin
    intros g,
    cases h (r ≫ g ≫ s) with x hx,
    use x ≫ r,
    unfold is_retraction at ret,
    calc (x ≫ r) ≫ g = x ≫ r ≫ g ≫ 𝟙 A : by {simp}
        ... = x ≫ r ≫ g ≫ (s ≫ r) : by {rw ret,}
        ... = (x ≫ r ≫ g ≫ s) ≫ r : by simp
        ... = x ≫ r : by rw hx,
end

-- Exercise 3 page 126
namespace ex3_page126
section wrap

parameters (CC : Type*) [category CC]
parameters (Circle Disk Term : CC)

parameter antipodal : (Circle ⟶ Circle)
parameter j : (Circle ⟶ Disk)
-- Notice, no axioms on j, so it's arbitrary, not a real inclusion

-- axioms
lemma antipodal_no_fp : ¬ ∃ (x : Term ⟶ Circle), x ≫ antipodal = x  := sorry
lemma has_fp : ∀ (f : Disk ⟶ Disk), ∃ (x : Term ⟶ Disk), x ≫ f = x  := sorry

include Term
include antipodal
example : ¬ ∃ (r : Disk ⟶ Circle), is_retraction j r :=
begin
    by_contradiction contra,
    cases contra with r ret,
    have exist_fp := fp_of_retraction_fp Circle Disk ret (has_fp CC Disk Term) antipodal,
    have not_exist_fp := antipodal_no_fp CC Circle Term antipodal,
    exact not_exist_fp exist_fp,
end
end wrap
end ex3_page126

end exercises


/-
Copyright (c) 2018 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Johannes Hölzl, Reid Barton, Sean Leather

! This file was ported from Lean 3 source module category_theory.concrete_category.bundled
! leanprover-community/mathlib commit 448144f7ae193a8990cb7473c9e9a01990f64ac7
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Tactic.Lint.Default

/-!
# Bundled types

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

`bundled c` provides a uniform structure for bundling a type equipped with a type class.

We provide `category` instances for these in `category_theory/unbundled_hom.lean`
(for categories with unbundled homs, e.g. topological spaces)
and in `category_theory/bundled_hom.lean` (for categories with bundled homs, e.g. monoids).
-/

universe u v

namespace CategoryTheory

variable {c d : Type u → Type v} {α : Type u}

#print CategoryTheory.Bundled /-
/-- `bundled` is a type bundled with a type class instance for that type. Only
the type class is exposed as a parameter. -/
@[nolint has_nonempty_instance]
structure Bundled (c : Type u → Type v) : Type max (u + 1) v where
  α : Type u
  str : c α := by infer_instance
#align category_theory.bundled CategoryTheory.Bundled
-/

namespace Bundled

#print CategoryTheory.Bundled.of /-
-- Usually explicit instances will provide their own version of this, e.g. `Mon.of` and `Top.of`.
/-- A generic function for lifting a type equipped with an instance to a bundled object. -/
def of {c : Type u → Type v} (α : Type u) [str : c α] : Bundled c :=
  ⟨α, str⟩
#align category_theory.bundled.of CategoryTheory.Bundled.of
-/

instance : CoeSort (Bundled c) (Type u) :=
  ⟨Bundled.α⟩

#print CategoryTheory.Bundled.coe_mk /-
@[simp]
theorem coe_mk (α) (str) : (@Bundled.mk c α str : Type u) = α :=
  rfl
#align category_theory.bundled.coe_mk CategoryTheory.Bundled.coe_mk
-/

#print CategoryTheory.Bundled.map /-
/-
`bundled.map` is reducible so that, if we define a category

  def Ring : Type (u+1) := induced_category SemiRing (bundled.map @ring.to_semiring)

instance search is able to "see" that a morphism R ⟶ S in Ring is really
a (semi)ring homomorphism from R.α to S.α, and not merely from
`(bundled.map @ring.to_semiring R).α` to `(bundled.map @ring.to_semiring S).α`.
-/
/-- Map over the bundled structure -/
@[reducible]
def map (f : ∀ {α}, c α → d α) (b : Bundled c) : Bundled d :=
  ⟨b, f b.str⟩
#align category_theory.bundled.map CategoryTheory.Bundled.map
-/

end Bundled

end CategoryTheory


import algebra
import algebra.group
import algebra.group.defs
import logic.relation
import order.lexicographic
import declare

instance fin.has_top (k : ℕ) : has_top (fin k.succ) := ⟨k⟩
-- todo instance i2 : linear_order unit := sorry
-- instance i2 (k : ℕ) : linear_order (fin k) := infer_instance
-- instance i3 {α β: Type*} [linear_order α] [linear_order β] : linear_order (lex α β) := infer_instance

universes u v
variables (α β : Type*)

def emit_type (I V : Type*) := option (I × option V)

structure iter (σ I V : Type*) :=
  (δ : function.End σ)
  (emit : σ → emit_type I V)

def_declare one := "variables {σ I V : Type} [linear_order I] (a : iter σ I V)"
def_declare two := "variables {σ₁ σ₂ I I₁ I₂ V V₁ V₂ V₃ : Type} [linear_order I] [linear_order I₁] [linear_order I₂] (a : iter σ₁ I V₁) (b : iter σ₂ I V₂)"
def_declare add := "variables (add : V₁ → V₂ → V₃) [has_zero V₁] [has_zero V₂] [has_zero V₃]"
def_declare mul := "variables (mul : V₁ → V₂ → V₃)"

namespace iter

section params_unary
variables {σ I V : Type} (a : iter σ I V) (s t : σ)

def ι : with_top I := match a.emit s with | none := none | some (i, _) := some i end
def ν :   option V := match a.emit s with | none := none | some (_, v) := v end
--def ν :   option V := option.bind (a.emit s) prod.snd

section semantics
variables [add_monoid V] [decidable_eq I]

def elementary (i : I) (v : V) := λ j, if i = j then v else 0

@[simp] def semantics₁ (s : σ) : I → V :=
  match a.emit s with
  | none := 0
  | some (i, none) := 0
  | some (i, some v) := elementary i v
  end

@[simp] def semantics : σ → ℕ → I → V
| _ 0 := 0
| s (n+1) := a.semantics₁ s + semantics (a.δ s) n

--notation `⟦` a, s `⟧` := a.semantics s
notation `⟦` a, s, j `⟧` := a.semantics s j
--example (j : ℕ) : ∀ i:I, ⟦a, s, j⟧ i = ⟦a, s⟧ j i := λ _, rfl

end semantics

variables [linear_order I]

def reachable := relation.refl_trans_gen (λ s t, t = a.δ s)

namespace transition -- can't use reachable??
open relation.refl_trans_gen
theorem trans {x y z : σ} : reachable a x y → reachable a y z → reachable a x z := trans
def step {x : σ} : reachable a x (a.δ x) := single rfl
end transition

theorem none_top {α : Type*} [linear_order α] : ∀ {i : with_top α}, ⊤ ≤ i → i = none | _ h := le_antisymm le_top h

def step       (s : σ) (i:ℕ) := a.δ^i • s
def monotonic          := ∀ (s t : σ), a.reachable s t → a.ι s ≤ a.ι t
def terminal   (s : σ) := a.ι s = ⊤
def finite     (s : σ) := ∃ (t : σ), reachable a s t ∧ terminal a t
def productive (s : σ) := ν a s ≠ none
def reduced    (s : σ) := ∀ (t t' : σ), a.reachable s t → a.reachable s t' →
  productive a t → productive a t' → ι a t = ι a t' → t = t'

def future (s : σ) : set σ := { t | reachable a s t ∧ ¬ terminal a t}
@[simp] def terminal_by (s : σ) (i : ℕ) := a.terminal (a.step s i)

instance [decidable_eq I] : decidable (terminal a s) := if h : ι a s = none then is_true h else is_false h

lemma some_not_terminal {a : iter σ I V} {s} {i : I} : a.ι s = some i → ¬ a.terminal s :=
λ h1 h2, false.rec _ (option.some_ne_none i (h1 ▸ h2))

open relation.refl_trans_gen
def path_of_index {a : iter σ I V} : ∀ (i:ℕ), a.reachable s (a.step s i)
| 0 := refl
| (n+1) := tail (path_of_index n) rfl

lemma le_of_index_lt {a : iter σ I V} (i j : ℕ) : a.monotonic → i ≤ j → a.ι ((a.δ^i)•s) ≤ a.ι ((a.δ^j) • s) := begin
  intros mono lt, apply mono, induction lt, exact refl, exact tail ‹_› rfl,
end
lemma index_lt_of_ge {a : iter σ I V} (i j : ℕ) : a.monotonic → a.ι ((a.δ^i)•s) < a.ι ((a.δ^j)•s) → i < j := λ mono, begin
have h := mt (le_of_index_lt s j i mono),
simpa using h,
end

@[simp] lemma step_zero : a.step s 0 = s := rfl
@[simp] lemma step_succ (s : σ) (i : ℕ) : a.step s i.succ = a.step (a.δ s) i :=
begin
change a.δ ^ (i+1) • s = a.δ ^ i • a.δ^1 • s,
rw [pow_add, mul_smul],
end

lemma not_terminal_succ {a : iter σ I V} {i : ℕ} {s} : ¬ a.terminal s → a.terminal_by s i → ∃ i':ℕ, i = i'.succ := begin
intros hnt ht, induction i with i hi,
exact false.rec _ (hnt ht),
exact ⟨i, rfl⟩,
end

lemma index_of_path {a : iter σ I V} {s t} : a.reachable s t → ∃ (i: ℕ), t = a.step s i := begin
  intros p, induction p, refine ⟨0 , _⟩, refl,
  case tail : s1 s2 path st h {
    cases h with i hh, refine ⟨i+1, _⟩,
    simp only [step] at *,
    rw [add_comm, pow_add, mul_smul, ← hh], exact st,
  }
end

section lemmas

lemma ι_top_emit_none {a : iter σ I V} {s} : a.ι s = ⊤ ↔ a.emit s = none := begin
split; intro h1,
{ cases h : a.emit s, exact rfl,
  cases val,
  simp only [ι, h] at h1,
  exfalso, apply option.some_ne_none _ h1 },
{ simp only [ι, h1], refl },
end

@[simp]
theorem terminal_succ_terminal {a : iter σ I V} (m : a.monotonic) (h : a.terminal t) : a.terminal (a.δ t) :=
begin
simp only [terminal] at *, apply none_top, rw ←h, exact m _ _ (transition.step _)
end

@[simp]
theorem emit_none_of_terminal {a : iter σ I V} {t} : a.terminal t → a.emit t = none := begin
intro h, simp only [terminal] at h, exact ι_top_emit_none.1 h,
end

end lemmas
end params_unary
end iter

structure stream (σ I V : Type*) :=
  (q : σ)
  (iter : iter σ I V)

namespace stream
variables {σ I V : Type} (s : stream σ I V)

@[simp] def ι := s.iter.ι s.q
@[simp] def ν := s.iter.ν s.q

@[simp] def δ (s : stream σ I V) : stream σ I V :=
{ q := s.iter.δ s.q .. s}

@[simp] def emit : emit_type I V := s.iter.emit s.q

variables [decidable_eq I]

@[simp] def semantics₁ [add_monoid V] (s : stream σ I V) : I → V
:= s.iter.semantics₁ s.q
-- simp?
@[simp] def semantics [add_monoid V] (s : stream σ I V) : ℕ → I → V
:= s.iter.semantics s.q
notation `⟦` s, i `⟧` := s.semantics i

variables [linear_order I]

@[simp] def terminal_by (i : ℕ) := s.iter.terminal_by s.q i

@[simp] def monotonic := s.iter.monotonic

end stream


import hilbert.wr.dc

namespace clfrags
    namespace hilbert
        namespace wr
            namespace dc

                theorem dc₄' {a b c : Prop} (h₁ : dc a b c) : dc b a c :=
                    have h₂ : dc (dc b a c) (dc a b c) (dc a b c), from dc₃ h₁,
                    have h₃ : dc (dc a b c) (dc b a c) (dc b a c), from dc₄ h₂,
                    show dc b a c, from dc₂ h₃

                theorem dc₅' {a b c : Prop} (h₁ : dc a b c) : dc a c b :=
                    have h₂ : dc (dc a c b) (dc a b c) (dc a b c), from dc₃ h₁,
                    have h₃ : dc (dc a b c) (dc a c b) (dc a c b), from dc₅ h₂,
                    show dc a c b, from dc₂ h₃

                theorem dc₆' {a b c d e : Prop}
                    (h₁ : dc d e (dc a b c)) : dc (dc d e a) (dc d e b) c :=
                    let f := dc d e (dc a b c), g := dc (dc d e a) (dc d e b) c in
                        have h₂ : dc g f f, from dc₃ h₁,
                        have h₃ : dc g f g, from dc₆ h₂,
                        have h₄ : dc f g g, from dc₄' h₃,
                        show g, from dc₂ h₄

                theorem dc₇' {a b c d e : Prop}
                    (h₁ : dc (dc d e a) (dc d e b) c) : dc d e (dc a b c) :=
                    let f := dc d e (dc a b c), g := dc (dc d e a) (dc d e b) c in
                        have h₂ : dc f g g, from dc₃ h₁,
                        have h₃ : dc f g f, from dc₇ h₂,
                        have h₄ : dc g f f, from dc₄' h₃,
                        show f, from dc₂ h₄

                theorem dc₁_dc {a b c d e : Prop} (h₁ : dc d e a) (h₂ : dc d e b) :
                    dc d e (dc a b c) :=
                    have h₂ : dc (dc d e a) (dc d e b) c, from dc₁ h₁ h₂,
                    show dc d e (dc a b c), from dc₇' h₂

                theorem dc₂_dc {a b c d : Prop} (h₁ : dc c d (dc b a a)) : dc c d a :=
                    have h₂ : dc d c (dc a b a), from dc₄ h₁,
                    have h₃ : dc c d (dc a a b), from dc₅ h₂,
                    have h₄ : dc (dc c d a) (dc c d a) b, from dc₆' h₃,
                    have h₅ : dc b (dc c d a) (dc c d a), from dc₄' (dc₅' h₄),
                    show dc c d a, from dc₂ h₅

                theorem dc₃_dc {a b c d : Prop} (h₁ : dc c d a) : dc c d (dc b a a) :=
                    have h₂ : dc b (dc c d a) (dc c d a), from dc₃ h₁,
                    have h₃ : dc (dc c d a) (dc c d a) b, from dc₅' (dc₄' h₂),
                    have h₄ : dc c d (dc a a b), from dc₇' h₃,
                    have h₅ : dc d c (dc a b a), from dc₅ h₄,
                    show dc c d (dc b a a), from dc₄ h₅

                theorem dc₄_dc {a b c d e f g : Prop} (h₁ : dc f g (dc d e (dc a b c))) :
                    dc f g (dc e d (dc b a c)) :=
                    have h₂ : dc g f (dc e d (dc a b c)), from dc₄ h₁,
                    have h₃ : dc g f (dc (dc e d a) (dc e d b) c), from dc₆ h₂,
                    have h₄ : dc f g (dc (dc e d b) (dc e d a) c), from dc₄ h₃,
                    show dc f g (dc e d (dc b a c)), from dc₇ h₄

                theorem dc₅_dc {a b c d e f g : Prop} (h₁ : dc f g (dc d e (dc a b c))) :
                    dc f g (dc e d (dc a c b)) :=
                    have h₂ : dc g f (dc e d (dc a b c)), from dc₄ h₁,
                    have h₃ : dc (dc g f e) (dc g f d) (dc a b c), from dc₆' h₂,
                    have h₄ : dc (dc g f d) (dc g f e) (dc a c b), from dc₅ h₃,
                    have h₅ : dc g f (dc d e (dc a c b)), from dc₇' h₄,
                    show dc f g (dc e d (dc a c b)), from dc₄ h₅

                theorem dc₆_dc {a b c d e f g h i : Prop}
                    (h₁ : dc h i (dc f g (dc d e (dc a b c))))
                    : dc h i (dc f g (dc (dc d e a) (dc d e b) c)) :=
                    have h₂ : dc (dc h i f) (dc h i g) (dc d e (dc a b c)), from dc₆' h₁,
                    have h₃ : dc (dc h i f) (dc h i g) (dc (dc d e a) (dc d e b) c), from dc₆ h₂,
                    show dc h i (dc f g (dc (dc d e a) (dc d e b) c)), from dc₇' h₃

                theorem dc₇_dc {a b c d e f g h i : Prop}
                    (h₁ : dc h i (dc f g (dc (dc d e a) (dc d e b) c))) :
                    dc h i (dc f g (dc d e (dc a b c))) :=
                    have h₂ : dc (dc h i f) (dc h i g) (dc (dc d e a) (dc d e b) c), from dc₆' h₁,
                    have h₃ : dc (dc h i f) (dc h i g) (dc d e (dc a b c)), from dc₇ h₂,
                    show dc h i (dc f g (dc d e (dc a b c))), from dc₇' h₃

            end dc
        end wr
    end hilbert
end clfrags


example (P Q : Type) (p : P) (h : P → Q) : Q :=
begin
exact h(p),
end


/-
Copyright (c) 2017 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Mario Carneiro
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.seq.seq
import Mathlib.Lean3Lib.data.dlist
import Mathlib.PostPort

universes u_1 u v w

namespace Mathlib

/-
coinductive wseq (α : Type u) : Type u
| nil : wseq α
| cons : α → wseq α → wseq α
| think : wseq α → wseq α
-/

/-- Weak sequences.

  While the `seq` structure allows for lists which may not be finite,
  a weak sequence also allows the computation of each element to
  involve an indeterminate amount of computation, including possibly
  an infinite loop. This is represented as a regular `seq` interspersed
  with `none` elements to indicate that computation is ongoing.

  This model is appropriate for Haskell style lazy lists, and is closed
  under most interesting computation patterns on infinite lists,
  but conversely it is difficult to extract elements from it. -/
def wseq (α : Type u_1) := seq (Option α)

namespace wseq

/-- Turn a sequence into a weak sequence -/
def of_seq {α : Type u} : seq α → wseq α := Functor.map some

/-- Turn a list into a weak sequence -/
def of_list {α : Type u} (l : List α) : wseq α := of_seq ↑l

/-- Turn a stream into a weak sequence -/
def of_stream {α : Type u} (l : stream α) : wseq α := of_seq ↑l

protected instance coe_seq {α : Type u} : has_coe (seq α) (wseq α) := has_coe.mk of_seq

protected instance coe_list {α : Type u} : has_coe (List α) (wseq α) := has_coe.mk of_list

protected instance coe_stream {α : Type u} : has_coe (stream α) (wseq α) := has_coe.mk of_stream

/-- The empty weak sequence -/
def nil {α : Type u} : wseq α := seq.nil

protected instance inhabited {α : Type u} : Inhabited (wseq α) := { default := nil }

/-- Prepend an element to a weak sequence -/
def cons {α : Type u} (a : α) : wseq α → wseq α := seq.cons (some a)

/-- Compute for one tick, without producing any elements -/
def think {α : Type u} : wseq α → wseq α := seq.cons none

/-- Destruct a weak sequence, to (eventually possibly) produce either
  `none` for `nil` or `some (a, s)` if an element is produced. -/
def destruct {α : Type u} : wseq α → computation (Option (α × wseq α)) :=
  computation.corec fun (s : wseq α) => sorry

def cases_on {α : Type u} {C : wseq α → Sort v} (s : wseq α) (h1 : C nil)
    (h2 : (x : α) → (s : wseq α) → C (cons x s)) (h3 : (s : wseq α) → C (think s)) : C s :=
  seq.cases_on s h1 fun (o : Option α) => option.cases_on o h3 h2

protected def mem {α : Type u} (a : α) (s : wseq α) := seq.mem (some a) s

protected instance has_mem {α : Type u} : has_mem α (wseq α) := has_mem.mk wseq.mem

theorem not_mem_nil {α : Type u} (a : α) : ¬a ∈ nil := seq.not_mem_nil ↑a

/-- Get the head of a weak sequence. This involves a possibly
  infinite computation. -/
def head {α : Type u} (s : wseq α) : computation (Option α) :=
  computation.map (Functor.map prod.fst) (destruct s)

/-- Encode a computation yielding a weak sequence into additional
  `think` constructors in a weak sequence -/
def flatten {α : Type u} : computation (wseq α) → wseq α :=
  seq.corec fun (c : computation (wseq α)) => sorry

/-- Get the tail of a weak sequence. This doesn't need a `computation`
  wrapper, unlike `head`, because `flatten` allows us to hide this
  in the construction of the weak sequence itself. -/
def tail {α : Type u} (s : wseq α) : wseq α :=
  flatten ((fun (o : Option (α × wseq α)) => option.rec_on o nil prod.snd) <$> destruct s)

/-- drop the first `n` elements from `s`. -/
@[simp] def drop {α : Type u} (s : wseq α) : ℕ → wseq α := sorry

/-- Get the nth element of `s`. -/
def nth {α : Type u} (s : wseq α) (n : ℕ) : computation (Option α) := head (drop s n)

/-- Convert `s` to a list (if it is finite and completes in finite time). -/
def to_list {α : Type u} (s : wseq α) : computation (List α) :=
  computation.corec (fun (_x : List α × wseq α) => sorry) ([], s)

/-- Get the length of `s` (if it is finite and completes in finite time). -/
def length {α : Type u} (s : wseq α) : computation ℕ :=
  computation.corec (fun (_x : ℕ × wseq α) => sorry) (0, s)

/-- A weak sequence is finite if `to_list s` terminates. Equivalently,
  it is a finite number of `think` and `cons` applied to `nil`. -/
def is_finite {α : Type u} (s : wseq α) := computation.terminates (to_list s)

protected instance to_list_terminates {α : Type u} (s : wseq α) [h : is_finite s] :
    computation.terminates (to_list s) :=
  h

/-- Get the list corresponding to a finite weak sequence. -/
def get {α : Type u} (s : wseq α) [is_finite s] : List α := computation.get (to_list s)

/-- A weak sequence is *productive* if it never stalls forever - there are
 always a finite number of `think`s between `cons` constructors.
 The sequence itself is allowed to be infinite though. -/
def productive {α : Type u} (s : wseq α) := ∀ (n : ℕ), computation.terminates (nth s n)

protected instance nth_terminates {α : Type u} (s : wseq α) [h : productive s] (n : ℕ) :
    computation.terminates (nth s n) :=
  h

protected instance head_terminates {α : Type u} (s : wseq α) [h : productive s] :
    computation.terminates (head s) :=
  h 0

/-- Replace the `n`th element of `s` with `a`. -/
def update_nth {α : Type u} (s : wseq α) (n : ℕ) (a : α) : wseq α :=
  seq.corec (fun (_x : ℕ × wseq α) => sorry) (n + 1, s)

/-- Remove the `n`th element of `s`. -/
def remove_nth {α : Type u} (s : wseq α) (n : ℕ) : wseq α :=
  seq.corec (fun (_x : ℕ × wseq α) => sorry) (n + 1, s)

/-- Map the elements of `s` over `f`, removing any values that yield `none`. -/
def filter_map {α : Type u} {β : Type v} (f : α → Option β) : wseq α → wseq β :=
  seq.corec fun (s : wseq α) => sorry

/-- Select the elements of `s` that satisfy `p`. -/
def filter {α : Type u} (p : α → Prop) [decidable_pred p] : wseq α → wseq α :=
  filter_map fun (a : α) => ite (p a) (some a) none

-- example of infinite list manipulations

/-- Get the first element of `s` satisfying `p`. -/
def find {α : Type u} (p : α → Prop) [decidable_pred p] (s : wseq α) : computation (Option α) :=
  head (filter p s)

/-- Zip a function over two weak sequences -/
def zip_with {α : Type u} {β : Type v} {γ : Type w} (f : α → β → γ) (s1 : wseq α) (s2 : wseq β) :
    wseq γ :=
  seq.corec (fun (_x : wseq α × wseq β) => sorry) (s1, s2)

/-- Zip two weak sequences into a single sequence of pairs -/
def zip {α : Type u} {β : Type v} : wseq α → wseq β → wseq (α × β) := zip_with Prod.mk

/-- Get the list of indexes of elements of `s` satisfying `p` -/
def find_indexes {α : Type u} (p : α → Prop) [decidable_pred p] (s : wseq α) : wseq ℕ :=
  filter_map (fun (_x : α × ℕ) => sorry) (zip s ↑stream.nats)

/-- Get the index of the first element of `s` satisfying `p` -/
def find_index {α : Type u} (p : α → Prop) [decidable_pred p] (s : wseq α) : computation ℕ :=
  (fun (o : Option ℕ) => option.get_or_else o 0) <$> head (find_indexes p s)

/-- Get the index of the first occurrence of `a` in `s` -/
def index_of {α : Type u} [DecidableEq α] (a : α) : wseq α → computation ℕ := find_index (Eq a)

/-- Get the indexes of occurrences of `a` in `s` -/
def indexes_of {α : Type u} [DecidableEq α] (a : α) : wseq α → wseq ℕ := find_indexes (Eq a)

/-- `union s1 s2` is a weak sequence which interleaves `s1` and `s2` in
  some order (nondeterministically). -/
def union {α : Type u} (s1 : wseq α) (s2 : wseq α) : wseq α :=
  seq.corec (fun (_x : wseq α × wseq α) => sorry) (s1, s2)

/-- Returns `tt` if `s` is `nil` and `ff` if `s` has an element -/
def is_empty {α : Type u} (s : wseq α) : computation Bool := computation.map option.is_none (head s)

/-- Calculate one step of computation -/
def compute {α : Type u} (s : wseq α) : wseq α := sorry

/-- Get the first `n` elements of a weak sequence -/
def take {α : Type u} (s : wseq α) (n : ℕ) : wseq α :=
  seq.corec (fun (_x : ℕ × wseq α) => sorry) (n, s)

/-- Split the sequence at position `n` into a finite initial segment
  and the weak sequence tail -/
def split_at {α : Type u} (s : wseq α) (n : ℕ) : computation (List α × wseq α) :=
  computation.corec (fun (_x : ℕ × List α × wseq α) => sorry) (n, [], s)

/-- Returns `tt` if any element of `s` satisfies `p` -/
def any {α : Type u} (s : wseq α) (p : α → Bool) : computation Bool :=
  computation.corec (fun (s : wseq α) => sorry) s

/-- Returns `tt` if every element of `s` satisfies `p` -/
def all {α : Type u} (s : wseq α) (p : α → Bool) : computation Bool :=
  computation.corec (fun (s : wseq α) => sorry) s

/-- Apply a function to the elements of the sequence to produce a sequence
  of partial results. (There is no `scanr` because this would require
  working from the end of the sequence, which may not exist.) -/
def scanl {α : Type u} {β : Type v} (f : α → β → α) (a : α) (s : wseq β) : wseq α :=
  cons a (seq.corec (fun (_x : α × wseq β) => sorry) (a, s))

/-- Get the weak sequence of initial segments of the input sequence -/
def inits {α : Type u} (s : wseq α) : wseq (List α) :=
  cons [] (seq.corec (fun (_x : dlist α × wseq α) => sorry) (dlist.empty, s))

/-- Like take, but does not wait for a result. Calculates `n` steps of
  computation and returns the sequence computed so far -/
def collect {α : Type u} (s : wseq α) (n : ℕ) : List α := list.filter_map id (seq.take n s)

/-- Append two weak sequences. As with `seq.append`, this may not use
  the second sequence if the first one takes forever to compute -/
def append {α : Type u} : wseq α → wseq α → wseq α := seq.append

/-- Map a function over a weak sequence -/
def map {α : Type u} {β : Type v} (f : α → β) : wseq α → wseq β := seq.map (option.map f)

/-- Flatten a sequence of weak sequences. (Note that this allows
  empty sequences, unlike `seq.join`.) -/
def join {α : Type u} (S : wseq (wseq α)) : wseq α :=
  seq.join ((fun (o : Option (wseq α)) => sorry) <$> S)

/-- Monadic bind operator for weak sequences -/
def bind {α : Type u} {β : Type v} (s : wseq α) (f : α → wseq β) : wseq β := join (map f s)

@[simp] def lift_rel_o {α : Type u} {β : Type v} (R : α → β → Prop) (C : wseq α → wseq β → Prop) :
    Option (α × wseq α) → Option (β × wseq β) → Prop :=
  sorry

theorem lift_rel_o.imp {α : Type u} {β : Type v} {R : α → β → Prop} {S : α → β → Prop}
    {C : wseq α → wseq β → Prop} {D : wseq α → wseq β → Prop}
    (H1 : ∀ (a : α) (b : β), R a b → S a b) (H2 : ∀ (s : wseq α) (t : wseq β), C s t → D s t)
    {o : Option (α × wseq α)} {p : Option (β × wseq β)} : lift_rel_o R C o p → lift_rel_o S D o p :=
  sorry

theorem lift_rel_o.imp_right {α : Type u} {β : Type v} (R : α → β → Prop)
    {C : wseq α → wseq β → Prop} {D : wseq α → wseq β → Prop}
    (H : ∀ (s : wseq α) (t : wseq β), C s t → D s t) {o : Option (α × wseq α)}
    {p : Option (β × wseq β)} : lift_rel_o R C o p → lift_rel_o R D o p :=
  lift_rel_o.imp (fun (_x : α) (_x_1 : β) => id) H

@[simp] def bisim_o {α : Type u} (R : wseq α → wseq α → Prop) :
    Option (α × wseq α) → Option (α × wseq α) → Prop :=
  lift_rel_o Eq R

theorem bisim_o.imp {α : Type u} {R : wseq α → wseq α → Prop} {S : wseq α → wseq α → Prop}
    (H : ∀ (s t : wseq α), R s t → S s t) {o : Option (α × wseq α)} {p : Option (α × wseq α)} :
    bisim_o R o p → bisim_o S o p :=
  lift_rel_o.imp_right Eq H

/-- Two weak sequences are `lift_rel R` related if they are either both empty,
  or they are both nonempty and the heads are `R` related and the tails are
  `lift_rel R` related. (This is a coinductive definition.) -/
def lift_rel {α : Type u} {β : Type v} (R : α → β → Prop) (s : wseq α) (t : wseq β) :=
  ∃ (C : wseq α → wseq β → Prop),
    C s t ∧
      ∀ {s : wseq α} {t : wseq β},
        C s t → computation.lift_rel (lift_rel_o R C) (destruct s) (destruct t)

/-- If two sequences are equivalent, then they have the same values and
  the same computational behavior (i.e. if one loops forever then so does
  the other), although they may differ in the number of `think`s needed to
  arrive at the answer. -/
def equiv {α : Type u} : wseq α → wseq α → Prop := lift_rel Eq

theorem lift_rel_destruct {α : Type u} {β : Type v} {R : α → β → Prop} {s : wseq α} {t : wseq β} :
    lift_rel R s t → computation.lift_rel (lift_rel_o R (lift_rel R)) (destruct s) (destruct t) :=
  sorry

theorem lift_rel_destruct_iff {α : Type u} {β : Type v} {R : α → β → Prop} {s : wseq α}
    {t : wseq β} :
    lift_rel R s t ↔ computation.lift_rel (lift_rel_o R (lift_rel R)) (destruct s) (destruct t) :=
  sorry

infixl:50 " ~ " => Mathlib.wseq.equiv

theorem destruct_congr {α : Type u} {s : wseq α} {t : wseq α} :
    s ~ t → computation.lift_rel (bisim_o equiv) (destruct s) (destruct t) :=
  lift_rel_destruct

theorem destruct_congr_iff {α : Type u} {s : wseq α} {t : wseq α} :
    s ~ t ↔ computation.lift_rel (bisim_o equiv) (destruct s) (destruct t) :=
  lift_rel_destruct_iff

theorem lift_rel.refl {α : Type u} (R : α → α → Prop) (H : reflexive R) : reflexive (lift_rel R) :=
  sorry

theorem lift_rel_o.swap {α : Type u} {β : Type v} (R : α → β → Prop) (C : wseq α → wseq β → Prop) :
    function.swap (lift_rel_o R C) = lift_rel_o (function.swap R) (function.swap C) :=
  sorry

theorem lift_rel.swap_lem {α : Type u} {β : Type v} {R : α → β → Prop} {s1 : wseq α} {s2 : wseq β}
    (h : lift_rel R s1 s2) : lift_rel (function.swap R) s2 s1 :=
  sorry

theorem lift_rel.swap {α : Type u} {β : Type v} (R : α → β → Prop) :
    function.swap (lift_rel R) = lift_rel (function.swap R) :=
  funext
    fun (x : wseq β) =>
      funext fun (y : wseq α) => propext { mp := lift_rel.swap_lem, mpr := lift_rel.swap_lem }

theorem lift_rel.symm {α : Type u} (R : α → α → Prop) (H : symmetric R) : symmetric (lift_rel R) :=
  sorry

theorem lift_rel.trans {α : Type u} (R : α → α → Prop) (H : transitive R) :
    transitive (lift_rel R) :=
  sorry

theorem lift_rel.equiv {α : Type u} (R : α → α → Prop) : equivalence R → equivalence (lift_rel R) :=
  sorry

theorem equiv.refl {α : Type u} (s : wseq α) : s ~ s := lift_rel.refl Eq Eq.refl

theorem equiv.symm {α : Type u} {s : wseq α} {t : wseq α} : s ~ t → t ~ s :=
  lift_rel.symm Eq Eq.symm

theorem equiv.trans {α : Type u} {s : wseq α} {t : wseq α} {u : wseq α} : s ~ t → t ~ u → s ~ u :=
  lift_rel.trans Eq Eq.trans

theorem equiv.equivalence {α : Type u} : equivalence equiv :=
  { left := equiv.refl, right := { left := equiv.symm, right := equiv.trans } }

@[simp] theorem destruct_nil {α : Type u} : destruct nil = computation.return none :=
  computation.destruct_eq_ret rfl

@[simp] theorem destruct_cons {α : Type u} (a : α) (s : wseq α) :
    destruct (cons a s) = computation.return (some (a, s)) :=
  sorry

@[simp] theorem destruct_think {α : Type u} (s : wseq α) :
    destruct (think s) = computation.think (destruct s) :=
  sorry

@[simp] theorem seq_destruct_nil {α : Type u} : seq.destruct nil = none := seq.destruct_nil

@[simp] theorem seq_destruct_cons {α : Type u} (a : α) (s : wseq α) :
    seq.destruct (cons a s) = some (some a, s) :=
  seq.destruct_cons (some a) s

@[simp] theorem seq_destruct_think {α : Type u} (s : wseq α) :
    seq.destruct (think s) = some (none, s) :=
  seq.destruct_cons none s

@[simp] theorem head_nil {α : Type u} : head nil = computation.return none := sorry

@[simp] theorem head_cons {α : Type u} (a : α) (s : wseq α) :
    head (cons a s) = computation.return (some a) :=
  sorry

@[simp] theorem head_think {α : Type u} (s : wseq α) :
    head (think s) = computation.think (head s) :=
  sorry

@[simp] theorem flatten_ret {α : Type u} (s : wseq α) : flatten (computation.return s) = s := sorry

@[simp] theorem flatten_think {α : Type u} (c : computation (wseq α)) :
    flatten (computation.think c) = think (flatten c) :=
  sorry

@[simp] theorem destruct_flatten {α : Type u} (c : computation (wseq α)) :
    destruct (flatten c) = c >>= destruct :=
  sorry

theorem head_terminates_iff {α : Type u} (s : wseq α) :
    computation.terminates (head s) ↔ computation.terminates (destruct s) :=
  computation.terminates_map_iff (Functor.map prod.fst) (destruct s)

@[simp] theorem tail_nil {α : Type u} : tail nil = nil := sorry

@[simp] theorem tail_cons {α : Type u} (a : α) (s : wseq α) : tail (cons a s) = s := sorry

@[simp] theorem tail_think {α : Type u} (s : wseq α) : tail (think s) = think (tail s) := sorry

@[simp] theorem dropn_nil {α : Type u} (n : ℕ) : drop nil n = nil := sorry

@[simp] theorem dropn_cons {α : Type u} (a : α) (s : wseq α) (n : ℕ) :
    drop (cons a s) (n + 1) = drop s n :=
  sorry

@[simp] theorem dropn_think {α : Type u} (s : wseq α) (n : ℕ) :
    drop (think s) n = think (drop s n) :=
  sorry

theorem dropn_add {α : Type u} (s : wseq α) (m : ℕ) (n : ℕ) : drop s (m + n) = drop (drop s m) n :=
  sorry

theorem dropn_tail {α : Type u} (s : wseq α) (n : ℕ) : drop (tail s) n = drop s (n + 1) :=
  eq.mpr (id (Eq._oldrec (Eq.refl (drop (tail s) n = drop s (n + 1))) (add_comm n 1)))
    (Eq.symm (dropn_add s 1 n))

theorem nth_add {α : Type u} (s : wseq α) (m : ℕ) (n : ℕ) : nth s (m + n) = nth (drop s m) n :=
  congr_arg head (dropn_add s m n)

theorem nth_tail {α : Type u} (s : wseq α) (n : ℕ) : nth (tail s) n = nth s (n + 1) :=
  congr_arg head (dropn_tail s n)

@[simp] theorem join_nil {α : Type u} : join nil = nil := seq.join_nil

@[simp] theorem join_think {α : Type u} (S : wseq (wseq α)) : join (think S) = think (join S) :=
  sorry

@[simp] theorem join_cons {α : Type u} (s : wseq α) (S : wseq (wseq α)) :
    join (cons s S) = think (append s (join S)) :=
  sorry

@[simp] theorem nil_append {α : Type u} (s : wseq α) : append nil s = s := seq.nil_append s

@[simp] theorem cons_append {α : Type u} (a : α) (s : wseq α) (t : wseq α) :
    append (cons a s) t = cons a (append s t) :=
  seq.cons_append (some a) s t

@[simp] theorem think_append {α : Type u} (s : wseq α) (t : wseq α) :
    append (think s) t = think (append s t) :=
  seq.cons_append none s t

@[simp] theorem append_nil {α : Type u} (s : wseq α) : append s nil = s := seq.append_nil s

@[simp] theorem append_assoc {α : Type u} (s : wseq α) (t : wseq α) (u : wseq α) :
    append (append s t) u = append s (append t u) :=
  seq.append_assoc s t u

@[simp] def tail.aux {α : Type u} : Option (α × wseq α) → computation (Option (α × wseq α)) := sorry

theorem destruct_tail {α : Type u} (s : wseq α) : destruct (tail s) = destruct s >>= tail.aux :=
  sorry

@[simp] def drop.aux {α : Type u} : ℕ → Option (α × wseq α) → computation (Option (α × wseq α)) :=
  sorry

theorem drop.aux_none {α : Type u} (n : ℕ) : drop.aux n none = computation.return none := sorry

theorem destruct_dropn {α : Type u} (s : wseq α) (n : ℕ) :
    destruct (drop s n) = destruct s >>= drop.aux n :=
  sorry

theorem head_terminates_of_head_tail_terminates {α : Type u} (s : wseq α)
    [T : computation.terminates (head (tail s))] : computation.terminates (head s) :=
  sorry

theorem destruct_some_of_destruct_tail_some {α : Type u} {s : wseq α} {a : α × wseq α}
    (h : some a ∈ destruct (tail s)) : ∃ (a' : α × wseq α), some a' ∈ destruct s :=
  sorry

theorem head_some_of_head_tail_some {α : Type u} {s : wseq α} {a : α} (h : some a ∈ head (tail s)) :
    ∃ (a' : α), some a' ∈ head s :=
  sorry

theorem head_some_of_nth_some {α : Type u} {s : wseq α} {a : α} {n : ℕ} (h : some a ∈ nth s n) :
    ∃ (a' : α), some a' ∈ head s :=
  sorry

protected instance productive_tail {α : Type u} (s : wseq α) [productive s] : productive (tail s) :=
  fun (n : ℕ) =>
    eq.mpr (id (Eq._oldrec (Eq.refl (computation.terminates (nth (tail s) n))) (nth_tail s n)))
      (wseq.nth_terminates s (n + 1))

protected instance productive_dropn {α : Type u} (s : wseq α) [productive s] (n : ℕ) :
    productive (drop s n) :=
  fun (m : ℕ) =>
    eq.mpr
      (id
        (Eq._oldrec (Eq.refl (computation.terminates (nth (drop s n) m)))
          (Eq.symm (nth_add s n m))))
      (wseq.nth_terminates s (n + m))

/-- Given a productive weak sequence, we can collapse all the `think`s to
  produce a sequence. -/
def to_seq {α : Type u} (s : wseq α) [productive s] : seq α :=
  { val := fun (n : ℕ) => computation.get (nth s n), property := sorry }

theorem nth_terminates_le {α : Type u} {s : wseq α} {m : ℕ} {n : ℕ} (h : m ≤ n) :
    computation.terminates (nth s n) → computation.terminates (nth s m) :=
  sorry

theorem head_terminates_of_nth_terminates {α : Type u} {s : wseq α} {n : ℕ} :
    computation.terminates (nth s n) → computation.terminates (head s) :=
  nth_terminates_le (nat.zero_le n)

theorem destruct_terminates_of_nth_terminates {α : Type u} {s : wseq α} {n : ℕ}
    (T : computation.terminates (nth s n)) : computation.terminates (destruct s) :=
  iff.mp (head_terminates_iff s) (head_terminates_of_nth_terminates T)

theorem mem_rec_on {α : Type u} {C : wseq α → Prop} {a : α} {s : wseq α} (M : a ∈ s)
    (h1 : ∀ (b : α) (s' : wseq α), a = b ∨ C s' → C (cons b s'))
    (h2 : ∀ (s : wseq α), C s → C (think s)) : C s :=
  sorry

@[simp] theorem mem_think {α : Type u} (s : wseq α) (a : α) : a ∈ think s ↔ a ∈ s := sorry

theorem eq_or_mem_iff_mem {α : Type u} {s : wseq α} {a : α} {a' : α} {s' : wseq α} :
    some (a', s') ∈ destruct s → (a ∈ s ↔ a = a' ∨ a ∈ s') :=
  sorry

@[simp] theorem mem_cons_iff {α : Type u} (s : wseq α) (b : α) {a : α} :
    a ∈ cons b s ↔ a = b ∨ a ∈ s :=
  sorry

theorem mem_cons_of_mem {α : Type u} {s : wseq α} (b : α) {a : α} (h : a ∈ s) : a ∈ cons b s :=
  iff.mpr (mem_cons_iff s b) (Or.inr h)

theorem mem_cons {α : Type u} (s : wseq α) (a : α) : a ∈ cons a s :=
  iff.mpr (mem_cons_iff s a) (Or.inl rfl)

theorem mem_of_mem_tail {α : Type u} {s : wseq α} {a : α} : a ∈ tail s → a ∈ s := sorry

theorem mem_of_mem_dropn {α : Type u} {s : wseq α} {a : α} {n : ℕ} : a ∈ drop s n → a ∈ s := sorry

theorem nth_mem {α : Type u} {s : wseq α} {a : α} {n : ℕ} : some a ∈ nth s n → a ∈ s := sorry

theorem exists_nth_of_mem {α : Type u} {s : wseq α} {a : α} (h : a ∈ s) :
    ∃ (n : ℕ), some a ∈ nth s n :=
  sorry

theorem exists_dropn_of_mem {α : Type u} {s : wseq α} {a : α} (h : a ∈ s) :
    ∃ (n : ℕ), ∃ (s' : wseq α), some (a, s') ∈ destruct (drop s n) :=
  sorry

theorem lift_rel_dropn_destruct {α : Type u} {β : Type v} {R : α → β → Prop} {s : wseq α}
    {t : wseq β} (H : lift_rel R s t) (n : ℕ) :
    computation.lift_rel (lift_rel_o R (lift_rel R)) (destruct (drop s n)) (destruct (drop t n)) :=
  sorry

theorem exists_of_lift_rel_left {α : Type u} {β : Type v} {R : α → β → Prop} {s : wseq α}
    {t : wseq β} (H : lift_rel R s t) {a : α} (h : a ∈ s) : Exists fun {b : β} => b ∈ t ∧ R a b :=
  sorry

theorem exists_of_lift_rel_right {α : Type u} {β : Type v} {R : α → β → Prop} {s : wseq α}
    {t : wseq β} (H : lift_rel R s t) {b : β} (h : b ∈ t) : Exists fun {a : α} => a ∈ s ∧ R a b :=
  exists_of_lift_rel_left
    (eq.mp
      (Eq._oldrec (Eq.refl (lift_rel R s t)) (Eq.symm (lift_rel.swap fun (x : β) (y : α) => R y x)))
      H)
    h

theorem head_terminates_of_mem {α : Type u} {s : wseq α} {a : α} (h : a ∈ s) :
    computation.terminates (head s) :=
  sorry

theorem of_mem_append {α : Type u} {s₁ : wseq α} {s₂ : wseq α} {a : α} :
    a ∈ append s₁ s₂ → a ∈ s₁ ∨ a ∈ s₂ :=
  seq.of_mem_append

theorem mem_append_left {α : Type u} {s₁ : wseq α} {s₂ : wseq α} {a : α} :
    a ∈ s₁ → a ∈ append s₁ s₂ :=
  seq.mem_append_left

theorem exists_of_mem_map {α : Type u} {β : Type v} {f : α → β} {b : β} {s : wseq α} :
    b ∈ map f s → ∃ (a : α), a ∈ s ∧ f a = b :=
  sorry

@[simp] theorem lift_rel_nil {α : Type u} {β : Type v} (R : α → β → Prop) : lift_rel R nil nil :=
  sorry

@[simp] theorem lift_rel_cons {α : Type u} {β : Type v} (R : α → β → Prop) (a : α) (b : β)
    (s : wseq α) (t : wseq β) : lift_rel R (cons a s) (cons b t) ↔ R a b ∧ lift_rel R s t :=
  sorry

@[simp] theorem lift_rel_think_left {α : Type u} {β : Type v} (R : α → β → Prop) (s : wseq α)
    (t : wseq β) : lift_rel R (think s) t ↔ lift_rel R s t :=
  sorry

@[simp] theorem lift_rel_think_right {α : Type u} {β : Type v} (R : α → β → Prop) (s : wseq α)
    (t : wseq β) : lift_rel R s (think t) ↔ lift_rel R s t :=
  sorry

theorem cons_congr {α : Type u} {s : wseq α} {t : wseq α} (a : α) (h : s ~ t) :
    cons a s ~ cons a t :=
  sorry

theorem think_equiv {α : Type u} (s : wseq α) : think s ~ s :=
  eq.mpr (id (congr_fun (congr_fun equiv.equations._eqn_1 (think s)) s))
    (eq.mpr (id (propext (lift_rel_think_left Eq s s))) (equiv.refl s))

theorem think_congr {α : Type u} {s : wseq α} {t : wseq α} (a : α) (h : s ~ t) :
    think s ~ think t :=
  eq.mpr (id (congr_fun (congr_fun equiv.equations._eqn_1 (think s)) (think t)))
    (eq.mpr
      (id
        (Eq.trans (propext (lift_rel_think_right Eq (think s) t))
          (propext (lift_rel_think_left Eq s t))))
      h)

theorem head_congr {α : Type u} {s : wseq α} {t : wseq α} : s ~ t → head s ~ head t := sorry

theorem flatten_equiv {α : Type u} {c : computation (wseq α)} {s : wseq α} (h : s ∈ c) :
    flatten c ~ s :=
  sorry

theorem lift_rel_flatten {α : Type u} {β : Type v} {R : α → β → Prop} {c1 : computation (wseq α)}
    {c2 : computation (wseq β)} (h : computation.lift_rel (lift_rel R) c1 c2) :
    lift_rel R (flatten c1) (flatten c2) :=
  sorry

theorem flatten_congr {α : Type u} {c1 : computation (wseq α)} {c2 : computation (wseq α)} :
    computation.lift_rel equiv c1 c2 → flatten c1 ~ flatten c2 :=
  lift_rel_flatten

theorem tail_congr {α : Type u} {s : wseq α} {t : wseq α} (h : s ~ t) : tail s ~ tail t := sorry

theorem dropn_congr {α : Type u} {s : wseq α} {t : wseq α} (h : s ~ t) (n : ℕ) :
    drop s n ~ drop t n :=
  sorry

theorem nth_congr {α : Type u} {s : wseq α} {t : wseq α} (h : s ~ t) (n : ℕ) : nth s n ~ nth t n :=
  head_congr (dropn_congr h n)

theorem mem_congr {α : Type u} {s : wseq α} {t : wseq α} (h : s ~ t) (a : α) : a ∈ s ↔ a ∈ t :=
  sorry

theorem productive_congr {α : Type u} {s : wseq α} {t : wseq α} (h : s ~ t) :
    productive s ↔ productive t :=
  forall_congr fun (n : ℕ) => computation.terminates_congr (nth_congr h n)

theorem equiv.ext {α : Type u} {s : wseq α} {t : wseq α} (h : ∀ (n : ℕ), nth s n ~ nth t n) :
    s ~ t :=
  sorry

theorem length_eq_map {α : Type u} (s : wseq α) :
    length s = computation.map list.length (to_list s) :=
  sorry

@[simp] theorem of_list_nil {α : Type u} : of_list [] = nil := rfl

@[simp] theorem of_list_cons {α : Type u} (a : α) (l : List α) :
    of_list (a :: l) = cons a (of_list l) :=
  sorry

@[simp] theorem to_list'_nil {α : Type u} (l : List α) :
    computation.corec to_list._match_2 (l, nil) = computation.return (list.reverse l) :=
  computation.destruct_eq_ret rfl

@[simp] theorem to_list'_cons {α : Type u} (l : List α) (s : wseq α) (a : α) :
    computation.corec to_list._match_2 (l, cons a s) =
        computation.think (computation.corec to_list._match_2 (a :: l, s)) :=
  sorry

@[simp] theorem to_list'_think {α : Type u} (l : List α) (s : wseq α) :
    computation.corec to_list._match_2 (l, think s) =
        computation.think (computation.corec to_list._match_2 (l, s)) :=
  sorry

theorem to_list'_map {α : Type u} (l : List α) (s : wseq α) :
    computation.corec to_list._match_2 (l, s) = append (list.reverse l) <$> to_list s :=
  sorry

@[simp] theorem to_list_cons {α : Type u} (a : α) (s : wseq α) :
    to_list (cons a s) = computation.think (List.cons a <$> to_list s) :=
  sorry

@[simp] theorem to_list_nil {α : Type u} : to_list nil = computation.return [] :=
  computation.destruct_eq_ret rfl

theorem to_list_of_list {α : Type u} (l : List α) : l ∈ to_list (of_list l) := sorry

@[simp] theorem destruct_of_seq {α : Type u} (s : seq α) :
    destruct (of_seq s) =
        computation.return (option.map (fun (a : α) => (a, of_seq (seq.tail s))) (seq.head s)) :=
  sorry

@[simp] theorem head_of_seq {α : Type u} (s : seq α) :
    head (of_seq s) = computation.return (seq.head s) :=
  sorry

@[simp] theorem tail_of_seq {α : Type u} (s : seq α) : tail (of_seq s) = of_seq (seq.tail s) :=
  sorry

@[simp] theorem dropn_of_seq {α : Type u} (s : seq α) (n : ℕ) :
    drop (of_seq s) n = of_seq (seq.drop s n) :=
  sorry

theorem nth_of_seq {α : Type u} (s : seq α) (n : ℕ) :
    nth (of_seq s) n = computation.return (seq.nth s n) :=
  sorry

protected instance productive_of_seq {α : Type u} (s : seq α) : productive (of_seq s) :=
  fun (n : ℕ) =>
    eq.mpr (id (Eq._oldrec (Eq.refl (computation.terminates (nth (of_seq s) n))) (nth_of_seq s n)))
      (computation.ret_terminates (seq.nth s n))

theorem to_seq_of_seq {α : Type u} (s : seq α) : to_seq (of_seq s) = s := sorry

/-- The monadic `return a` is a singleton list containing `a`. -/
def ret {α : Type u} (a : α) : wseq α := of_list [a]

@[simp] theorem map_nil {α : Type u} {β : Type v} (f : α → β) : map f nil = nil := rfl

@[simp] theorem map_cons {α : Type u} {β : Type v} (f : α → β) (a : α) (s : wseq α) :
    map f (cons a s) = cons (f a) (map f s) :=
  seq.map_cons (option.map f) (some a) s

@[simp] theorem map_think {α : Type u} {β : Type v} (f : α → β) (s : wseq α) :
    map f (think s) = think (map f s) :=
  seq.map_cons (option.map f) none s

@[simp] theorem map_id {α : Type u} (s : wseq α) : map id s = s := sorry

@[simp] theorem map_ret {α : Type u} {β : Type v} (f : α → β) (a : α) : map f (ret a) = ret (f a) :=
  sorry

@[simp] theorem map_append {α : Type u} {β : Type v} (f : α → β) (s : wseq α) (t : wseq α) :
    map f (append s t) = append (map f s) (map f t) :=
  seq.map_append (option.map f) s t

theorem map_comp {α : Type u} {β : Type v} {γ : Type w} (f : α → β) (g : β → γ) (s : wseq α) :
    map (g ∘ f) s = map g (map f s) :=
  sorry

theorem mem_map {α : Type u} {β : Type v} (f : α → β) {a : α} {s : wseq α} :
    a ∈ s → f a ∈ map f s :=
  seq.mem_map (option.map f)

-- The converse is not true without additional assumptions

theorem exists_of_mem_join {α : Type u} {a : α} {S : wseq (wseq α)} :
    a ∈ join S → ∃ (s : wseq α), s ∈ S ∧ a ∈ s :=
  sorry

theorem exists_of_mem_bind {α : Type u} {β : Type v} {s : wseq α} {f : α → wseq β} {b : β}
    (h : b ∈ bind s f) : ∃ (a : α), ∃ (H : a ∈ s), b ∈ f a :=
  sorry

theorem destruct_map {α : Type u} {β : Type v} (f : α → β) (s : wseq α) :
    destruct (map f s) = computation.map (option.map (prod.map f (map f))) (destruct s) :=
  sorry

theorem lift_rel_map {α : Type u} {β : Type v} {γ : Type w} {δ : Type u_1} (R : α → β → Prop)
    (S : γ → δ → Prop) {s1 : wseq α} {s2 : wseq β} {f1 : α → γ} {f2 : β → δ} (h1 : lift_rel R s1 s2)
    (h2 : ∀ {a : α} {b : β}, R a b → S (f1 a) (f2 b)) : lift_rel S (map f1 s1) (map f2 s2) :=
  sorry

theorem map_congr {α : Type u} {β : Type v} (f : α → β) {s : wseq α} {t : wseq α} (h : s ~ t) :
    map f s ~ map f t :=
  lift_rel_map Eq Eq h fun (_x _x_1 : α) => congr_arg fun (_x : α) => f _x

@[simp] def destruct_append.aux {α : Type u} (t : wseq α) :
    Option (α × wseq α) → computation (Option (α × wseq α)) :=
  sorry

theorem destruct_append {α : Type u} (s : wseq α) (t : wseq α) :
    destruct (append s t) = computation.bind (destruct s) (destruct_append.aux t) :=
  sorry

@[simp] def destruct_join.aux {α : Type u} :
    Option (wseq α × wseq (wseq α)) → computation (Option (α × wseq α)) :=
  sorry

theorem destruct_join {α : Type u} (S : wseq (wseq α)) :
    destruct (join S) = computation.bind (destruct S) destruct_join.aux :=
  sorry

theorem lift_rel_append {α : Type u} {β : Type v} (R : α → β → Prop) {s1 : wseq α} {s2 : wseq α}
    {t1 : wseq β} {t2 : wseq β} (h1 : lift_rel R s1 t1) (h2 : lift_rel R s2 t2) :
    lift_rel R (append s1 s2) (append t1 t2) :=
  sorry

theorem lift_rel_join.lem {α : Type u} {β : Type v} (R : α → β → Prop) {S : wseq (wseq α)}
    {T : wseq (wseq β)} {U : wseq α → wseq β → Prop} (ST : lift_rel (lift_rel R) S T)
    (HU :
      ∀ (s1 : wseq α) (s2 : wseq β),
        (∃ (s : wseq α),
            ∃ (t : wseq β),
              ∃ (S : wseq (wseq α)),
                ∃ (T : wseq (wseq β)),
                  s1 = append s (join S) ∧
                    s2 = append t (join T) ∧ lift_rel R s t ∧ lift_rel (lift_rel R) S T) →
          U s1 s2)
    {a : Option (α × wseq α)} (ma : a ∈ destruct (join S)) :
    Exists fun {b : Option (β × wseq β)} => b ∈ destruct (join T) ∧ lift_rel_o R U a b :=
  sorry

theorem lift_rel_join {α : Type u} {β : Type v} (R : α → β → Prop) {S : wseq (wseq α)}
    {T : wseq (wseq β)} (h : lift_rel (lift_rel R) S T) : lift_rel R (join S) (join T) :=
  sorry

theorem join_congr {α : Type u} {S : wseq (wseq α)} {T : wseq (wseq α)} (h : lift_rel equiv S T) :
    join S ~ join T :=
  lift_rel_join Eq h

theorem lift_rel_bind {α : Type u} {β : Type v} {γ : Type w} {δ : Type u_1} (R : α → β → Prop)
    (S : γ → δ → Prop) {s1 : wseq α} {s2 : wseq β} {f1 : α → wseq γ} {f2 : β → wseq δ}
    (h1 : lift_rel R s1 s2) (h2 : ∀ {a : α} {b : β}, R a b → lift_rel S (f1 a) (f2 b)) :
    lift_rel S (bind s1 f1) (bind s2 f2) :=
  lift_rel_join S (lift_rel_map R (lift_rel S) h1 h2)

theorem bind_congr {α : Type u} {β : Type v} {s1 : wseq α} {s2 : wseq α} {f1 : α → wseq β}
    {f2 : α → wseq β} (h1 : s1 ~ s2) (h2 : ∀ (a : α), f1 a ~ f2 a) : bind s1 f1 ~ bind s2 f2 :=
  lift_rel_bind Eq Eq h1
    fun (a b : α) (h : a = b) =>
      eq.mpr (id (Eq._oldrec (Eq.refl (lift_rel Eq (f1 a) (f2 b))) h)) (h2 b)

@[simp] theorem join_ret {α : Type u} (s : wseq α) : join (ret s) ~ s := sorry

@[simp] theorem join_map_ret {α : Type u} (s : wseq α) : join (map ret s) ~ s := sorry

@[simp] theorem join_append {α : Type u} (S : wseq (wseq α)) (T : wseq (wseq α)) :
    join (append S T) ~ append (join S) (join T) :=
  sorry

@[simp] theorem bind_ret {α : Type u} {β : Type v} (f : α → β) (s : wseq α) :
    bind s (ret ∘ f) ~ map f s :=
  id
    (eq.mpr (id (Eq._oldrec (Eq.refl (join (map (ret ∘ f) s) ~ map f s)) (map_comp f ret s)))
      (join_map_ret (map f s)))

@[simp] theorem ret_bind {α : Type u} {β : Type v} (a : α) (f : α → wseq β) :
    bind (ret a) f ~ f a :=
  sorry

@[simp] theorem map_join {α : Type u} {β : Type v} (f : α → β) (S : wseq (wseq α)) :
    map f (join S) = join (map (map f) S) :=
  sorry

@[simp] theorem join_join {α : Type u} (SS : wseq (wseq (wseq α))) :
    join (join SS) ~ join (map join SS) :=
  sorry

@[simp] theorem bind_assoc {α : Type u} {β : Type v} {γ : Type w} (s : wseq α) (f : α → wseq β)
    (g : β → wseq γ) : bind (bind s f) g ~ bind s fun (x : α) => bind (f x) g :=
  sorry

protected instance monad : Monad wseq :=
  { toApplicative :=
      { toFunctor := { map := map, mapConst := fun (α β : Type u_1) => map ∘ function.const β },
        toPure := { pure := ret },
        toSeq :=
          { seq :=
              fun (α β : Type u_1) (f : wseq (α → β)) (x : wseq α) =>
                bind f fun (_x : α → β) => map _x x },
        toSeqLeft :=
          { seqLeft :=
              fun (α β : Type u_1) (a : wseq α) (b : wseq β) =>
                (fun (α β : Type u_1) (f : wseq (α → β)) (x : wseq α) =>
                    bind f fun (_x : α → β) => map _x x)
                  β α (map (function.const β) a) b },
        toSeqRight :=
          { seqRight :=
              fun (α β : Type u_1) (a : wseq α) (b : wseq β) =>
                (fun (α β : Type u_1) (f : wseq (α → β)) (x : wseq α) =>
                    bind f fun (_x : α → β) => map _x x)
                  β β (map (function.const α id) a) b } },
    toBind := { bind := bind } }

end Mathlib


import sheaves_of_modules.defs
/-

# Pushforward and pullback of sheaves of modules

-/

variables {X Y : RINGED_SPACE}
namespace SHEAF_OF_MODULES

section experiment

--#check @Top.sheaf.pushforward

variable (f : X ⟶ Y)

example : (X : TOP) ⟶ Y := f.base

end experiment

--#check Top.presheaf.pushforward_obj
--set_option pp.notation false

/-
instance (𝓜 : SHEAF_OF_MODULES X) (U : (opens (X : TOP))ᵒᵖ) :
  module ((𝓞_ X) U) (𝓜.obj U) := 𝓜.module_structure U
-/

--instance (U) : module
--#print notation _*
--#check Top.presheaf.pushforward_obj

/-

/-- Pushforward a presheaf on `X` along a continuous map `f : X ⟶ Y`, obtaining a presheaf
on `Y`. -/
def pushforward_obj {X Y : Top.{w}} (f : X ⟶ Y) (ℱ : X.presheaf C) : Y.presheaf C :=
(opens.map f).op ⋙ ℱ

infix ` _* `: 80 := pushforward_obj
-/

--#where
def map (f : X ⟶ Y) (𝓜 : SHEAF_OF_MODULES X) : SHEAF_OF_MODULES Y :=
{ ab_sheaf := (Top.sheaf.pushforward.{0} f.base).obj 𝓜.ab_sheaf,
  module_structure := λ U, by letI : module ↥((f.base _* X.to_PresheafedSpace.presheaf).obj U)
    ↥(((Top.sheaf.pushforward f.base).obj 𝓜.ab_sheaf).val.obj U) := obj.module 𝓜 ((topological_space.opens.map f.base).op.obj U); exact
    module.comp_hom (𝓜.obj ((topological_space.opens.map f.base).op.obj U)) (f.c.app U),
--   module_structure := λ U, begin
-- --    delta Top.sheaf.pushforward,
-- --    dsimp only,
-- --    delta Top.presheaf.pushforward_obj,
-- --    change module _ (𝓜.obj _),
--     let V : (topological_space.opens (X : TOP))ᵒᵖ := (topological_space.opens.map f.base).op.obj U,
--     change module ((𝓞_ Y) U) (𝓜.obj V),
-- --    letI baz : module ((𝓞_ X) V) (𝓜.obj V) := infer_instance, -- show_term {apply_instance}
--     letI : module ↥((f.base _* X.to_PresheafedSpace.presheaf).obj U) ↥(𝓜.obj V) := obj.module 𝓜 V,
-- --    let foo : (𝓞_ Y) U →+* (𝓞_ X) V := f.c.app U,
--     exact module.comp_hom (𝓜.obj V) (f.c.app U),
--   end,
  compatibility_bit := λ U V i, begin
    rintro s (n : 𝓜.ab_sheaf.val.obj _),
    change ↥((𝓞_ Y) U) at s,
    have foo := f.c.naturality i,
    let j : ((topological_space.opens.map f.base).op.obj U) ⟶ ((topological_space.opens.map f.base).op.obj V) :=
      ((topological_space.opens.map f.base).op.map i),
    let r : (𝓞_ X) ((topological_space.opens.map f.base).op.obj U) := f.c.app U s,
    --have bar := 𝓜.compatibility_bit _ _ j r n,
    convert 𝓜.compatibility_bit _ _ j r n using 1,
    rw fun_like.ext_iff at foo,
    specialize foo s,
    have moo : (f.base _* X.to_PresheafedSpace.presheaf).map i = X.to_PresheafedSpace.presheaf.map j,
      refl,
    rw fun_like.ext_iff at moo,
    specialize moo r,
    rw ← moo,
    change _ = ((f.c.app U ≫ (f.base _* X.to_PresheafedSpace.presheaf).map i) s) • _,
    rw ← foo,
    refl,

    -- need to pull back i; need to fix implicits
    -- might need pen and paper here
    --convert bar _ _,
    /-
    Have foo: O_Y(U)->O_Y(V)->f_*O_X(V) = O_Y(U)->f_*O_X(U)->f_*O_X(V)
    have bar : ∀ r ∈ O_X(f⁻¹(U)), m ∈ 𝓜(f⁻¹(U)),
      res(r•m) ∈ 𝓜(f⁻¹(V)) = (res(r) : O_X(f⁻¹(V)))•res(m)

    Want: ∀ s ∈ O_Y(U), ∀ n ∈ f_*𝓜(U) := 𝓜(f⁻¹(U)), res(s•n)=res(s)•res(n)
    Proof: define r=image of s in O_X(f⁻¹(U))=f_*O_X(U).

    -/
    --letI : module (Y.to_PresheafedSpace.presheaf.obj U)
    --  (((Top.sheaf.pushforward f.base).obj 𝓜.ab_sheaf).val.obj U) := module_structure 𝓜 ((topological_space.opens.map f.base).op.obj U),

    --calc
    --(((Top.sheaf.pushforward f.base).obj 𝓜.ab_sheaf).val.map i) (s • n) =
    --((Y.to_PresheafedSpace.presheaf.map i) s : (𝓞_ Y) V) • (((Top.sheaf.pushforward f.base).obj 𝓜.ab_sheaf).val.map i) n : sorry
  end }

infix (name := hi) ` _* `: 80 := map

--#check Top.sheaf.pushforward

variables (f : X ⟶ Y) (𝓜 : SHEAF_OF_MODULES X)

def map_id (𝓜 : SHEAF_OF_MODULES X) : (𝟙 X) _* 𝓜 ≅ 𝓜 :=
{ hom :=
  { ab_sheaf :=
    { val :=
      { app := λ U, 𝓜.ab_sheaf.val.map $ category_theory.op_hom_of_le $ λ x hx, hx,
        naturality' := begin
          intros U V f,
          ext,
          simp only [category_theory.comp_apply],
          sorry,
        end } },
      map_smul := begin
        intros,
        simp only [category_theory.op_hom_of_le],
        sorry,
      end },
    inv :=
    { ab_sheaf :=
      { val :=
        { app := λ U, 𝓜.ab_sheaf.val.map $ category_theory.op_hom_of_le $ λ x hx, hx,
          naturality' := begin
            intros U V g,
            ext,
            simp only [category_theory.comp_apply],
            sorry,
          end } },
      map_smul := sorry },
  hom_inv_id' := begin
    ext U m,
    --dsimp only [category_theory.comp_apply],
    unfold_coes,
    dsimp only,
    sorry,
  end,
  inv_hom_id' := sorry }

end SHEAF_OF_MODULES

example (Z : Type) [topological_space Z] (U V : (topological_space.opens Z)ᵒᵖ) (h : V.unop ⊆ U.unop):
  U ⟶ V :=
begin
  refine category_theory.op_hom_of_le h,
end