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

! This file was ported from Lean 3 source module tactic.equiv_rw
! leanprover-community/mathlib commit 9407b03373c8cd201df99d6bc5514fc2db44054f
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Logic.Equiv.Defs
import Mathbin.Tactic.Clear
import Mathbin.Tactic.SimpResult
import Mathbin.Tactic.Apply
import Mathbin.Control.EquivFunctor.Instances
import Mathbin.Logic.Equiv.Functor

/-!
# The `equiv_rw` tactic transports goals or hypotheses along equivalences.

The basic syntax is `equiv_rw e`, where `e : α ≃ β` is an equivalence.
This will try to replace occurrences of `α` in the goal with `β`, for example
transforming
* `⊢ α` to `⊢ β`,
* `⊢ option α` to `⊢ option β`
* `⊢ {a // P}` to `{b // P (⇑(equiv.symm e) b)}`

The tactic can also be used to rewrite hypotheses, using the syntax `equiv_rw e at h`.

## Implementation details

The main internal function is `equiv_rw_type e t`,
which attempts to turn an expression `e : α ≃ β` into a new equivalence with left hand side `t`.
As an example, with `t = option α`, it will generate `functor.map_equiv option e`.

This is achieved by generating a new synthetic goal `%%t ≃ _`,
and calling `solve_by_elim` with an appropriate set of congruence lemmas.
To avoid having to specify the relevant congruence lemmas by hand,
we mostly rely on `equiv_functor.map_equiv` and `bifunctor.map_equiv`
along with some structural congruence lemmas such as
* `equiv.arrow_congr'`,
* `equiv.subtype_equiv_of_subtype'`,
* `equiv.sigma_congr_left'`, and
* `equiv.Pi_congr_left'`.

The main `equiv_rw` function, when operating on the goal, simply generates a new equivalence `e'`
with left hand side matching the target, and calls `apply e'.inv_fun`.

When operating on a hypothesis `x : α`, we introduce a new fact `h : x = e.symm (e x)`, revert this,
and then attempt to `generalize`, replacing all occurrences of `e x` with a new constant `y`, before
`intro`ing and `subst`ing `h`, and renaming `y` back to `x`.

## Future improvements
In a future PR I anticipate that `derive equiv_functor` should work on many examples,
(internally using `transport`, which is in turn based on `equiv_rw`)
and we can incrementally bootstrap the strength of `equiv_rw`.

An ambitious project might be to add `equiv_rw!`,
a tactic which, when failing to find appropriate `equiv_functor` instances,
attempts to `derive` them on the spot.

For now `equiv_rw` is entirely based on `equiv`,
but the framework can readily be generalised to also work with other types of equivalences,
for example specific notations such as ring equivalence (`≃+*`),
or general categorical isomorphisms (`≅`).

This will allow us to transport across more general types of equivalences,
but this will wait for another subsequent PR.
-/

-- these make equiv_rw more powerful!
-- these make equiv_rw more powerful!
-- so do these!
-- so do these!
namespace Tactic

-- Although this looks 'hard-coded', in fact the lemma `equiv_functor.map_equiv`
-- allows us to extend `equiv_rw` simply by constructing new instance so `equiv_functor`.
-- TODO: We should also use `category_theory.functorial` and `category_theory.hygienic` instances.
-- (example goal: we could rewrite along an isomorphism of rings (either as `R ≅ S` or `R ≃+* S`)
-- and turn an `x : mv_polynomial σ R` into an `x : mv_polynomial σ S`.).
/-- A list of lemmas used for constructing congruence equivalences. -/
unsafe def equiv_congr_lemmas : List (tactic expr) :=
  [`equiv.of_iff,-- TODO decide what to do with this; it's an equiv_bifunctor?
        `equiv.equiv_congr,-- The function arrow is technically a bifunctor `Typeᵒᵖ → Type → Type`,
        -- but the pattern matcher will never see this.
        `equiv.arrow_congr',-- Allow rewriting in subtypes:
        `equiv.subtype_equiv_of_subtype',-- Allow rewriting in the first component of a sigma-type:
        `equiv.sigma_congr_left',-- Allow rewriting ∀s:
        -- (You might think that repeated application of `equiv.forall_congr'
        -- would handle the higher arity cases, but unfortunately unification is not clever enough.)
        `equiv.forall₃_congr',
        `equiv.forall₂_congr',
        `equiv.forall_congr',-- Allow rewriting in argument of Pi types:
        `equiv.Pi_congr_left',-- Handles `sum` and `prod`, and many others:
        `bifunctor.map_equiv,-- Handles `list`, `option`, `unique`, and many others:
        `equiv_functor.map_equiv,-- We have to filter results to ensure we don't cheat and use exclusively
        -- `equiv.refl` and `iff.refl`!
        `equiv.refl,
        `iff.refl].map
    fun n => mk_const n
#align tactic.equiv_congr_lemmas tactic.equiv_congr_lemmas

initialize
  registerTraceClass.1 `equiv_rw_type

/-- Configuration structure for `equiv_rw`.

* `max_depth` bounds the search depth for equivalences to rewrite along.
  The default value is 10.
  (e.g., if you're rewriting along `e : α ≃ β`, and `max_depth := 2`,
  you can rewrite `option (option α))` but not `option (option (option α))`.
-/
unsafe structure equiv_rw_cfg where
  max_depth : ℕ := 10
#align tactic.equiv_rw_cfg tactic.equiv_rw_cfg

/- ./././Mathport/Syntax/Translate/Expr.lean:330:4: warning: unsupported (TODO): `[tacs] -/
/- ./././Mathport/Syntax/Translate/Expr.lean:330:4: warning: unsupported (TODO): `[tacs] -/
/- ./././Mathport/Syntax/Translate/Expr.lean:330:4: warning: unsupported (TODO): `[tacs] -/
/- ./././Mathport/Syntax/Translate/Expr.lean:330:4: warning: unsupported (TODO): `[tacs] -/
/-- Implementation of `equiv_rw_type`, using `solve_by_elim`.
Expects a goal of the form `t ≃ _`,
and tries to solve it using `eq : α ≃ β` and congruence lemmas.
-/
unsafe def equiv_rw_type_core (eq : expr) (cfg : equiv_rw_cfg) : tactic Unit := do
  /-
          We now call `solve_by_elim` to try to generate the requested equivalence.
          There are a few subtleties!
          * We make sure that `eq` is the first lemma, so it is applied whenever possible.
          * In `equiv_congr_lemmas`, we put `equiv.refl` last so it is only used when it is not possible
            to descend further.
          * Since some congruence lemmas generate subgoals with `∀` statements,
            we use the `pre_apply` subtactic of `solve_by_elim` to preprocess each new goal with `intros`.
        -/
      solve_by_elim
      { use_symmetry := False
        use_exfalso := False
        lemma_thunks := some (pure Eq :: equiv_congr_lemmas)
        ctx_thunk := pure []
        max_depth := cfg
        -- Subgoals may contain function types,
        -- and we want to continue trying to construct equivalences after the binders.
        pre_apply := tactic.intros >> skip
        backtrack_all_goals := tt
        -- If solve_by_elim gets stuck, make sure it isn't because there's a later `≃` or `↔` goal
        -- that we should still attempt.
        discharger :=
          (sorry >> sorry) >> (sorry <|> sorry) <|>
            trace_if_enabled `equiv_rw_type "Failed, no congruence lemma applied!" >> failed
        -- We use the `accept` tactic in `solve_by_elim` to provide tracing.
        accept := fun goals =>
          lock_tactic_state do
            when_tracing `equiv_rw_type do
                goals pp >>= fun goals => trace f! "So far, we've built: {goals}"
            done <|>
                when_tracing `equiv_rw_type do
                  let gs ← get_goals
                  let gs ← gs fun g => infer_type g >>= pp
                  trace f! "Attempting to adapt to {gs}" }
#align tactic.equiv_rw_type_core tactic.equiv_rw_type_core

-- failed to format: unknown constant 'term.pseudo.antiquot'
/--
      `equiv_rw_type e t` rewrites the type `t` using the equivalence `e : α ≃ β`,
      returning a new equivalence `t ≃ t'`.
      -/
    unsafe
  def
    equiv_rw_type
    ( eqv : expr ) ( ty : expr ) ( cfg : equiv_rw_cfg ) : tactic expr
    :=
      do
        when_tracing
            `equiv_rw_type
              do
                let ty_pp ← pp ty
                  let eqv_pp ← pp eqv
                  let eqv_ty_pp ← infer_type eqv >>= pp
                  trace
                    f!
                      "Attempting to rewrite the type `{
                        ty_pp
                        }` using `{
                        eqv_pp
                        } : {
                        eqv_ty_pp
                        }`."
          let q( _ ≃ _ ) ← infer_type eqv | fail f! "{ eqv } must be an `equiv`"
          let equiv_ty ← to_expr ` `( $ ( ty ) ≃ _ )
          let new_eqv ← Prod.snd <$> ( solve_aux equiv_ty <| equiv_rw_type_core eqv cfg )
          let new_eqv ← instantiate_mvars new_eqv
          kdepends_on new_eqv eqv >>= guardb
            <|>
            do
              let eqv_pp ← pp eqv
                let ty_pp ← pp ty
                fail
                  f! "Could not construct an equivalence from { eqv_pp } of the form: { ty_pp } ≃ _"
          Prod.fst <$> new_eqv { failIfUnchanged := ff }
#align tactic.equiv_rw_type tactic.equiv_rw_type

/- failed to parenthesize: unknown constant 'Lean.Meta._root_.Lean.Parser.Command.registerSimpAttr'
[PrettyPrinter.parenthesize.input] (Lean.Meta._root_.Lean.Parser.Command.registerSimpAttr
     [(Command.docComment
       "/--"
       "The simpset `equiv_rw_simp` is used by the tactic `equiv_rw` to\nsimplify applications of equivalences and their inverses. -/")]
     "register_simp_attr"
     `equiv_rw_simp)-/-- failed to format: unknown constant 'Lean.Meta._root_.Lean.Parser.Command.registerSimpAttr'
/--
    The simpset `equiv_rw_simp` is used by the tactic `equiv_rw` to
    simplify applications of equivalences and their inverses. -/
  register_simp_attr
  equiv_rw_simp

attribute [equiv_rw_simp] Equiv.symm_symm Equiv.apply_symm_apply Equiv.symm_apply_apply

/- ./././Mathport/Syntax/Translate/Expr.lean:330:4: warning: unsupported (TODO): `[tacs] -/
-- failed to format: unknown constant 'term.pseudo.antiquot'
/--
      Attempt to replace the hypothesis with name `x`
      by transporting it along the equivalence in `e : α ≃ β`.
      -/
    unsafe
  def
    equiv_rw_hyp
    ( x : Name ) ( e : expr ) ( cfg : equiv_rw_cfg := { } ) : tactic Unit
    :=
      dsimp_result
        (
            do
              let x' ← get_local x
                let x_ty ← infer_type x'
                let e ← equiv_rw_type e x_ty cfg
                let
                  eq ← to_expr ` `( $ ( x' ) = Equiv.symm $ ( e ) ( Equiv.toFun $ ( e ) $ ( x' ) ) )
                let prf ← to_expr ` `( ( Equiv.symm_apply_apply $ ( e ) $ ( x' ) ) . symm )
                let h ← note_anon Eq prf
                revert h
                let ex ← to_expr ` `( Equiv.toFun $ ( e ) $ ( x' ) )
                generalize ex ( by infer_param ) transparency.none
                intro x
                let h ← intro1
                let b ← target >>= is_prop
                if
                  b
                  then
                  do subst h sorry
                  else
                  unfreezing_hyp x' ( clear' tt [ x' ] )
                    <|>
                    fail
                      f!
                        "equiv_rw expected to be able to clear the original hypothesis {
                          x
                          }, but couldn't."
                skip
            )
          { failIfUnchanged := false }
          true
#align tactic.equiv_rw_hyp tactic.equiv_rw_hyp

-- call `dsimp_result` with `no_defaults := tt`.
/-- Rewrite the goal using an equiv `e`. -/
unsafe def equiv_rw_target (e : expr) (cfg : equiv_rw_cfg := { }) : tactic Unit := do
  let t ← target
  let e ← equiv_rw_type e t cfg
  let s ← to_expr ``(Equiv.invFun $(e))
  tactic.eapply s
  skip
#align tactic.equiv_rw_target tactic.equiv_rw_target

end Tactic

namespace Tactic.Interactive

open Tactic

/- ./././Mathport/Syntax/Translate/Tactic/Mathlib/Core.lean:38:34: unsupported: setup_tactic_parser -/
/-- Auxiliary function to call `equiv_rw_hyp` on a `list pexpr` recursively. -/
unsafe def equiv_rw_hyp_aux (hyp : Name) (cfg : equiv_rw_cfg) (permissive : Bool := false) :
    List expr → itactic
  | [] => skip
  | e :: t => do
    if permissive then equiv_rw_hyp hyp e cfg <|> skip else equiv_rw_hyp hyp e cfg
    equiv_rw_hyp_aux t
#align tactic.interactive.equiv_rw_hyp_aux tactic.interactive.equiv_rw_hyp_aux

/-- Auxiliary function to call `equiv_rw_target` on a `list pexpr` recursively. -/
unsafe def equiv_rw_target_aux (cfg : equiv_rw_cfg) (permissive : Bool) : List expr → itactic
  | [] => skip
  | e :: t => do
    if permissive then equiv_rw_target e cfg <|> skip else equiv_rw_target e cfg
    equiv_rw_target_aux t
#align tactic.interactive.equiv_rw_target_aux tactic.interactive.equiv_rw_target_aux

/-- `equiv_rw e at h₁ h₂ ⋯`, where each `hᵢ : α` is a hypothesis, and `e : α ≃ β`,
will attempt to transport each `hᵢ` along `e`, producing a new hypothesis `hᵢ : β`,
with all occurrences of `hᵢ` in other hypotheses and the goal replaced with `e.symm hᵢ`.

`equiv_rw e` will attempt to transport the goal along an equivalence `e : α ≃ β`.
In its minimal form it replaces the goal `⊢ α` with `⊢ β` by calling `apply e.inv_fun`.

`equiv_rw [e₁, e₂, ⋯] at h₁ h₂ ⋯` is equivalent to
`{ equiv_rw [e₁, e₂, ⋯] at h₁, equiv_rw [e₁, e₂, ⋯] at h₂, ⋯ }`.

`equiv_rw [e₁, e₂, ⋯] at *` will attempt to apply `equiv_rw [e₁, e₂, ⋯]` on the goal
and on each expression available in the local context (except on the `eᵢ`s themselves),
failing silently when it can't. Failing on a rewrite for a certain `eᵢ` at a certain
hypothesis `h` doesn't stop `equiv_rw` from trying the other equivalences on the list
at `h`. This only happens for the wildcard location.

`equiv_rw` will also try rewriting under (equiv_)functors, so it can turn
a hypothesis `h : list α` into `h : list β` or
a goal `⊢ unique α` into `⊢ unique β`.

The maximum search depth for rewriting in subexpressions is controlled by
`equiv_rw e {max_depth := n}`.
-/
unsafe def equiv_rw (l : parse pexpr_list_or_texpr) (locat : parse location)
    (cfg : equiv_rw_cfg := { }) : itactic := do
  let es ← l.mapM fun e => to_expr e
  match locat with
    | loc.wildcard => do
      equiv_rw_target_aux cfg tt es
      let ctx ← local_context
      ctx fun e => if e ∈ es then skip else equiv_rw_hyp_aux e cfg tt es
      skip
    | loc.ns names => do
      names fun hyp' =>
          match hyp' with
          | some hyp => equiv_rw_hyp_aux hyp cfg ff es
          | none => equiv_rw_target_aux cfg ff es
      skip
#align tactic.interactive.equiv_rw tactic.interactive.equiv_rw

add_tactic_doc
  { Name := "equiv_rw"
    category := DocCategory.tactic
    declNames := [`tactic.interactive.equiv_rw]
    tags := ["rewriting", "equiv", "transport"] }

