import analysis.calculus.bump_function_inner

/-
Multilinear map stuff that was meant as preliminaries for smooth functions gluing.

We no longer intend to use this file in the sphere eversion project.
-/

namespace function

variables {ι : Sort*} [decidable_eq ι] {α β : ι → Type*}

/-- Special case of `function.apply_update`. Useful for `rw`/`simp`. -/
lemma update_fst (g : Π i, α i × β i) (i : ι) (v : α i × β i) (j : ι) :
  (update g i v j).fst = update (λ k, (g k).fst) i v.fst j :=
apply_update (λ _, prod.fst) g i v j

/-- Special case of `function.apply_update`. Useful for `rw`/`simp`. -/
lemma update_snd (g : Π i, α i × β i) (i : ι) (v : α i × β i) (j : ι) :
  (update g i v j).snd = update (λ k, (g k).snd) i v.snd j :=
apply_update (λ _, prod.snd) g i v j

end function
open function

namespace multilinear_map
variables {R ι ι' M₃ M₄ : Type*} {M₁ M₂ : ι → Type*} {N : ι' → Type*}
variables [decidable_eq ι] [decidable_eq ι'] [semiring R]
variables [Π i, add_comm_monoid (M₁ i)] [Π i, module R (M₁ i)]
variables [Π i, add_comm_monoid (M₂ i)] [Π i, module R (M₂ i)]
variables [Π i, add_comm_monoid (N i)] [Π i, module R (N i)]
variables [add_comm_monoid M₃] [module R M₃]
variables [add_comm_monoid M₄] [module R M₄]

/-- The coproduct of two multilinear maps. -/
@[simps]
def coprod (L₁ : multilinear_map R M₁ M₃) (L₂ : multilinear_map R M₂ M₃) :
  multilinear_map R (λ i, M₁ i × M₂ i) M₃ :=
{ to_fun := λ v, L₁ (λ i, (v i).1) + L₂ (λ i, (v i).2),
  map_add' := λ v i p q, by {
  simp_rw [update_fst, update_snd, add_add_add_comm, ← L₁.map_add, ← L₂.map_add, prod.add_def] },
  map_smul' := λ v i c p, by {
  simp_rw [update_fst, update_snd, smul_add, ← L₁.map_smul, ← L₂.map_smul, prod.smul_def] } }

end multilinear_map

namespace continuous_multilinear_map
variables {R ι ι' : Type*} {M₁ M₂ : ι → Type*} {M₃ M₄ : Type*} {N : ι' → Type*}
variables [decidable_eq ι] [decidable_eq ι'] [semiring R]
variables [Π i, add_comm_monoid (M₁ i)] [Π i, add_comm_monoid (M₂ i)] [add_comm_monoid M₃]
variables [Π i, module R (M₁ i)] [Π i, module R (M₂ i)] [module R M₃]
variables [Π i, topological_space (M₁ i)] [Π i, topological_space (M₂ i)]
variables [topological_space M₃]
variables [add_comm_monoid M₄] [module R M₄] [topological_space M₄]
variables [Π i, add_comm_monoid (N i)] [Π i, module R (N i)] [Π i, topological_space (N i)]

variables [has_continuous_add M₃]
@[simps]
def coprod (L₁ : continuous_multilinear_map R M₁ M₃) (L₂ : continuous_multilinear_map R M₂ M₃) :
  continuous_multilinear_map R (λ i, M₁ i × M₂ i) M₃ :=
{ cont := (L₁.cont.comp $ by continuity).add (L₂.cont.comp $ by continuity),
  .. L₁.to_multilinear_map.coprod L₂.to_multilinear_map }

@[simp]
def zero_coprod_zero :
  (0 : continuous_multilinear_map R M₁ M₃).coprod (0 : continuous_multilinear_map R M₂ M₃) = 0 :=
by { ext, simp }

end continuous_multilinear_map


example (p q r : Prop) (hp : p) (hq : q) (hr : r) :
  p ∧ ((p ∧ q) ∧ r) ∧ (q ∧ r ∧ p) :=
begin
  repeat { any_goals { split } },
  all_goals { assumption }
end


/-
Copyright (c) 2020 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.isomorphism_classes
import Mathlib.category_theory.thin
import Mathlib.PostPort

universes v₁ u₁ v₂ u₂ l u₃ v₃

namespace Mathlib

/-!
# Skeleton of a category

Define skeletal categories as categories in which any two isomorphic objects are equal.

Construct the skeleton of a thin category as a partial ordering, and (noncomputably) show it is
a skeleton of the original category. The advantage of this special case being handled separately
is that lemmas and definitions about orderings can be used directly, for example for the subobject
lattice (TODO). In addition, some of the commutative diagrams about the functors commute
definitionally on the nose which is convenient in practice.

(TODO): Construct the skeleton of a general category using choice, and show it is a skeleton.
-/

namespace category_theory

/-- A category is skeletal if isomorphic objects are equal. -/
def skeletal (C : Type u₁) [category C] := ∀ {X Y : C}, is_isomorphic X Y → X = Y

/--
`is_skeleton_of C D F` says that `F : D ⥤ C` exhibits `D` as a skeletal full subcategory of `C`,
in particular `F` is a (strong) equivalence and `D` is skeletal.
-/
structure is_skeleton_of (C : Type u₁) [category C] (D : Type u₂) [category D] (F : D ⥤ C) where
  skel : skeletal D
  eqv : is_equivalence F

/-- If `C` is thin and skeletal, then any naturally isomorphic functors to `C` are equal. -/
theorem functor.eq_of_iso {C : Type u₁} [category C] {D : Type u₂} [category D] {F₁ : D ⥤ C}
    {F₂ : D ⥤ C} [∀ (X Y : C), subsingleton (X ⟶ Y)] (hC : skeletal C) (hF : F₁ ≅ F₂) : F₁ = F₂ :=
  sorry

/--
If `C` is thin and skeletal, `D ⥤ C` is skeletal.
`category_theory.functor_thin` shows it is thin also.
-/
theorem functor_skeletal {C : Type u₁} [category C] {D : Type u₂} [category D]
    [∀ (X Y : C), subsingleton (X ⟶ Y)] (hC : skeletal C) : skeletal (D ⥤ C) :=
  fun (F₁ F₂ : D ⥤ C) (h : is_isomorphic F₁ F₂) => nonempty.elim h (functor.eq_of_iso hC)

/--
Construct the skeleton category by taking the quotient of objects. This construction gives a
preorder with nice definitional properties, but is only really appropriate for thin categories.
-/
def thin_skeleton (C : Type u₁) [category C] := quotient (is_isomorphic_setoid C)

protected instance inhabited_thin_skeleton (C : Type u₁) [category C] [Inhabited C] :
    Inhabited (thin_skeleton C) :=
  { default := quotient.mk Inhabited.default }

protected instance thin_skeleton.preorder (C : Type u₁) [category C] : preorder (thin_skeleton C) :=
  preorder.mk (quotient.lift₂ (fun (X Y : C) => Nonempty (X ⟶ Y)) sorry)
    (fun (a b : thin_skeleton C) =>
      quotient.lift₂ (fun (X Y : C) => Nonempty (X ⟶ Y)) sorry a b ∧
        ¬quotient.lift₂ (fun (X Y : C) => Nonempty (X ⟶ Y)) sorry b a)
    sorry sorry

/-- The functor from a category to its thin skeleton. -/
@[simp] theorem to_thin_skeleton_obj (C : Type u₁) [category C] (a : C) :
    functor.obj (to_thin_skeleton C) a = quotient.mk a :=
  Eq.refl (functor.obj (to_thin_skeleton C) a)

/-!
The constructions here are intended to be used when the category `C` is thin, even though
some of the statements can be shown without this assumption.
-/

namespace thin_skeleton

/-- The thin skeleton is thin. -/
protected instance thin (C : Type u₁) [category C] {X : thin_skeleton C} {Y : thin_skeleton C} :
    subsingleton (X ⟶ Y) :=
  subsingleton.intro
    fun (a b : X ⟶ Y) =>
      ulift.cases_on a
        fun (a : plift (X ≤ Y)) =>
          plift.cases_on a
            fun (f₁ : X ≤ Y) =>
              ulift.cases_on b
                fun (b : plift (X ≤ Y)) =>
                  plift.cases_on b fun (f₂ : X ≤ Y) => Eq.refl (ulift.up (plift.up f₁))

/-- A functor `C ⥤ D` computably lowers to a functor `thin_skeleton C ⥤ thin_skeleton D`. -/
def map {C : Type u₁} [category C] {D : Type u₂} [category D] (F : C ⥤ D) :
    thin_skeleton C ⥤ thin_skeleton D :=
  functor.mk (quotient.map (functor.obj F) sorry)
    fun (X Y : thin_skeleton C) =>
      quotient.rec_on_subsingleton₂ X Y
        fun (x y : C) (k : quotient.mk x ⟶ quotient.mk y) => hom_of_le sorry

theorem comp_to_thin_skeleton {C : Type u₁} [category C] {D : Type u₂} [category D] (F : C ⥤ D) :
    F ⋙ to_thin_skeleton D = to_thin_skeleton C ⋙ map F :=
  rfl

/-- Given a natural transformation `F₁ ⟶ F₂`, induce a natural transformation `map F₁ ⟶ map F₂`.-/
def map_nat_trans {C : Type u₁} [category C] {D : Type u₂} [category D] {F₁ : C ⥤ D} {F₂ : C ⥤ D}
    (k : F₁ ⟶ F₂) : map F₁ ⟶ map F₂ :=
  nat_trans.mk
    fun (X : thin_skeleton C) =>
      quotient.rec_on_subsingleton X fun (x : C) => ulift.up (plift.up sorry)

-- TODO: state the lemmas about what happens when you compose with `to_thin_skeleton`

/-- A functor `C ⥤ D ⥤ E` computably lowers to a functor
`thin_skeleton C ⥤ thin_skeleton D ⥤ thin_skeleton E` -/
@[simp] theorem map₂_obj_obj {C : Type u₁} [category C] {D : Type u₂} [category D] {E : Type u₃}
    [category E] (F : C ⥤ D ⥤ E) (x : thin_skeleton C) (y : thin_skeleton D) :
    functor.obj (functor.obj (map₂ F) x) y =
        quotient.map₂ (fun (X : C) (Y : D) => functor.obj (functor.obj F X) Y) (map₂._proof_1 F) x
          y :=
  Eq.refl (functor.obj (functor.obj (map₂ F) x) y)

protected instance to_thin_skeleton_faithful (C : Type u₁) [category C]
    [∀ (X Y : C), subsingleton (X ⟶ Y)] : faithful (to_thin_skeleton C) :=
  faithful.mk

/-- Use `quotient.out` to create a functor out of the thin skeleton. -/
@[simp] theorem from_thin_skeleton_map (C : Type u₁) [category C]
    [∀ (X Y : C), subsingleton (X ⟶ Y)] (x : thin_skeleton C) (y : thin_skeleton C) :
    ∀ (ᾰ : x ⟶ y),
        functor.map (from_thin_skeleton C) ᾰ =
          quotient.rec_on_subsingleton₂ x y
            (fun (X Y : C) (f : quotient.mk X ⟶ quotient.mk Y) =>
              iso.hom (nonempty.some (from_thin_skeleton._proof_2 C X)) ≫
                nonempty.some (from_thin_skeleton._proof_3 C X Y f) ≫
                  iso.inv (nonempty.some (from_thin_skeleton._proof_4 C Y)))
            ᾰ :=
  fun (ᾰ : x ⟶ y) => Eq.refl (functor.map (from_thin_skeleton C) ᾰ)

protected instance from_thin_skeleton_equivalence (C : Type u₁) [category C]
    [∀ (X Y : C), subsingleton (X ⟶ Y)] : is_equivalence (from_thin_skeleton C) :=
  is_equivalence.mk' (to_thin_skeleton C)
    (nat_iso.of_components
      (fun (x : thin_skeleton C) => quotient.rec_on_subsingleton x fun (X : C) => eq_to_iso sorry)
      sorry)
    (nat_iso.of_components (fun (X : C) => nonempty.some sorry) sorry)

theorem equiv_of_both_ways {C : Type u₁} [category C] [∀ (X Y : C), subsingleton (X ⟶ Y)] {X : C}
    {Y : C} (f : X ⟶ Y) (g : Y ⟶ X) : X ≈ Y :=
  Nonempty.intro (iso_of_both_ways f g)

protected instance thin_skeleton_partial_order {C : Type u₁} [category C]
    [∀ (X Y : C), subsingleton (X ⟶ Y)] : partial_order (thin_skeleton C) :=
  partial_order.mk preorder.le preorder.lt sorry sorry sorry

theorem skeletal {C : Type u₁} [category C] [∀ (X Y : C), subsingleton (X ⟶ Y)] :
    skeletal (thin_skeleton C) :=
  sorry

theorem map_comp_eq {C : Type u₁} [category C] {D : Type u₂} [category D] {E : Type u₃} [category E]
    [∀ (X Y : C), subsingleton (X ⟶ Y)] (F : E ⥤ D) (G : D ⥤ C) : map (F ⋙ G) = map F ⋙ map G :=
  sorry

theorem map_id_eq {C : Type u₁} [category C] [∀ (X Y : C), subsingleton (X ⟶ Y)] : map 𝟭 = 𝟭 :=
  sorry

theorem map_iso_eq {C : Type u₁} [category C] {D : Type u₂} [category D]
    [∀ (X Y : C), subsingleton (X ⟶ Y)] {F₁ : D ⥤ C} {F₂ : D ⥤ C} (h : F₁ ≅ F₂) : map F₁ = map F₂ :=
  functor.eq_of_iso skeletal (iso.mk (map_nat_trans (iso.hom h)) (map_nat_trans (iso.inv h)))

/-- `from_thin_skeleton C` exhibits the thin skeleton as a skeleton. -/
def thin_skeleton_is_skeleton {C : Type u₁} [category C] [∀ (X Y : C), subsingleton (X ⟶ Y)] :
    is_skeleton_of C (thin_skeleton C) (from_thin_skeleton C) :=
  is_skeleton_of.mk sorry (thin_skeleton.from_thin_skeleton_equivalence C)

protected instance is_skeleton_of_inhabited {C : Type u₁} [category C]
    [∀ (X Y : C), subsingleton (X ⟶ Y)] :
    Inhabited (is_skeleton_of C (thin_skeleton C) (from_thin_skeleton C)) :=
  { default := thin_skeleton_is_skeleton }

end Mathlib


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

Proofs that integrating out the KL and reparametizing are sound when
applied to the naive variational encoder.
-/
import .util .graph ..prove_model_ok ..backprop_correct

namespace certigrad
namespace aevb

open graph list tactic certigrad.tactic

set_option profiler true

#print "proving backprop_correct_on_aevb..."

theorem backprop_correct_on_aevb (a : arch) (ws : weights a) (x_data : T [a^.n_in, a^.n_x]) :
let g : graph := reparam (integrate_kl $ naive_aevb a x_data) in
let fdict : env := mk_input_dict ws x_data g in
∀ (tgt : reference) (idx : ℕ) (H_at_idx : at_idx g^.targets idx tgt),
∇ (λ θ₀, E (graph.to_dist (λ m, ⟦sum_costs m g^.costs⟧) (env.insert tgt θ₀ fdict) g^.nodes) dvec.head) (env.get tgt fdict)
=
E (graph.to_dist (λ m, backprop g^.costs g^.nodes m g^.targets) fdict g^.nodes) (λ dict, dvec.get tgt.2 dict idx) :=
by prove_model_ok

end aevb
end certigrad


import ..lovelib

/-! # LoVe Demo 8: Operational Semantics

In this and the next two lectures, we will see how to use Lean to specify the
syntax and semantics of programming languages and to reason about the
semantics. -/

set_option pp.beta true
set_option pp.generalized_field_notation false

namespace LoVe

/-! ## Formal Semantics

A formal semantics helps specify and reason about the programming language
itself, and about individual programs.

It can form the basis of verified compilers, interpreters, verifiers, static
analyzers, type checkers, etc. Without formal proofs, these tools are
**almost always wrong**.

In this area, proof assistants are widely used. Every year, about 10-20% of POPL
papers are partially or totally formalized. Reasons for this success:

* Little machinery (background libraries, tactics) is needed to get started,
  beyond inductive types and predicates and recursive functions.

* The proofs tend to have lots of cases, which is a good match for computers.

* Proof assistants keep track of what needs to be changed when as extend the
  programming language with more features.

Case in point: WebAssembly. To quote Conrad Watt (with some abbreviations):

    We have produced a full Isabelle mechanisation of the core execution
    semantics and type system of the WebAssembly language. To complete this
    proof, **several deficiencies** in the official WebAssembly specification,
    uncovered by our proof and modelling work, needed to be corrected. In some
    cases, these meant that the type system was **originally unsound**.

    We have maintained a constructive dialogue with the working group,
    verifying new features as they are added. In particular, the mechanism by
    which a WebAssembly implementation interfaces with its host environment was
    not formally specified in the working group's original paper. Extending our
    mechanisation to model this feature revealed a deficiency in the WebAssembly
    specification that **sabotaged the soundness** of the type system.

    (https://www.doc.ic.ac.uk/~pg/publications/Watt2021Two.pdf)

## A Minimalistic Imperative Language

A state `s` is a function from variable names to values (`string → ℕ`).

__WHILE__ is a minimalistic imperative language with the following grammar:

    S  ::=  skip                 -- no-op
         |  x := a               -- assignment
         |  S ; S                -- sequential composition
         |  if b then S else S   -- conditional statement
         |  while b do S         -- while loop

where `S` stands for a statement (also called command or program), `x` for a
variable, `a` for an arithmetic expression, and `b` for a Boolean expression. -/

#print state

inductive stmt : Type
| skip   : stmt
| assign : string → (state → ℕ) → stmt
| seq    : stmt → stmt → stmt
| ite    : (state → Prop) → stmt → stmt → stmt
| while  : (state → Prop) → stmt → stmt

infixr ` ;; ` : 90 := stmt.seq

#check λ s : state, s "y" + 2 * s "z"

/-! In our grammar, we deliberately leave the syntax of arithmetic and Boolean
expressions unspecified. In Lean, we have the choice:

* We could use a type such as `aexp` from lecture 1 and similarly for Boolean
  expressions.

* We could decide that an arithmetic expression is simply a function from
  states to natural numbers (`state → ℕ`) and a Boolean expression is a
  predicate (`state → Prop` or `state → bool`).

This corresponds to the difference between deep and shallow embeddings:

* A __deep embedding__ of some syntax (expression, formula, program, etc.)
  consists of an abstract syntax tree specified in the proof assistant
  (e.g., `aexp`) with a semantics (e.g., `eval`).

* In contrast, a __shallow embedding__ simply reuses the corresponding
  mechanisms from the logic (e.g., λ-terms, functions and predicate types).

A deep embedding allows us to reason about the syntax (and its semantics). A
shallow embedding is more lightweight, because we can use it directly, without
having to define a semantics.

We will use a deep embedding of programs (which we find interesting), and
shallow embeddings of assignments and Boolean expressions (which we find
boring). -/

def silly_loop : stmt :=
stmt.while (λs, s "x" > s "y")
  (stmt.skip ;; stmt.assign "x" (λs, s "x" - 1))

/-! ## Big-Step Semantics

An __operational semantics__ corresponds to an idealized interpreter (specified
in a Prolog-like language). Two main variants:

* big-step semantics;

* small-step semantics.

In a __big-step semantics__ (also called __natural semantics__), judgments have
the form `(S, s) ⟹ t`:

    Starting in a state `s`, executing `S` terminates in the state `t`.

Example:

    `(x := x + y; y := 0, [x ↦ 3, y ↦ 5]) ⟹ [x ↦ 8, y ↦ 0]`

Derivation rules:

    ——————————————— Skip
    (skip, s) ⟹ s

    ——————————————————————————— Asn
    (x := a, s) ⟹ s[x ↦ s(a)]

    (S, s) ⟹ t   (T, t) ⟹ u
    ——————————————————————————— Seq
    (S; T, s) ⟹ u

    (S, s) ⟹ t
    ————————————————————————————— If-True   if s(b) is true
    (if b then S else T, s) ⟹ t

    (T, s) ⟹ t
    ————————————————————————————— If-False   if s(b) is false
    (if b then S else T, s) ⟹ t

    (S, s) ⟹ t   (while b do S, t) ⟹ u
    —————————————————————————————————————— While-True   if s(b) is true
    (while b do S, s) ⟹ u

    ————————————————————————— While-False   if s(b) is false
    (while b do S, s) ⟹ s

Above, `s(e)` denotes the value of expression `e` in state `s`.

In Lean, the judgment corresponds to an inductive predicate, and the derivation
rules correspond to the predicate's introduction rules. Using an inductive
predicate as opposed to a recursive function allows us to cope with
nontermination (e.g., a diverging `while`) and nondeterminism (e.g.,
multithreading). -/

inductive big_step : stmt × state → state → Prop
| skip {s} :
  big_step (stmt.skip, s) s
| assign {x a s} :
  big_step (stmt.assign x a, s) (s{x ↦ a s})
| seq {S T s t u} (hS : big_step (S, s) t)
    (hT : big_step (T, t) u) :
  big_step (S ;; T, s) u
| ite_true {b : state → Prop} {S T s t} (hcond : b s)
    (hbody : big_step (S, s) t) :
  big_step (stmt.ite b S T, s) t
| ite_false {b : state → Prop} {S T s t} (hcond : ¬ b s)
    (hbody : big_step (T, s) t) :
  big_step (stmt.ite b S T, s) t
| while_true {b : state → Prop} {S s t u} (hcond : b s)
    (hbody : big_step (S, s) t)
    (hrest : big_step (stmt.while b S, t) u) :
  big_step (stmt.while b S, s) u
| while_false {b : state → Prop} {S s} (hcond : ¬ b s) :
  big_step (stmt.while b S, s) s

infix ` ⟹ ` : 110 := big_step

lemma silly_loop_from_1_big_step :
  (silly_loop, (λ_, 0){"x" ↦ 1}) ⟹ (λ_, 0) :=
begin
  rw silly_loop,
  apply big_step.while_true,
  { simp },
  { apply big_step.seq,
    { apply big_step.skip },
    { apply big_step.assign } },
  { simp,
    apply big_step.while_false,
    linarith }
end

/-! ## Properties of the Big-Step Semantics

Equipped with a big-step semantics, we can

* prove properties of the programming language, such as **equivalence proofs**
  between programs and **determinism**;

* reason about **concrete programs**, proving theorems relating final states `t`
  with initial states `s`. -/

lemma big_step_deterministic {S s l r} (hl : (S, s) ⟹ l)
    (hr : (S, s) ⟹ r) :
  l = r :=
begin
  induction' hl,
  case skip {
    cases' hr,
    refl },
  case assign {
    cases' hr,
    refl },
  case seq : S T s t l hS hT ihS ihT {
    cases' hr with _ _ _ _ _ _ _ t' _ hS' hT',
    cases' ihS hS',
    cases' ihT hT',
    refl },
  case ite_true : b S T s t hb hS ih {
    cases' hr,
    { apply ih hr },
    { cc } },
  case ite_false : b S T s t hb hT ih {
    cases' hr,
    { cc },
    { apply ih hr } },
  case while_true : b S s t u hb hS hw ihS ihw {
    cases' hr,
    { cases' ihS hr,
      cases' ihw hr_1,
      refl },
    { cc } },
  case while_false {
    cases' hr,
    { cc },
    { refl } }
end

lemma big_step_terminates {S s} :
  ∃t, (S, s) ⟹ t :=
sorry   -- unprovable

lemma big_step_doesnt_terminate {S s t} :
  ¬ (stmt.while (λ_, true) S, s) ⟹ t :=
begin
  intro hw,
  induction' hw,
  case while_true {
    assumption },
  case while_false {
    cc }
end

/-! We can define inversion rules about the big-step semantics: -/

@[simp] lemma big_step_skip_iff {s t} :
  (stmt.skip, s) ⟹ t ↔ t = s :=
begin
  apply iff.intro,
  { intro h,
    cases' h,
    refl },
  { intro h,
    rw h,
    exact big_step.skip }
end

@[simp] lemma big_step_assign_iff {x a s t} :
  (stmt.assign x a, s) ⟹ t ↔ t = s{x ↦ a s} :=
begin
  apply iff.intro,
  { intro h,
    cases' h,
    refl },
  { intro h,
    rw h,
    exact big_step.assign }
end

@[simp] lemma big_step_seq_iff {S T s t} :
  (S ;; T, s) ⟹ t ↔ (∃u, (S, s) ⟹ u ∧ (T, u) ⟹ t) :=
begin
  apply iff.intro,
  { intro h,
    cases' h,
    apply exists.intro,
    apply and.intro; assumption },
  { intro h,
    cases' h,
    cases' h,
    apply big_step.seq; assumption }
end

@[simp] lemma big_step_ite_iff {b S T s t} :
  (stmt.ite b S T, s) ⟹ t ↔
  (b s ∧ (S, s) ⟹ t) ∨ (¬ b s ∧ (T, s) ⟹ t) :=
begin
  apply iff.intro,
  { intro h,
    cases' h,
    { apply or.intro_left,
      cc },
    { apply or.intro_right,
      cc } },
  { intro h,
    cases' h; cases' h,
    { apply big_step.ite_true; assumption },
    { apply big_step.ite_false; assumption } }
end

lemma big_step_while_iff {b S s u} :
  (stmt.while b S, s) ⟹ u ↔
  (∃t, b s ∧ (S, s) ⟹ t ∧ (stmt.while b S, t) ⟹ u)
  ∨ (¬ b s ∧ u = s) :=
begin
  apply iff.intro,
  { intro h,
    cases' h,
    { apply or.intro_left,
      apply exists.intro t,
      cc },
    { apply or.intro_right,
      cc } },
  { intro h,
    cases' h,
    case inl {
      cases' h with t h,
      cases' h with hb h,
      cases' h with hS hwhile,
      exact big_step.while_true hb hS hwhile },
    case inr {
      cases' h with hb hus,
      rw hus,
      exact big_step.while_false hb } }
end

lemma big_step_while_true_iff {b : state → Prop} {S s u}
    (hcond : b s) :
  (stmt.while b S, s) ⟹ u ↔
  (∃t, (S, s) ⟹ t ∧ (stmt.while b S, t) ⟹ u) :=
by rw big_step_while_iff; simp [hcond]

@[simp] lemma big_step_while_false_iff {b : state → Prop}
    {S s t} (hcond : ¬ b s) :
  (stmt.while b S, s) ⟹ t ↔ t = s :=
by rw big_step_while_iff; simp [hcond]

/-! ## Small-Step Semantics

A big-step semantics

* does not let us reason about intermediate states;

* does not let us express nontermination or interleaving (for multithreading).

__Small-step semantics__ (also called __structural operational semantics__)
solve the above issues.

A judgment has the form `(S, s) ⇒ (T, t)`:

    Starting in a state `s`, executing one step of `S` leaves us in the
    state `t`, with the program `T` remaining to be executed.

An execution is a finite or infinite chain `(S₀, s₀) ⇒ (S₁, s₁) ⇒ …`.

A pair `(S, s)` is called a __configuration__. It is __final__ if no transition
of the form `(S, s) ⇒ _` is possible.

Example:

      `(x := x + y; y := 0, [x ↦ 3, y ↦ 5])`
    `⇒ (skip; y := 0,       [x ↦ 8, y ↦ 5])`
    `⇒ (y := 0,             [x ↦ 8, y ↦ 5])`
    `⇒ (skip,               [x ↦ 8, y ↦ 0])`

Derivation rules:

    ————————————————————————————————— Asn
    (x := a, s) ⇒ (skip, s[x ↦ s(a)])

    (S, s) ⇒ (S', s')
    ———-————————————————————— Seq-Step
    (S ; T, s) ⇒ (S' ; T, s')

    —————————————————————— Seq-Skip
    (skip ; S, s) ⇒ (S, s)

    ———————————————————————————————— If-True   if s(b) is true
    (if b then S else T, s) ⇒ (S, s)

    ———————————————————————————————— If-False   if s(b) is false
    (if b then S else T, s) ⇒ (T, s)

    ——————————————————————————————————————————————————————————————— While
    (while b do S, s) ⇒ (if b then (S ; while b do S) else skip, s)

There is no rule for `skip` (why?). -/

inductive small_step : stmt × state → stmt × state → Prop
| assign {x a s} :
  small_step (stmt.assign x a, s) (stmt.skip, s{x ↦ a s})
| seq_step {S S' T s s'} (hS : small_step (S, s) (S', s')) :
  small_step (S ;; T, s) (S' ;; T, s')
| seq_skip {T s} :
  small_step (stmt.skip ;; T, s) (T, s)
| ite_true {b : state → Prop} {S T s} (hcond : b s) :
  small_step (stmt.ite b S T, s) (S, s)
| ite_false {b : state → Prop} {S T s} (hcond : ¬ b s) :
  small_step (stmt.ite b S T, s) (T, s)
| while {b : state → Prop} {S s} :
  small_step (stmt.while b S, s)
    (stmt.ite b (S ;; stmt.while b S) stmt.skip, s)

infixr (name := small_step) ` ⇒ ` := small_step
infixr ` ⇒* ` : 100 := star small_step

lemma silly_loop_from_1_small_step :
  (silly_loop, (λ_, 0){"x" ↦ 1}) ⇒*
  (stmt.skip, ((λ_, 0) : state)) :=
begin
  rw silly_loop,
  apply star.head,
  { apply small_step.while },
  { apply star.head,
    { apply small_step.ite_true,
      simp },
    { apply star.head,
      { apply small_step.seq_step,
        apply small_step.seq_skip },
      { apply star.head,
        { apply small_step.seq_step,
          apply small_step.assign },
        { apply star.head,
          { apply small_step.seq_skip },
          { apply star.head,
            { apply small_step.while },
            { apply star.head,
              { apply small_step.ite_false,
                simp },
              { simp } } } } } } }
end

/-! Equipped with a small-step semantics, we can **define** a big-step
semantics:

    `(S, s) ⟹ t` if and only if `(S, s) ⇒* (skip, t)`

where `r*` denotes the reflexive transitive closure of a relation `r`.

Alternatively, if we have already defined a big-step semantics, we can **prove**
the above equivalence theorem to validate our definitions.

The main disadvantage of small-step semantics is that we now have two relations,
`⇒` and `⇒*`, and reasoning tends to be more complicated.

## Properties of the Small-Step Semantics

We can prove that a configuration `(S, s)` is final if and only if `S = skip`.
This ensures that we have not forgotten a derivation rule. -/

lemma small_step_final (S s) :
  (¬ ∃T t, (S, s) ⇒ (T, t)) ↔ S = stmt.skip :=
begin
  induction' S,
  case skip {
    simp,
    intros T t hstep,
    cases' hstep },
  case assign : x a {
    simp,
    apply exists.intro stmt.skip,
    apply exists.intro (s{x ↦ a s}),
    exact small_step.assign },
  case seq : S T ihS ihT {
    simp,
    cases' classical.em (S = stmt.skip),
    case inl {
      rw h,
      apply exists.intro T,
      apply exists.intro s,
      exact small_step.seq_skip },
    case inr {
      simp [h, auto.not_forall_eq, auto.not_not_eq] at ihS,
      cases' ihS s with S' hS',
      cases' hS' with s' hs',
      apply exists.intro (S' ;; T),
      apply exists.intro s',
      exact small_step.seq_step hs' } },
  case ite : b S T ihS ihT {
    simp,
    cases' classical.em (b s),
    case inl {
      apply exists.intro S,
      apply exists.intro s,
      exact small_step.ite_true h },
    case inr {
      apply exists.intro T,
      apply exists.intro s,
      exact small_step.ite_false h } },
  case while : b S ih {
    simp,
    apply exists.intro (stmt.ite b (S ;; stmt.while b S) stmt.skip),
    apply exists.intro s,
    exact small_step.while }
end

lemma small_step_deterministic {S s Ll Rr}
    (hl : (S, s) ⇒ Ll) (hr : (S, s) ⇒ Rr) :
  Ll = Rr :=
begin
  induction' hl,
  case assign : x a s {
    cases' hr,
    refl },
  case seq_step : S S₁ T s s₁ hS₁ ih {
    cases' hr,
    case seq_step : S S₂ _ _ s₂ hS₂ {
      have hSs₁₂ := ih hS₂,
      cc },
    case seq_skip {
      cases' hS₁ } },
  case seq_skip : T s {
    cases' hr,
    case seq_step {
      cases' hr },
    case seq_skip {
      refl } },
  case ite_true : b S T s hcond {
    cases' hr,
    case ite_true {
      refl },
    case ite_false {
      cc } },
  case ite_false : b S T s hcond {
    cases' hr,
    case ite_true {
      cc },
    case ite_false {
      refl } },
  case while : b S s {
    cases' hr,
    refl }
end

/-! We can define inversion rules also about the small-step semantics. Here are
three examples: -/

lemma small_step_skip {S s t} :
  ¬ ((stmt.skip, s) ⇒ (S, t)) :=
by intro h; cases' h

@[simp] lemma small_step_seq_iff {S T s Ut} :
  (S ;; T, s) ⇒ Ut ↔
  (∃S' t, (S, s) ⇒ (S', t) ∧ Ut = (S' ;; T, t))
  ∨ (S = stmt.skip ∧ Ut = (T, s)) :=
begin
  apply iff.intro,
  { intro h,
    cases' h,
    { apply or.intro_left,
      apply exists.intro S',
      apply exists.intro s',
      cc },
    { apply or.intro_right,
      cc } },
  { intro h,
    cases' h,
    { cases' h,
      cases' h,
      cases' h,
      rw right,
      apply small_step.seq_step,
      assumption },
    { cases' h,
      rw left,
      rw right,
      apply small_step.seq_skip } }
end

@[simp] lemma small_step_ite_iff {b S T s Us} :
  (stmt.ite b S T, s) ⇒ Us ↔
  (b s ∧ Us = (S, s)) ∨ (¬ b s ∧ Us = (T, s)) :=
begin
  apply iff.intro,
  { intro h,
    cases' h,
    { apply or.intro_left,
      cc },
    { apply or.intro_right,
      cc } },
  { intro h,
    cases' h,
    { cases' h,
      rw right,
      apply small_step.ite_true,
      assumption },
    { cases' h,
      rw right,
      apply small_step.ite_false,
      assumption } }
end

/-! ### Equivalence of the Big-Step and the Small-Step Semantics (**optional**)

A more important result is the connection between the big-step and the
small-step semantics:

    `(S, s) ⟹ t ↔ (S, s) ⇒* (stmt.skip, t)`

Its proof, given below, is beyond the scope of this course. -/

lemma star_small_step_seq {S T s u}
    (h : (S, s) ⇒* (stmt.skip, u)) :
  (S ;; T, s) ⇒* (stmt.skip ;; T, u) :=
begin
  apply star.lift (λSs, (prod.fst Ss ;; T, prod.snd Ss)) _ h,
  intros Ss Ss' h,
  cases' Ss,
  cases' Ss',
  apply small_step.seq_step,
  assumption
end

lemma star_small_step_of_big_step {S s t} (h : (S, s) ⟹ t) :
  (S, s) ⇒* (stmt.skip, t) :=
begin
  induction' h,
  case skip {
    refl },
  case assign {
    exact star.single small_step.assign },
  case seq : S T s t u hS hT ihS ihT {
    transitivity,
    exact star_small_step_seq ihS,
    apply star.head small_step.seq_skip ihT },
  case ite_true : b S T s t hs hst ih {
    exact star.head (small_step.ite_true hs) ih },
  case ite_false : b S T s t hs hst ih {
    exact star.head (small_step.ite_false hs) ih },
  case while_true : b S s t u hb hS hw ihS ihw {
    exact (star.head small_step.while
      (star.head (small_step.ite_true hb)
         (star.trans (star_small_step_seq ihS)
            (star.head small_step.seq_skip ihw)))) },
  case while_false : b S s hb {
    exact star.tail (star.single small_step.while)
      (small_step.ite_false hb) }
end

lemma big_step_of_small_step_of_big_step {S₀ S₁ s₀ s₁ s₂}
  (h₁ : (S₀, s₀) ⇒ (S₁, s₁)) :
  (S₁, s₁) ⟹ s₂ → (S₀, s₀) ⟹ s₂ :=
begin
  induction' h₁;
    simp [*, big_step_while_true_iff] {contextual := tt},
  case seq_step {
    intros u hS' hT,
    apply exists.intro u,
    exact and.intro (ih hS') hT }
end

lemma big_step_of_star_small_step {S s t} :
  (S, s) ⇒* (stmt.skip, t) → (S, s) ⟹ t :=
begin
  generalize hSs : (S, s) = Ss,
  intro h,
  induction h
      using LoVe.rtc.star.head_induction_on
      with _ S's' h h' ih
      generalizing S s;
    cases' hSs,
  { exact big_step.skip },
  { cases' S's' with S' s',
    apply big_step_of_small_step_of_big_step h,
    apply ih,
    refl }
end

lemma big_step_iff_star_small_step {S s t} :
  (S, s) ⟹ t ↔ (S, s) ⇒* (stmt.skip, t) :=
iff.intro star_small_step_of_big_step
  big_step_of_star_small_step

/-! ## Parallelism (**optional**) -/

/--
a proof of `par_step i (Ss, t) (Ss', t')` represents:
"
  Let `Ss` be a list of WHILE programs that we wish to execute in parallel.
  If we evaluate one step of the `i`th program in `Ss` while in state `t`,
  we reach state `t'`, with the list of programs `Ss'` remaining to execute."
-/
inductive par_step :
    nat → list stmt × state → list stmt × state → Prop
| intro {Ss Ss' S S' s s' i}
    (hi : i < list.length Ss)
    (hS : S = list.nth_le Ss i hi)
    (hs : (S, s) ⇒ (S', s'))
    (hS' : Ss' = list.update_nth Ss i S') :
  par_step i (Ss, s) (Ss', s')

lemma par_step_diamond {i j Ss Ts Ts' s t t'}
    (hi : i < list.length Ss)
    (hj : j < list.length Ss)
    (hij : i ≠ j)
    (hT : par_step i (Ss, s) (Ts, t))
    (hT' : par_step j (Ss, s) (Ts', t')) :
  ∃u Us, par_step j (Ts, t) (Us, u) ∧
    par_step i (Ts', t') (Us, u) :=
sorry

/--
`stmt.W S` returns the set of variables written to by a thread `S`.
-/
def stmt.W : stmt → set string
| stmt.skip         := ∅
| (stmt.assign x _) := {x}
| (stmt.seq S T)    := stmt.W S ∪ stmt.W T
| (stmt.ite _ S T)  := stmt.W S ∪ stmt.W T
| (stmt.while _ S)  := stmt.W S

/--
`exp.R f` returns the set of variables read by an arithmetic or boolean expression `f`.
-/
def exp.R {α : Type} (f : state → α) : set string :=
{x | ∃ s n, f (s{x ↦ n}) ≠ f s}

/--
`stmt.R S` returns the set of variables read by a thread `S`.
-/
def stmt.R : stmt → set string
| stmt.skip         := ∅
| (stmt.assign _ a) := exp.R a
| (stmt.seq S T)    := stmt.R S ∪ stmt.R T
| (stmt.ite b S T)  := exp.R b ∪ stmt.R S ∪ stmt.R T
| (stmt.while b S)  := exp.R b ∪ stmt.R S

/--
`stmt.V S` returns the set of variables written to or read by a thread `S`.
-/
def stmt.V : stmt → set string
| S := stmt.W S ∪ stmt.R S

lemma par_step_diamond_VW_disjoint {i j Ss Ts Ts' s t t'}
    (hiS : i < list.length Ss)
    (hjT : j < list.length Ts)
    (hij : i ≠ j)
    (hT : par_step i (Ss, s) (Ts, t))
    (hT' : par_step j (Ss, s) (Ts', t'))
    (hWV : stmt.W (list.nth_le Ss i hiS)
       ∩ stmt.V (list.nth_le Ts j hjT) = ∅)
    (hVW : stmt.V (list.nth_le Ss i hiS)
       ∩ stmt.W (list.nth_le Ts j hjT) = ∅) :
  ∃u Us, par_step j (Ts, t) (Us, u) ∧
    par_step i (Ts', t') (Us, u) :=
sorry   -- this should be provable

end LoVe


/-
Copyright (c) 2019 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Floris van Doorn
-/
import category_theory.limits.shapes.finite_products
import category_theory.discrete_category

/-!
# Limits in `C` give colimits in `Cᵒᵖ`.

We also give special cases for (co)products,
(co)equalizers, and pullbacks / pushouts.

-/

universes v₁ v₂ u₁ u₂

noncomputable theory

open category_theory
open category_theory.functor
open opposite

namespace category_theory.limits

variables {C : Type u₁} [category.{v₁} C]
variables {J : Type u₂} [category.{v₂} J]

/-- Turn a colimit for `F : J ⥤ C` into a limit for `F.op : Jᵒᵖ ⥤ Cᵒᵖ`. -/
@[simps] def is_limit_cocone_op (F : J ⥤ C) {c : cocone F} (hc : is_colimit c) :
  is_limit c.op :=
{ lift := λ s, (hc.desc s.unop).op,
  fac' := λ s j, quiver.hom.unop_inj (by simpa),
  uniq' := λ s m w,
  begin
    refine quiver.hom.unop_inj (hc.hom_ext (λ j, quiver.hom.op_inj _)),
    simpa only [quiver.hom.unop_op, is_colimit.fac] using w (op j)
  end }

/-- Turn a limit for `F : J ⥤ C` into a colimit for `F.op : Jᵒᵖ ⥤ Cᵒᵖ`. -/
@[simps] def is_colimit_cone_op (F : J ⥤ C) {c : cone F} (hc : is_limit c) :
  is_colimit c.op :=
{ desc := λ s, (hc.lift s.unop).op,
  fac' := λ s j, quiver.hom.unop_inj (by simpa),
  uniq' := λ s m w,
  begin
    refine quiver.hom.unop_inj (hc.hom_ext (λ j, quiver.hom.op_inj _)),
    simpa only [quiver.hom.unop_op, is_limit.fac] using w (op j)
  end }

/-- Turn a colimit for `F : J ⥤ Cᵒᵖ` into a limit for `F.left_op : Jᵒᵖ ⥤ C`. -/
@[simps] def is_limit_cone_left_op_of_cocone (F : J ⥤ Cᵒᵖ) {c : cocone F} (hc : is_colimit c) :
  is_limit (cone_left_op_of_cocone c) :=
{ lift := λ s, (hc.desc (cocone_of_cone_left_op s)).unop,
  fac' :=  λ s j, quiver.hom.op_inj $ by simpa only [cone_left_op_of_cocone_π_app, op_comp,
    quiver.hom.op_unop, is_colimit.fac, cocone_of_cone_left_op_ι_app],
  uniq' := λ s m w,
  begin
    refine quiver.hom.op_inj (hc.hom_ext (λ j, quiver.hom.unop_inj _)),
    simpa only [quiver.hom.op_unop, is_colimit.fac, cocone_of_cone_left_op_ι_app] using w (op j)
  end }

/-- Turn a limit of `F : J ⥤ Cᵒᵖ` into a colimit of `F.left_op : Jᵒᵖ ⥤ C`. -/
@[simps] def is_colimit_cocone_left_op_of_cone (F : J ⥤ Cᵒᵖ) {c : cone F} (hc : is_limit c) :
  is_colimit (cocone_left_op_of_cone c) :=
{ desc := λ s, (hc.lift (cone_of_cocone_left_op s)).unop,
  fac' := λ s j, quiver.hom.op_inj $ by simpa only [cocone_left_op_of_cone_ι_app, op_comp,
    quiver.hom.op_unop, is_limit.fac, cone_of_cocone_left_op_π_app],
  uniq' := λ s m w,
  begin
    refine quiver.hom.op_inj (hc.hom_ext (λ j, quiver.hom.unop_inj _)),
    simpa only [quiver.hom.op_unop, is_limit.fac, cone_of_cocone_left_op_π_app] using w (op j)
  end }

/-- Turn a colimit for `F : Jᵒᵖ ⥤ C` into a limit for `F.right_op : J ⥤ Cᵒᵖ`. -/
@[simps] def is_limit_cone_right_op_of_cocone (F : Jᵒᵖ ⥤ C) {c : cocone F} (hc : is_colimit c) :
  is_limit (cone_right_op_of_cocone c) :=
{ lift := λ s, (hc.desc (cocone_of_cone_right_op s)).op,
  fac' := λ s j, quiver.hom.unop_inj (by simpa),
  uniq' := λ s m w,
  begin
    refine quiver.hom.unop_inj (hc.hom_ext (λ j, quiver.hom.op_inj _)),
    simpa only [quiver.hom.unop_op, is_colimit.fac] using w (unop j)
  end }

/-- Turn a limit for `F : Jᵒᵖ ⥤ C` into a colimit for `F.right_op : J ⥤ Cᵒᵖ`. -/
@[simps] def is_colimit_cocone_right_op_of_cone (F : Jᵒᵖ ⥤ C) {c : cone F} (hc : is_limit c) :
  is_colimit (cocone_right_op_of_cone c) :=
{ desc := λ s, (hc.lift (cone_of_cocone_right_op s)).op,
  fac' := λ s j, quiver.hom.unop_inj (by simpa),
  uniq' := λ s m w,
  begin
    refine quiver.hom.unop_inj (hc.hom_ext (λ j, quiver.hom.op_inj _)),
    simpa only [quiver.hom.unop_op, is_limit.fac] using w (unop j)
  end }

/-- Turn a colimit for `F : Jᵒᵖ ⥤ Cᵒᵖ` into a limit for `F.unop : J ⥤ C`. -/
@[simps] def is_limit_cone_unop_of_cocone (F : Jᵒᵖ ⥤ Cᵒᵖ) {c : cocone F} (hc : is_colimit c) :
  is_limit (cone_unop_of_cocone c) :=
{ lift := λ s, (hc.desc (cocone_of_cone_unop s)).unop,
  fac' := λ s j, quiver.hom.op_inj (by simpa),
  uniq' := λ s m w,
  begin
    refine quiver.hom.op_inj (hc.hom_ext (λ j, quiver.hom.unop_inj _)),
    simpa only [quiver.hom.op_unop, is_colimit.fac] using w (unop j)
  end }

/-- Turn a limit of `F : Jᵒᵖ ⥤ Cᵒᵖ` into a colimit of `F.unop : J ⥤ C`. -/
@[simps] def is_colimit_cocone_unop_of_cone (F : Jᵒᵖ ⥤ Cᵒᵖ) {c : cone F} (hc : is_limit c) :
  is_colimit (cocone_unop_of_cone c) :=
{ desc := λ s, (hc.lift (cone_of_cocone_unop s)).unop,
  fac' := λ s j, quiver.hom.op_inj (by simpa),
  uniq' := λ s m w,
  begin
    refine quiver.hom.op_inj (hc.hom_ext (λ j, quiver.hom.unop_inj _)),
    simpa only [quiver.hom.op_unop, is_limit.fac] using w (unop j)
  end }

/-- Turn a colimit for `F.op : Jᵒᵖ ⥤ Cᵒᵖ` into a limit for `F : J ⥤ C`. -/
@[simps] def is_limit_cocone_unop (F : J ⥤ C) {c : cocone F.op} (hc : is_colimit c) :
  is_limit c.unop :=
{ lift := λ s, (hc.desc s.op).unop,
  fac' := λ s j, quiver.hom.op_inj (by simpa),
  uniq' := λ s m w,
  begin
    refine quiver.hom.op_inj (hc.hom_ext (λ j, quiver.hom.unop_inj _)),
    simpa only [quiver.hom.op_unop, is_colimit.fac] using w (unop j)
  end }

/-- Turn a limit for `F.op : Jᵒᵖ ⥤ Cᵒᵖ` into a colimit for `F : J ⥤ C`. -/
@[simps] def is_colimit_cone_unop (F : J ⥤ C) {c : cone F.op} (hc : is_limit c) :
  is_colimit c.unop :=
{ desc := λ s, (hc.lift s.op).unop,
  fac' := λ s j, quiver.hom.op_inj (by simpa),
  uniq' := λ s m w,
  begin
    refine quiver.hom.op_inj (hc.hom_ext (λ j, quiver.hom.unop_inj _)),
    simpa only [quiver.hom.op_unop, is_limit.fac] using w (unop j)
  end }

/-- Turn a colimit for `F.left_op : Jᵒᵖ ⥤ C` into a limit for `F : J ⥤ Cᵒᵖ`. -/
@[simps] def is_limit_cone_of_cocone_left_op (F : J ⥤ Cᵒᵖ) {c : cocone F.left_op}
  (hc : is_colimit c) : is_limit (cone_of_cocone_left_op c) :=
{ lift := λ s, (hc.desc (cocone_left_op_of_cone s)).op,
  fac' := λ s j, quiver.hom.unop_inj $ by simpa only [cone_of_cocone_left_op_π_app, unop_comp,
    quiver.hom.unop_op, is_colimit.fac, cocone_left_op_of_cone_ι_app],
  uniq' := λ s m w,
  begin
    refine quiver.hom.unop_inj (hc.hom_ext (λ j, quiver.hom.op_inj _)),
    simpa only [quiver.hom.unop_op, is_colimit.fac, cone_of_cocone_left_op_π_app] using w (unop j)
  end }

/-- Turn a limit of `F.left_op : Jᵒᵖ ⥤ C` into a colimit of `F : J ⥤ Cᵒᵖ`. -/
@[simps] def is_colimit_cocone_of_cone_left_op (F : J ⥤ Cᵒᵖ) {c : cone (F.left_op)}
  (hc : is_limit c) : is_colimit (cocone_of_cone_left_op c) :=
{ desc := λ s, (hc.lift (cone_left_op_of_cocone s)).op,
  fac' := λ s j, quiver.hom.unop_inj $ by simpa only [cocone_of_cone_left_op_ι_app, unop_comp,
    quiver.hom.unop_op, is_limit.fac, cone_left_op_of_cocone_π_app],
  uniq' := λ s m w,
  begin
    refine quiver.hom.unop_inj (hc.hom_ext (λ j, quiver.hom.op_inj _)),
    simpa only [quiver.hom.unop_op, is_limit.fac, cocone_of_cone_left_op_ι_app] using w (unop j)
  end }

/-- Turn a colimit for `F.right_op : J ⥤ Cᵒᵖ` into a limit for `F : Jᵒᵖ ⥤ C`. -/
@[simps] def is_limit_cone_of_cocone_right_op (F : Jᵒᵖ ⥤ C) {c : cocone F.right_op}
  (hc : is_colimit c) : is_limit (cone_of_cocone_right_op c) :=
{ lift := λ s, (hc.desc (cocone_right_op_of_cone s)).unop,
  fac' := λ s j, quiver.hom.op_inj (by simpa),
  uniq' := λ s m w,
  begin
    refine quiver.hom.op_inj (hc.hom_ext (λ j, quiver.hom.unop_inj _)),
    simpa only [quiver.hom.op_unop, is_colimit.fac] using w (op j)
  end }

/-- Turn a limit for `F.right_op : J ⥤ Cᵒᵖ` into a limit for `F : Jᵒᵖ ⥤ C`. -/
@[simps] def is_colimit_cocone_of_cone_right_op (F : Jᵒᵖ ⥤ C) {c : cone F.right_op}
  (hc : is_limit c) : is_colimit (cocone_of_cone_right_op c) :=
{ desc := λ s, (hc.lift (cone_right_op_of_cocone s)).unop,
  fac' := λ s j, quiver.hom.op_inj (by simpa),
  uniq' := λ s m w,
  begin
    refine quiver.hom.op_inj (hc.hom_ext (λ j, quiver.hom.unop_inj _)),
    simpa only [quiver.hom.op_unop, is_limit.fac] using w (op j)
  end }

/-- Turn a colimit for `F.unop : J ⥤ C` into a limit for `F : Jᵒᵖ ⥤ Cᵒᵖ`. -/
@[simps] def is_limit_cone_of_cocone_unop (F : Jᵒᵖ ⥤ Cᵒᵖ) {c : cocone F.unop} (hc : is_colimit c) :
  is_limit (cone_of_cocone_unop c) :=
{ lift := λ s, (hc.desc (cocone_unop_of_cone s)).op,
  fac' := λ s j, quiver.hom.unop_inj (by simpa),
  uniq' := λ s m w,
  begin
    refine quiver.hom.unop_inj (hc.hom_ext (λ j, quiver.hom.op_inj _)),
    simpa only [quiver.hom.unop_op, is_colimit.fac] using w (op j)
  end }

/-- Turn a limit for `F.unop : J ⥤ C` into a colimit for `F : Jᵒᵖ ⥤ Cᵒᵖ`. -/
@[simps] def is_colimit_cone_of_cocone_unop (F : Jᵒᵖ ⥤ Cᵒᵖ) {c : cone F.unop} (hc : is_limit c) :
  is_colimit (cocone_of_cone_unop c) :=
{ desc := λ s, (hc.lift (cone_unop_of_cocone s)).op,
  fac' := λ s j, quiver.hom.unop_inj (by simpa),
  uniq' := λ s m w,
  begin
    refine quiver.hom.unop_inj (hc.hom_ext (λ j, quiver.hom.op_inj _)),
    simpa only [quiver.hom.unop_op, is_limit.fac] using w (op j)
  end }

/--
If `F.left_op : Jᵒᵖ ⥤ C` has a colimit, we can construct a limit for `F : J ⥤ Cᵒᵖ`.
-/
lemma has_limit_of_has_colimit_left_op (F : J ⥤ Cᵒᵖ) [has_colimit F.left_op] : has_limit F :=
has_limit.mk
{ cone := cone_of_cocone_left_op (colimit.cocone F.left_op),
  is_limit := is_limit_cone_of_cocone_left_op _ (colimit.is_colimit _) }

/--
If `C` has colimits of shape `Jᵒᵖ`, we can construct limits in `Cᵒᵖ` of shape `J`.
-/
lemma has_limits_of_shape_op_of_has_colimits_of_shape [has_colimits_of_shape Jᵒᵖ C] :
  has_limits_of_shape J Cᵒᵖ :=
{ has_limit := λ F, has_limit_of_has_colimit_left_op F }

local attribute [instance] has_limits_of_shape_op_of_has_colimits_of_shape

/--
If `C` has colimits, we can construct limits for `Cᵒᵖ`.
-/
lemma has_limits_op_of_has_colimits [has_colimits C] : has_limits Cᵒᵖ := ⟨infer_instance⟩

/--
If `F.left_op : Jᵒᵖ ⥤ C` has a limit, we can construct a colimit for `F : J ⥤ Cᵒᵖ`.
-/
lemma has_colimit_of_has_limit_left_op (F : J ⥤ Cᵒᵖ) [has_limit F.left_op] : has_colimit F :=
has_colimit.mk
{ cocone := cocone_of_cone_left_op (limit.cone F.left_op),
  is_colimit := is_colimit_cocone_of_cone_left_op _ (limit.is_limit _) }

/--
If `C` has colimits of shape `Jᵒᵖ`, we can construct limits in `Cᵒᵖ` of shape `J`.
-/
lemma has_colimits_of_shape_op_of_has_limits_of_shape [has_limits_of_shape Jᵒᵖ C] :
  has_colimits_of_shape J Cᵒᵖ :=
{ has_colimit := λ F, has_colimit_of_has_limit_left_op F }

local attribute [instance] has_colimits_of_shape_op_of_has_limits_of_shape

/--
If `C` has limits, we can construct colimits for `Cᵒᵖ`.
-/
lemma has_colimits_op_of_has_limits [has_limits C] : has_colimits Cᵒᵖ := ⟨infer_instance⟩

variables (X : Type v₁)
/--
If `C` has products indexed by `X`, then `Cᵒᵖ` has coproducts indexed by `X`.
-/
lemma has_coproducts_opposite [has_products_of_shape X C] :
  has_coproducts_of_shape X Cᵒᵖ :=
begin
  haveI : has_limits_of_shape (discrete X)ᵒᵖ C :=
    has_limits_of_shape_of_equivalence (discrete.opposite X).symm,
  apply_instance
end

/--
If `C` has coproducts indexed by `X`, then `Cᵒᵖ` has products indexed by `X`.
-/
lemma has_products_opposite [has_coproducts_of_shape X C] :
  has_products_of_shape X Cᵒᵖ :=
begin
  haveI : has_colimits_of_shape (discrete X)ᵒᵖ C :=
    has_colimits_of_shape_of_equivalence (discrete.opposite X).symm,
  apply_instance
end

lemma has_finite_coproducts_opposite [has_finite_products C] :
  has_finite_coproducts Cᵒᵖ :=
{ out := λ J 𝒟, begin
    resetI,
    haveI : has_limits_of_shape (discrete J)ᵒᵖ C :=
      has_limits_of_shape_of_equivalence (discrete.opposite J).symm,
    apply_instance,
  end }

lemma has_finite_products_opposite [has_finite_coproducts C] :
  has_finite_products Cᵒᵖ :=
{ out := λ J 𝒟, begin
    resetI,
    haveI : has_colimits_of_shape (discrete J)ᵒᵖ C :=
      has_colimits_of_shape_of_equivalence (discrete.opposite J).symm,
    apply_instance,
  end }

lemma has_equalizers_opposite [has_coequalizers C] : has_equalizers Cᵒᵖ :=
begin
  haveI : has_colimits_of_shape walking_parallel_pair.{v₁}ᵒᵖ C :=
    has_colimits_of_shape_of_equivalence walking_parallel_pair_op_equiv.{v₁},
  apply_instance
end

lemma has_coequalizers_opposite [has_equalizers C] : has_coequalizers Cᵒᵖ :=
begin
  haveI : has_limits_of_shape walking_parallel_pair.{v₁}ᵒᵖ C :=
    has_limits_of_shape_of_equivalence walking_parallel_pair_op_equiv.{v₁},
  apply_instance
end

lemma has_finite_colimits_opposite [has_finite_limits C] :
  has_finite_colimits Cᵒᵖ :=
{ out := λ J 𝒟 𝒥, by { resetI, apply_instance, }, }

lemma has_finite_limits_opposite [has_finite_colimits C] :
  has_finite_limits Cᵒᵖ :=
{ out := λ J 𝒟 𝒥, by { resetI, apply_instance, }, }

lemma has_pullbacks_opposite [has_pushouts C] : has_pullbacks Cᵒᵖ :=
begin
  haveI : has_colimits_of_shape walking_cospan.{v₁}ᵒᵖ C :=
    has_colimits_of_shape_of_equivalence walking_cospan_op_equiv.symm,
  apply has_limits_of_shape_op_of_has_colimits_of_shape,
end

lemma has_pushouts_opposite [has_pullbacks C] : has_pushouts Cᵒᵖ :=
begin
  haveI : has_limits_of_shape walking_span.{v₁}ᵒᵖ C :=
    has_limits_of_shape_of_equivalence walking_span_op_equiv.symm,
  apply has_colimits_of_shape_op_of_has_limits_of_shape,
end

end category_theory.limits


/-
Copyright (c) 2019 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author(s): Simon Hudon
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.tactic.core
import Mathlib.PostPort

universes u_1

namespace Mathlib

/-!
This file provides an alternative implementation for `apply` to fix the so-called "apply bug".

The issue arises when the goals is a Π-type -- whether it is visible or hidden behind a definition.

For instance, consider the following proof:

```
example {α β} (x y z : α → β) (h₀ : x ≤ y) (h₁ : y ≤ z) : x ≤ z :=
begin
  apply le_trans,
end
```

Because `x ≤ z` is definitionally equal to `∀ i, x i ≤ z i`, `apply` will fail. The alternative
definition, `apply'` fixes this. When `apply` would work, `apply` is used and otherwise,
a different strategy is deployed
-/

namespace tactic

/-- With `gs` a list of proof goals, `reorder_goals gs new_g` will use the `new_goals` policy
`new_g` to rearrange the dependent goals to either drop them, push them to the end of the list
or leave them in place. The `bool` values in `gs` indicates whether the goal is dependent or not. -/
def reorder_goals {α : Type u_1} (gs : List (Bool × α)) : new_goals → List α := sorry

end Mathlib


-- definitions that are used by the lemmas but not referenced by the a theorem

import .definitions2

-- (∀x {call(x)} ⇒ P) ∈ CallQuantifiers
structure callquantifier := (x: var) (P: prop)

-- s ∈ DStacks := (R, σ, e) | s · (R, σ, let y = f(x) in e)
inductive dstack
| top  : spec → env → exp → dstack
| cons : dstack → spec → env → var → var → var → exp → dstack

-- (R, σ, e) : dstack
instance : has_coe (spec × env × exp) dstack := ⟨λe, dstack.top e.1 e.2.1 e.2.2⟩

-- stack precondition projection

def dstack.pre: dstack → spec
| (dstack.top R _ _) := R
| (dstack.cons _ R _ _ _ _ _) := R

lemma sizeof_substack {s: dstack} {R: spec} {σ: env} {f x y: var} {e: exp}:
      s.sizeof < (dstack.cons s R σ f x y e).sizeof :=
  begin
    unfold dstack.sizeof,
    change sizeof s < 1 + sizeof s + sizeof R + sizeof σ + sizeof f + sizeof x + sizeof y + sizeof e,
    rw[add_assoc],
    rw[add_assoc],
    rw[add_assoc],
    rw[add_assoc],
    rw[add_assoc],
    rw[add_assoc],
    rw[add_comm],
    rw[add_assoc],
    apply lt_add_of_pos_right,
    rw[add_comm],
    rw[add_comm],
    apply lt_add_of_le_of_pos nonneg_of_nat,
    from zero_lt_one
  end

-- top-level calls and quantifiers in positive and negative positions
mutual inductive prop.has_call_p, prop.has_call_n

with prop.has_call_p: calltrigger → prop → Prop
| calltrigger {x: term}                                 : prop.has_call_p ⟨x⟩ (prop.call x)
| not {P: prop} {c: calltrigger}                        : prop.has_call_n c P  → prop.has_call_p c P.not
| and₁ {P₁ P₂: prop} {c: calltrigger}                   : prop.has_call_p c P₁ → prop.has_call_p c (P₁ ⋀ P₂)
| and₂ {P₁ P₂: prop} {c: calltrigger}                   : prop.has_call_p c P₂ → prop.has_call_p c (P₁ ⋀ P₂)
| or₁ {P₁ P₂: prop} {c: calltrigger}                    : prop.has_call_p c P₁ → prop.has_call_p c (P₁ ⋁ P₂)
| or₂ {P₁ P₂: prop} {c: calltrigger}                    : prop.has_call_p c P₂ → prop.has_call_p c (P₁ ⋁ P₂)

with prop.has_call_n: calltrigger → prop → Prop
| not {P: prop} {c: calltrigger}                        : prop.has_call_p c P  → prop.has_call_n c P.not
| and₁ {P₁ P₂: prop} {c: calltrigger}                   : prop.has_call_n c P₁ → prop.has_call_n c (P₁ ⋀ P₂)
| and₂ {P₁ P₂: prop} {c: calltrigger}                   : prop.has_call_n c P₂ → prop.has_call_n c (P₁ ⋀ P₂)
| or₁ {P₁ P₂: prop} {c: calltrigger}                    : prop.has_call_n c P₁ → prop.has_call_n c (P₁ ⋁ P₂)
| or₂ {P₁ P₂: prop} {c: calltrigger}                    : prop.has_call_n c P₂ → prop.has_call_n c (P₁ ⋁ P₂)

-- sets of calls
def calls_p (P: prop): set calltrigger := λc, prop.has_call_p c P
def calls_n (P: prop): set calltrigger := λc, prop.has_call_n c P

mutual inductive prop.has_quantifier_p, prop.has_quantifier_n

with prop.has_quantifier_p: callquantifier → prop → Prop
| callquantifier {x: var} {P: prop}           : prop.has_quantifier_p ⟨x, P⟩ (prop.forallc x P)
| not {P: prop} {q: callquantifier}           : prop.has_quantifier_n q P  → prop.has_quantifier_p q P.not
| and₁ {P₁ P₂: prop} {q: callquantifier}      : prop.has_quantifier_p q P₁ → prop.has_quantifier_p q (P₁ ⋀ P₂)
| and₂ {P₁ P₂: prop} {q: callquantifier}      : prop.has_quantifier_p q P₂ → prop.has_quantifier_p q (P₁ ⋀ P₂)
| or₁ {P₁ P₂: prop} {q: callquantifier}       : prop.has_quantifier_p q P₁ → prop.has_quantifier_p q (P₁ ⋁ P₂)
| or₂ {P₁ P₂: prop} {q: callquantifier}       : prop.has_quantifier_p q P₂ → prop.has_quantifier_p q (P₁ ⋁ P₂)

with prop.has_quantifier_n: callquantifier → prop → Prop
| not {P: prop} {q: callquantifier}           : prop.has_quantifier_p q P  → prop.has_quantifier_n q P.not
| and₁ {P₁ P₂: prop} {q: callquantifier}      : prop.has_quantifier_n q P₁ → prop.has_quantifier_n q (P₁ ⋀ P₂)
| and₂ {P₁ P₂: prop} {q: callquantifier}      : prop.has_quantifier_n q P₂ → prop.has_quantifier_n q (P₁ ⋀ P₂)
| or₁ {P₁ P₂: prop} {q: callquantifier}       : prop.has_quantifier_n q P₁ → prop.has_quantifier_n q (P₁ ⋁ P₂)
| or₂ {P₁ P₂: prop} {q: callquantifier}       : prop.has_quantifier_n q P₂ → prop.has_quantifier_n q (P₁ ⋁ P₂)
-- universal quantifiers below existential quantifiers only occur in positive positions,
-- so can be skolemized instead of instantiated

-- sets of quantifiers
def quantifiers_p (P: prop): set callquantifier := λc, has_quantifier_p c P
def quantifiers_n (P: prop): set callquantifier := λc, has_quantifier_n c P
def quantifiers (P: prop): set callquantifier := quantifiers_p P ∪ quantifiers_n P

 -- propositions without call triggers or quantifiers do not participate in instantiations
def no_instantiations(P: prop): Prop := (calls_p P = ∅) ∧ (calls_n P = ∅) ∧
                                        (quantifiers_p P = ∅) ∧ (quantifiers_n P = ∅)

-- set of calltriggers after substitution
def calltrigger.subst (σ: env) (c: calltrigger): calltrigger := ⟨term.subst_env σ c.x⟩
def calls_p_subst (σ: env) (P: prop): set calltrigger := (calltrigger.subst σ) '' calls_p P
def calls_n_subst (σ: env) (P: prop): set calltrigger := (calltrigger.subst σ) '' calls_n P

-- uses variables (either free or quantified)

inductive prop.uses_var (x: var) : prop → Prop
| term {t: term}                        : free_in_term x t  → prop.uses_var t
| not {P: prop}                         : prop.uses_var P   → prop.uses_var (prop.not P)
| and₁ {P₁ P₂: prop}                    : prop.uses_var P₁  → prop.uses_var (prop.and P₁ P₂)
| and₂ {P₁ P₂: prop}                    : prop.uses_var P₂  → prop.uses_var (prop.and P₁ P₂)
| or₁ {P₁ P₂: prop}                     : prop.uses_var P₁  → prop.uses_var (prop.or P₁ P₂)
| or₂ {P₁ P₂: prop}                     : prop.uses_var P₂  → prop.uses_var (prop.or P₁ P₂)
| pre₁ {t₁ t₂: term}                    : free_in_term x t₁ → prop.uses_var (prop.pre t₁ t₂)
| pre₂ {t₁ t₂: term}                    : free_in_term x t₂ → prop.uses_var (prop.pre t₁ t₂)
| preop {t: term} {op: unop}            : free_in_term x t  → prop.uses_var (prop.pre₁ op t)
| preop₁ {t₁ t₂: term} {op: binop}      : free_in_term x t₁ → prop.uses_var (prop.pre₂ op t₁ t₂)
| preop₂ {t₁ t₂: term} {op: binop}      : free_in_term x t₂ → prop.uses_var (prop.pre₂ op t₁ t₂)
| post₁ {t₁ t₂: term}                   : free_in_term x t₁ → prop.uses_var (prop.post t₁ t₂)
| post₂ {t₁ t₂: term}                   : free_in_term x t₂ → prop.uses_var (prop.post t₁ t₂)
| call {t: term}                        : free_in_term x t → prop.uses_var (prop.call t)
| forallc {y: var} {P: prop}            : prop.uses_var P → prop.uses_var (prop.forallc y P)
| uquantified {P: prop}                 : prop.uses_var (prop.forallc x P)
| exis {y: var} {P: prop}               : prop.uses_var P → prop.uses_var (prop.exis y P)
| equantified {P: prop}                 : prop.uses_var (prop.exis x P)

inductive vc.uses_var (x: var) : vc → Prop
| term {t: term}                        : free_in_term x t  → vc.uses_var t
| not {P: vc}                           : vc.uses_var P     → vc.uses_var (vc.not P)
| and₁ {P₁ P₂: vc}                      : vc.uses_var P₁    → vc.uses_var (vc.and P₁ P₂)
| and₂ {P₁ P₂: vc}                      : vc.uses_var P₂    → vc.uses_var (vc.and P₁ P₂)
| or₁ {P₁ P₂: vc}                       : vc.uses_var P₁    → vc.uses_var (vc.or P₁ P₂)
| or₂ {P₁ P₂: vc}                       : vc.uses_var P₂    → vc.uses_var (vc.or P₁ P₂)
| pre₁ {t₁ t₂: term}                    : free_in_term x t₁ → vc.uses_var (vc.pre t₁ t₂)
| pre₂ {t₁ t₂: term}                    : free_in_term x t₂ → vc.uses_var (vc.pre t₁ t₂)
| preop {t: term} {op: unop}            : free_in_term x t  → vc.uses_var (vc.pre₁ op t)
| preop₁ {t₁ t₂: term} {op: binop}      : free_in_term x t₁ → vc.uses_var (vc.pre₂ op t₁ t₂)
| preop₂ {t₁ t₂: term} {op: binop}      : free_in_term x t₂ → vc.uses_var (vc.pre₂ op t₁ t₂)
| post₁ {t₁ t₂: term}                   : free_in_term x t₁ → vc.uses_var (vc.post t₁ t₂)
| post₂ {t₁ t₂: term}                   : free_in_term x t₂ → vc.uses_var (vc.post t₁ t₂)
| univ {y: var} {P: vc}                 : vc.uses_var P → vc.uses_var (vc.univ y P)
| quantified {P: vc}                    : vc.uses_var (vc.univ x P)

-- evaluation relation that includes the current function precondition for each stack frame

inductive dstep : dstack → dstack → Prop
notation s₁ `⟹` s₂:100 := dstep s₁ s₂

| ctx {s s': dstack} {R: spec} {σ: env} {y f x: var} {e: exp}:
    (s ⟹ s') →
    (dstack.cons s R σ y f x e ⟹ dstack.cons s' R σ y f x e)

| tru {R: spec} {σ: env} {x: var} {e: exp}:
    (R, σ, lett x = true in e) ⟹ (R, σ[x↦value.true], e)

| fals {R: spec} {σ: env} {x: var} {e: exp}:
    (R, σ, letf x = false in e) ⟹ (R, σ[x↦value.false], e)

| num {R: spec} {σ: env} {x: var} {e: exp} {n: ℤ}:
    (R, σ, letn x = n in e) ⟹ (R, σ[x↦value.num n], e)

| closure {σ: env} {R' R S: spec} {f x: var} {e₁ e₂: exp}:
    (R', σ, letf f[x] req R ens S {e₁} in e₂) ⟹
    (R', σ[f↦value.func f x R S e₁ σ], e₂)

| unop {R: spec} {op: unop} {σ: env} {x y: var} {e: exp} {v₁ v: value}:
    (σ x = v₁) →
    (unop.apply op v₁ = v) →
    ((R, σ, letop y = op [x] in e) ⟹ (R, σ[y↦v], e))

| binop {R: spec} {op: binop} {σ: env} {x y z: var} {e: exp} {v₁ v₂ v: value}:
    (σ x = v₁) →
    (σ y = v₂) →
    (binop.apply op v₁ v₂ = v) →
    ((R, σ, letop2 z = op [x, y] in e) ⟹ (R, σ[z↦v], e))

| app {σ σ': env} {R' R S: spec} {f g x y z: var} {e e': exp} {v: value}:
    (σ f = value.func g z R S e σ') →
    (σ x = v) →
    ((R', σ, letapp y = f[x] in e') ⟹
    (dstack.cons (R, (σ'[g↦value.func g z R S e σ'][z↦v]), e) R' σ y f x e'))

| return {σ₁ σ₂ σ₃: env} {f g gx x y z: var} {R₁ R₂ R S: spec} {e e': exp} {v vₓ: value}:
    (σ₁ z = v) →
    (σ₂ f = value.func g gx R S e σ₃) →
    (σ₂ x = vₓ) →
    (dstack.cons (R₁, σ₁, exp.return z) R₂ σ₂ y f x e' ⟹ (R₂, σ₂[y↦v], e'))

| ite_true {R: spec} {σ: env} {e₁ e₂: exp} {x: var}:
    (σ x = value.true) →
    ((R, σ, exp.ite x e₁ e₂) ⟹ (R, σ, e₁))

| ite_false {R: spec} {σ: env} {e₁ e₂: exp} {x: var}:
    (σ x = value.false) →
    ((R, σ, exp.ite x e₁ e₂) ⟹ (R, σ, e₂))

notation s₁ `⟹` s₂:100 := dstep s₁ s₂

-- transitive closure
inductive trans_dstep : dstack → dstack → Prop
notation s `⟹*` s':100 := trans_dstep s s'
| rfl {s: dstack}          : s ⟹* s
| trans {s s' s'': dstack} : (s ⟹* s') → (s' ⟹ s'') → (s ⟹* s'')

notation s `⟹*` s':100 := trans_dstep s s'

def is_dvalue (s: dstack) :=
  ∃(R: spec) (σ: env) (x: var) (v: value), s = (R, σ, exp.return x) ∧ (σ x = v)

-- runtime verification of stacks

inductive stack.dvcgen : dstack → propctx → Prop
notation `⊩ₛ` s `:` Q : 10 := stack.dvcgen s Q

| top {R: spec} {P: prop} {σ: env} {e: exp} {Q: propctx}:
    (⊩ σ : P) →
    FV R.to_prop ⊆ FV P →
    (σ ⊨ R.to_prop.to_vc) →
    (R ⋀ P ⊩ e : Q) →
    (⊩ₛ (R, σ, e) : P ⋀ Q)

| cons {P₁ P₂ P₃: prop} {s: dstack} {σ₁ σ₂: env}
       {f fx g x y: var} {R₁ R₂ S₂: spec} {e₁ e₂: exp} {v: value} {Q₁ Q₂ Q₂': propctx}:
    (⊩ₛ s : Q₂') →
    y ∉ σ₁ →
    (⊩ σ₁ : P₁) →
    (⊩ σ₂ : P₂ ) →
    (⊩ (σ₂[f↦value.func f fx R₂ S₂ e₂ σ₂][fx↦v]) : P₃) →
    FV R₁.to_prop ⊆ FV P₁ →
    (σ₁ ⊨ R₁.to_prop.to_vc) →
    (σ₁ g = value.func f fx R₂ S₂ e₂ σ₂) →
    (σ₁ x = v) →
    (R₁ ⋀ P₁ ⋀ prop.call x ⋀ prop.post g x ⋀ y ≡ term.app g x ⊩ e₁ : Q₁) →
    (P₂ ⋀ spec.func f fx R₂ S₂ ⋀ R₂ ⊩ e₂ : Q₂) →
    (∀σ' t, (σ' ⊨ (Q₂' t).to_vc) → σ' ⊨ (P₃ ⋀ (Q₂ t)).to_vc) →
    (∀v: value, FV (P₃ ⋀ (Q₂ v)) ⊆ FV (Q₂' v)) →
    ⦃ prop.implies (R₁ ⋀ P₁ ⋀ prop.call x) (term.unop unop.isFunc g ⋀ prop.pre g x) ⦄ →
    ((R₂, σ₂[f↦value.func f fx R₂ S₂ e₂ σ₂][fx↦v], e₂) ⟹* s) →
    (⊩ₛ dstack.cons s R₁ σ₁ y g x e₁ : P₁ ⋀
          propctx.exis y (prop.call x ⋀ prop.post g x ⋀ y ≡ term.app g x ⋀ Q₁))

notation `⊩ₛ` s `:` Q : 10 := stack.dvcgen s Q

inductive stack_equiv_dstack : stack → dstack → Prop
| top {R: spec} {σ: env} {e: exp} :
  stack_equiv_dstack (stack.top σ e) (dstack.top R σ e)
| cons {s': stack} {d': dstack} {R: spec} {σ: env} {f x y: var} {e: exp}:
  stack_equiv_dstack s' d' →
  stack_equiv_dstack (stack.cons s' σ f x y e) (dstack.cons d' R σ f x y e)


/-
Copyright (c) 2022 Yuma Mizuno. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yuma Mizuno
-/
import category_theory.bicategory.functor

/-!
# Oplax natural transformations

Just as there are natural transformations between functors, there are oplax natural transformations
between oplax functors. The equality in the naturality of natural transformations is replaced by a
specified 2-morphism `F.map f ≫ app b ⟶ app a ≫ G.map f` in the case of oplax natural
transformations.

## Main definitions

* `oplax_nat_trans F G` : oplax natural transformations between oplax functors `F` and `G`
* `oplax_nat_trans.vcomp η θ` : the vertical composition of oplax natural transformations `η`
  and `θ`
* `oplax_nat_trans.category F G` : the category structure on the oplax natural transformations
  between `F` and `G`
-/

namespace category_theory

open category bicategory
open_locale bicategory

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

variables {B : Type u₁} [bicategory.{w₁ v₁} B] {C : Type u₂} [bicategory.{w₂ v₂} C]

/--
If `η` is an oplax natural transformation between `F` and `G`, we have a 1-morphism
`η.app a : F.obj a ⟶ G.obj a` for each object `a : B`. We also have a 2-morphism
`η.naturality f : F.map f ≫ app b ⟶ app a ≫ G.map f` for each 1-morphism `f : a ⟶ b`.
These 2-morphisms satisfies the naturality condition, and preserve the identities and
the compositions modulo some adjustments of domains and codomains of 2-morphisms.
-/
structure oplax_nat_trans (F G : oplax_functor B C) :=
(app (a : B) : F.obj a ⟶ G.obj a)
(naturality {a b : B} (f : a ⟶ b) : F.map f ≫ app b ⟶ app a ≫ G.map f)
(naturality_naturality' : ∀ {a b : B} {f g : a ⟶ b} (η : f ⟶ g),
  F.map₂ η ▷ app b ≫ naturality g = naturality f ≫ app a ◁ G.map₂ η . obviously)
(naturality_id' : ∀ a : B,
  naturality (𝟙 a) ≫ app a ◁ G.map_id a =
    F.map_id a ▷ app a ≫ (λ_ (app a)).hom ≫ (ρ_ (app a)).inv . obviously)
(naturality_comp' : ∀ {a b c : B} (f : a ⟶ b) (g : b ⟶ c),
  naturality (f ≫ g) ≫ app a ◁ G.map_comp f g =
    F.map_comp f g ▷ app c ≫ (α_ _ _ _).hom ≫
      F.map f ◁ naturality g ≫ (α_ _ _ _).inv ≫
        naturality f ▷ G.map g ≫ (α_ _ _ _).hom . obviously)

restate_axiom oplax_nat_trans.naturality_naturality'
restate_axiom oplax_nat_trans.naturality_id'
restate_axiom oplax_nat_trans.naturality_comp'
attribute [simp, reassoc] oplax_nat_trans.naturality_naturality
  oplax_nat_trans.naturality_id oplax_nat_trans.naturality_comp

namespace oplax_nat_trans

section
variables (F : oplax_functor B C)

/-- The identity oplax natural transformation. -/
@[simps]
def id : oplax_nat_trans F F :=
{ app := λ a, 𝟙 (F.obj a),
  naturality := λ a b f, (ρ_ (F.map f)).hom ≫ (λ_ (F.map f)).inv }

instance : inhabited (oplax_nat_trans F F) := ⟨id F⟩

variables {F} {G H : oplax_functor B C} (η : oplax_nat_trans F G) (θ : oplax_nat_trans G H)

section
variables {a b c : B} {a' : C}

@[simp, reassoc]
lemma whisker_left_naturality_naturality (f : a' ⟶ G.obj a) {g h : a ⟶ b} (β : g ⟶ h) :
  f ◁ G.map₂ β ▷ θ.app b ≫ f ◁ θ.naturality h =
    f ◁ θ.naturality g ≫ f ◁ θ.app a ◁ H.map₂ β :=
by simp_rw [←bicategory.whisker_left_comp, naturality_naturality]

@[simp, reassoc]
lemma whisker_right_naturality_naturality {f g : a ⟶ b} (β : f ⟶ g) (h : G.obj b ⟶ a') :
  F.map₂ β ▷ η.app b ▷ h ≫ η.naturality g ▷ h =
    η.naturality f ▷ h ≫ (α_ _ _ _).hom ≫ η.app a ◁ G.map₂ β ▷ h ≫ (α_ _ _ _).inv :=
by rw [←comp_whisker_right, naturality_naturality, comp_whisker_right, whisker_assoc]

@[simp, reassoc]
lemma whisker_left_naturality_comp (f : a' ⟶ G.obj a) (g : a ⟶ b) (h : b ⟶ c) :
  f ◁ θ.naturality (g ≫ h) ≫ f ◁ θ.app a ◁ H.map_comp g h =
    f ◁ G.map_comp g h ▷ θ.app c ≫ f ◁ (α_ _ _ _).hom ≫
      f ◁ G.map g ◁ θ.naturality h ≫ f ◁ (α_ _ _ _).inv ≫
        f ◁ θ.naturality g ▷ H.map h ≫ f ◁ (α_ _ _ _).hom :=
by simp_rw [←bicategory.whisker_left_comp, naturality_comp]

@[simp, reassoc]
lemma whisker_right_naturality_comp (f : a ⟶ b) (g : b ⟶ c) (h : G.obj c ⟶ a') :
  η.naturality (f ≫ g) ▷ h ≫ (α_ _ _ _).hom ≫ η.app a ◁ G.map_comp f g ▷ h =
    F.map_comp f g ▷ η.app c ▷ h ≫ (α_ _ _ _).hom ▷ h ≫ (α_ _ _ _).hom ≫
      F.map f ◁ η.naturality g ▷ h ≫ (α_ _ _ _).inv ≫ (α_ _ _ _).inv ▷ h ≫
        η.naturality f ▷ G.map g ▷ h ≫ (α_ _ _ _).hom ▷ h ≫ (α_ _ _ _).hom :=
by { rw [←associator_naturality_middle, ←comp_whisker_right_assoc, naturality_comp], simp }

@[simp, reassoc]
lemma whisker_left_naturality_id (f : a' ⟶ G.obj a) :
  f ◁ θ.naturality (𝟙 a) ≫ f ◁ θ.app a ◁ H.map_id a =
    f ◁ G.map_id a ▷ θ.app a ≫ f ◁ (λ_ (θ.app a)).hom ≫ f ◁ (ρ_ (θ.app a)).inv :=
by simp_rw [←bicategory.whisker_left_comp, naturality_id]

@[simp, reassoc]
lemma whisker_right_naturality_id (f : G.obj a ⟶ a') :
  η.naturality (𝟙 a) ▷ f ≫ (α_ _ _ _).hom ≫ η.app a ◁ G.map_id a ▷ f =
    F.map_id a ▷ η.app a ▷ f ≫ (λ_ (η.app a)).hom ▷ f ≫
      (ρ_ (η.app a)).inv ▷ f ≫ (α_ _ _ _).hom :=
by { rw [←associator_naturality_middle, ←comp_whisker_right_assoc, naturality_id], simp }

end

/-- Vertical composition of oplax natural transformations. -/
@[simps]
def vcomp (η : oplax_nat_trans F G) (θ : oplax_nat_trans G H) : oplax_nat_trans F H :=
{ app := λ a, η.app a ≫ θ.app a,
  naturality := λ a b f,
    (α_ _ _ _).inv ≫ η.naturality f ▷ θ.app b ≫ (α_ _ _ _).hom ≫
      η.app a ◁ θ.naturality f ≫ (α_ _ _ _).inv,
  naturality_comp' := λ a b c f g, by
  { calc _ =  _ ≫
    F.map_comp f g ▷ η.app c ▷ θ.app c ≫ _ ≫
      F.map f ◁ η.naturality g ▷ θ.app c ≫ _ ≫
        (F.map f ≫ η.app b) ◁ θ.naturality g ≫
          η.naturality f ▷ (θ.app b ≫ H.map g) ≫ _ ≫
            η.app a ◁ θ.naturality f ▷ H.map g ≫ _  : _
    ... =  _ : _,
    exact (α_ _ _ _).inv,
    exact (α_ _ _ _).hom ▷ _ ≫ (α_ _ _ _).hom,
    exact _ ◁ (α_ _ _ _).hom ≫ (α_ _ _ _).inv,
    exact (α_ _ _ _).hom ≫ _ ◁ (α_ _ _ _).inv,
    exact _ ◁ (α_ _ _ _).hom ≫ (α_ _ _ _).inv,
    { rw [whisker_exchange_assoc], simp },
    { simp } } }

variables (B C)

@[simps]
instance : category_struct (oplax_functor B C) :=
{ hom  := oplax_nat_trans,
  id   := oplax_nat_trans.id,
  comp := λ F G H, oplax_nat_trans.vcomp }

end

section
variables {F G : oplax_functor B C}

/--
A modification `Γ` between oplax natural transformations `η` and `θ` consists of a family of
2-morphisms `Γ.app a : η.app a ⟶ θ.app a`, which satisfies the equation
`(F.map f ◁ app b) ≫ θ.naturality f = η.naturality f ≫ (app a ▷ G.map f)`
for each 1-morphism `f : a ⟶ b`.
-/
@[ext]
structure modification (η θ : F ⟶ G) :=
(app (a : B) : η.app a ⟶ θ.app a)
(naturality' : ∀ {a b : B} (f : a ⟶ b),
  (F.map f ◁ app b) ≫ θ.naturality f = η.naturality f ≫ (app a ▷ G.map f) . obviously)

restate_axiom modification.naturality'
attribute [simp, reassoc] modification.naturality

variables {η θ ι : F ⟶ G}

namespace modification

variables (η)

/-- The identity modification. -/
@[simps]
def id : modification η η := { app := λ a, 𝟙 (η.app a) }

instance : inhabited (modification η η) := ⟨modification.id η⟩

variables {η}

section
variables (Γ : modification η θ) {a b c : B} {a' : C}

@[simp, reassoc]
lemma whisker_left_naturality (f : a' ⟶ F.obj b) (g : b ⟶ c) :
  f ◁ F.map g ◁ Γ.app c ≫ f ◁ θ.naturality g =
    f ◁ η.naturality g ≫ f ◁ Γ.app b ▷ G.map g :=
by simp_rw [←bicategory.whisker_left_comp, naturality]

@[simp, reassoc]
lemma whisker_right_naturality (f : a ⟶ b) (g : G.obj b ⟶ a') :
  F.map f ◁ Γ.app b ▷ g ≫ (α_ _ _ _).inv ≫ θ.naturality f ▷ g =
    (α_ _ _ _).inv ≫ η.naturality f ▷ g ≫ Γ.app a ▷ G.map f ▷ g :=
by simp_rw [associator_inv_naturality_middle_assoc, ←comp_whisker_right, naturality]

end

/-- Vertical composition of modifications. -/
@[simps]
def vcomp (Γ : modification η θ) (Δ : modification θ ι) : modification η ι :=
{ app := λ a, Γ.app a ≫ Δ.app a }

end modification

/-- Category structure on the oplax natural transformations between oplax_functors. -/
@[simps]
instance category (F G : oplax_functor B C) : category (F ⟶ G) :=
{ hom  := modification,
  id   := modification.id,
  comp := λ η θ ι, modification.vcomp }

/--
Construct a modification isomorphism between oplax natural transformations
by giving object level isomorphisms, and checking naturality only in the forward direction.
-/
@[simps]
def modification_iso.of_components
  (app : ∀ a, η.app a ≅ θ.app a)
  (naturality : ∀ {a b} (f : a ⟶ b),
    F.map f ◁ (app b).hom ≫ θ.naturality f = η.naturality f ≫ (app a).hom ▷ G.map f) :
  η ≅ θ :=
{ hom := { app := λ a, (app a).hom },
  inv :=
  { app := λ a, (app a).inv,
    naturality' := λ a b f, by simpa using
      congr_arg (λ f, _ ◁ (app b).inv ≫ f ≫ (app a).inv ▷ _) (naturality f).symm } }

end

end oplax_nat_trans

end category_theory


/-
Copyright (c) 2019 Bruno Bentzen. All rights reserved.
Released under the Apache License 2.0 (see "License");
Author: Bruno Bentzen
-/

import ..core.interval

open interval

-- diagonal maps (contraction) for types and terms

example {A : I → I → Type} : I → Type := λ i, A i i

example {A : I → I → Type} (a : Π j i, A j i) : Π i, A i i := λ i, a i i


import .definitions3 .logic

lemma exp.progress {R: spec} {P: prop} {Q: propctx} {e: exp} {σ: env}:
      (⊩ σ: P) → (FV R.to_prop ⊆ FV P) → (σ ⊨ R.to_prop.to_vc) → (R ⋀ P ⊩ e: Q) →
      is_dvalue (R, σ, e) ∨ ∃s', (R, σ, e) ⟹ s' :=
  assume env_verified: (⊩ σ : P),
  assume fv_R: FV R.to_prop ⊆ FV P,
  assume R_valid: (σ ⊨ R.to_prop.to_vc),
  assume e_verified: (R ⋀ P ⊩ e : Q),
  have R_closed: closed_subst σ R.to_prop, from (
    assume z: var,
    assume : z ∈ FV R.to_prop,
    have z ∈ FV P, from set.mem_of_subset_of_mem fv_R this,
    show z ∈ σ.dom, from (free_iff_contains env_verified).symm ▸ this
  ),
  show is_dvalue (R, σ, e) ∨ ∃s', (R, σ, e) ⟹ s', by begin
    cases e_verified,
    case exp.dvcgen.tru x e' { from
      let s: dstack := (R, σ, lett x = true in e') in
      have s ⟹ (R, σ[x↦value.true], e'), from dstep.tru,
      have ∃s', s ⟹ s', from exists.intro (R, σ[x↦value.true], e') this,
      show is_dvalue s ∨ ∃s', s ⟹ s', from or.inr this
    },
    case exp.dvcgen.fals x e' { from
      let s: dstack := (R, σ, letf x = false in e') in
      have s ⟹ (R, σ[x↦value.false], e'), from dstep.fals,
      have ∃s', s ⟹ s', from exists.intro (R, σ[x↦value.false], e') this,
      show is_dvalue s ∨ ∃s', s ⟹ s', from or.inr this
    },
    case exp.dvcgen.num x n e' { from
      let s: dstack := (R, σ, letn x = n in e') in
      have s ⟹ (R, σ[x↦value.num n], e'), from dstep.num,
      have ∃s', s ⟹ s', from exists.intro (R, σ[x↦value.num n], e') this,
      show is_dvalue s ∨ ∃s', s ⟹ s', from or.inr this
    },
    case exp.dvcgen.func f x R' S' e₁ e₂ { from
      let s: dstack := (R, σ, letf f[x] req R' ens S' {e₁} in e₂) in
      have s ⟹ (R, σ[f↦value.func f x R' S' e₁ σ], e₂), from dstep.closure,
      have ∃s', s ⟹ s', from exists.intro (R, σ[f↦value.func f x R' S' e₁ σ], e₂) this,
      show is_dvalue s ∨ ∃s', s ⟹ s', from or.inr this
    },
    case exp.dvcgen.unop op x y e' Q' x_free_in_P _ e'_verified vc_valid { from
      let s: dstack := (R, σ, letop y = op[x] in e') in
      let ⟨v, env_has_x⟩ := (val_of_free_in_pre_env env_verified fv_R x_free_in_P) in
      have closed_subst σ (prop.pre₁ op x), from (
        assume z: var,
        assume : z ∈ FV (prop.pre₁ op x),
        have free_in_term z x, from free_in_prop.pre₁.inv this,
        have z = x, from free_in_term.var.inv this,
        show z ∈ σ, from this.symm ▸ env.contains_apply_equiv.right.mp (exists.intro v env_has_x)
      ),
      have h1: σ ⊨ (prop.pre₁ op x).to_vc, from consequent_of_pre_P env_verified R_closed R_valid this vc_valid,
      have (prop.pre₁ op x).to_vc = vc.pre₁ op x, by unfold prop.to_vc,
      have h2: ⊨ vc.subst_env σ (vc.pre₁ op x), from this ▸ h1,
      have vc.subst_env σ (vc.pre₁ op x) = vc.pre₁ op (term.subst_env σ x), from vc.subst_env.pre₁,
      have ⊨ vc.pre₁ op (term.subst_env σ x), from this ▸ h2,
      have x_from_env: term.subst_env σ x = v, from (term.subst_env.var.right v).mp env_has_x,
      have ⊨ vc.pre₁ op v, from x_from_env ▸ this,
      have option.is_some (unop.apply op v), from valid.pre₁ this,
      have (∃v', unop.apply op v = some v'), from option.is_some_iff_exists.mp this,
      let ⟨v', op_v_is_v'⟩ := this in
      have s ⟹ (R, σ[y↦v'], e'), from dstep.unop env_has_x op_v_is_v',
      have ∃s', s ⟹ s', from exists.intro (R, σ[y↦v'], e') this,
      show is_dvalue s ∨ ∃s', s ⟹ s', from or.inr this
    },
    case exp.dvcgen.binop op x y z e' Q' x_free_in_P y_free_in_P _ e'_verified vc_valid { from
      let s: dstack := (R, σ, letop2 z = op[x,y] in e') in
      let ⟨vx, env_has_x⟩ := (val_of_free_in_pre_env env_verified fv_R x_free_in_P) in
      let ⟨vy, env_has_y⟩ := (val_of_free_in_pre_env env_verified fv_R y_free_in_P) in
      have closed_subst σ (prop.pre₂ op x y), from (
        assume z: var,
        assume : z ∈ FV (prop.pre₂ op x y),
        or.elim (free_in_prop.pre₂.inv this) (
          assume : free_in_term z x,
          have z = x, from free_in_term.var.inv this,
          show z ∈ σ, from this.symm ▸ env.contains_apply_equiv.right.mp (exists.intro vx env_has_x)
        ) (
          assume : free_in_term z y,
          have z = y, from free_in_term.var.inv this,
          show z ∈ σ, from this.symm ▸ env.contains_apply_equiv.right.mp (exists.intro vy env_has_y)
        )
      ),
      have h1: σ ⊨ (prop.pre₂ op x y).to_vc, from consequent_of_pre_P env_verified R_closed R_valid this vc_valid,
      have (prop.pre₂ op x y).to_vc = vc.pre₂ op x y, by unfold prop.to_vc,
      have h2: ⊨ vc.subst_env σ (vc.pre₂ op x y), from this ▸ h1,
      have vc.subst_env σ (vc.pre₂ op x y) = vc.pre₂ op (term.subst_env σ x) (term.subst_env σ y),
      from vc.subst_env.pre₂,
      have h3: ⊨ vc.pre₂ op (term.subst_env σ x) (term.subst_env σ y), from this ▸ h2,
      have term.subst_env σ x = vx, from (term.subst_env.var.right vx).mp env_has_x,
      have h4: ⊨ vc.pre₂ op vx (term.subst_env σ y), from this ▸ h3,
      have term.subst_env σ y = vy, from (term.subst_env.var.right vy).mp env_has_y,
      have ⊨ vc.pre₂ op vx vy, from this ▸ h4,
      have option.is_some (binop.apply op vx vy), from valid.pre₂ this,
      have (∃v', binop.apply op vx vy = some v'), from option.is_some_iff_exists.mp this,
      let ⟨v', op_v_is_v'⟩ := this in
      have s ⟹ (R, σ[z↦v'], e'), from dstep.binop env_has_x env_has_y op_v_is_v',
      have ∃s', s ⟹ s', from exists.intro (R, σ[z↦v'], e') this,
      show is_dvalue s ∨ ∃s', s ⟹ s', from or.inr this
    },
    case exp.dvcgen.app y f x e' Q' f_free_in_P x_free_in_P _ e'_verified vc_valid { from
      let s: dstack := (R, σ, letapp y = f [x] in e') in
      let ⟨vf, env_f_is_vf⟩ := (val_of_free_in_pre_env env_verified fv_R f_free_in_P) in
      have env_has_f: f ∈ σ, from env.contains_apply_equiv.right.mp (exists.intro vf env_f_is_vf),
      let ⟨vx, env_x_is_vx⟩ := (val_of_free_in_pre_env env_verified fv_R x_free_in_P) in
      have env_has_x: x ∈ σ, from env.contains_apply_equiv.right.mp (exists.intro vx env_x_is_vx),
      have closed_subst σ (↑(term.unop unop.isFunc f) ⋀ prop.pre f x), from (
        assume z: var,
        assume : z ∈ FV (↑(term.unop unop.isFunc f) ⋀ prop.pre f x),
        or.elim (free_in_prop.and.inv this) (
          assume : free_in_prop z (term.unop unop.isFunc f),
          have free_in_term z (term.unop unop.isFunc f), from free_in_prop.term.inv this,
          have free_in_term z f, from free_in_term.unop.inv this,
          have z = f, from free_in_term.var.inv this,
          show z ∈ σ, from this.symm ▸ env_has_f
        ) (
          assume : z ∈ FV (prop.pre f x),
          or.elim (free_in_prop.pre.inv this) (
            assume : free_in_term z f,
            have z = f, from free_in_term.var.inv this,
            show z ∈ σ, from this.symm ▸ env_has_f
          ) (
            assume : free_in_term z x,
            have z = x, from free_in_term.var.inv this,
            show z ∈ σ, from this.symm ▸ env_has_x
          )
        )
      ),
      have h1: σ ⊨ (↑(term.unop unop.isFunc f) ⋀ prop.pre f x).to_vc,
      from consequent_of_pre_P_call env_verified R_closed R_valid env_has_x this vc_valid,
      have (prop.and (prop.term (term.unop unop.isFunc f)) (prop.pre f x)).to_vc
         = ((prop.term (term.unop unop.isFunc f)).to_vc ⋀ (prop.pre f x).to_vc),
      by unfold prop.to_vc,
      have σ ⊨ ((prop.term (term.unop unop.isFunc f)).to_vc ⋀ (prop.pre f x).to_vc), from this ▸ h1,
      have h2: ⊨ vc.subst_env σ ((prop.term (term.unop unop.isFunc f)).to_vc ⋀ (prop.pre f x).to_vc), from this,
      have vc.subst_env σ ((prop.term (term.unop unop.isFunc f)).to_vc ⋀ (prop.pre f x).to_vc)
         = (vc.subst_env σ ((prop.term (term.unop unop.isFunc f)).to_vc) ⋀ vc.subst_env σ ((prop.pre f x).to_vc)),
      from vc.subst_env.and,
      have ⊨ (vc.subst_env σ ((prop.term (term.unop unop.isFunc f)).to_vc) ⋀
              vc.subst_env σ ((prop.pre f x).to_vc)),
      from this ▸ h2,
      have h5: σ ⊨ (prop.term (term.unop unop.isFunc f)).to_vc, from (valid.and.mpr this).left,
      have (prop.term (term.unop unop.isFunc f)).to_vc = vc.term (term.unop unop.isFunc f),
      by unfold prop.to_vc,
      have h6: σ ⊨ vc.term (term.unop unop.isFunc f), from this ▸ h5,
      have vc.subst_env σ (vc.term (term.unop unop.isFunc f)) = vc.term (term.subst_env σ (term.unop unop.isFunc f)),
      from vc.subst_env.term,
      have h7: ⊨ vc.term (term.subst_env σ (term.unop unop.isFunc f)), from this ▸ h6,
      have term.subst_env σ (term.unop unop.isFunc f) = term.unop unop.isFunc (term.subst_env σ f),
      from term.subst_env.unop,
      have h8: ⊨ vc.term (term.unop unop.isFunc (term.subst_env σ f)), from this ▸ h7,
      have term.subst_env σ f = vf, from (term.subst_env.var.right vf).mp env_f_is_vf,
      have ⊨ term.unop unop.isFunc vf, from this ▸ h8,
      have ⊨ (value.true ≡ term.unop unop.isFunc vf), from valid.eq.true.mp this,
      have unop.apply unop.isFunc vf = some value.true, from valid.unop.mpr this,
      have ∃(g gx: var) (gR gS: spec) (ge: exp) (gσ: env), vf = value.func g gx gR gS ge gσ,
      from unop.isFunc.inv this,
      let ⟨g, gx, gR, gS, ge, gσ, vf_is_g⟩ := this in
      have some_vf_is_g: some vf = ↑(value.func g gx gR gS ge gσ), from some.inj.inv vf_is_g,
      have σ f = value.func g gx gR gS ge gσ, from eq.trans env_f_is_vf some_vf_is_g,
      let s': dstack := dstack.cons (gR, gσ[g↦value.func g gx gR gS ge gσ][gx↦vx], ge) R σ y f x e' in
      have s ⟹ s', from dstep.app this env_x_is_vx,
      have ∃s', s ⟹ s', from exists.intro s' this,
      show is_dvalue s ∨ ∃s', s ⟹ s', from or.inr this
    },
    case exp.dvcgen.ite x e₂ e₁ Q₁ Q₂ x_free_in_P _ _ vc_valid { from
      let s: dstack := (R, σ, exp.ite x e₁ e₂) in
      let ⟨v, env_has_x⟩ := (val_of_free_in_pre_env env_verified fv_R x_free_in_P) in
      have closed_subst σ (prop.term (term.unop unop.isBool x)), from (
        assume z: var,
        assume : z ∈ FV (prop.term (term.unop unop.isBool x)),
        have free_in_term z (term.unop unop.isBool x), from free_in_prop.term.inv this,
        have free_in_term z x, from free_in_term.unop.inv this,
        have z = x, from free_in_term.var.inv this,
        show z ∈ σ, from this.symm ▸ env.contains_apply_equiv.right.mp (exists.intro v env_has_x)
      ),
      have h1: σ ⊨ (prop.term (term.unop unop.isBool x)).to_vc,
      from consequent_of_pre_P env_verified R_closed R_valid this vc_valid,
      have (prop.term (term.unop unop.isBool x)).to_vc = vc.term (term.unop unop.isBool x),
      by unfold prop.to_vc,
      have h2: σ ⊨ vc.term (term.unop unop.isBool x), from this ▸ h1,
      have vc.subst_env σ (vc.term (term.unop unop.isBool x)) = vc.term (term.subst_env σ (term.unop unop.isBool x)),
      from vc.subst_env.term,
      have h3: ⊨ vc.term (term.subst_env σ (term.unop unop.isBool x)), from this ▸ h2,
      have term.subst_env σ (term.unop unop.isBool x) = term.unop unop.isBool (term.subst_env σ x),
      from term.subst_env.unop,
      have h4: ⊨ vc.term (term.unop unop.isBool (term.subst_env σ x)), from this ▸ h3,
      have term.subst_env σ x = v, from (term.subst_env.var.right v).mp env_has_x,
      have ⊨ term.unop unop.isBool v, from this ▸ h4,
      have ⊨ (value.true ≡ term.unop unop.isBool v), from valid.eq.true.mp this,
      have unop.apply unop.isBool v = some value.true, from valid.unop.mpr this,
      have (v = value.true) ∨ (v = value.false), from unop.isBool.inv this,
      or.elim this (
        assume : v = value.true,
        have some v = some value.true, from some.inj.inv this,
        have σ x = value.true, from eq.trans env_has_x this,
        have s ⟹ (R, σ, e₁), from dstep.ite_true this,
        have ∃s', s ⟹ s', from exists.intro (R, σ, e₁) this,
        show is_dvalue s ∨ ∃s', s ⟹ s', from or.inr this
      ) (
        assume : v = value.false,
        have some v = some value.false, from some.inj.inv this,
        have σ x = value.false, from eq.trans env_has_x this,
        have s ⟹ (R, σ, e₂), from dstep.ite_false this,
        have ∃s', s ⟹ s', from exists.intro (R, σ, e₂) this,
        show is_dvalue s ∨ ∃s', s ⟹ s', from or.inr this
      )
    },
    case exp.dvcgen.return x x_free_in_P { from
      let s: dstack := (R, σ, exp.return x) in
      have s_is_return: s = (R, σ, exp.return x), from rfl,
      let ⟨v, env_has_x⟩ := (val_of_free_in_pre_env env_verified fv_R x_free_in_P) in
      have is_value_s: is_dvalue s
        = (∃(R': spec) (σ': env) (x': var) (v: value), s = (R', σ', exp.return x') ∧ (σ' x' = v)),
      by unfold is_dvalue,
      have (∃(R': spec) (σ': env) (x': var) (v: value), s = (R', σ', exp.return x') ∧ (σ' x' = v)),
      from exists.intro R (exists.intro σ (exists.intro x (exists.intro v ⟨s_is_return, env_has_x⟩))),
      have is_dvalue s, from is_value_s ▸ this,
      show is_dvalue s ∨ ∃s', s ⟹ s', from or.inl this
    }
  end

theorem progress {s: dstack} {Q: propctx}: (⊩ₛ s : Q) → is_dvalue s ∨ ∃s', s ⟹ s'
:=
  assume s_verified: ⊩ₛ s : Q,
  begin
    induction s_verified,
    case stack.dvcgen.top σ e R P Q env_verified fv_R R_valid e_verified { from
      show is_dvalue (R, σ, e) ∨ ∃s', (R, σ, e) ⟹ s', from exp.progress env_verified fv_R R_valid e_verified
    },
    case stack.dvcgen.cons P P' P'' s' σ σ' f g x y fx R R' S' e₁ e₂ vₓ Q Q' Q''
                          s'_verified y_not_in_σ σ_verified σ'_verified σ''_verified fv_R R_valid g_is_func
                          x_is_v e₁_verified cont Q''_dom Q''_fv pre_vc steps ih { from
      let s := dstack.cons s' R σ y g x e₁ in
      have s_cons: s = (dstack.cons s' R σ y g x e₁), from rfl,
      or.elim ih
      ( -- step return
        assume s'_is_value: is_dvalue s',
        let ⟨R₂, σ₂, z, v, ⟨s'_return, env2_has_z⟩⟩ := s'_is_value in
        have s_return_cons: s = dstack.cons (R₂, σ₂, exp.return z) R σ y g x e₁,
        from s'_return ▸ s_cons,
        have s ⟹ (R, σ[y↦v], e₁),
        from s_return_cons.symm ▸ (dstep.return env2_has_z g_is_func x_is_v),
        have ∃s', s ⟹ s',
        from exists.intro (R, σ[y↦v], e₁) this,
        show is_dvalue s ∨ ∃s', s ⟹ s', from or.inr this
      )
      ( -- step ctx
        assume s'_can_step: ∃s'', s' ⟹ s'',
        let ⟨s'', s'_steps⟩ := s'_can_step in
        have s ⟹ dstack.cons s'' R σ y g x e₁, from dstep.ctx s'_steps,
        have ∃s', s ⟹ s', from exists.intro (dstack.cons s'' R σ y g x e₁) this,
        show is_dvalue s ∨ ∃s', s ⟹ s', from or.inr this
      )
    }
  end


import category_theory.abelian.projective
import for_mathlib.homotopy_category_pretriangulated
import for_mathlib.abelian_category
import for_mathlib.derived.homological
import for_mathlib.derived.lemmas
import for_mathlib.snake_lemma3
import for_mathlib.les_homology
import for_mathlib.exact_seq3
import for_mathlib.triangle_shift
import for_mathlib.homology_iso
import for_mathlib.projective_replacement
import for_mathlib.additive_functor

noncomputable theory

open category_theory category_theory.limits category_theory.triangulated
open homological_complex

universes v v' u u'
variables {A : Type u} [category.{v} A] [abelian A]

namespace bounded_homotopy_category

instance : category (bounded_homotopy_category A) :=
{ hom := λ X Y, X.val ⟶ Y.val,
  id := λ X, 𝟙 X.val,
  comp := λ X Y Z f g, f ≫ g,
  id_comp' := λ _ _ _, category.id_comp _,
  comp_id' := λ _ _ _, category.comp_id _,
  assoc' := λ _ _ _ _ _ _ _, category.assoc _ _ _ }

local attribute [instance] has_zero_object.has_zero

instance (X : bounded_homotopy_category A) : homotopy_category.is_bounded_above X.val := X.bdd

def of (X : homotopy_category A (complex_shape.up ℤ)) [homotopy_category.is_bounded_above X] :
  bounded_homotopy_category A := ⟨X⟩

abbreviation hom_val {X Y : bounded_homotopy_category A} (f : X ⟶ Y) : X.val ⟶ Y.val := f

lemma hom_ext {X Y : bounded_homotopy_category A} (f g : X ⟶ Y) (h : hom_val f = hom_val g) :
  f = g := h

@[simps]
def mk_iso {X Y : bounded_homotopy_category A} (i : X.val ≅ Y.val) :
  X ≅ Y :=
{ hom := i.hom,
  inv := i.inv,
  hom_inv_id' := i.hom_inv_id,
  inv_hom_id' := i.inv_hom_id, }

instance : preadditive (bounded_homotopy_category A) :=
{ hom_group := λ A B, show add_comm_group (A.val ⟶ B.val), by apply_instance,
  add_comp' := λ P Q R f g h, preadditive.add_comp _ _ _ _ _ _,
  comp_add' := λ P Q R f g h, preadditive.comp_add _ _ _ _ _ _ }

protected def zero : bounded_homotopy_category A :=
{ val := homotopy_category.zero,
  bdd := ⟨⟨0, λ i _, begin
    apply limits.is_zero_zero
  end⟩⟩ }

protected lemma is_zero_zero :
  is_zero (bounded_homotopy_category.zero : bounded_homotopy_category A) :=
begin
  rw is_zero_iff_id_eq_zero,
  apply homotopy_category.is_zero_zero.eq_of_src,
end

lemma zero_val {X : bounded_homotopy_category A} (hX : is_zero X) : is_zero X.val :=
by rwa is_zero_iff_id_eq_zero at hX ⊢

instance : has_zero_object (bounded_homotopy_category A) :=
⟨⟨bounded_homotopy_category.zero, bounded_homotopy_category.is_zero_zero⟩⟩

/-
lemma is_bounded_shift (X : bounded_homotopy_category A) (i : ℤ) :
  ∃ (a : ℤ), ∀ j, a ≤ j → is_zero (X.val⟦i⟧.as.X j) :=
begin
  obtain ⟨a,ha⟩ := X.2,
  use a - i,
  intros j hj,
  apply ha,
  linarith
end
-/

local attribute [instance] endofunctor_monoidal_category
local attribute [reducible] endofunctor_monoidal_category discrete.add_monoidal

instance : has_shift (bounded_homotopy_category A) ℤ :=
has_shift_mk _ _
{ F := λ i,
  { obj := λ X, ⟨X.val⟦(i : ℤ)⟧⟩,
    map := λ X Y f, f⟦i⟧',
    map_id' := λ X, (category_theory.shift_functor _ _).map_id _,
    map_comp' := λ X Y Z f g, (category_theory.shift_functor _ _).map_comp _ _ },
  ε :=
  { hom :=
    { app := λ X, (homotopy_category.shift_ε _).hom.app X.val,
      naturality' := λ _ _ _, (homotopy_category.shift_ε _).hom.naturality _ },
    inv :=
    { app := λ X, (homotopy_category.shift_ε _).inv.app X.val,
      naturality' := λ _ _ _, (homotopy_category.shift_ε _).inv.naturality _ },
    hom_inv_id' := begin
      ext,
      dsimp,
      erw [← nat_trans.comp_app, iso.hom_inv_id],
      refl,
    end,
    inv_hom_id' := begin
      ext,
      dsimp,
      erw [← nat_trans.comp_app, iso.inv_hom_id],
      refl,
    end },
  μ := λ m n,
  { hom :=
    { app := λ X, (homotopy_category.shift_functor_add _ _ _).hom.app X.val,
      naturality' := λ _ _ _, (homotopy_category.shift_functor_add _ _ _).hom.naturality _ },
    inv :=
    { app := λ X, (homotopy_category.shift_functor_add _ _ _).inv.app X.val,
      naturality' := λ _ _ _, (homotopy_category.shift_functor_add _ _ _).inv.naturality _ },
    hom_inv_id' := begin
      ext,
      dsimp,
      erw [← nat_trans.comp_app, iso.hom_inv_id],
      refl,
    end,
    inv_hom_id' := begin
      ext,
      dsimp,
      erw [← nat_trans.comp_app, iso.inv_hom_id],
      refl,
    end },
  associativity := λ m₁ m₂ m₃ X, homotopy_category.has_shift_associativity_aux _ m₁ m₂ m₃ X.val,
  left_unitality := λ n X, homotopy_category.has_shift_left_unitality_aux _ n X.val,
  right_unitality := λ n X, homotopy_category.has_shift_right_unitality_aux _ n X.val } .

@[simp] lemma shift_functor_obj_val (X : bounded_homotopy_category A) (i : ℤ) :
  ((category_theory.shift_functor _ i).obj X).val = X.val⟦i⟧ := rfl

instance shift_functor_additive (i : ℤ) :
  (category_theory.shift_functor (bounded_homotopy_category A) i).additive :=
by constructor

instance : triangulated.pretriangulated (bounded_homotopy_category A) :=
{ distinguished_triangles :=
  -- This could be expresed using `.map_triangle`?
  { T | triangle.mk (homotopy_category _ _) T.mor₁ T.mor₂ T.mor₃ ∈
    dist_triang (homotopy_category A (complex_shape.up ℤ)) },
  isomorphic_distinguished := by async begin
    intros T₁ hT₁ T₂ e,
    let S₁ : triangle (homotopy_category _ _) := triangle.mk _ T₁.mor₁ T₁.mor₂ T₁.mor₃,
    let S₂ : triangle (homotopy_category _ _) := triangle.mk _ T₂.mor₁ T₂.mor₂ T₂.mor₃,
    let E : S₂ ≅ S₁ :=
      triangle.iso.of_components
        ⟨e.hom.hom₁,e.inv.hom₁,_,_⟩
        ⟨e.hom.hom₂,e.inv.hom₂,_,_⟩
        ⟨e.hom.hom₃,e.inv.hom₃,_,_⟩
        _ _ _,
    apply pretriangulated.isomorphic_distinguished _ _ _ E,
    apply hT₁,

    { show (e.hom ≫ e.inv).hom₁ = _, rw iso.hom_inv_id, refl },
    { show (e.inv ≫ e.hom).hom₁ = _, rw iso.inv_hom_id, refl },

    { show (e.hom ≫ e.inv).hom₂ = _, rw iso.hom_inv_id, refl },
    { show (e.inv ≫ e.hom).hom₂ = _, rw iso.inv_hom_id, refl },

    { show (e.hom ≫ e.inv).hom₃ = _, rw iso.hom_inv_id, refl },
    { show (e.inv ≫ e.hom).hom₃ = _, rw iso.inv_hom_id, refl },

    { exact e.hom.comm₁ },
    { exact e.hom.comm₂ },
    { exact e.hom.comm₃ }
  end,
  contractible_distinguished := begin
    intros X,
    apply pretriangulated.isomorphic_distinguished _
      (pretriangulated.contractible_distinguished X.val),
    delta contractible_triangle,
    dsimp,
    refine mk_triangle_iso (iso.refl _) (iso.refl _) _ _ _ _,
    { dsimp, refine is_zero.iso_zero _, apply zero_val, exact limits.is_zero_zero _ },
    all_goals { dsimp, simp only [category.comp_id, category.id_comp, zero_comp, comp_zero]; refl }
  end,
  distinguished_cocone_triangle := begin
    intros X Y f,
    let T := (neg₃_functor (homotopy_category A (complex_shape.up ℤ))).obj (cone.triangleₕ f.out),
    let E := T.obj₃,
    haveI : homotopy_category.is_bounded_above E,
    { obtain ⟨a,ha⟩ := X.2,
      obtain ⟨b,hb⟩ := Y.2,
      use max (a - 1) b,
      intros i hi,
      apply is_zero_biprod,
      { apply ha, suffices : a - 1 ≤ i, by linarith, apply le_trans _ hi, apply le_max_left },
      { apply hb, apply le_trans _ hi, apply le_max_right } },
    refine ⟨⟨E⟩, T.mor₂, T.mor₃, _⟩,
    { erw homotopy_category.mem_distinguished_iff_exists_iso_cone,
      use [X.val.as, Y.val.as, f.out],
      unfreezingI {
      rcases X with ⟨⟨X⟩,hX⟩,
      rcases Y with ⟨⟨Y⟩,hY⟩,
      constructor,
      refine triangle.iso.of_components
        (iso.refl _) (iso.refl _) (iso.refl _) _ _ _,
      { dsimp, simp only [category.comp_id, homotopy_category.quotient_map_out, category.id_comp], },
      { dsimp [T], simp only [category.comp_id, category.id_comp], },
      { dsimp [T], simp only [category_theory.functor.map_id, category.comp_id, category.id_comp] } } }
  end,
  rotate_distinguished_triangle := by async begin
    intros T,
    split,
    { intros hT,
      apply homotopy_category.rotate_mem_distinguished_triangles _ hT },
    { intros hT,
      erw pretriangulated.rotate_distinguished_triangle,
      exact hT }
  end,
  complete_distinguished_triangle_morphism := by async begin
    intros T₁ T₂ hT₁ hT₂ f g h,
    apply pretriangulated.complete_distinguished_triangle_morphism _ _ hT₁ hT₂ f g h,
  end }
.

variable (A)

-- Move this
@[simps]
def _root_.homotopy_category.single (i : ℤ) : A ⥤ homotopy_category A (complex_shape.up ℤ) :=
homological_complex.single _ _ i ⋙ homotopy_category.quotient _ _

def single (i : ℤ) : A ⥤ bounded_homotopy_category A :=
{ obj := λ X,
  { val := (homotopy_category.single A i).obj X,
    bdd := begin
      use i+1,
      intros j hj,
      dsimp,
      erw if_neg,
      { apply limits.is_zero_zero },
      { exact ((i.lt_iff_add_one_le j).mpr hj).ne' }
    end },
  map := λ X Y f, (homotopy_category.single A i).map f,
  map_id' := λ X, (homotopy_category.single A i).map_id _,
  map_comp' := λ X Y Z f g, (homotopy_category.single A i).map_comp f g }

def forget :
  bounded_homotopy_category A ⥤ homotopy_category A (complex_shape.up ℤ) :=
{ obj := bounded_homotopy_category.val, map := λ _ _, id }

instance : full (forget A) := { preimage := λ _ _, id }
instance : faithful (forget A) := {}

def forget_shift (i : ℤ) :
  forget A ⋙ shift_functor (homotopy_category A (complex_shape.up ℤ)) i ≅
  shift_functor _ i ⋙ forget A :=
iso.refl _

noncomputable
def single_forget (i : ℤ) :
  single A i ⋙ forget A ≅ homotopy_category.single A i :=
iso.refl _

variable {A}

section

@[simps]
def _root_.homological_complex.shift_single_obj (i j : ℤ) (X : A) :
  ((homological_complex.single A (complex_shape.up ℤ) i).obj X)⟦j⟧ ≅
  (homological_complex.single A (complex_shape.up ℤ) (i - j)).obj X :=
{ hom := { f := λ k, eq_to_hom (by { dsimp, congr' 1, simpa using eq_sub_iff_add_eq.symm }) },
  inv := { f := λ k, eq_to_hom (by { dsimp, congr' 1, simpa using eq_sub_iff_add_eq }) } }

@[simps]
def _root_.homological_complex.single_shift (i j : ℤ) :
  homological_complex.single A (complex_shape.up ℤ) i ⋙ category_theory.shift_functor _ j ≅
  homological_complex.single A (complex_shape.up ℤ) (i - j) :=
nat_iso.of_components (λ X, homological_complex.shift_single_obj i j X)
begin
  intros,
  ext k,
  dsimp,
  split_ifs,
  { rw dif_pos (eq_sub_iff_add_eq.mpr h), simp },
  { rw dif_neg (eq_sub_iff_add_eq.not.mpr h), simp },
end
.
noncomputable
def shift_single_iso (i j : ℤ) :
  single A i ⋙ shift_functor _ j ≅ single A (i - j) :=
fully_faithful_cancel_right (bounded_homotopy_category.forget A)
(iso_whisker_right (homological_complex.single_shift i j)
  (homotopy_category.quotient A (complex_shape.up ℤ)) : _)

end

end bounded_homotopy_category

namespace category_theory.functor

variables {B : Type u'} [category.{v'} B] [abelian B]
variables (F : A ⥤ B) [functor.additive F]

instance is_bounded_above_map_homotopy_category_obj (X : bounded_homotopy_category A) :
  ((functor.map_homotopy_category (complex_shape.up ℤ) F).obj X.val).is_bounded_above :=
begin
  obtain ⟨a, ha⟩ := homotopy_category.is_bounded_above.cond X.val,
  refine ⟨⟨a, _⟩⟩,
  intros i hi,
  apply functor.map_is_zero,
  apply ha,
  apply hi,
end

@[simps]
def map_bounded_homotopy_category :
  bounded_homotopy_category A ⥤ bounded_homotopy_category B :=
{ obj := λ X, bounded_homotopy_category.of $
    (F.map_homotopy_category _).obj X.val,
  map := λ X Y f, (F.map_homotopy_category _).map f,
  map_id' := λ X, (F.map_homotopy_category _).map_id _,
  map_comp' := λ X Y Z f g, (F.map_homotopy_category _).map_comp _ _ }

end category_theory.functor