-- failed to format: unknown constant 'term.pseudo.antiquot'
/--
      Solve a goal of the form `t ≃ _`,
      by constructing an equivalence from `e : α ≃ β`.
      This is the same equivalence that `equiv_rw` would use to rewrite a term of type `t`.

      A typical usage might be:
      ```
      have e' : option α ≃ option β := by equiv_rw_type e
      ```
      -/
    unsafe
  def
    equiv_rw_type
    ( e : parse texpr ) ( cfg : equiv_rw_cfg := { } ) : itactic
    :=
      do
        let q( $ ( t ) ≃ _ ) ← target | fail "`equiv_rw_type` solves goals of the form `t ≃ _`."
          let e ← to_expr e
          tactic.equiv_rw_type e t cfg >>= tactic.exact
#align tactic.interactive.equiv_rw_type tactic.interactive.equiv_rw_type

add_tactic_doc
  { Name := "equiv_rw_type"
    category := DocCategory.tactic
    declNames := [`tactic.interactive.equiv_rw_type]
    tags := ["rewriting", "equiv", "transport"] }

end Tactic.Interactive


import pseudo_normed_group.LC
import analysis.normed.group.hom_completion

/-!

# V-hat(M_c^n)

One of the key players in the proof of the main theorem of this repo is
the normed group V-hat(M-bar_r'(S)_{≤c}^n). This file constructs

## Key defintions

- `CLCP V n`: the functor that sends a profinite set `S` to `V-hat(S^n)`
- `CLFCP v r' c n`: the functor sending a profinitely-filtered `T⁻¹`-module `M`
   to `V-hat((M_c)^n)`

-/
open_locale classical nnreal
noncomputable theory
local attribute [instance] type_pow

open SemiNormedGroup opposite Profinite pseudo_normed_group category_theory breen_deligne
open profinitely_filtered_pseudo_normed_group

universe variable u
variables (r : ℝ≥0) (V : SemiNormedGroup) (r' : ℝ≥0)
variables (c c₁ c₂ c₃ c₄ : ℝ≥0) (l m n : ℕ)

/-- `CLC V n` is the functor that sends a profinite set `S` to `V-hat(S^n)` -/
def CLC (V : SemiNormedGroup) : Profiniteᵒᵖ ⥤ SemiNormedGroup :=
LC V ⋙ Completion

namespace CLC

lemma map_norm_noninc {M₁ M₂} (f : M₁ ⟶ M₂) : ((CLC V).map f).norm_noninc :=
Completion.map_norm_noninc $ LC.map_norm_noninc _ _

def T [normed_with_aut r V] [fact (0 < r)] : CLC V ≅ CLC V :=
((whiskering_right _ _ _).obj _).map_iso (LC.T r V)

lemma norm_T_le [normed_with_aut r V] [fact (0 < r)] (A) : ∥(T r V).hom.app A∥ ≤ r :=
le_trans (normed_add_group_hom.norm_completion _).le $ LC.norm_T_le _ _ _

def T_inv [normed_with_aut r V] [fact (0 < r)] : CLC V ⟶ CLC V :=
whisker_right (LC.T_inv r V) Completion

lemma T_inv_eq [normed_with_aut r V] [fact (0 < r)] : (T r V).inv = T_inv r V := rfl

lemma norm_T_inv_le [normed_with_aut r V] [fact (0 < r)] (A) : ∥(T_inv r V).app A∥ ≤ r⁻¹ :=
le_trans (normed_add_group_hom.norm_completion _).le $ LC.norm_T_inv_le _ _ _

end CLC

/-- `CLFCP v r' c n` is the functor sending a profinitely-filtered `T⁻¹`-module `M`
   to `V-hat((M_c)^n)` -/
def CLCFP (V : SemiNormedGroup) (r' : ℝ≥0) (c : ℝ≥0) (n : ℕ) :
  (ProFiltPseuNormGrpWithTinv r')ᵒᵖ ⥤ SemiNormedGroup :=
(FiltrationPow r' c n).op ⋙ CLC V

theorem CLCFP_def (V : SemiNormedGroup) (r' : ℝ≥0) (c : ℝ≥0) (n : ℕ) :
  CLCFP V r' c n = LCFP V r' c n ⋙ Completion := rfl

namespace CLCFP

lemma map_norm_noninc {M₁ M₂} (f : M₁ ⟶ M₂) : ((CLCFP V r' c n).map f).norm_noninc :=
CLC.map_norm_noninc _ _

@[simps app]
def res [fact (c₂ ≤ c₁)] : CLCFP V r' c₁ n ⟶ CLCFP V r' c₂ n :=
(whisker_right (nat_trans.op $ FiltrationPow.cast_le r' c₂ c₁ n) (CLC V) : _)

lemma res_def [fact (c₂ ≤ c₁)] :
  res V r' c₁ c₂ n = whisker_right (nat_trans.op (FiltrationPow.cast_le r' c₂ c₁ n)) (CLC V) :=
rfl

lemma res_def' [fact (c₂ ≤ c₁)] (M : ProFiltPseuNormGrpWithTinv r') :
  (res V r' c₁ c₂ n).app (op M) =
  (CLC V).map ((Filtration.cast_le ((ProFiltPseuNormGrpWithTinv.Pow r' n).obj M) c₂ c₁)).op :=
rfl

lemma res_app' [fact (c₂ ≤ c₁)] (M : (ProFiltPseuNormGrpWithTinv r')ᵒᵖ) :
  (res V r' c₁ c₂ n).app M = (CLC V).map ((FiltrationPow.cast_le r' c₂ c₁ n).app (unop M)).op :=
rfl

@[simp] lemma res_refl : res V r' c c n = 𝟙 _ :=
by { rw [res, FiltrationPow.cast_le_refl, nat_trans.op_id, whisker_right_id'], refl }

lemma res_comp_res [fact (c₂ ≤ c₁)] [fact (c₃ ≤ c₂)] [fact (c₃ ≤ c₁)] :
  res V r' c₁ c₂ n ≫ res V r' c₂ c₃ n = res V r' c₁ c₃ n :=
by simp only [res, ← whisker_right_comp, FiltrationPow.cast_le_comp, ← nat_trans.op_comp]

lemma res_norm_noninc [fact (c₂ ≤ c₁)] (M) :
  ((res V r' c₁ c₂ n).app M).norm_noninc :=
Completion.map_norm_noninc $ LCFP.res_norm_noninc _ _ _ _ _ _

section Tinv
-- kmb commented out the next line
--open profinitely_filtered_pseudo_normed_group_with_Tinv
variables [fact (0 < r')] [fact (c₂ ≤ r' * c₁)]

-- @[simps obj {fully_applied := ff}]
def Tinv : CLCFP V r' c₁ n ⟶ CLCFP V r' c₂ n :=
(whisker_right (nat_trans.op $ FiltrationPow.Tinv r' c₂ c₁ n)
  (LocallyConstant.obj V ⋙ Completion) : _)
.

lemma Tinv_def : Tinv V r' c₁ c₂ n =
  (whisker_right (LCFP.Tinv V r' c₁ c₂ n) Completion : _) := rfl

lemma Tinv_def' : Tinv V r' c₁ c₂ n =
  whisker_right (nat_trans.op $ FiltrationPow.Tinv r' c₂ c₁ n) (CLC V) := rfl

lemma res_comp_Tinv [fact (c₂ ≤ c₁)] [fact (c₃ ≤ c₂)] [fact (c₃ ≤ r' * c₂)] :
  res V r' c₁ c₂ n ≫ Tinv V r' c₂ c₃ n = Tinv V r' c₁ c₂ n ≫ res V r' c₂ c₃ n :=
begin
  dsimp only [Tinv, res, CLC, LC],
  simp only [← whisker_right_comp, ← nat_trans.op_comp],
  refl
end

end Tinv

section T_inv

variables [normed_with_aut r V] [fact (0 < r)]

@[simps {fully_applied := ff}]
def T : CLCFP V r' c n ≅ CLCFP V r' c n :=
((whiskering_left _ _ _).obj (FiltrationPow r' c n).op).map_iso (CLC.T r V)

@[simps app_apply {fully_applied := ff}]
def T_inv : CLCFP V r' c n ⟶ CLCFP V r' c n :=
whisker_left (FiltrationPow r' c n).op (CLC.T_inv r V)

lemma T_inv_eq [normed_with_aut r V] [fact (0 < r)] : (T r V r' c n).inv = T_inv r V r' c n := rfl

lemma T_inv_def : T_inv r V r' c n = (whisker_right (LCFP.T_inv r V r' c n) Completion : _) :=
rfl

lemma T_inv_app [fact (0 < r)] (M : (ProFiltPseuNormGrpWithTinv r')ᵒᵖ) :
  (T_inv r V r' c n).app M =
    (CLC.T_inv r V).app ((FiltrationPow r' c n).op.obj M) :=
rfl

lemma res_comp_T_inv [fact (c₂ ≤ c₁)] :
  res V r' c₁ c₂ n ≫ T_inv r V r' c₂ n =
    T_inv r V r' c₁ n ≫ res V r' c₁ c₂ n :=
begin
  ext M : 2,
  simp only [nat_trans.comp_app, res_app', T_inv_app],
  exact (CLC.T_inv r V).naturality _,
end

end T_inv

end CLCFP

namespace breen_deligne

open CLCFP
variables {l m n}

namespace universal_map

variables (ϕ ψ : universal_map m n)

def eval_CLCFP [ϕ.suitable c₂ c₁] : CLCFP V r' c₁ n ⟶ CLCFP V r' c₂ m :=
(whisker_right (ϕ.eval_LCFP V r' c₁ c₂) Completion : _)

lemma eval_CLCFP_of (f : basic_universal_map m n) [f.suitable c₂ c₁] :
  eval_CLCFP V r' c₁ c₂ (free_abelian_group.of f) =
  (whisker_right (nat_trans.op $ f.eval_FP r' c₂ c₁) (CLC V)) :=
by { rw [eval_CLCFP, eval_LCFP_of, basic_universal_map.eval_LCFP, whisker_right_twice], refl }

@[simp] lemma eval_CLCFP_zero :
  (0 : universal_map m n).eval_CLCFP V r' c₁ c₂ = 0 :=
begin
  simp only [eval_CLCFP, eval_LCFP_zero],
  ext x : 2,
  exact Completion.map_zero _ _
end

@[simp] lemma eval_CLCFP_add [ϕ.suitable c₂ c₁] [ψ.suitable c₂ c₁] :
  (ϕ + ψ : universal_map m n).eval_CLCFP V r' c₁ c₂ =
  ϕ.eval_CLCFP V r' c₁ c₂ + ψ.eval_CLCFP V r' c₁ c₂ :=
begin
  simp only [eval_CLCFP, eval_LCFP_add],
  ext x : 2,
  exact Completion.map_add
end

@[simp] lemma eval_CLCFP_sub [ϕ.suitable c₂ c₁] [ψ.suitable c₂ c₁] :
  (ϕ - ψ : universal_map m n).eval_CLCFP V r' c₁ c₂ =
  ϕ.eval_CLCFP V r' c₁ c₂ - ψ.eval_CLCFP V r' c₁ c₂ :=
begin
  simp only [eval_CLCFP, eval_LCFP_sub],
  ext x : 2,
  exact Completion.map_sub
end

open category_theory.limits

lemma eval_CLCFP_comp (g : universal_map m n) (f : universal_map l m)
  [hg : g.suitable c₂ c₁] [hf : f.suitable c₃ c₂] :
  @eval_CLCFP V r' c₁ c₃ _ _ (comp g f) (suitable.comp c₂) =
    g.eval_CLCFP V r' c₁ c₂ ≫ f.eval_CLCFP V r' c₂ c₃ :=
by simp only [eval_CLCFP, ← whisker_right_comp, eval_LCFP_comp V r' c₁ c₂ c₃]

lemma res_comp_eval_CLCFP
  [fact (c₂ ≤ c₁)] [ϕ.suitable c₄ c₂] [ϕ.suitable c₃ c₁] [fact (c₄ ≤ c₃)] :
  res V r' c₁ c₂ n ≫ ϕ.eval_CLCFP V r' c₂ c₄ =
    ϕ.eval_CLCFP V r' c₁ c₃ ≫ res V r' c₃ c₄ m :=
by { dsimp only [CLC, res], simp only [eval_CLCFP, ← whisker_right_comp, ← whisker_right_twice],
     congr' 1, apply res_comp_eval_LCFP }

lemma Tinv_comp_eval_CLCFP [fact (0 < r')] [fact (c₂ ≤ r' * c₁)] [fact (c₄ ≤ r' * c₃)]
  [ϕ.suitable c₃ c₁] [ϕ.suitable c₄ c₂] :
  Tinv V r' c₁ c₂ n ≫ ϕ.eval_CLCFP V r' c₂ c₄ =
    ϕ.eval_CLCFP V r' c₁ c₃ ≫ Tinv V r' c₃ c₄ m :=
by simp only [eval_CLCFP, Tinv_def, ← whisker_right_comp]; congr' 1; apply Tinv_comp_eval_LCFP

lemma T_inv_comp_eval_CLCFP [normed_with_aut r V] [fact (0 < r)] [ϕ.suitable c₂ c₁] :
  T_inv r V r' c₁ n ≫ ϕ.eval_CLCFP V r' c₁ c₂ =
    ϕ.eval_CLCFP V r' c₁ c₂ ≫ T_inv r V r' c₂ m :=
by simp only [eval_CLCFP, T_inv_def, ← whisker_right_comp, T_inv_comp_eval_LCFP]

lemma norm_eval_CLCFP_le [normed_with_aut r V] [fact (0 < r)] [ϕ.suitable c₂ c₁]
  (N : ℕ) (h : ϕ.bound_by N) (M) :
  ∥(ϕ.eval_CLCFP V r' c₁ c₂).app M∥ ≤ N :=
le_trans (normed_add_group_hom.norm_completion _).le $ norm_eval_LCFP_le _ _ _ _ _ _ _ h _

end universal_map

end breen_deligne


/-
Copyright (c) 2021-2022 Julien Marquet. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Julien Marquet
-/

import Lean

import Flows.Groundwork
import Flows.SolveSets
import Flows.Term
import Flows.Subst
import Flows.Vehicle
import Flows.Vanishing
import Flows.Unifier

open Classical

set_option codegen false

universe u

section

theorem cons_carrier_in {θ φ : Subst α β} {l₁ r₁ l₂ r₂ : Term α β}
  (h₁ : (𝒱 θ : Fintype β) ⊆ 𝒱 l₁ ∪ 𝒱 l₂)
  (h₂ : (𝒱 φ : Fintype β) ⊆ 𝒱 (r₁ • θ) ∪ 𝒱 (r₂ • θ))
  (h₃ : vanishing θ) (h₄ : vanishing φ)
  (h₅ : carrier θ ⊆ 𝒱 l₁ ∪ 𝒱 l₂) (h₆ : carrier φ ⊆ 𝒱 (r₁ • θ) ∪ 𝒱 (r₂ • θ)) :
  carrier (θ * φ) ⊆ 𝒱 (Term.Cons l₁ r₁) ∪ 𝒱 (Term.Cons l₂ r₂) := by
  apply Fintype.included_trans (carrier_cons _ _)
  simp only [vehicle_cons]
  rw [Fintype.union_assoc]
  apply Fintype.union_included_iff.2 (And.intro _ _)
  focus
    apply Fintype.included_trans h₅
    solve_sets
  focus
    apply Fintype.included_trans h₆
    apply Fintype.union_included_iff.2 ⟨ _, _ ⟩
      <;> apply Fintype.included_trans (vehicle_on_image h₁ _)
      <;> solve_sets

end

section

theorem lex_of_le_and_lt {α β : Type u}
  {ha : WellFoundedRelation α} {hb : WellFoundedRelation β}
  {a₁ a₂ : α} {b₁ b₂ : β} (h₁ : ha.rel a₁ a₂ ∨ a₁ = a₂) (h₂ : hb.rel b₁ b₂) :
  (Prod.lex ha hb).rel (a₁, b₁) (a₂, b₂) := by
  cases h₁ with
  | inl h₁ =>
    apply Prod.Lex.left
    exact h₁
  | inr h₁ =>
    rw [h₁]
    apply Prod.Lex.right
    exact h₂

end

section

variable {α β : Type u}

private theorem flush_add_left (a : Nat) {b c : Nat} : b + c + a = b + a + c := by
  simp only [Nat.add_assoc]
  rw [Nat.add_comm a c]

theorem mass_lower_bound {x : β} {v : Term α β} (h : Term.Var x ≠ v) (u : Term α β)
  (θ : Subst α β) : mass u + weight x u * mass (v • θ) ≤ mass (u • (Subst.elementary h * θ)) := by
  induction u with
  | Cst c => match θ with
    | ⟨ θ, _ ⟩ =>
      suffices p : ∀ n, 0 + 0 * n ≤ 0 from p (mass (map_reduce θ v))
      intros; simp
  | Var y => match θ with
    | ⟨ θ, _ ⟩ =>
      by_cases p : x = y
        <;> simp [mass, weight, RSMul.smul, map_reduce, Subst.elementary, HMul.hMul, Mul.mul, comp, p]
      rw [Nat.one_mul]
      exact Nat.le.refl
      simp [Ne.symm p, map_reduce, Nat.zero_le]
  | Cons l r hl hr =>
    simp only [mass, weight, subst_cons]
    simp only [Nat.left_distrib, Nat.right_distrib, ← Nat.add_assoc]
    simp only [flush_add_left ((weight x r) * mass (v • θ))]
    simp only [flush_add_left (mass r)]
    simp only [flush_add_left ((weight x l) * mass (v • θ))]
    simp only [flush_add_left (mass l)]
    apply Nat.succ_le_succ
    rw [Nat.add_assoc]
    exact Nat.le_of_le_of_le hl hr

theorem weight_nonzero_of_mem_vehicle {x : β} {u : Term α β} (h : x ∈ (𝒱 u : Fintype β)) :
  weight x u ≠ 0 := by
  induction u with
  | Cst _ => exact False.elim <| Fintype.not_mem_empty _ h
  | Var y =>
    suffices p : x = y by
      rw [p]
      simp [weight]
    cases h <;> trivial
  | Cons l r hl hr =>
    simp only [weight]
    rw [vehicle_cons, Fintype.mem_union_iff] at h
    cases h with
    | inl h => exact Nat.add_ne_zero_of_l_ne_zero <| hl h
    | inr h => exact Nat.add_ne_zero_of_r_ne_zero <| hr h

end

section

variable {α β : Type u} [Monoid α]

theorem smul_cons_eq {l r : Term α β} {θ : Subst α β} :
  (Term.Cons l r) • θ = (Term.Cons (l • θ) (r • θ)) :=
  match θ with
  | ⟨ θ, hθ ⟩ => rfl

private theorem cons_mgu {l₁ r₁ l₂ r₂ : Term α β} {θ φ : Subst α β}
  (θ_mgu : is_mgu _ l₁ l₂ θ) (φ_mgu : is_mgu _ (r₁ • θ) (r₂ • θ) φ) :
  is_mgu _ (Term.Cons l₁ r₁) (Term.Cons l₂ r₂) (θ * φ) := by
  apply mgu_of_unifies_and_most_general
  focus
    simp [smul_cons_eq, ← RAction.smul_mul,
      unifies_of_mgu θ_mgu, unifies_of_mgu φ_mgu]
  focus
    intro
    simp [smul_cons_eq]
    intro ⟨ h₁, h₂ ⟩
    let ⟨ ρ₁, hρ₁ ⟩ := most_general_of_mgu θ_mgu h₁
    rw [← hρ₁, ← RAction.smul_mul, ← RAction.smul_mul] at h₂
    let ⟨ ρ₂, hρ₂ ⟩ := most_general_of_mgu φ_mgu h₂
    exact ⟨ ρ₂, (Monoid.mul_assoc _ _ _ ▸ hρ₂ ▸ hρ₁ ▸ rfl) ⟩

private def rel : WellFoundedRelation (Term α β × Term α β) :=
  invImage (λ (u, v) => ((𝒱 u ∪ 𝒱 v : Fintype β), (u, v)))
  <| Prod.lex
    (Fintype.included_wfRel)
    (Prod.rprod Term.mass_wfRel Term.mass_wfRel)

abbrev P (x : Option (Subst α β)) (u v : Term α β) := match x with
  | none => strangers (Subst α β) u v
  | some θ => is_mgu _ u v θ
      ∧ (𝒱 θ : Fintype β) ⊆ 𝒱 u ∪ 𝒱 v
      ∧ vanishing θ
      ∧ carrier θ ⊆ 𝒱 u ∪ 𝒱 v

private def P_comm (u v : Term α β)
  : { x // P x u v } → { x // P x v u } := by
  intro ⟨ x, h ⟩
  apply Subtype.mk x
  match x with
  | none =>
    simp_all only [strangers_iff_no_unifier]
    intro θ h'
    exact h θ h'.symm
  | some θ =>
    let ⟨ θ_mgu, θ_vehicle, θ_vanishing, θ_carrier ⟩ := h
    apply And.intro _ (And.intro _ (And.intro _ _))
    focus
      simp only [is_mgu]
      suffices p : unifiers (Subst α β) v u = unifiers (Subst α β) u v by
        rw [p]
        exact θ_mgu
      funext φ
      simp [unifiers]
      apply propext
      apply Iff.intro
      intro h; rw [h]
      intro h; rw [h]
    focus
      rw [Fintype.union_comm]
      exact θ_vehicle
    focus
      exact θ_vanishing
    focus
      rw [Fintype.union_comm]
      exact θ_carrier

private theorem decr_left (l₁ r₁ l₂ r₂ : Term α β) :
  rel.rel (l₁, l₂) (Term.Cons l₁ r₁, Term.Cons l₂ r₂) := by
  simp [rel, invImage, InvImage]
  apply lex_of_le_and_lt
  focus
    simp [invImage, InvImage, Fintype.included_wfRel]
    simp only [WellFoundedRelation.rel]
    simp only [vehicle_cons]
    suffices h : (𝒱 l₁ ∪ 𝒱 l₂ : Fintype β)
      ⊆ 𝒱 (Term.Cons l₁ r₁) ∪ 𝒱 (Term.Cons l₂ r₂) by
      by_cases p : (𝒱 l₁ ∪ 𝒱 l₂ : Fintype β)
        = 𝒱 (Term.Cons l₁ r₁) ∪ 𝒱 (Term.Cons l₂ r₂)
      exact Or.inr p
      exact Or.inl ⟨ h, p ⟩
    simp only [vehicle_cons]
    solve_sets
  focus
    exact Prod.RProd.intro (mass_decr_l _ _) (mass_decr_l _ _)

private theorem decr_right (l₁ r₁ l₂ r₂ : Term α β) {θ : Subst α β}
  (θ_vehicle : (𝒱 θ : Fintype β) ⊆ 𝒱 l₁ ∪ 𝒱 l₂)
  (θ_vanishing : vanishing θ) (θ_carrier : carrier θ ⊆ 𝒱 l₁ ∪ 𝒱 l₂) :
  rel.rel (r₁ • θ, r₂ • θ) (Term.Cons l₁ r₁, Term.Cons l₂ r₂) := by
  by_cases h : θ = 1
  focus
    rw [h, RAction.smul_one, RAction.smul_one]
    apply lex_of_le_and_lt
    focus
      simp [invImage, InvImage, Fintype.included_wfRel]
      suffices h : (𝒱 r₁ ∪ 𝒱 r₂ : Fintype β)
        ⊆ 𝒱 (Term.Cons l₁ r₁) ∪ 𝒱 (Term.Cons l₂ r₂) by
        by_cases p : (𝒱 r₁ ∪ 𝒱 r₂ : Fintype β)
          = 𝒱 (Term.Cons l₁ r₁) ∪ 𝒱 (Term.Cons l₂ r₂)
        exact Or.inr p
        exact Or.inl ⟨ h, p ⟩
      simp only [vehicle_cons]
      solve_sets
    focus
      exact Prod.RProd.intro (mass_decr_r _ _) (mass_decr_r _ _)
  focus
    apply Prod.Lex.left
    apply And.intro
    focus
      simp only [vehicle_cons]
      apply Fintype.union_included_iff.2 <| And.intro _ _
      focus
        apply Fintype.included_trans (vehicle_on_image Fintype.included_refl r₁)
        apply Fintype.union_included_iff.2
          <| And.intro (Fintype.included_trans θ_vehicle _) _
          <;> solve_sets
      focus
        apply Fintype.included_trans (vehicle_on_image Fintype.included_refl r₂)
        apply Fintype.union_included_iff.2 <| And.intro (Fintype.included_trans θ_vehicle _) _
          <;> solve_sets
    focus
      let ⟨ x, hx ⟩ := (not_one_iff_modifying θ).1 h
      let not_in_r₁ := vanishing_on_term θ_vanishing hx r₁
      let not_in_r₂ := vanishing_on_term θ_vanishing hx r₂
      let not_in_lhs : ¬ x ∈ (𝒱 (r₁ • θ) ∪ 𝒱 (r₂ • θ) : Fintype β) :=
        λ h => match (Fintype.mem_union_iff _ _ _).1 h with
          | Or.inl h => not_in_r₁ h
          | Or.inr h => not_in_r₂ h
      let in_rhs : x ∈ (𝒱 (Term.Cons l₁ r₁) ∪ 𝒱 (Term.Cons l₂ r₂) : Fintype β) := by
        simp only [vehicle_cons]
        have p := carrier_spec.2 hx
        rw [Fintype.mem_iff_singleton_included]
        rw [Fintype.mem_iff_singleton_included] at p
        apply Fintype.included_trans p
        apply Fintype.included_trans θ_carrier
        solve_sets
      exact Fintype.different_if_not_same_element not_in_lhs in_rhs

private theorem prepend_elementary_on_variable_unifier {x : β} {u : Term α β} {θ : Subst α β}
  (h : Term.Var x ≠ u) (h' : (Term.Var x : Term α β) • θ = u • θ) :
  θ = (Subst.elementary h) * θ := by
  apply Subst.ext.2
  intro y
  rw [← RAction.smul_mul]
  by_cases p : y = x
  focus
    rw [p, h', Subst.elementary_spec₁]
  focus
    rw [Subst.elementary_spec₂]
    exact p

private def unify_variable_of_not_in_vehicle {x : β} {u : Term α β}
  (h : ¬ x ∈ (𝒱 u : Fintype β)) : { e : Option (Subst α β) // P e (Term.Var x) u } :=
  let x_ne_u := (show Term.Var x ≠ u by
    intro h'
    rw [← h'] at h
    apply h
    apply List.Mem.head);
  ⟨ some (Subst.elementary x_ne_u), by
  apply And.intro (mgu_of_unifies_and_most_general _ _)
    (And.intro _ (And.intro _ _))
  focus
    rw [Subst.elementary_spec₁ x_ne_u]
    rw [elementary_on_not_in_vehicle]
    exact h
  focus
    intro θ hθ
    apply Exists.intro θ
    exact Eq.symm <| prepend_elementary_on_variable_unifier x_ne_u hθ
  focus
    rw [vehicle_elementary]
    apply Fintype.included_union_l _ <| Fintype.included_refl
  focus
    apply elementary_vanishing
    exact h
  focus
    rw [elementary_carrier]
    exact Fintype.included_union_r _ <| Fintype.included_refl ⟩

-- Clearly not well written, I sould automate this...
-- But since I don't do a lot of calculus in the proofs here, I don't feel the need
-- to spend time writing tactics for numbers.
private theorem variable_stranger_of_in_vehicle {x : β} {u : Term α β}
  (h₁ : mass u ≠ 0) (h₂ : x ∈ (𝒱 u : Fintype β)) :
  strangers (Subst α β) (Term.Var x) u := by
  have x_ne_u : Term.Var x ≠ u := by
    intro h
    apply h₁
    rw [← h]
    rfl
  rw [strangers_iff_no_unifier]
  intro θ h
  have p := prepend_elementary_on_variable_unifier x_ne_u h
  conv at h => rhs; rw [p]
  have p' := mass_lower_bound x_ne_u u θ
  conv at p' => rhs; rw [← p]
  have p'' := Nat.mul_le_mul_right (mass (u • θ))
    <| Nat.one_le_of_ne_zero
    <| weight_nonzero_of_mem_vehicle h₂
  rw [Nat.one_mul] at p''
  have p₄ := Nat.le_trans p' p''
  have p₅ : mass u = 0 := by
    apply byContradiction
    intro h
    have p := Nat.lt_of_succ_le <| Nat.one_le_of_ne_zero h
    have p' := Nat.add_lt_add_right p (weight x u * mass (u • θ))
    have p''' := Nat.lt_of_lt_of_le p' p₄
    rw [Nat.zero_add] at p'''
    exact False.elim <| Nat.not_lt_self _ p'''
  exact h₁ p₅

theorem strangers_of_left_strangers {l₁ r₁ l₂ r₂ : Term α β} (h : strangers (Subst α β) l₁ l₂) :
  strangers (Subst α β) (Term.Cons l₁ r₁) (Term.Cons l₂ r₂) := by
  apply strangers_iff_no_unifier.2
  intro θ h'
  apply strangers_iff_no_unifier.1 h θ
  simp only [subst_cons] at h'
  apply Term.noConfusion h'
  exact λ h _ => h

theorem strangers_of_right_strangers {l₁ r₁ l₂ r₂ : Term α β} {θ : Subst α β}
  (θ_mgu : is_mgu _ l₁ l₂ θ) (h : strangers (Subst α β) (r₁ • θ) (r₂ • θ)) :
  strangers (Subst α β) (Term.Cons l₁ r₁) (Term.Cons l₂ r₂) := by
  apply strangers_iff_no_unifier.2
  intro φ h'
  suffices h' : l₁ • φ = l₂ • φ ∧ r₁ • φ = r₂ • φ by
    let ⟨ ρ, hρ ⟩ := most_general_of_mgu θ_mgu h'.1
    apply strangers_iff_no_unifier.1 h ρ
    simp only [RAction.smul_mul, hρ]
    exact h'.2
  simp only [subst_cons] at h'
  apply And.intro <;> apply Term.noConfusion h'
    <;> intros
          <;> assumption

namespace Robinson

def unify_same {u v : Term α β} (h : u = v) : { e // P e u v } := by
  apply Subtype.mk (some 1)
  rw [← h]
  apply And.intro _ (And.intro _ (And.intro _ _))
  focus
    funext θ
    apply propext
    suffices p : ∃ ρ, 1 * ρ = θ by
      simp_all [unifiers, generated_by]
    apply Exists.intro θ
    exact Monoid.one_mul _
  focus
    rw [vehicle_one]
    exact Fintype.empty_included _
  focus
    exact λ h => False.elim (h rfl)
  focus
    rw [is_one_iff_empty_carrier.1 rfl]
    apply Fintype.empty_included _

def unify_var_cons (x : β) (l r : Term α β) :
  { e : Option (Subst α β) // P e (Term.Var x) (Term.Cons l r)} :=
  if p : x ∈ (𝒱 (Term.Cons l r) : Fintype β) then ⟨ none, by
    apply variable_stranger_of_in_vehicle _ p
    apply Ne.symm ∘ Nat.ne_of_lt
      <| Nat.lt_of_lt_of_le (Nat.zero_lt_one) (Nat.le_add_left _ _) ⟩
  else unify_variable_of_not_in_vehicle p

def unify_var_var (x y : β) :
  { e : Option (Subst α β) // P e (Term.Var x) (Term.Var y)} :=
  if p : x = y then unify_same (by rw [p])
  else by
    have p' : (Term.Var x : Term α β) ≠ Term.Var y :=
      λ h => p <| Term.noConfusion h id
    apply unify_variable_of_not_in_vehicle
    intro h; apply p; cases h <;> trivial

def unify_var_cst (x : β) (c : α) :
  { e : Option (Subst α β) // P e (Term.Var x) (Term.Cst c) } := by
  have p' : (Term.Var x : Term α β) ≠ Term.Cst c := by
    intro h
    apply Term.noConfusion h
  apply unify_variable_of_not_in_vehicle
  intro h; cases h <;> trivial

def unify_cst_cons (c : α) (l r : Term α β) :
  { e : Option (Subst α β) // P e (Term.Cst c) (Term.Cons l r) } :=
  ⟨ none, by
  apply strangers_iff_no_unifier.2
  intro ⟨ θ, _ ⟩ h
  apply Term.noConfusion h ⟩

def unify_cst_cst (a b : α) :
  { e : Option (Subst α β) // P e (Term.Cst a) (Term.Cst b)} :=
  if p : a = b then unify_same (by rw [p])
  else by
    apply Subtype.mk none
    apply strangers_iff_no_unifier.2
    exact λ θ h => p <| match θ with
    | ⟨ _, _ ⟩ => Term.noConfusion h id

def robinson (u v : Term α β) : { e // P e u v } := match u, v with
  | Term.Cons l₁ r₁, Term.Cons l₂ r₂ =>
    match robinson l₁ l₂ with
    | ⟨ none, h ⟩ => ⟨ none, strangers_of_left_strangers h ⟩
    | ⟨ some θ, θ_mgu, θ_vehicle, θ_vanishing, θ_carrier ⟩ =>
      match robinson (r₁ • θ) (r₂ • θ) with
      | ⟨ none, h ⟩ => ⟨ none, strangers_of_right_strangers θ_mgu h ⟩
      | ⟨ some φ, φ_mgu, φ_vehicle, φ_vanishing, φ_carrier ⟩ =>
        ⟨ some (θ * φ),
          cons_mgu θ_mgu φ_mgu,
          cons_vehicle_in θ_vehicle φ_vehicle,
          cons_vanishing θ_vehicle φ_vehicle θ_vanishing φ_vanishing,
          cons_carrier_in θ_vehicle φ_vehicle θ_vanishing φ_vanishing θ_carrier φ_carrier ⟩
  | Term.Var x, Term.Cons l r =>
    unify_var_cons _ _ _
  | Term.Cons l r, Term.Var x =>
    P_comm _ _ <| unify_var_cons _ _ _
  | Term.Var x, Term.Var y =>
    unify_var_var _ _
  | Term.Var x, Term.Cst c =>
    unify_var_cst _ _
  | Term.Cst c, Term.Var x =>
    P_comm _ _ <| unify_var_cst _ _
  | Term.Cst c, Term.Cons l r =>
    unify_cst_cons _ _ _
  | Term.Cons l r, Term.Cst c =>
    P_comm _ _ <| unify_cst_cons _ _ _
  | Term.Cst a, Term.Cst b =>
    unify_cst_cst _ _
termination_by' invImage (λ ⟨ u, v ⟩ => (u, v)) rel
decreasing_by
  first
    | exact decr_left _ _ _ _
    | apply decr_right <;> assumption

end Robinson

def robinson (u v : Term α β) := (Robinson.robinson u v).1

theorem robinson_eq (u v : Term α β) : robinson u v = match u, v with
  | Term.Cons l₁ r₁, Term.Cons l₂ r₂ =>
    match robinson l₁ l₂ with
    | none => none
    | some θ => match robinson (r₁ • θ) (r₂ • θ) with
      | none => none
      | some φ => some (θ * φ)
  | Term.Var x, Term.Cons l r =>
    if p : x ∈ (𝒱 (Term.Cons l r) : Fintype β) then none
    else subst_simple x (Term.Cons l r)
  | Term.Cons l r, Term.Var x =>
    if p : x ∈ (𝒱 (Term.Cons l r) : Fintype β) then none
    else subst_simple x (Term.Cons l r)
  | Term.Var x, Term.Var y => some (subst_simple x (Term.Var y))
  | Term.Var x, Term.Cst c => some (subst_simple x (Term.Cst c))
  | Term.Cst c, Term.Var x => some (subst_simple x (Term.Cst c))
  | Term.Cst c, Term.Cons l r => none
  | Term.Cons l r, Term.Cst c => none
  | Term.Cst a, Term.Cst b => if a = b then some 1 else none
  := match u, v with
  | Term.Cons l₁ r₁, Term.Cons l₂ r₂ => by
    simp only []
    conv => lhs; rw [robinson]; unfold Robinson.robinson
    conv => rhs; rw [robinson]
    simp only []
    let o := Robinson.robinson l₁ l₂
    rw [show Robinson.robinson l₁ l₂ = o from rfl]
    match o with
    | Subtype.mk none h => simp only []
    | ⟨ (some θ), _, _, _, _ ⟩ =>
      simp only []
      rw [robinson]
      let o' := Robinson.robinson (r₁ • θ) (r₂ • θ)
      rw [show Robinson.robinson (r₁ • θ) (r₂ • θ) = o' from rfl]
      match o' with
      | ⟨ none, _ ⟩ => simp
      | ⟨ some φ, _, _, _, _ ⟩ => simp
  | Term.Var x, Term.Cons l r => by
    rw [robinson, Robinson.robinson, Robinson.unify_var_cons]
    by_cases p : x ∈ (𝒱 (Term.Cons l r) : Fintype β)
    simp [p]
    simp [subst_simple, p, unify_variable_of_not_in_vehicle]
  | Term.Cons l r, Term.Var x => by
    rw [robinson, Robinson.robinson, Robinson.unify_var_cons]
    by_cases p : x ∈ (𝒱 (Term.Cons l r) : Fintype β)
    simp only [p]
    simp [P_comm]
    simp only [p]
    simp [P_comm, subst_simple, unify_variable_of_not_in_vehicle]
  | Term.Var x, Term.Var y => by
    rw [robinson, Robinson.robinson, Robinson.unify_var_var]
    by_cases p : x = y
    simp [p, subst_simple, Robinson.unify_same]
    simp [p, subst_simple, unify_variable_of_not_in_vehicle]
  | Term.Var x, Term.Cst c => by
    rw [robinson, Robinson.robinson]
    simp [subst_simple, Robinson.unify_var_cst, unify_variable_of_not_in_vehicle]
  | Term.Cst c, Term.Var x => by
    rw [robinson, Robinson.robinson, P_comm]
    simp [subst_simple, Robinson.unify_var_cst, unify_variable_of_not_in_vehicle]
  | Term.Cst c, Term.Cons l r => by
    simp [robinson, Robinson.robinson, Robinson.unify_cst_cons]
  | Term.Cons l r, Term.Cst c => by
    simp [robinson, Robinson.robinson, P_comm, Robinson.unify_cst_cons]
  | Term.Cst a, Term.Cst b => by
    rw [robinson, Robinson.robinson, Robinson.unify_cst_cst]
    by_cases p : a = b
    simp [p]
    rw [Robinson.unify_same]
    simp [p]

theorem robinson_spec (u v : Term α β) :
  match robinson u v with
  | none => strangers (Subst α β) u v
  | some θ => is_mgu _ u v θ := by
  rw [robinson]
  exact match Robinson.robinson u v with
  | ⟨ none, h ⟩ => h
  | ⟨ some _, h, _ ⟩ => h

theorem herbrand (u v : Term α β) :
  strangers (Subst α β) u v ∨ ∃ θ : Subst α β, is_mgu _ u v θ :=
  match Robinson.robinson u v with
  | ⟨ none, p ⟩ => Or.inl p
  | ⟨ some θ, p, _ ⟩ => Or.inr ⟨ θ, p ⟩

example : robinson (Term.Cons (Term.Var 0) (Term.Var 0) : Term Nat Nat)
  (Term.Cons (Term.Var 0) (Term.Var 0) : Term Nat Nat) = some 1 := by
  repeat rw [robinson_eq]; simp

example : robinson (Term.Cons (Term.Var 0) (Term.Var 0) : Term Nat Nat)
  (Term.Cons (Term.Var 1) (Term.Var 1) : Term Nat Nat) =
  some (subst_simple 0 (Term.Var 1)) := by
  repeat rw [robinson_eq]; simp

end


theorem ex1 (n m : Nat) (f : Nat → Nat) : some n = some m → f n = f m := by
  intro h
  injection h with h
  rw [h]


/-
Copyright (c) 2015 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura, Mario Carneiro
-/
import data.tree
import data.sign
import data.finmap
import logic.equiv.basic
import tactic.ring
import tactic.zify
import tree
import misc

/-!
# Encodable types using trees

This file defines encodings to `unit_tree` rather than `ℕ`.
This is especially useful for encoding tree-like data
naturally.

TODO: the `encoding`'s used in `src/computability` should be to trees.

## Main declarations

* `tencodable α`: States that there exists an explicit encoding function `encode : α → unit_tree`
   with a partial inverse `decode : unit_tree → option α`.

-/
open tree
open_locale tree

/-- Encoding of a type into a tree structure -/
class tencodable (α : Type*) :=
(encode : α → tree unit)
(decode [] : tree unit → option α)
(encodek : ∀ a, decode (encode a) = some a)

attribute [simp, higher_order] tencodable.encodek

namespace tencodable
variables {α β : Type*} [tencodable α] [tencodable β]

theorem encode_injective : function.injective (@encode α _)
| x y e := option.some.inj $ by rw [← encodek, e, encodek]

@[simp] lemma encode_inj {a b : α} : encode a = encode b ↔ a = b :=
encode_injective.eq_iff

/-- Any tencodable element has decidable equality by checking if the encodings are equal -/
def decidable_eq_of_encodable (α) [tencodable α] : decidable_eq α
| a b := decidable_of_iff _ encode_inj

/-- If `α` is encodable and there is an injection `f : β → α`, then `β` is encodable as well. -/
def of_left_injection {β} (f : β → α) (finv : α → option β) (linv : ∀ b, finv (f b) = some b) :
  tencodable β :=
⟨λ b, encode (f b),
 λ n, (decode α n).bind finv,
 λ b, by simp [linv]⟩

/-- If `α` is encodable and `f : β → α` is invertible, then `β` is encodable as well. -/
def of_left_inverse {β} (f : β → α) (finv : α → β) (linv : ∀ b, finv (f b) = b) : tencodable β :=
of_left_injection f (some ∘ finv) (λ b, congr_arg some (linv b))

/-- Encodability is preserved by equivalence. -/
def of_equiv {β} (α) [tencodable α] (e : β ≃ α) : tencodable β :=
of_left_inverse e e.symm e.left_inv

instance _root_.unit_tree.tencodable : tencodable (tree unit) :=
{ encode := id,
  decode := some,
  encodek := λ _, rfl }

@[simp] lemma encode_unit_tree (x : tree unit) : encode x = x := rfl
@[simp] lemma decode_unit_tree (x : tree unit) : decode (tree unit) x = some x := rfl

@[priority 100] instance _root_.is_empty.to_tencodable {α} [is_empty α] : tencodable α :=
⟨is_empty_elim, λ n, none, is_empty_elim⟩

instance _root_.punit.tencodable : tencodable punit :=
⟨λ_, nil, λ _, some punit.star, λ _, by simp⟩

lemma encode_star : encode punit.star = nil := rfl

section prod

instance (β : α → Type*) [∀ i, tencodable (β i)] : tencodable (sigma β) :=
{ encode := λ x, (encode x.1) △ (encode x.2),
  decode := λ x, (decode α x.left).bind $ λ a, (decode (β a) x.right).bind $ λ b, some ⟨a, b⟩,
  encodek := λ x, by cases x; simp }

/-- Encoding of a pair of encodable elements -/
instance _root_.prod.tencodable : tencodable (α × β) :=
{ encode := λ x, (encode x.1) △ (encode x.2),
  decode := λ y, (decode α y.left).bind $ λ l, (decode β y.right).bind $ λ r, some (l, r),
  encodek := λ x, by simp }

lemma encode_prod (x : α) (y : β) : encode (x, y) = (encode x) △ (encode y) := rfl

lemma encode_sigma {β : α → Type*} [∀ i, tencodable (β i)] (x : α) (y : β x) : encode (⟨x, y⟩ : sigma β) = (encode x) △ (encode y) := rfl

end prod

section bool

abbreviation non_nil : tree unit := nil △ nil
@[simp] lemma non_nil_ne_nil : non_nil ≠ nil := by trivial

/-- Encoding of `bool` -/
instance _root_.bool.tencodable : tencodable bool :=
{ encode := λ b, cond b nil non_nil,
  decode := λ x, some (x = nil : bool),
  encodek := λ b, by cases b; simp }

lemma encode_tt : encode tt = nil := rfl
lemma encode_ff : encode ff = non_nil := rfl

end bool

section list

/-- Interpret a tree as a list of trees according to the left children
  of the nodes on the rightmost path-/
def as_list : tree unit → list (tree unit)
| nil := []
| (a △ b) := a :: as_list b

/-- Interpret a list of trees as a single tree -/
def of_list : list (tree unit) → tree unit
| [] := nil
| (x :: xs) := x △ (of_list xs)

/-- There is an equivalence between `unit_tree` and `list unit_tree`
  corresponding to taking all of the left children on nodes of the rightmost path.
  We use this to encode lists -/
def equiv_list : tree unit ≃ list (tree unit) :=
{ to_fun := as_list,
  inv_fun := of_list,
  left_inv := λ t, by induction t using tree.unit_rec_on; simp [as_list, of_list, *],
  right_inv := λ l, by induction l; simp [as_list, of_list, *] }

@[simp] lemma equiv_list_nil : equiv_list nil = [] := rfl
@[simp] lemma equiv_list_node (a b : tree unit) :
  equiv_list (a △ b) = a :: (equiv_list b) := rfl
@[simp] lemma equiv_list_symm_nil : equiv_list.symm [] = nil := rfl
@[simp] lemma equiv_list_symm_cons (a : tree unit) (b : list (tree unit)) :
  equiv_list.symm (a :: b) = a △ (equiv_list.symm b) := rfl

instance _root_.list.tencodable : tencodable (list α) :=
{ encode := λ l, equiv_list.symm (l.map encode),
  decode := λ t, ((equiv_list t).map (decode α)).all_some,
  encodek := λ l, by simp }

lemma encode_nil : encode (@list.nil α) = nil := rfl
lemma encode_cons (x : α) (xs : list α) : encode (x :: xs) = (encode x) △ (encode xs) := rfl

lemma encode_list_tree (x : list (tree unit)) : encode x = equiv_list.symm x :=
by simp [encode]

lemma decode_list_tree (x : tree unit) : decode _ x = some (equiv_list x) :=
by simp [decode]

end list

section nat

/-- This is a unary encoding for natural numbers. The canonical
  way of representing `n` is as n ↦ nil △ nil △ ... -/
instance _root_.nat.unary_tencodable : tencodable ℕ :=
{ encode := λ n, (equiv_list.symm $ list.repeat nil n),
  decode := λ t, some t.num_nodes,
  encodek := λ n, congr_arg some $ by induction n; simp [*] }

lemma encode_zero : encode 0 = nil := rfl
lemma encode_succ (n : ℕ) : encode (n + 1) = nil △ (encode n) := rfl
lemma encode_nat_eq_iterate (n : ℕ) :
  encode n = ((λ x, nil △ x)^[n] nil) :=
by { induction n; simp [*, function.iterate_succ', encode_zero, encode_succ], }

@[simp] lemma encode_num_nodes (n : ℕ) : (encode n).num_nodes = n :=
option.some_injective _ (tencodable.encodek n)

end nat

section option

/-- Encode an `option α`, using `nil` as `none` -/
@[simp] def of_option : option α → tree unit
| none := nil
| (some x) := nil △ (encode x)

/-- Decode an `option α` as a tree -/
@[simp] def to_option : tree unit → option (option α)
| nil := some none
| (x △ y) := (decode α y).map some

/-- Encoding of `option α` when `α` has an encoding -/
instance : tencodable (option α) :=
{ encode := of_option,
  decode := to_option,
  encodek := λ x, by cases x; simp [of_option, to_option] }

end option

section sum

/-- Encode a sum by using the left child of the root to signal if the right represents α or β -/
@[simp] def of_sum : α ⊕ β → tree unit
| (sum.inl x) := nil △ (encode x)
| (sum.inr x) := non_nil △ (encode x)

/-- Decode a sum by using the left child of the root to signal if the right represents α or β -/
@[simp] def to_sum (x : tree unit) : option (α ⊕ β) :=
  if x.left = nil then (decode α x.right).map sum.inl
  else (decode β x.right).map sum.inr

/-- Encoding of a sum type given encodings for `α` and `β` -/
instance : tencodable (α ⊕ β) :=
{ encode := of_sum,
  decode := to_sum,
  encodek := λ x, by cases x; simp }

end sum

section subtype

instance subtype.tencodable (P : α → Prop) [decidable_pred P] : tencodable {x // P x} :=
of_left_injection (coe : _ → α) (λ r : α, if h : P r then some (⟨r, h⟩ : {x // P x}) else none)
  (λ x, by simpa [imp_false] using x.prop)

lemma subtype_encode {P : α → Prop} [decidable_pred P] (a : {x // P x}) :
  encode a = encode (a : α) := rfl

instance {n} : tencodable (vector α n) := subtype.tencodable _

lemma encode_vec_nil : encode (vector.nil : vector α 0) = tree.nil := rfl

lemma encode_vec_cons {n : ℕ} (x : α) (v : vector α n) :
  encode (x ::ᵥ v) = (encode x) △ (encode v) := by { cases v, refl, }

end subtype

section fin

instance (n : ℕ) : tencodable (fin n) := of_equiv {k // k < n} fin.equiv_subtype

noncomputable def fintype.tencodable {α : Type*} [fintype α] : tencodable α :=
of_equiv (fin (fintype.card α)) (fintype.equiv_fin α)

end fin

section ordering

def _root_.ordering.equiv_sign : ordering ≃ sign_type :=
{ to_fun := λ x, by { cases x, exacts [-1, 0, 1], },
  inv_fun := λ x, by { cases x, exacts [ordering.eq, ordering.lt, ordering.gt], },
  left_inv := λ x, by { cases x; refl, },
  right_inv := λ x, by { cases x; refl, } }

instance : fintype ordering := fintype.of_equiv _ ordering.equiv_sign.symm

noncomputable instance ordering.tencodable : tencodable ordering := fintype.tencodable

end ordering

section quotient

def _root_.setoid.tencodable (h : setoid α) (out : quotient h → α) (hout : function.left_inverse quotient.mk out) :
  tencodable (quotient h) := of_left_inverse out quotient.mk hout

end quotient

section finset

def lift_le : α → α → Prop := λ x y, encode x ≤ encode y

local attribute [reducible] lift_le
instance : decidable_rel (@lift_le α _) := infer_instance
local attribute [semireducible] lift_le

instance : is_linear_order α lift_le :=
@has_le.le.is_linear_order α (linear_order.lift' encode encode_injective)

instance : tencodable (multiset α) :=
(list.is_setoid α).tencodable (multiset.sort lift_le) (multiset.sort_eq _)

lemma encode_multiset (x : multiset α) : encode x = encode (x.sort lift_le) := rfl

instance [decidable_eq α] : tencodable (finset α) :=
of_equiv {val : multiset α // val.nodup}
{ to_fun := λ x, ⟨x.1, x.2⟩,
  inv_fun := λ x, ⟨x.1, x.2⟩,
  left_inv := λ ⟨x, h⟩, rfl,
  right_inv := λ ⟨x, h⟩, rfl }

lemma encode_finset [decidable_eq α] (x : finset α) : encode x = encode x.val := rfl

end finset

section finmap

instance _root_.multiset.nodupkeys_decidable {α : Type*} {β : α → Type*} [decidable_eq α] (s : multiset (sigma β)) : decidable s.nodupkeys :=
quotient.rec_on_subsingleton s $ λ l, l.keys.nodup_decidable

instance [decidable_eq α] {β : α → Type*} [∀ i, tencodable (β i)] : tencodable (finmap β) :=
of_equiv {val : multiset (sigma β) // val.nodupkeys}
{ to_fun := λ x, ⟨x.1, x.2⟩,
  inv_fun := λ x, ⟨x.1, x.2⟩,
  left_inv := λ ⟨x₁, x₂⟩, rfl,
  right_inv := λ ⟨x₁, x₂⟩, rfl }

lemma encode_finmap [decidable_eq α] {β : α → Type*} [∀ i, tencodable (β i)] (x : finmap β) :
  encode x = encode x.entries := rfl

end finmap

end tencodable


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

Coinductive formalization of unbounded computations.
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.Lean3Lib.data.stream
import Mathlib.tactic.basic
import Mathlib.PostPort

universes u u_1 v w

namespace Mathlib

/-
coinductive computation (α : Type u) : Type u
| return : α → computation α
| think : computation α → computation α
-/

/-- `computation α` is the type of unbounded computations returning `α`.
  An element of `computation α` is an infinite sequence of `option α` such
  that if `f n = some a` for some `n` then it is constantly `some a` after that. -/
def computation (α : Type u) :=
  Subtype fun (f : stream (Option α)) => ∀ {n : ℕ} {a : α}, f n = some a → f (n + 1) = some a

namespace computation

-- constructors

/-- `return a` is the computation that immediately terminates with result `a`. -/
def return {α : Type u} (a : α) : computation α :=
  { val := stream.const (some a), property := sorry }

protected instance has_coe_t {α : Type u} : has_coe_t α (computation α) := has_coe_t.mk return

/-- `think c` is the computation that delays for one "tick" and then performs
  computation `c`. -/
def think {α : Type u} (c : computation α) : computation α :=
  { val := none :: subtype.val c, property := sorry }

/-- `thinkN c n` is the computation that delays for `n` ticks and then performs
  computation `c`. -/
def thinkN {α : Type u} (c : computation α) : ℕ → computation α := sorry

-- check for immediate result

/-- `head c` is the first step of computation, either `some a` if `c = return a`
  or `none` if `c = think c'`. -/
def head {α : Type u} (c : computation α) : Option α := stream.head (subtype.val c)

-- one step of computation

/-- `tail c` is the remainder of computation, either `c` if `c = return a`
  or `c'` if `c = think c'`. -/
def tail {α : Type u} (c : computation α) : computation α :=
  { val := stream.tail (subtype.val c), property := sorry }

/-- `empty α` is the computation that never returns, an infinite sequence of
  `think`s. -/
def empty (α : Type u_1) : computation α := { val := stream.const none, property := sorry }

protected instance inhabited {α : Type u} : Inhabited (computation α) := { default := empty α }

/-- `run_for c n` evaluates `c` for `n` steps and returns the result, or `none`
  if it did not terminate after `n` steps. -/
def run_for {α : Type u} : computation α → ℕ → Option α := subtype.val

/-- `destruct c` is the destructor for `computation α` as a coinductive type.
  It returns `inl a` if `c = return a` and `inr c'` if `c = think c'`. -/
def destruct {α : Type u} (c : computation α) : α ⊕ computation α := sorry

/-- `run c` is an unsound meta function that runs `c` to completion, possibly
  resulting in an infinite loop in the VM. -/
theorem destruct_eq_ret {α : Type u} {s : computation α} {a : α} :
    destruct s = sum.inl a → s = return a :=
  sorry

theorem destruct_eq_think {α : Type u} {s : computation α} {s' : computation α} :
    destruct s = sum.inr s' → s = think s' :=
  sorry

@[simp] theorem destruct_ret {α : Type u} (a : α) : destruct (return a) = sum.inl a := rfl

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

@[simp] theorem destruct_empty {α : Type u} : destruct (empty α) = sum.inr (empty α) := rfl

@[simp] theorem head_ret {α : Type u} (a : α) : head (return a) = some a := rfl

@[simp] theorem head_think {α : Type u} (s : computation α) : head (think s) = none := rfl

@[simp] theorem head_empty {α : Type u} : head (empty α) = none := rfl

@[simp] theorem tail_ret {α : Type u} (a : α) : tail (return a) = return a := rfl

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

@[simp] theorem tail_empty {α : Type u} : tail (empty α) = empty α := rfl

theorem think_empty {α : Type u} : empty α = think (empty α) := destruct_eq_think destruct_empty

def cases_on {α : Type u} {C : computation α → Sort v} (s : computation α)
    (h1 : (a : α) → C (return a)) (h2 : (s : computation α) → C (think s)) : C s :=
  (fun (_x : α ⊕ computation α) (H : destruct s = _x) =>
      sum.rec (fun (v : α) (H : destruct s = sum.inl v) => eq.mpr sorry (h1 v))
        (fun (v : computation α) (H : destruct s = sum.inr v) =>
          subtype.cases_on v
            (fun (a : stream (Option α))
              (s' : ∀ {n : ℕ} {a_1 : α}, a n = some a_1 → a (n + 1) = some a_1)
              (H : destruct s = sum.inr { val := a, property := s' }) =>
              eq.mpr sorry (h2 { val := a, property := s' }))
            H)
        _x H)
    (destruct s) sorry

def corec.F {α : Type u} {β : Type v} (f : β → α ⊕ β) : α ⊕ β → Option α × (α ⊕ β) := sorry

/-- `corec f b` is the corecursor for `computation α` as a coinductive type.
  If `f b = inl a` then `corec f b = return a`, and if `f b = inl b'` then
  `corec f b = think (corec f b')`. -/
def corec {α : Type u} {β : Type v} (f : β → α ⊕ β) (b : β) : computation α :=
  { val := stream.corec' sorry (sum.inr b), property := sorry }

/-- left map of `⊕` -/
@[simp] def lmap {α : Type u} {β : Type v} {γ : Type w} (f : α → β) : α ⊕ γ → β ⊕ γ := sorry

/-- right map of `⊕` -/
@[simp] def rmap {α : Type u} {β : Type v} {γ : Type w} (f : β → γ) : α ⊕ β → α ⊕ γ := sorry

@[simp] theorem corec_eq {α : Type u} {β : Type v} (f : β → α ⊕ β) (b : β) :
    destruct (corec f b) = rmap (corec f) (f b) :=
  sorry

@[simp] def bisim_o {α : Type u} (R : computation α → computation α → Prop) :
    α ⊕ computation α → α ⊕ computation α → Prop :=
  sorry

def is_bisimulation {α : Type u} (R : computation α → computation α → Prop) :=
  ∀ {s₁ s₂ : computation α}, R s₁ s₂ → bisim_o R (destruct s₁) (destruct s₂)

theorem eq_of_bisim {α : Type u} (R : computation α → computation α → Prop)
    (bisim : is_bisimulation R) {s₁ : computation α} {s₂ : computation α} (r : R s₁ s₂) : s₁ = s₂ :=
  sorry

-- It's more of a stretch to use ∈ for this relation, but it

-- asserts that the computation limits to the given value.

protected def mem {α : Type u} (a : α) (s : computation α) := some a ∈ subtype.val s

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

theorem le_stable {α : Type u} (s : computation α) {a : α} {m : ℕ} {n : ℕ} (h : m ≤ n) :
    subtype.val s m = some a → subtype.val s n = some a :=
  sorry

theorem mem_unique {α : Type u} : relator.left_unique has_mem.mem := sorry

/-- `terminates s` asserts that the computation `s` eventually terminates with some value. -/
def terminates {α : Type u} (s : computation α) := ∃ (a : α), a ∈ s

theorem terminates_of_mem {α : Type u} {s : computation α} {a : α} : a ∈ s → terminates s :=
  exists.intro a

theorem terminates_def {α : Type u} (s : computation α) :
    terminates s ↔ ∃ (n : ℕ), ↥(option.is_some (subtype.val s n)) :=
  sorry

theorem ret_mem {α : Type u} (a : α) : a ∈ return a := exists.intro 0 rfl

theorem eq_of_ret_mem {α : Type u} {a : α} {a' : α} (h : a' ∈ return a) : a' = a :=
  mem_unique h (ret_mem a)

protected instance ret_terminates {α : Type u} (a : α) : terminates (return a) :=
  terminates_of_mem (ret_mem a)

theorem think_mem {α : Type u} {s : computation α} {a : α} : a ∈ s → a ∈ think s := sorry

protected instance think_terminates {α : Type u} (s : computation α) [terminates s] :
    terminates (think s) :=
  sorry

theorem of_think_mem {α : Type u} {s : computation α} {a : α} : a ∈ think s → a ∈ s := sorry

theorem of_think_terminates {α : Type u} {s : computation α} :
    terminates (think s) → terminates s :=
  fun (ᾰ : terminates (think s)) =>
    Exists.dcases_on ᾰ
      fun (ᾰ_w : α) (ᾰ_h : ᾰ_w ∈ think s) =>
        idRhs (∃ (a : α), a ∈ s) (Exists.intro ᾰ_w (of_think_mem ᾰ_h))

theorem not_mem_empty {α : Type u} (a : α) : ¬a ∈ empty α := sorry

theorem not_terminates_empty {α : Type u} : ¬terminates (empty α) := sorry

theorem eq_empty_of_not_terminates {α : Type u} {s : computation α} (H : ¬terminates s) :
    s = empty α :=
  sorry

theorem thinkN_mem {α : Type u} {s : computation α} {a : α} (n : ℕ) : a ∈ thinkN s n ↔ a ∈ s :=
  sorry

protected instance thinkN_terminates {α : Type u} (s : computation α) [terminates s] (n : ℕ) :
    terminates (thinkN s n) :=
  sorry

theorem of_thinkN_terminates {α : Type u} (s : computation α) (n : ℕ) :
    terminates (thinkN s n) → terminates s :=
  fun (ᾰ : terminates (thinkN s n)) =>
    Exists.dcases_on ᾰ
      fun (ᾰ_w : α) (ᾰ_h : ᾰ_w ∈ thinkN s n) =>
        idRhs (∃ (a : α), a ∈ s) (Exists.intro ᾰ_w (iff.mp (thinkN_mem n) ᾰ_h))

/-- `promises s a`, or `s ~> a`, asserts that although the computation `s`
  may not terminate, if it does, then the result is `a`. -/
def promises {α : Type u} (s : computation α) (a : α) := ∀ {a' : α}, a' ∈ s → a = a'

infixl:50 " ~> " => Mathlib.computation.promises

theorem mem_promises {α : Type u} {s : computation α} {a : α} : a ∈ s → s ~> a :=
  fun (h : a ∈ s) (a' : α) => mem_unique h

theorem empty_promises {α : Type u} (a : α) : empty α ~> a :=
  fun (a' : α) (h : a' ∈ empty α) => absurd h (not_mem_empty a')

/-- `length s` gets the number of steps of a terminating computation -/
def length {α : Type u} (s : computation α) [h : terminates s] : ℕ := nat.find sorry

/-- `get s` returns the result of a terminating computation -/
def get {α : Type u} (s : computation α) [h : terminates s] : α := option.get sorry

theorem get_mem {α : Type u} (s : computation α) [h : terminates s] : get s ∈ s :=
  exists.intro (length s) (Eq.symm (option.eq_some_of_is_some (get._proof_2 s)))

theorem get_eq_of_mem {α : Type u} (s : computation α) [h : terminates s] {a : α} :
    a ∈ s → get s = a :=
  mem_unique (get_mem s)

theorem mem_of_get_eq {α : Type u} (s : computation α) [h : terminates s] {a : α} :
    get s = a → a ∈ s :=
  fun (h_1 : get s = a) => eq.mpr (id (Eq._oldrec (Eq.refl (a ∈ s)) (Eq.symm h_1))) (get_mem s)

@[simp] theorem get_think {α : Type u} (s : computation α) [h : terminates s] :
    get (think s) = get s :=
  sorry

@[simp] theorem get_thinkN {α : Type u} (s : computation α) [h : terminates s] (n : ℕ) :
    get (thinkN s n) = get s :=
  get_eq_of_mem (thinkN s n) (iff.mpr (thinkN_mem n) (get_mem s))

theorem get_promises {α : Type u} (s : computation α) [h : terminates s] : s ~> get s :=
  fun (a : α) => get_eq_of_mem s

theorem mem_of_promises {α : Type u} (s : computation α) [h : terminates s] {a : α} (p : s ~> a) :
    a ∈ s :=
  Exists.dcases_on h fun (a' : α) (h : a' ∈ s) => eq.mpr (id (Eq._oldrec (Eq.refl (a ∈ s)) (p h))) h

theorem get_eq_of_promises {α : Type u} (s : computation α) [h : terminates s] {a : α} :
    s ~> a → get s = a :=
  get_eq_of_mem s ∘ mem_of_promises s

/-- `results s a n` completely characterizes a terminating computation:
  it asserts that `s` terminates after exactly `n` steps, with result `a`. -/
def results {α : Type u} (s : computation α) (a : α) (n : ℕ) := ∃ (h : a ∈ s), length s = n

theorem results_of_terminates {α : Type u} (s : computation α) [T : terminates s] :
    results s (get s) (length s) :=
  Exists.intro (get_mem s) rfl

theorem results_of_terminates' {α : Type u} (s : computation α) [T : terminates s] {a : α}
    (h : a ∈ s) : results s a (length s) :=
  eq.mpr (id (Eq._oldrec (Eq.refl (results s a (length s))) (Eq.symm (get_eq_of_mem s h))))
    (results_of_terminates s)

theorem results.mem {α : Type u} {s : computation α} {a : α} {n : ℕ} : results s a n → a ∈ s :=
  fun (ᾰ : results s a n) =>
    Exists.dcases_on ᾰ fun (ᾰ_w : a ∈ s) (ᾰ_h : length s = n) => idRhs (a ∈ s) ᾰ_w

theorem results.terminates {α : Type u} {s : computation α} {a : α} {n : ℕ} (h : results s a n) :
    terminates s :=
  terminates_of_mem (results.mem h)

theorem results.length {α : Type u} {s : computation α} {a : α} {n : ℕ} [T : terminates s] :
    results s a n → length s = n :=
  fun (ᾰ : results s a n) =>
    Exists.dcases_on ᾰ fun (ᾰ_w : a ∈ s) (ᾰ_h : length s = n) => idRhs (length s = n) ᾰ_h

theorem results.val_unique {α : Type u} {s : computation α} {a : α} {b : α} {m : ℕ} {n : ℕ}
    (h1 : results s a m) (h2 : results s b n) : a = b :=
  mem_unique (results.mem h1) (results.mem h2)

theorem results.len_unique {α : Type u} {s : computation α} {a : α} {b : α} {m : ℕ} {n : ℕ}
    (h1 : results s a m) (h2 : results s b n) : m = n :=
  eq.mpr (id (Eq._oldrec (Eq.refl (m = n)) (Eq.symm (results.length h1))))
    (eq.mpr (id (Eq._oldrec (Eq.refl (length s = n)) (results.length h2))) (Eq.refl n))

theorem exists_results_of_mem {α : Type u} {s : computation α} {a : α} (h : a ∈ s) :
    ∃ (n : ℕ), results s a n :=
  Exists.intro (length s) (results_of_terminates' s h)

@[simp] theorem get_ret {α : Type u} (a : α) : get (return a) = a :=
  get_eq_of_mem (return a) (Exists.intro 0 rfl)

@[simp] theorem length_ret {α : Type u} (a : α) : length (return a) = 0 :=
  let h : terminates (return a) := computation.ret_terminates a;
  nat.eq_zero_of_le_zero (nat.find_min' (iff.mp (terminates_def (return a)) h) rfl)

theorem results_ret {α : Type u} (a : α) : results (return a) a 0 :=
  Exists.intro (ret_mem a) (length_ret a)

@[simp] theorem length_think {α : Type u} (s : computation α) [h : terminates s] :
    length (think s) = length s + 1 :=
  sorry

theorem results_think {α : Type u} {s : computation α} {a : α} {n : ℕ} (h : results s a n) :
    results (think s) a (n + 1) :=
  Exists.intro (think_mem (results.mem h))
    (eq.mpr (id (Eq._oldrec (Eq.refl (length (think s) = n + 1)) (length_think s)))
      (eq.mpr (id (Eq._oldrec (Eq.refl (length s + 1 = n + 1)) (results.length h)))
        (Eq.refl (n + 1))))

theorem of_results_think {α : Type u} {s : computation α} {a : α} {n : ℕ}
    (h : results (think s) a n) : ∃ (m : ℕ), results s a m ∧ n = m + 1 :=
  Exists.intro (length s)
    { left := results_of_terminates' s (of_think_mem (results.mem h)),
      right :=
        results.len_unique h
          (results_think (results_of_terminates' s (of_think_mem (results.mem h)))) }

@[simp] theorem results_think_iff {α : Type u} {s : computation α} {a : α} {n : ℕ} :
    results (think s) a (n + 1) ↔ results s a n :=
  sorry

theorem results_thinkN {α : Type u} {s : computation α} {a : α} {m : ℕ} (n : ℕ) :
    results s a m → results (thinkN s n) a (m + n) :=
  sorry

theorem results_thinkN_ret {α : Type u} (a : α) (n : ℕ) : results (thinkN (return a) n) a n :=
  eq.mp (Eq._oldrec (Eq.refl (results (thinkN (return a) n) a (0 + n))) (nat.zero_add n))
    (results_thinkN n (results_ret a))

@[simp] theorem length_thinkN {α : Type u} (s : computation α) [h : terminates s] (n : ℕ) :
    length (thinkN s n) = length s + n :=
  results.length (results_thinkN n (results_of_terminates s))

theorem eq_thinkN {α : Type u} {s : computation α} {a : α} {n : ℕ} (h : results s a n) :
    s = thinkN (return a) n :=
  sorry

theorem eq_thinkN' {α : Type u} (s : computation α) [h : terminates s] :
    s = thinkN (return (get s)) (length s) :=
  eq_thinkN (results_of_terminates s)

def mem_rec_on {α : Type u} {C : computation α → Sort v} {a : α} {s : computation α} (M : a ∈ s)
    (h1 : C (return a)) (h2 : (s : computation α) → C s → C (think s)) : C s :=
  eq.mpr sorry
    (eq.mpr sorry
      (Nat.rec h1 (fun (n : ℕ) (IH : C (thinkN (return a) n)) => h2 (thinkN (return a) n) IH)
        (length s)))

def terminates_rec_on {α : Type u} {C : computation α → Sort v} (s : computation α) [terminates s]
    (h1 : (a : α) → C (return a)) (h2 : (s : computation α) → C s → C (think s)) : C s :=
  mem_rec_on (get_mem s) (h1 (get s)) h2

/-- Map a function on the result of a computation. -/
def map {α : Type u} {β : Type v} (f : α → β) : computation α → computation β := sorry

def bind.G {α : Type u} {β : Type v} : β ⊕ computation β → β ⊕ computation α ⊕ computation β :=
  sorry

def bind.F {α : Type u} {β : Type v} (f : α → computation β) :
    computation α ⊕ computation β → β ⊕ computation α ⊕ computation β :=
  sorry

/-- Compose two computations into a monadic `bind` operation. -/
def bind {α : Type u} {β : Type v} (c : computation α) (f : α → computation β) : computation β :=
  corec sorry (sum.inl c)

protected instance has_bind : Bind computation := { bind := bind }

theorem has_bind_eq_bind {α : Type u} {β : Type u} (c : computation α) (f : α → computation β) :
    c >>= f = bind c f :=
  rfl

/-- Flatten a computation of computations into a single computation. -/
def join {α : Type u} (c : computation (computation α)) : computation α := c >>= id

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

@[simp] theorem map_think {α : Type u} {β : Type v} (f : α → β) (s : computation α) :
    map f (think s) = think (map f s) :=
  sorry

@[simp] theorem destruct_map {α : Type u} {β : Type v} (f : α → β) (s : computation α) :
    destruct (map f s) = lmap f (rmap (map f) (destruct s)) :=
  sorry

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

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

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

@[simp] theorem think_bind {α : Type u} {β : Type v} (c : computation α) (f : α → computation β) :
    bind (think c) f = think (bind c f) :=
  sorry

@[simp] theorem bind_ret {α : Type u} {β : Type v} (f : α → β) (s : computation α) :
    bind s (return ∘ f) = map f s :=
  sorry

@[simp] theorem bind_ret' {α : Type u} (s : computation α) : bind s return = s :=
  eq.mpr (id (Eq._oldrec (Eq.refl (bind s return = s)) (bind_ret (fun (x : α) => x) s)))
    (id (eq.mpr (id (Eq._oldrec (Eq.refl (map id s = s)) (map_id s))) (Eq.refl s)))

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

theorem results_bind {α : Type u} {β : Type v} {s : computation α} {f : α → computation β} {a : α}
    {b : β} {m : ℕ} {n : ℕ} (h1 : results s a m) (h2 : results (f a) b n) :
    results (bind s f) b (n + m) :=
  sorry

theorem mem_bind {α : Type u} {β : Type v} {s : computation α} {f : α → computation β} {a : α}
    {b : β} (h1 : a ∈ s) (h2 : b ∈ f a) : b ∈ bind s f :=
  sorry

protected instance terminates_bind {α : Type u} {β : Type v} (s : computation α)
    (f : α → computation β) [terminates s] [terminates (f (get s))] : terminates (bind s f) :=
  terminates_of_mem (mem_bind (get_mem s) (get_mem (f (get s))))

@[simp] theorem get_bind {α : Type u} {β : Type v} (s : computation α) (f : α → computation β)
    [terminates s] [terminates (f (get s))] : get (bind s f) = get (f (get s)) :=
  get_eq_of_mem (bind s f) (mem_bind (get_mem s) (get_mem (f (get s))))

@[simp] theorem length_bind {α : Type u} {β : Type v} (s : computation α) (f : α → computation β)
    [T1 : terminates s] [T2 : terminates (f (get s))] :
    length (bind s f) = length (f (get s)) + length s :=
  results.len_unique (results_of_terminates (bind s f))
    (results_bind (results_of_terminates s) (results_of_terminates (f (get s))))

theorem of_results_bind {α : Type u} {β : Type v} {s : computation α} {f : α → computation β}
    {b : β} {k : ℕ} :
    results (bind s f) b k →
        ∃ (a : α), ∃ (m : ℕ), ∃ (n : ℕ), results s a m ∧ results (f a) b n ∧ k = n + m :=
  sorry

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

theorem bind_promises {α : Type u} {β : Type v} {s : computation α} {f : α → computation β} {a : α}
    {b : β} (h1 : s ~> a) (h2 : f a ~> b) : bind s f ~> b :=
  sorry

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

protected instance is_lawful_monad : is_lawful_monad computation :=
  is_lawful_monad.mk ret_bind bind_assoc

theorem has_map_eq_map {α : Type u} {β : Type u} (f : α → β) (c : computation α) :
    f <$> c = map f c :=
  rfl

@[simp] theorem return_def {α : Type u} (a : α) : return a = return a := rfl

@[simp] theorem map_ret' {α : Type u_1} {β : Type u_1} (f : α → β) (a : α) :
    f <$> return a = return (f a) :=
  map_ret

@[simp] theorem map_think' {α : Type u_1} {β : Type u_1} (f : α → β) (s : computation α) :
    f <$> think s = think (f <$> s) :=
  map_think

theorem mem_map {α : Type u} {β : Type v} (f : α → β) {a : α} {s : computation α} (m : a ∈ s) :
    f a ∈ map f s :=
  eq.mpr (id (Eq._oldrec (Eq.refl (f a ∈ map f s)) (Eq.symm (bind_ret f s))))
    (mem_bind m (ret_mem (f a)))

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

protected instance terminates_map {α : Type u} {β : Type v} (f : α → β) (s : computation α)
    [terminates s] : terminates (map f s) :=
  eq.mpr (id (Eq._oldrec (Eq.refl (terminates (map f s))) (Eq.symm (bind_ret f s))))
    (computation.terminates_bind s (return ∘ f))

theorem terminates_map_iff {α : Type u} {β : Type v} (f : α → β) (s : computation α) :
    terminates (map f s) ↔ terminates s :=
  sorry

-- Parallel computation

/-- `c₁ <|> c₂` calculates `c₁` and `c₂` simultaneously, returning
  the first one that gives a result. -/
def orelse {α : Type u} (c₁ : computation α) (c₂ : computation α) : computation α :=
  corec (fun (_x : computation α × computation α) => sorry) (c₁, c₂)

protected instance alternative : alternative computation := alternative.mk empty

@[simp] theorem ret_orelse {α : Type u} (a : α) (c₂ : computation α) :
    (return a <|> c₂) = return a :=
  sorry

@[simp] theorem orelse_ret {α : Type u} (c₁ : computation α) (a : α) :
    (think c₁ <|> return a) = return a :=
  sorry

@[simp] theorem orelse_think {α : Type u} (c₁ : computation α) (c₂ : computation α) :
    (think c₁ <|> think c₂) = think (c₁ <|> c₂) :=
  sorry

@[simp] theorem empty_orelse {α : Type u} (c : computation α) : (empty α <|> c) = c := sorry

@[simp] theorem orelse_empty {α : Type u} (c : computation α) : (c <|> empty α) = c := sorry

/-- `c₁ ~ c₂` asserts that `c₁` and `c₂` either both terminate with the same result,
  or both loop forever. -/
def equiv {α : Type u} (c₁ : computation α) (c₂ : computation α) := ∀ (a : α), a ∈ c₁ ↔ a ∈ c₂

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

theorem equiv.refl {α : Type u} (s : computation α) : s ~ s := fun (_x : α) => iff.rfl

theorem equiv.symm {α : Type u} {s : computation α} {t : computation α} : s ~ t → t ~ s :=
  fun (h : s ~ t) (a : α) => iff.symm (h a)

theorem equiv.trans {α : Type u} {s : computation α} {t : computation α} {u : computation α} :
    s ~ t → t ~ u → s ~ u :=
  fun (h1 : s ~ t) (h2 : t ~ u) (a : α) => iff.trans (h1 a) (h2 a)

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

theorem equiv_of_mem {α : Type u} {s : computation α} {t : computation α} {a : α} (h1 : a ∈ s)
    (h2 : a ∈ t) : s ~ t :=
  fun (a' : α) =>
    { mp := fun (ma : a' ∈ s) => eq.mpr (id (Eq._oldrec (Eq.refl (a' ∈ t)) (mem_unique ma h1))) h2,
      mpr :=
        fun (ma : a' ∈ t) => eq.mpr (id (Eq._oldrec (Eq.refl (a' ∈ s)) (mem_unique ma h2))) h1 }

theorem terminates_congr {α : Type u} {c₁ : computation α} {c₂ : computation α} (h : c₁ ~ c₂) :
    terminates c₁ ↔ terminates c₂ :=
  exists_congr h

theorem promises_congr {α : Type u} {c₁ : computation α} {c₂ : computation α} (h : c₁ ~ c₂)
    (a : α) : c₁ ~> a ↔ c₂ ~> a :=
  forall_congr fun (a' : α) => imp_congr (h a') iff.rfl

theorem get_equiv {α : Type u} {c₁ : computation α} {c₂ : computation α} (h : c₁ ~ c₂)
    [terminates c₁] [terminates c₂] : get c₁ = get c₂ :=
  get_eq_of_mem c₁ (iff.mpr (h (get c₂)) (get_mem c₂))

theorem think_equiv {α : Type u} (s : computation α) : think s ~ s :=
  fun (a : α) => { mp := of_think_mem, mpr := think_mem }

theorem thinkN_equiv {α : Type u} (s : computation α) (n : ℕ) : thinkN s n ~ s :=
  fun (a : α) => thinkN_mem n

theorem bind_congr {α : Type u} {β : Type v} {s1 : computation α} {s2 : computation α}
    {f1 : α → computation β} {f2 : α → computation β} (h1 : s1 ~ s2) (h2 : ∀ (a : α), f1 a ~ f2 a) :
    bind s1 f1 ~ bind s2 f2 :=
  sorry

theorem equiv_ret_of_mem {α : Type u} {s : computation α} {a : α} (h : a ∈ s) : s ~ return a :=
  equiv_of_mem h (ret_mem a)

/-- `lift_rel R ca cb` is a generalization of `equiv` to relations other than
  equality. It asserts that if `ca` terminates with `a`, then `cb` terminates with
  some `b` such that `R a b`, and if `cb` terminates with `b` then `ca` terminates
  with some `a` such that `R a b`. -/
def lift_rel {α : Type u} {β : Type v} (R : α → β → Prop) (ca : computation α)
    (cb : computation β) :=
  (∀ {a : α}, a ∈ ca → Exists fun {b : β} => b ∈ cb ∧ R a b) ∧
    ∀ {b : β}, b ∈ cb → Exists fun {a : α} => a ∈ ca ∧ R a b

theorem lift_rel.swap {α : Type u} {β : Type v} (R : α → β → Prop) (ca : computation α)
    (cb : computation β) : lift_rel (function.swap R) cb ca ↔ lift_rel R ca cb :=
  and_comm (∀ {a : β}, a ∈ cb → Exists fun {b : α} => b ∈ ca ∧ function.swap R a b)
    (∀ {b : α}, b ∈ ca → Exists fun {a : β} => a ∈ cb ∧ function.swap R a b)

theorem lift_eq_iff_equiv {α : Type u} (c₁ : computation α) (c₂ : computation α) :
    lift_rel Eq c₁ c₂ ↔ c₁ ~ c₂ :=
  sorry

theorem lift_rel.refl {α : Type u} (R : α → α → Prop) (H : reflexive R) : reflexive (lift_rel R) :=
  fun (s : computation α) =>
    { left := fun (a : α) (as : a ∈ s) => Exists.intro a { left := as, right := H a },
      right := fun (b : α) (bs : b ∈ s) => Exists.intro b { left := bs, right := H b } }

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 lift_rel.imp {α : Type u} {β : Type v} {R : α → β → Prop} {S : α → β → Prop}
    (H : ∀ {a : α} {b : β}, R a b → S a b) (s : computation α) (t : computation β) :
    lift_rel R s t → lift_rel S s t :=
  sorry

theorem terminates_of_lift_rel {α : Type u} {β : Type v} {R : α → β → Prop} {s : computation α}
    {t : computation β} : lift_rel R s t → (terminates s ↔ terminates t) :=
  sorry

theorem rel_of_lift_rel {α : Type u} {β : Type v} {R : α → β → Prop} {ca : computation α}
    {cb : computation β} : lift_rel R ca cb → ∀ {a : α} {b : β}, a ∈ ca → b ∈ cb → R a b :=
  sorry

theorem lift_rel_of_mem {α : Type u} {β : Type v} {R : α → β → Prop} {a : α} {b : β}
    {ca : computation α} {cb : computation β} (ma : a ∈ ca) (mb : b ∈ cb) (ab : R a b) :
    lift_rel R ca cb :=
  sorry

theorem exists_of_lift_rel_left {α : Type u} {β : Type v} {R : α → β → Prop} {ca : computation α}
    {cb : computation β} (H : lift_rel R ca cb) {a : α} (h : a ∈ ca) :
    Exists fun {b : β} => b ∈ cb ∧ R a b :=
  and.left H a h

theorem exists_of_lift_rel_right {α : Type u} {β : Type v} {R : α → β → Prop} {ca : computation α}
    {cb : computation β} (H : lift_rel R ca cb) {b : β} (h : b ∈ cb) :
    Exists fun {a : α} => a ∈ ca ∧ R a b :=
  and.right H b h

theorem lift_rel_def {α : Type u} {β : Type v} {R : α → β → Prop} {ca : computation α}
    {cb : computation β} :
    lift_rel R ca cb ↔
        (terminates ca ↔ terminates cb) ∧ ∀ {a : α} {b : β}, a ∈ ca → b ∈ cb → R a b :=
  sorry

theorem lift_rel_bind {α : Type u} {β : Type v} {γ : Type w} {δ : Type u_1} (R : α → β → Prop)
    (S : γ → δ → Prop) {s1 : computation α} {s2 : computation β} {f1 : α → computation γ}
    {f2 : β → computation δ} (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) :=
  sorry

@[simp] theorem lift_rel_return_left {α : Type u} {β : Type v} (R : α → β → Prop) (a : α)
    (cb : computation β) : lift_rel R (return a) cb ↔ Exists fun {b : β} => b ∈ cb ∧ R a b :=
  sorry

@[simp] theorem lift_rel_return_right {α : Type u} {β : Type v} (R : α → β → Prop)
    (ca : computation α) (b : β) :
    lift_rel R ca (return b) ↔ Exists fun {a : α} => a ∈ ca ∧ R a b :=
  sorry

@[simp] theorem lift_rel_return {α : Type u} {β : Type v} (R : α → β → Prop) (a : α) (b : β) :
    lift_rel R (return a) (return b) ↔ R a b :=
  sorry

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

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

theorem lift_rel_mem_cases {α : Type u} {β : Type v} {R : α → β → Prop} {ca : computation α}
    {cb : computation β} (Ha : ∀ (a : α), a ∈ ca → lift_rel R ca cb)
    (Hb : ∀ (b : β), b ∈ cb → lift_rel R ca cb) : lift_rel R ca cb :=
  { left := fun (a : α) (ma : a ∈ ca) => and.left (Ha a ma) a ma,
    right := fun (b : β) (mb : b ∈ cb) => and.right (Hb b mb) b mb }

theorem lift_rel_congr {α : Type u} {β : Type v} {R : α → β → Prop} {ca : computation α}
    {ca' : computation α} {cb : computation β} {cb' : computation β} (ha : ca ~ ca')
    (hb : cb ~ cb') : lift_rel R ca cb ↔ lift_rel R ca' cb' :=
  and_congr
    (forall_congr
      fun (a : α) => imp_congr (ha a) (exists_congr fun (b : β) => and_congr (hb b) iff.rfl))
    (forall_congr
      fun (b : β) => imp_congr (hb b) (exists_congr fun (a : α) => and_congr (ha a) iff.rfl))

theorem lift_rel_map {α : Type u} {β : Type v} {γ : Type w} {δ : Type u_1} (R : α → β → Prop)
    (S : γ → δ → Prop) {s1 : computation α} {s2 : computation β} {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} (R : α → α → Prop) (S : β → β → Prop)
    {s1 : computation α} {s2 : computation α} {f : α → β} (h1 : s1 ~ s2) : map f s1 ~ map f s2 :=
  eq.mpr
    (id
      (Eq._oldrec (Eq.refl (map f s1 ~ map f s2))
        (Eq.symm (propext (lift_eq_iff_equiv (map f s1) (map f s2))))))
    (lift_rel_map Eq Eq (iff.mpr (lift_eq_iff_equiv s1 s2) h1)
      fun (a b : α) => congr_arg fun (a : α) => f a)

@[simp] def lift_rel_aux {α : Type u} {β : Type v} (R : α → β → Prop)
    (C : computation α → computation β → Prop) : α ⊕ computation α → β ⊕ computation β → Prop :=
  sorry

@[simp] theorem lift_rel_aux.ret_left {α : Type u} {β : Type v} (R : α → β → Prop)
    (C : computation α → computation β → Prop) (a : α) (cb : computation β) :
    lift_rel_aux R C (sum.inl a) (destruct cb) ↔ Exists fun {b : β} => b ∈ cb ∧ R a b :=
  sorry

theorem lift_rel_aux.swap {α : Type u} {β : Type v} (R : α → β → Prop)
    (C : computation α → computation β → Prop) (a : α ⊕ computation α) (b : β ⊕ computation β) :
    lift_rel_aux (function.swap R) (function.swap C) b a = lift_rel_aux R C a b :=
  sorry

@[simp] theorem lift_rel_aux.ret_right {α : Type u} {β : Type v} (R : α → β → Prop)
    (C : computation α → computation β → Prop) (b : β) (ca : computation α) :
    lift_rel_aux R C (destruct ca) (sum.inl b) ↔ Exists fun {a : α} => a ∈ ca ∧ R a b :=
  sorry

theorem lift_rel_rec.lem {α : Type u} {β : Type v} {R : α → β → Prop}
    (C : computation α → computation β → Prop)
    (H :
      ∀ {ca : computation α} {cb : computation β},
        C ca cb → lift_rel_aux R C (destruct ca) (destruct cb))
    (ca : computation α) (cb : computation β) (Hc : C ca cb) (a : α) (ha : a ∈ ca) :
    lift_rel R ca cb :=
  sorry

theorem lift_rel_rec {α : Type u} {β : Type v} {R : α → β → Prop}
    (C : computation α → computation β → Prop)
    (H :
      ∀ {ca : computation α} {cb : computation β},
        C ca cb → lift_rel_aux R C (destruct ca) (destruct cb))
    (ca : computation α) (cb : computation β) (Hc : C ca cb) : lift_rel R ca cb :=
  lift_rel_mem_cases sorry
    fun (b : β) (hb : b ∈ cb) => iff.mpr (lift_rel.swap (fun (x : β) (y : α) => R y x) cb ca) sorry

end Mathlib


import for_mathlib.commsq
import for_mathlib.snake_lemma_naturality2
import for_mathlib.AddCommGroup.pt
import for_mathlib.bicartesian4
import for_mathlib.abelian_sheaves.functor_category

import system_of_complexes.shift_sub_id
import pseudo_normed_group.system_of_complexes2

noncomputable theory

universes u

open_locale nnreal

open opposite category_theory category_theory.limits category_theory.preadditive

section step1

variables {A B C : ℝ≥0ᵒᵖ ⥤ Ab.{u}} (f : A ⟶ B)
variables (ι : ulift.{u} ℕ → ℝ≥0)

def shift_sub_id.commsq (hι : monotone ι) :
  commsq (shift_sub_id A ι hι)
    (pi.map $ λ _, f.app _) (pi.map $ λ _, f.app _)
         (shift_sub_id B ι hι) :=
commsq.of_eq
begin
  simp only [shift_sub_id, sub_comp, comp_sub, category.id_comp, category.comp_id, shift_sub_id.shift],
  congr' 1,
  apply limit.hom_ext,
  intro j,
  simp only [limit.lift_map, limit.lift_π, cones.postcompose_obj_π, nat_trans.comp_app,
    fan.mk_π_app, discrete.nat_trans_app, category.assoc, nat_trans.naturality, lim_map_π_assoc],
end

end step1

section step2

variables {A B C : ulift.{u} ℕ → Ab.{u}} (f : Π k, A k ⟶ B k) (g : Π k, B k ⟶ C k)

lemma pi_map_exact (H : ∀ k, exact (f k) (g k)) :
  exact (pi.map f) (pi.map g) :=
begin
  simp only [AddCommGroup.exact_iff'] at H ⊢,
  split,
  { apply limit.hom_ext, intro j,
    simp only [category.assoc, lim_map_π, discrete.nat_trans_app, lim_map_π_assoc,
      zero_comp, (H j).1, comp_zero], },
  intros x hx,
  rw [add_monoid_hom.mem_ker, Ab.apply_eq_zero] at hx,
  have : ∀ k, (Ab.pt (limit.π (discrete.functor (λ k, B k)) k x)) ≫ g k = 0,
  { intro k,
    suffices : Ab.pt x ≫ pi.map g ≫ pi.π _ k = 0,
    { simpa only [lim_map_π, discrete.nat_trans_app, ← category.assoc, hx, Ab.pt_comp] },
    rw [← category.assoc, hx, zero_comp] },
  simp only [← Ab.apply_eq_zero] at this,
  replace := λ k, (H k).2 (this k),
  choose y hy using this,
  refine ⟨pi.lift (λ k, Ab.pt (y k)) ⟨1⟩, _⟩,
  rw [← category_theory.comp_apply, ← Ab.pt_apply' x],
  congr' 1,
  apply limit.hom_ext,
  intro j,
  simp only [limit.lift_map, limit.lift_π, cones.postcompose_obj_π, nat_trans.comp_app,
    fan.mk_π_app, discrete.nat_trans_app, Ab.pt_comp, hy],
end

end step2

section step3

variables {A B C : ℝ≥0ᵒᵖ ⥤ cochain_complex Ab.{u} ℕ} (f : A ⟶ B) (g : B ⟶ C)
variables (ι : ulift.{u} ℕ → ℝ≥0) (n : ℕ)

def piH_hom :
  (∏ (λ x, (A.obj (op $ ι x)).homology n)) ⟶ (∏ (λ x, (B.obj (op $ ι x)).homology n)) :=
pi.map $ λ k, (homology_functor _ _ _).map $ f.app _

def shift_sub_id.δ (H : ∀ c n, short_exact ((f.app c).f n) ((g.app c).f n)) :
  C ⋙ homology_functor _ _ n ⟶ A ⋙ homology_functor _ _ (n+1) :=
{ app := λ c, homological_complex.δ (f.app _) (g.app _) (H _) _ _ rfl,
  naturality' := λ c₁ c₂ h, by { symmetry, apply homological_complex.δ_natural } }

def piδ (H : ∀ c n, short_exact ((f.app c).f n) ((g.app c).f n)) :
  (∏ (λ x, (C.obj (op $ ι x)).homology n)) ⟶ (∏ (λ x, (A.obj (op $ ι x)).homology (n+1))) :=
pi.map $ λ k, (shift_sub_id.δ _ _ _ H).app _

lemma piH_les (H : ∀ c n, short_exact ((f.app c).f n) ((g.app c).f n)) :
  exact_seq Ab.{u} [piH_hom f ι n, piH_hom g ι n, piδ f g ι n H] :=
begin
  apply exact.cons,
  { apply pi_map_exact, intro k,
    have := homological_complex.six_term_exact_seq _ _ (H (op $ ι k)) n (n+1) rfl,
    exact this.pair, },
  apply exact.exact_seq,
  { apply pi_map_exact, intro k,
    have := homological_complex.six_term_exact_seq _ _ (H (op $ ι k)) n (n+1) rfl,
    exact (this.drop 1).pair, },
end

end step3

section step4

variables {A B C : system_of_complexes.{u}} (f : A.to_Ab ⟶ B.to_Ab) (g : B.to_Ab ⟶ C.to_Ab)
variables (n : ℕ) (ι : ulift.{u} ℕ → ℝ≥0) (hι : monotone ι)

lemma shift_sub_id.bicartesian
  (HA₁ : (shift_sub_id.shift (A.to_AbH n) ι hι) = 0)
  (HA₂ : (shift_sub_id.shift (A.to_AbH (n+1)) ι hι) = 0)
  (H : ∀ c n, short_exact ((f.app c).f n) ((g.app c).f n)) :
  (@shift_sub_id.commsq (B.to_AbH n) (C.to_AbH n)
    (whisker_right g _) ι hι).bicartesian :=
begin
  rw ← commsq.bicartesian.symm_iff,
  let S1 := ((@shift_sub_id.commsq (A.to_AbH n) (B.to_AbH n) (whisker_right f _) ι hι)).symm,
  let S2 := ((@shift_sub_id.commsq (B.to_AbH n) (C.to_AbH n) (whisker_right g _) ι hι)).symm,
  let S3 := ((@shift_sub_id.commsq (C.to_AbH n) (A.to_AbH (n+1)) (shift_sub_id.δ _ _ _ H) ι hι)).symm,
  apply bicartesian_of_id_of_end_of_end_of_id (piH_les _ _ _ _ _) S1 S2 S3; clear S1 S2 S3,
  { rw [shift_sub_id, HA₁, zero_sub], refl },
  { rw [shift_sub_id, HA₂, zero_sub], refl },
end

end step4

section step5

variables {A B A' B' : ℝ≥0ᵒᵖ ⥤ Ab.{u}} (f : A ⟶ B) (f' : A' ⟶ B') (eA : A ≅ A') (eB : B ≅ B')
variables (ι : ulift.{u} ℕ → ℝ≥0) (hι : monotone ι)

lemma shift_sub_id.bicartesian_iso (w : f ≫ eB.hom = eA.hom ≫ f')
  (sq : (shift_sub_id.commsq f ι hι).bicartesian) :
  (shift_sub_id.commsq f' ι hι).bicartesian :=
begin
  let H : _ := _,
  apply commsq.bicartesian.of_iso _ _ _ _ _ H H _ sq,
  { refine limits.lim.map_iso (discrete.nat_iso $ λ k, eA.app _), },
  { refine limits.lim.map_iso (discrete.nat_iso $ λ k, eB.app _), },
  { apply shift_sub_id.commsq },
  { apply shift_sub_id.commsq },
  { apply commsq.of_eq, delta pi.map,
    simp only [functor.map_iso_hom, ← lim_map_eq_lim_map, ← category_theory.functor.map_comp],
    apply limit.hom_ext,
    simp only [lim_map_eq_lim_map, lim_map_π, nat_trans.comp_app, discrete.nat_trans_app,
      discrete.nat_iso_hom_app, iso.app_hom],
    intro, simp only [← nat_trans.comp_app, w], }
end

end step5