import params

import category_theory.category.basic
import category_theory.core

open params

open category_theory

namespace operations

variable [category (bitvec word_len)]

/-!
  # Operations

  Building blocks operations.

  The salsa20 cipher is built fully with add-rotate-XOR operations.

  ## Building blocks operations and the relation with their inverses
-/

/-- Rotate operation implemented as https://github.com/alexwebr/salsa20/blob/master/salsa20.c#L6 -/
def rotl : bitvec word_len → ℕ → bitvec word_len
| a shift := (a.shl shift).or (a.ushr (word_len - shift))

/-- Inverse of the rotate operation (`rotl`). -/
def rotl_inv : bitvec word_len → ℕ → bitvec word_len
| a shift := (a.ushr shift).or (a.shl (word_len - shift))

local notation `rotl⁻¹` := rotl_inv

/-- `rotl⁻¹` after `rotl` produces the identity.  -/
lemma rotl_inv_is_inverse_of_rotl (I : rotl ≅ rotl⁻¹): I.hom ≫ I.inv = 𝟙 rotl :=
begin
  exact I.hom_inv_id',
end

/-- Bitwise modulo addition implemented as https://stackoverflow.com/a/19760152 -/
def mod : bitvec word_len → bitvec word_len → bitvec word_len
| a b := (bitvec.and (a + b) (max_bitvec))

/-- The salsa20 xor operation is just bitwise xor. -/
def xor : bitvec word_len → bitvec word_len → bitvec word_len
| a b := a.xor b

/-- `xor` after `xor` produces the identity.  -/
lemma xor_is_inverse_of_xor (I : xor ≅ xor): I.hom ≫ I.inv = 𝟙 xor :=
begin
  exact I.hom_inv_id',
end

-- Some notation:
notation  ` ZERO `        := bitvec.zero word_len
infix     ` ROTL `  : 90  := rotl
infix     ` ROTL⁻¹ `: 90  := rotl_inv

infix     ` MOD `   : 90  := mod

infix     ` XOR `   : 90  := xor

/-! ## Operation as a combination of building block operations -/

/-- We split the salsa20 operations in 2 terms, one at each side of the XOR. This is the right hand side. -/
def operation_rhs (b c : bitvec word_len) (shift : ℕ ): bitvec word_len := (b MOD c) ROTL shift

/-- With the split done in `operation_rhs`, an operation is just a XOR of 2 bitvectors. -/
def operation : bitvec word_len → bitvec word_len → bitvec word_len
| a b := a XOR b

/-! ## Operation lemmas -/

-- some notation for operations:
infix   ` OP `   : 90   := operation
notation `OP_RHS`       := operation_rhs

/-- OP is just XOR, so each operation is its own inverse. -/
lemma operation_inverse (I : operation ≅ operation) : I.hom ≫ I.inv = 𝟙 operation :=
  by rw [iso.hom_inv_id]

end operations


import data.set.pointwise.smul
import mathlib.order

open_locale pointwise

namespace set
variables {α β : Type*}

section has_involutive_inv
variables [has_involutive_inv α]  {s t : set α}

@[simp, to_additive] lemma inv_sUnion (S : set (set α)) : (⋃₀ S)⁻¹ = ⋃ s ∈ S, s⁻¹ :=
by simp_rw [←image_inv, image_sUnion]

end has_involutive_inv

section has_smul
variables [has_smul α β]

/-- The dilation of nonempty set `x • s` is defined as `{x • y | y ∈ s}` in locale `pointwise`. -/
@[to_additive "The translation of nonempty set `x +ᵥ s` is defined as `{x +ᵥ y | y ∈ s}` in
locale `pointwise`."]
protected def has_smul_nonempty : has_smul α {s : set β // s.nonempty} :=
⟨λ a s, ⟨a • s, s.2.smul_set⟩⟩

localized "attribute [instance] set.has_vadd_nonempty set.has_smul_nonempty" in pointwise

@[simp, norm_cast, to_additive] lemma coe_smul_nonempty (a : α) (s : {s : set β // s.nonempty}) :
  (↑(a • s) : set β) = a • s := rfl

@[simp, to_additive] lemma smul_nonempty_mk (a : α) (s hs) :
  a • (⟨s, hs⟩ : {s : set β // s.nonempty}) = ⟨a • s, hs.smul_set⟩ := rfl

end has_smul

open_locale pointwise

/-- A multiplicative action on a type `β` gives a multiplicative action on its nonempty sets. -/
@[to_additive "An additive action on a type gives an additive action on its nonempty sets."]
protected def mul_action_nonempty [monoid α] [mul_action α β] :
  mul_action α {s : set β // s.nonempty} :=
subtype.coe_injective.mul_action _ coe_smul_nonempty

localized "attribute [instance] set.add_action_nonempty set.mul_action_nonempty" in pointwise

end set


import .definitions
import data.bool
import data.int.gcd
import tactic
import .mod
import .solve
import .main

lemma divide_by_gcd'_correct (eqs eqs': Eqs)
	(h1: divide_by_gcd' eqs = some eqs')
	(x: list ℤ) (h2: x ∈ eqs):
	(x ∈ eqs') ∧ (t eqs' ≤ t eqs) :=
begin
	cases eqs,
	cases eqs',
	cases eqs_eqs;
	unfold divide_by_gcd' at h1,
	{
		rw Eqs.has_mem_iff at h2,
		simp at h2,
		simp at h1,
		rw Eqs.has_mem_iff,
		simp [t, ←h1.2],
		cases  (find_min_non_zero_or_default {dim := eqs'_dim, eqs := list.nil});
		simp [t._match_1, *],
	}, {
		sorry,
	}
end

theorem divide_by_gcd_correct (e: Eqs) (r: EqsReduction)
	(h1: divide_by_gcd e = some r)
	(x: list ℤ) (h2: x ∈ r.eqs):
	(r.reduction x ∈ e) ∧ (t r.eqs ≤ t e) :=
begin
	unfold divide_by_gcd at h1,
	sorry,
end

@[simp]
lemma Eq.add_length (eq1 eq2: Eq): (eq1.add eq2).as.length = min eq1.as.length eq2.as.length :=
by simp [Eq.add]

@[simp]
lemma Eq.mul_length (eq: Eq) (f: ℤ): (eq.mul f).as.length = eq.as.length :=
by simp [Eq.mul]

lemma annihilate_var_correct (e: Eq) (var_def: Eq) (i: ℕ) (h: (e.as.inth i).nat_abs = 1) (h': var_def.as.length = e.as.length) (x: list ℤ) (h2: x ∈ var_def):
	x ∈ (annihilate_var e var_def i) ↔ x ∈ e :=
begin
	rw Eq.has_mem_iff at h2,

	rw Eq.has_mem_iff,
	rw Eq.has_mem_iff,
	unfold annihilate_var,

	apply and_congr, { simp [h2, h'], },

	simp,
	split, {
		assume h2,
		sorry,
	},
	sorry,
end

theorem eliminate_unit_var_correct (e: Eqs) (r: EqsReduction)
	(h1: eliminate_unit_var e = some r)
	(x: list ℤ) (h2: x ∈ r.eqs):
	(r.reduction x ∈ e) ∧ (t r.eqs ≤ t e) :=
begin
	unfold eliminate_unit_var at h1,
	cases find_isolated_var e,
	{
		unfold eliminate_unit_var._match_1 at h1,
		finish,
	}, {
		cases val,
		unfold eliminate_unit_var._match_1 at h1,
		simp at h1,

		split, {
			subst h1,
			simp at h2,
			simp,
			sorry,
		},
		sorry,
	}
end

theorem fixpoint_of_simplify_terminates (eqs: Eqs) (r: EqsReduction)
	(h1: simplify eqs = some r): (t r.eqs < t eqs) :=
begin
	sorry,
end


import category_theory.abelian.homology
import algebra.homology.additive
import for_mathlib.abelian_category
import for_mathlib.equalizers
import for_mathlib.homology_map_datum
import for_mathlib.short_complex
import for_mathlib.derived.defs

namespace category_theory

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

lemma exact.mono_desc {X Y Z : A} {f : X ⟶ Y} {g : Y ⟶ Z} (e : exact f g) :
  mono (limits.cokernel.desc _ _ e.w) :=
abelian.category_theory.limits.cokernel.desc.category_theory.mono f g e --WAT?

lemma exact.epi_lift {X Y Z : A} {f : X ⟶ Y} {g : Y ⟶ Z} (e : exact f g) :
  epi (limits.kernel.lift _ _ e.w) :=
limits.kernel.lift.epi e

lemma exact.epi_of_exact_zero_right {X Y Z : A} {f : X ⟶ Y} (e : exact f (0 : Y ⟶ Z)) :
  epi f :=
begin
  rw abelian.epi_iff_cokernel_π_eq_zero,
  rw abelian.exact_iff at e,
  cases e with e1 e2,
  simpa using e2,
end

lemma exact.mono_of_exact_zero_left {X Y Z : A} {f : Y ⟶ Z} (e : exact (0 : X ⟶ Y) f) :
  mono f :=
begin
  rw abelian.mono_iff_kernel_ι_eq_zero,
  rw abelian.exact_iff at e,
  cases e with e1 e2,
  simpa using e2,
end

namespace functor

open category_theory.limits

def exact : Prop :=
∀ ⦃X Y Z : A⦄ (f : X ⟶ Y) (g : Y ⟶ Z), exact f g → exact (F.map f) (F.map g)

noncomputable theory

-- Sanity check
example : preserves_zero_morphisms F := infer_instance

open_locale zero_object classical

lemma epi_of_epi_of_exact (h : F.exact) {X Y : A} (f : X ⟶ Y)
  [epi f] : epi (F.map f) :=
begin
  have : category_theory.exact f (0 : _ ⟶ 0) := exact_epi_zero f,
  replace this := h _ _ this,
  simp at this,
  apply this.epi_of_exact_zero_right,
end

lemma mono_of_mono_of_exact (h : F.exact) {X Y : A} (f : X ⟶ Y)
  [mono f] : mono (F.map f) :=
begin
  have : category_theory.exact (0 : X ⟶ _) f := exact_zero_left_of_mono X,
  replace this := h _ _ this,
  simp at this,
  apply this.mono_of_exact_zero_left,
end

lemma is_iso_cokernel_comparison_of_exact
  (hh : F.exact) {X Y : A} (f : X ⟶ Y) : is_iso (cokernel_comparison f F) :=
begin
  have : category_theory.exact (F.map f) (F.map (cokernel.π f)),
  { apply hh, exact abelian.exact_cokernel f },
  dsimp [cokernel_comparison],
  apply_with is_iso_of_mono_of_epi { instances := ff },
  apply_instance,
  apply this.mono_desc,
  constructor, intros Z a b h,
  apply_fun (λ e, cokernel.π _ ≫ e) at h,
  simp at h,
  haveI := epi_of_epi_of_exact _ hh (cokernel.π f),
  rwa cancel_epi at h,
end

def preserves_coequalizers_of_exact (hh : F.exact) {X Y : A} (f g : X ⟶ Y) :
  preserves_colimit (parallel_pair f g) F :=
preserves_colimit_of_preserves_colimit_cocone (cofork_of_cokernel_is_colimit _ _)
begin
  let e : parallel_pair f g ⋙ F ≅ parallel_pair (F.map f) (F.map g) :=
    diagram_iso_parallel_pair _,
  equiv_rw (is_colimit.precompose_inv_equiv e _).symm,
  apply is_colimit.of_iso_colimit (cofork_of_cokernel_is_colimit (F.map f) (F.map g)),
  haveI := is_iso_cokernel_comparison_of_exact F hh (f-g),
  refine cocones.ext (cokernel.map_iso (F.map f - F.map g) (F.map (f-g))
    (iso.refl _) (iso.refl _) (by simp) ≪≫ as_iso (cokernel_comparison (f-g) F)) _,
  rintro (_|_),
  tidy,
end

def preserves_finite_colimits_of_exact (hh : F.exact) : preserves_finite_colimits F :=
begin
  apply_with preserves_finite_colimits_of_preserves_coequalizers_and_finite_coproducts
    { instances := ff },
  any_goals { apply_instance },
  { constructor,
    intro K,
    apply_with preserves_colimit_of_iso_diagram { instances := ff },
    exact (diagram_iso_parallel_pair K).symm,
    apply preserves_coequalizers_of_exact F hh, },
  { introsI J hI,
    apply preserves_coproducts_of_shape_of_preserves_biproducts_of_shape }
end

lemma is_iso_kernel_comparison_of_exact
  (hh : F.exact) {X Y : A} (f : X ⟶ Y) : is_iso (kernel_comparison f F) :=
begin
  have : category_theory.exact (F.map (kernel.ι f)) (F.map f),
  { apply hh, exact exact_kernel_ι },
  dsimp [kernel_comparison],
  apply_with is_iso_of_mono_of_epi { instances := ff },
  apply_instance,
  constructor,
  intros Z a b h,
  apply_fun (λ e, e ≫ kernel.ι _) at h,
  simp at h,
  haveI := mono_of_mono_of_exact _ hh (kernel.ι f),
  rwa cancel_mono at h,
  apply this.epi_lift,
end

def preserves_equalizers_of_exact (hh : F.exact) {X Y : A} (f g : X ⟶ Y) :
  preserves_limit (parallel_pair f g) F :=
preserves_limit_of_preserves_limit_cone (fork_of_kernel_is_limit _ _)
begin
  let e : parallel_pair f g ⋙ F ≅ parallel_pair (F.map f) (F.map g) :=
    diagram_iso_parallel_pair _,
  equiv_rw (is_limit.postcompose_hom_equiv e _).symm,
  apply is_limit.of_iso_limit (fork_of_kernel_is_limit (F.map f) (F.map g)),
  haveI := is_iso_kernel_comparison_of_exact F hh (f-g),
  symmetry,
  refine cones.ext (as_iso (kernel_comparison (f-g) F) ≪≫
    kernel.map_iso (F.map (f-g)) (F.map f - F.map g) (iso.refl _) (iso.refl _) (by simp)) _,
  rintro (_|_),
  tidy,
end

def preserves_finite_limits_of_exact (h : F.exact) : preserves_finite_limits F :=
begin
  apply_with preserves_finite_limits_of_preserves_equalizers_and_finite_products
    { instances := ff },
  any_goals { apply_instance },
  { constructor,
    intro K,
    apply_with preserves_limit_of_iso_diagram { instances := ff },
    exact (diagram_iso_parallel_pair K).symm,
    apply preserves_equalizers_of_exact F h, },
  { introsI J hJ,
    apply preserves_products_of_shape_of_preserves_biproducts_of_shape }
end

variables [preserves_finite_limits F] [preserves_finite_colimits F]
variables [preserves_finite_limits G] [preserves_finite_colimits G]

def homology_nat_iso :
  (short_complex.homology_functor : short_complex A ⥤ A) ⋙ F ≅
    F.map_short_complex ⋙ short_complex.homology_functor :=
nat_iso.of_components
  (λ S, ((homology_iso_datum.tautological' S.1.f S.1.g S.2).apply_exact_functor F).iso)
  (λ S₁ S₂ φ, by simp only [comp_map, iso.hom_inv_id_assoc,
    ((homology_map_datum.tautological' φ).map_exact_functor F).homology_map_eq])

def homology_iso {X Y Z : A} (f : X ⟶ Y) (g : Y ⟶ Z) (w w') :
  F.obj (homology f g w) ≅ homology (F.map f) (F.map g) w' :=
F.homology_nat_iso.app (short_complex.mk f g w)

def homology_functor_iso {M : Type*} (c : complex_shape M) (i : M) :
  homology_functor A c i ⋙ F ≅
  F.map_homological_complex _ ⋙ homology_functor B c i :=
begin
  calc homology_functor A c i ⋙ F ≅
    (short_complex.functor_homological_complex A c i ⋙ short_complex.homology_functor) ⋙ F : _
  ... ≅ short_complex.functor_homological_complex A c i ⋙ short_complex.homology_functor ⋙ F : _
  ... ≅ short_complex.functor_homological_complex A c i ⋙ F.map_short_complex ⋙
    short_complex.homology_functor : _
  ... ≅ (short_complex.functor_homological_complex A c i ⋙ F.map_short_complex) ⋙
    short_complex.homology_functor : _
  ... ≅ (F.map_homological_complex _ ⋙ short_complex.functor_homological_complex B c i) ⋙
    short_complex.homology_functor : _
  ... ≅ F.map_homological_complex _ ⋙ (short_complex.functor_homological_complex B c i) ⋙
    short_complex.homology_functor : _
  ... ≅ F.map_homological_complex _ ⋙ homology_functor B c i : _,
  { exact iso_whisker_right (short_complex.homology_functor_iso A c i) F, },
  { apply associator, },
  { exact iso_whisker_left _ (F.homology_nat_iso), },
  { symmetry, apply associator, },
  { exact iso_whisker_right (short_complex.functor_homological_complex_map F c i) _, },
  { apply associator, },
  { exact iso_whisker_left _ (short_complex.homology_functor_iso B c i).symm, },
end

variables {F G}

def naturality_homology_nat_iso_app (S : short_complex A) :
  φ.app (S.homology) ≫ G.homology_nat_iso.hom.app S =
    F.homology_nat_iso.hom.app S ≫
      short_complex.homology_functor.map (φ.map_short_complex.app S) :=
begin
  let h := (homology_iso_datum.tautological' S.obj.f S.obj.g S.zero),
  simpa [← cancel_epi (h.apply_exact_functor F).iso.hom, iso.hom_inv_id_assoc]
    using (h.map_nat_trans φ).homology_map_eq.symm,
end

/-- naturality of `homology_functor_iso` on the variable `F` -/
lemma naturality_homology_functor_iso_hom_app {M : Type*} {c : complex_shape M}
  (X : homological_complex A c) (i : M) :
  φ.app ((homology_functor A c i).obj X) ≫ (G.homology_functor_iso c i).hom.app X =
  (F.homology_functor_iso c i).hom.app X ≫
    (homology_functor B c i).map ((nat_trans.map_homological_complex φ c).app X) :=
begin
  dsimp only [homology_functor_iso, iso.trans, iso_whisker_left, whiskering_left,
    whisker_left, iso_whisker_right, whiskering_right, whisker_right, map_iso,
    associator, iso.symm, short_complex.homology_functor_iso,
    nat_iso.of_components, iso.refl],
  simp only [category.assoc, nat_trans.comp_app, category.id_comp, F.map_id, G.map_id],
  erw [category.id_comp, category.id_comp, category.comp_id],
  slice_lhs 1 2 { erw naturality_homology_nat_iso_app φ
    ((short_complex.functor_homological_complex A c i).obj X), },
  rw [category.assoc, ← short_complex.homology_functor.map_comp],
    simpa only [short_complex.naturality_functor_homological_complex_map,
      short_complex.homology_functor.map_comp],
end

lemma naturality_homology_functor_iso {M : Type*} (c : complex_shape M) (i : M) :
  𝟙 (homology_functor A c i) ◫ φ ≫ (G.homology_functor_iso c i).hom =
  (F.homology_functor_iso c i).hom ≫
    nat_trans.map_homological_complex φ c ◫ (𝟙 (homology_functor B c i)) :=
begin
  ext1, ext1 X,
  simp only [nat_trans.comp_app, nat_trans.hcomp_app, nat_trans.id_app, G.map_id,
    category.comp_id],
  erw category.id_comp,
  apply naturality_homology_functor_iso_hom_app,
end

variable (F)

def homology_functor_iso_on_homotopy_category {M : Type*} (c : complex_shape M) (i : M) :
  homotopy_category.homology_functor A c i ⋙ F ≅
  F.map_homotopy_category _ ⋙ homotopy_category.homology_functor B c i :=
nat_iso.of_components
(λ X, (F.homology_functor_iso c i).app X.as)
(λ X Y f, begin
  nth_rewrite 0 ← homotopy_category.quotient_map_out f,
  erw (F.homology_functor_iso c i).hom.naturality (quot.out f),
  refl,
end)

def map_quasi_iso_on_homotopy_category {M : Type*} {c : complex_shape M}
  {X₁ X₂ : homotopy_category A c} (φ : X₁ ⟶ X₂) [hφ : homotopy_category.is_quasi_iso φ] :
  homotopy_category.is_quasi_iso ((F.map_homotopy_category c).map φ) :=
⟨begin
  intro i,
  let F₁ := homotopy_category.homology_functor A c i ⋙ F,
  let F₂ := map_homotopy_category c F ⋙ homotopy_category.homology_functor B c i,
  change is_iso (F₂.map φ),
  let e : F₁ ≅ F₂ := F.homology_functor_iso_on_homotopy_category c i,
  have h := e.hom.naturality φ,
  rw [← cancel_epi (e.inv.app X₁)] at h,
  conv_rhs at h { rw [← category.assoc, ← nat_trans.comp_app, e.inv_hom_id], },
  rw [nat_trans.id_app, category.id_comp] at h,
  rw ← h,
  haveI : is_iso (F₁.map φ) := begin
    haveI := hφ.cond,
    dsimp only [F₁, functor.comp],
    apply functor.map_is_iso,
  end,
  apply_instance,
end⟩

end functor

-- TODO: Exact iff preserves finite limits and colimits
end category_theory


/-
Copyright (c) 2019 Seul Baek. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Seul Baek
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.tactic.omega.clause
import Mathlib.tactic.omega.int.form
import Mathlib.PostPort

namespace Mathlib

/-
DNF transformation.
-/

namespace omega

namespace int

/-- push_neg p returns the result of normalizing ¬ p by
    pushing the outermost negation all the way down,
    until it reaches either a negation or an atom -/
@[simp] def push_neg : preform → preform := sorry

theorem push_neg_equiv {p : preform} : preform.equiv (push_neg p) (preform.not p) := sorry

/-- NNF transformation -/
def nnf : preform → preform := sorry

def is_nnf : preform → Prop := sorry

theorem is_nnf_push_neg (p : preform) : is_nnf p → is_nnf (push_neg p) := sorry

/-- Argument is free of negations -/
def neg_free : preform → Prop := sorry

theorem is_nnf_nnf (p : preform) : is_nnf (nnf p) := sorry

theorem nnf_equiv {p : preform} : preform.equiv (nnf p) p := sorry

/-- Eliminate all negations from preform -/
@[simp] def neg_elim : preform → preform := sorry

theorem neg_free_neg_elim (p : preform) : is_nnf p → neg_free (neg_elim p) := sorry

theorem le_and_le_iff_eq {α : Type} [partial_order α] {a : α} {b : α} : a ≤ b ∧ b ≤ a ↔ a = b :=
  sorry

theorem implies_neg_elim {p : preform} : preform.implies p (neg_elim p) := sorry

@[simp] def dnf_core : preform → List clause := sorry

/-- DNF transformation -/
def dnf (p : preform) : List clause := dnf_core (neg_elim (nnf p))

theorem exists_clause_holds {v : ℕ → ℤ} {p : preform} :
    neg_free p → preform.holds v p → ∃ (c : clause), ∃ (H : c ∈ dnf_core p), clause.holds v c :=
  sorry

theorem clauses_sat_dnf_core {p : preform} :
    neg_free p → preform.sat p → clauses.sat (dnf_core p) :=
  sorry

theorem unsat_of_clauses_unsat {p : preform} : clauses.unsat (dnf p) → preform.unsat p := sorry

end Mathlib


/-
Copyright (c) 2021 David Wärn. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: David Wärn, Antoine Labelle, Rémi Bottinelli
Ported by: Joël Riou, Rémi Bottinelli

! This file was ported from Lean 3 source module combinatorics.quiver.symmetric
! leanprover-community/mathlib commit 706d88f2b8fdfeb0b22796433d7a6c1a010af9f2
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Combinatorics.Quiver.Path
import Mathlib.Combinatorics.Quiver.Push
import Mathlib.Data.Sum.Basic

/-!
## Symmetric quivers and arrow reversal

This file contains constructions related to symmetric quivers:

* `Symmetrify V` adds formal inverses to each arrow of `V`.
* `HasReverse` is the class of quivers where each arrow has an assigned formal inverse.
* `HasInvolutiveReverse` extends `HasReverse` by requiring that the reverse of the reverse
  is equal to the original arrow.
* `Prefunctor.PreserveReverse` is the class of prefunctors mapping reverses to reverses.
* `Symmetrify.of`, `Symmetrify.lift`, and the associated lemmas witness the universal property
  of `Symmetrify`.
-/

universe v u w v'

namespace Quiver

/-- A type synonym for the symmetrized quiver (with an arrow both ways for each original arrow).
    NB: this does not work for `Prop`-valued quivers. It requires `[Quiver.{v+1} V]`. -/
-- Porting note: no hasNonemptyInstance linter yet
def Symmetrify (V : Type _) := V
#align quiver.symmetrify Quiver.Symmetrify

instance symmetrifyQuiver (V : Type u) [Quiver V] : Quiver (Symmetrify V) :=
  ⟨fun a b : V ↦ Sum (a ⟶ b) (b ⟶ a)⟩

variable (U V W : Type _) [Quiver.{u + 1} U] [Quiver.{v + 1} V] [Quiver.{w + 1} W]

/-- A quiver `HasReverse` if we can reverse an arrow `p` from `a` to `b` to get an arrow
    `p.reverse` from `b` to `a`.-/
class HasReverse where
  /-- the map which sends an arrow to its reverse -/
  reverse' : ∀ {a b : V}, (a ⟶ b) → (b ⟶ a)
#align quiver.has_reverse Quiver.HasReverse

/-- Reverse the direction of an arrow. -/
def reverse {V} [Quiver.{v + 1} V] [HasReverse V] {a b : V} : (a ⟶ b) → (b ⟶ a) :=
  HasReverse.reverse'
#align quiver.reverse Quiver.reverse

/-- A quiver `HasInvolutiveReverse` if reversing twice is the identity.`-/
class HasInvolutiveReverse extends HasReverse V where
  /-- `reverse` is involutive -/
  inv' : ∀ {a b : V} (f : a ⟶ b), reverse (reverse f) = f
#align quiver.has_involutive_reverse Quiver.HasInvolutiveReverse

variable {U V W}

@[simp]
theorem reverse_reverse [h : HasInvolutiveReverse V] {a b : V} (f : a ⟶ b) :
    reverse (reverse f) = f := by apply h.inv'
#align quiver.reverse_reverse Quiver.reverse_reverse

@[simp]
theorem reverse_inj [h : HasInvolutiveReverse V] {a b : V}
    (f g : a ⟶ b) : reverse f = reverse g ↔ f = g := by
  constructor
  · rintro h
    simpa using congr_arg Quiver.reverse h
  · rintro h
    congr
#align quiver.reverse_inj Quiver.reverse_inj

theorem eq_reverse_iff [h : HasInvolutiveReverse V] {a b : V} (f : a ⟶ b)
    (g : b ⟶ a) : f = reverse g ↔ reverse f = g := by
  rw [←reverse_inj, reverse_reverse]

#align quiver.eq_reverse_iff Quiver.eq_reverse_iff

section MapReverse

variable [HasReverse U] [HasReverse V] [HasReverse W]

/-- A prefunctor preserving reversal of arrows -/
class _root_.Prefunctor.MapReverse (φ : U ⥤q V) where
  /-- The image of a reverse is the reverse of the image. -/
  map_reverse' : ∀ {u v : U} (e : u ⟶ v), φ.map (reverse e) = reverse (φ.map e)
#align prefunctor.map_reverse Prefunctor.MapReverse

@[simp]
theorem _root_.Prefunctor.map_reverse (φ : U ⥤q V) [φ.MapReverse]
    {u v : U} (e : u ⟶ v) : φ.map (reverse e) = reverse (φ.map e) :=
  Prefunctor.MapReverse.map_reverse' e
#align prefunctor.map_reverse' Prefunctor.map_reverse

instance _root_.Prefunctor.mapReverseComp
    (φ : U ⥤q V) (ψ : V ⥤q W) [φ.MapReverse] [ψ.MapReverse] :
    (φ ⋙q ψ).MapReverse where
  map_reverse' e := by
    simp only [Prefunctor.comp_map, Prefunctor.MapReverse.map_reverse']
#align prefunctor.map_reverse_comp Prefunctor.mapReverseComp

instance _root_.Prefunctor.mapReverseId :
    (Prefunctor.id U).MapReverse where
  map_reverse' _ := rfl
#align prefunctor.map_reverse_id Prefunctor.mapReverseId

end MapReverse

instance : HasReverse (Symmetrify V) :=
  ⟨fun e => e.swap⟩

instance :
    HasInvolutiveReverse
      (Symmetrify V) where
  toHasReverse := ⟨fun e ↦ e.swap⟩
  inv' e := congr_fun Sum.swap_swap_eq e

@[simp]
theorem symmetrify_reverse {a b : Symmetrify V} (e : a ⟶ b) : reverse e = e.swap :=
  rfl
#align quiver.symmetrify_reverse Quiver.symmetrify_reverse

section Paths

/-- Shorthand for the "forward" arrow corresponding to `f` in `symmetrify V` -/
abbrev Hom.toPos {X Y : V} (f : X ⟶ Y) : (Quiver.symmetrifyQuiver V).Hom X Y :=
  Sum.inl f
#align quiver.hom.to_pos Quiver.Hom.toPos

/-- Shorthand for the "backward" arrow corresponding to `f` in `symmetrify V` -/
abbrev Hom.toNeg {X Y : V} (f : X ⟶ Y) : (Quiver.symmetrifyQuiver V).Hom Y X :=
  Sum.inr f
#align quiver.hom.to_neg Quiver.Hom.toNeg

/-- Reverse the direction of a path. -/
@[simp]
def Path.reverse [HasReverse V] {a : V} : ∀ {b}, Path a b → Path b a
  | _, Path.nil => Path.nil
  | _, Path.cons p e => (Quiver.reverse e).toPath.comp p.reverse
#align quiver.path.reverse Quiver.Path.reverse

@[simp]
theorem Path.reverse_toPath [HasReverse V] {a b : V} (f : a ⟶ b) :
    f.toPath.reverse = (Quiver.reverse f).toPath :=
  rfl
#align quiver.path.reverse_to_path Quiver.Path.reverse_toPath

@[simp]
theorem Path.reverse_comp [HasReverse V] {a b c : V} (p : Path a b) (q : Path b c) :
    (p.comp q).reverse = q.reverse.comp p.reverse := by
  induction' q with _ _ _ _ h
  · simp
  · simp [h]
#align quiver.path.reverse_comp Quiver.Path.reverse_comp

@[simp]
theorem Path.reverse_reverse [h : HasInvolutiveReverse V] {a b : V} (p : Path a b) :
    p.reverse.reverse = p := by
  induction' p with _ _ _ _ h
  · simp
  · rw [Path.reverse, Path.reverse_comp, h, Path.reverse_toPath, Quiver.reverse_reverse]
    rfl
#align quiver.path.reverse_reverse Quiver.Path.reverse_reverse

end Paths

namespace Symmetrify

/-- The inclusion of a quiver in its symmetrification -/
def of : Prefunctor V (Symmetrify V) where
  obj := id
  map := Sum.inl
#align quiver.symmetrify.of Quiver.Symmetrify.of

variable {V' : Type _} [Quiver.{v' + 1} V']

/-- Given a quiver `V'` with reversible arrows, a prefunctor to `V'` can be lifted to one from
    `Symmetrify V` to `V'` -/
def lift [HasReverse V'] (φ : Prefunctor V V') :
    Prefunctor (Symmetrify V) V' where
  obj := φ.obj
  map f := match f with
  | Sum.inl g => φ.map g
  | Sum.inr g => reverse (φ.map g)
#align quiver.symmetrify.lift Quiver.Symmetrify.lift

theorem lift_spec [HasReverse V'] (φ : Prefunctor V V') :
    Symmetrify.of.comp (Symmetrify.lift φ) = φ := by
  fapply Prefunctor.ext
  · rintro X
    rfl
  · rintro X Y f
    rfl
#align quiver.symmetrify.lift_spec Quiver.Symmetrify.lift_spec

theorem lift_reverse [h : HasInvolutiveReverse V']
    (φ : Prefunctor V V') {X Y : Symmetrify V} (f : X ⟶ Y) :
    (Symmetrify.lift φ).map (Quiver.reverse f) = Quiver.reverse ((Symmetrify.lift φ).map f) := by
  dsimp [Symmetrify.lift]; cases f
  · simp only
    rfl
  · simp only [reverse_reverse]
    rfl
#align quiver.symmetrify.lift_reverse Quiver.Symmetrify.lift_reverse

/-- `lift φ` is the only prefunctor extending `φ` and preserving reverses. -/
theorem lift_unique [HasReverse V'] (φ : V ⥤q V') (Φ : Symmetrify V ⥤q V') (hΦ : (of ⋙q Φ) = φ)
    (hΦinv : ∀ {X Y : Symmetrify V} (f : X ⟶ Y),
      Φ.map (Quiver.reverse f) = Quiver.reverse (Φ.map f)) :
    Φ = Symmetrify.lift φ := by
  subst_vars
  fapply Prefunctor.ext
  · rintro X
    rfl
  · rintro X Y f
    cases f
    · rfl
    · exact hΦinv (Sum.inl _)
#align quiver.symmetrify.lift_unique Quiver.Symmetrify.lift_unique

end Symmetrify

namespace Push

variable {V' : Type _} (σ : V → V')

instance [HasReverse V] : HasReverse (Quiver.Push σ) where
  reverse' := fun
              | PushQuiver.arrow f => PushQuiver.arrow (reverse f)

instance [h : HasInvolutiveReverse V] :
    HasInvolutiveReverse (Push σ) where
  reverse' := fun
  | PushQuiver.arrow f => PushQuiver.arrow (reverse f)
  inv' := fun
  | PushQuiver.arrow f => by dsimp [reverse]; congr; apply h.inv'

theorem of_reverse [HasInvolutiveReverse V] (X Y : V) (f : X ⟶ Y) :
    (reverse <| (Push.of σ).map f) = (Push.of σ).map (reverse f) :=
  rfl
#align quiver.push.of_reverse Quiver.Push.of_reverse

instance ofMapReverse [h : HasInvolutiveReverse V] : (Push.of σ).MapReverse :=
  ⟨by simp [of_reverse]⟩
#align quiver.push.of_map_reverse Quiver.Push.ofMapReverse

end Push

/-- A quiver is preconnected iff there exists a path between any pair of
vertices.
Note that if `V` doesn't `HasReverse`, then the definition is stronger than
simply having a preconnected underlying `simple_graph`, since a path in one
direction doesn't induce one in the other.
-/
def IsPreconnected (V) [Quiver.{u + 1} V] :=
  ∀ X Y : V, Nonempty (Path X Y)
#align quiver.is_preconnected Quiver.IsPreconnected

end Quiver


import tactic.restate_axiom

open tactic

structure A :=
(x : ℕ)
(a' : x = 1 . skip)
(b : x = 2 . skip)

restate_axiom A.a'
example (z : A) : z.x = 1 := begin success_if_fail { rw A.a' }, rw A.a end

restate_axiom A.b f
example (z : A) : z.x = 2 := by rw A.f

restate_axiom A.b
example (z : A) : z.x = 2 := by rw A.b_lemma


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import algebra.group.pi
import algebra.category.Group.preadditive
import category_theory.limits.shapes.biproducts
import algebra.category.Group.limits

/-!
# The category of abelian groups has finite biproducts
-/

open category_theory
open category_theory.limits

open_locale big_operators

universe u

namespace AddCommGroup

-- As `AddCommGroup` is preadditive, and has all limits, it automatically has biproducts.
instance : has_binary_biproducts AddCommGroup :=
has_binary_biproducts.of_has_binary_products

instance : has_finite_biproducts AddCommGroup :=
has_finite_biproducts.of_has_finite_products

-- We now construct explicit limit data,
-- so we can compare the biproducts to the usual unbundled constructions.

/--
Construct limit data for a binary product in `AddCommGroup`, using `AddCommGroup.of (G × H)`.
-/
@[simps cone_X is_limit_lift]
def binary_product_limit_cone (G H : AddCommGroup.{u}) : limits.limit_cone (pair G H) :=
{ cone :=
  { X := AddCommGroup.of (G × H),
    π := { app := λ j, discrete.cases_on j
      (λ j, walking_pair.cases_on j (add_monoid_hom.fst G H) (add_monoid_hom.snd G H)),
      naturality' := by rintros ⟨⟨⟩⟩ ⟨⟨⟩⟩ ⟨⟨⟨⟩⟩⟩; refl, }},
  is_limit :=
  { lift := λ s, add_monoid_hom.prod (s.π.app ⟨walking_pair.left⟩) (s.π.app ⟨walking_pair.right⟩),
    fac' := by { rintros s (⟨⟩|⟨⟩); { ext x, simp, } },
    uniq' := λ s m w, begin
      ext; [rw ← w ⟨walking_pair.left⟩, rw ← w ⟨walking_pair.right⟩]; refl,
    end, } }

@[simp] lemma binary_product_limit_cone_cone_π_app_left (G H : AddCommGroup.{u}) :
  (binary_product_limit_cone G H).cone.π.app ⟨walking_pair.left⟩ = add_monoid_hom.fst G H := rfl

@[simp] lemma binary_product_limit_cone_cone_π_app_right (G H : AddCommGroup.{u}) :
  (binary_product_limit_cone G H).cone.π.app ⟨walking_pair.right⟩ = add_monoid_hom.snd G H := rfl

/--
We verify that the biproduct in AddCommGroup is isomorphic to
the cartesian product of the underlying types:
-/
@[simps hom_apply] noncomputable
def biprod_iso_prod (G H : AddCommGroup.{u}) : (G ⊞ H : AddCommGroup) ≅ AddCommGroup.of (G × H) :=
is_limit.cone_point_unique_up_to_iso
  (binary_biproduct.is_limit G H)
  (binary_product_limit_cone G H).is_limit

@[simp, elementwise] lemma biprod_iso_prod_inv_comp_fst (G H : AddCommGroup.{u}) :
  (biprod_iso_prod G H).inv ≫ biprod.fst = add_monoid_hom.fst G H :=
is_limit.cone_point_unique_up_to_iso_inv_comp _ _ (discrete.mk walking_pair.left)

@[simp, elementwise] lemma biprod_iso_prod_inv_comp_snd (G H : AddCommGroup.{u}) :
  (biprod_iso_prod G H).inv ≫ biprod.snd = add_monoid_hom.snd G H :=
is_limit.cone_point_unique_up_to_iso_inv_comp _ _ (discrete.mk walking_pair.right)

variables {J : Type u} (f : J → AddCommGroup.{u})

namespace has_limit

/--
The map from an arbitrary cone over a indexed family of abelian groups
to the cartesian product of those groups.
-/
@[simps]
def lift (s : fan f) :
  s.X ⟶ AddCommGroup.of (Π j,f j) :=
{ to_fun := λ x j, s.π.app ⟨j⟩ x,
  map_zero' := by { ext, simp },
  map_add' := λ x y, by { ext, simp }, }

/--
Construct limit data for a product in `AddCommGroup`, using `AddCommGroup.of (Π j, F.obj j)`.
-/
@[simps] def product_limit_cone : limits.limit_cone (discrete.functor f) :=
{ cone :=
  { X := AddCommGroup.of (Π j, f j),
    π := discrete.nat_trans (λ j, pi.eval_add_monoid_hom (λ j, f j) j.as), },
  is_limit :=
  { lift := lift f,
    fac' := λ s j, by { cases j, ext, simp, },
    uniq' := λ s m w,
    begin
      ext x j,
      dsimp only [has_limit.lift],
      simp only [add_monoid_hom.coe_mk],
      exact congr_arg (λ g : s.X ⟶ f j, (g : s.X → f j) x) (w ⟨j⟩),
    end, }, }

end has_limit

open has_limit

/--
We verify that the biproduct we've just defined is isomorphic to the AddCommGroup structure
on the dependent function type
-/
@[simps hom_apply] noncomputable
def biproduct_iso_pi [fintype J] (f : J → AddCommGroup.{u}) :
  (⨁ f : AddCommGroup) ≅ AddCommGroup.of (Π j, f j) :=
is_limit.cone_point_unique_up_to_iso
  (biproduct.is_limit f)
  (product_limit_cone f).is_limit

@[simp, elementwise] lemma biproduct_iso_pi_inv_comp_π [fintype J]
  (f : J → AddCommGroup.{u}) (j : J) :
  (biproduct_iso_pi f).inv ≫ biproduct.π f j = pi.eval_add_monoid_hom (λ j, f j) j :=
is_limit.cone_point_unique_up_to_iso_inv_comp _ _ (discrete.mk j)

end AddCommGroup


/-
Copyright (c) 2019 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.limits.shapes.finite_limits
import Mathlib.order.complete_lattice
import Mathlib.PostPort

universes u

namespace Mathlib

namespace category_theory.limits.complete_lattice

protected instance has_finite_limits_of_semilattice_inf_top {α : Type u} [semilattice_inf_top α] : has_finite_limits α :=
  fun (J : Type u) (𝒥₁ : small_category J) (𝒥₂ : fin_category J) =>
    has_limits_of_shape.mk
      fun (F : J ⥤ α) =>
        has_limit.mk
          (limit_cone.mk
            (cone.mk (finset.inf finset.univ (functor.obj F))
              (nat_trans.mk fun (j : J) => hom_of_le (finset.inf_le (fintype.complete j))))
            (is_limit.mk
              fun (s : cone F) =>
                hom_of_le
                  (finset.le_inf
                    fun (j : J) (_x : j ∈ finset.univ) => plift.down (ulift.down (nat_trans.app (cone.π s) j)))))

protected instance has_finite_colimits_of_semilattice_sup_bot {α : Type u} [semilattice_sup_bot α] : has_finite_colimits α :=
  fun (J : Type u) (𝒥₁ : small_category J) (𝒥₂ : fin_category J) =>
    has_colimits_of_shape.mk
      fun (F : J ⥤ α) =>
        has_colimit.mk
          (colimit_cocone.mk
            (cocone.mk (finset.sup finset.univ (functor.obj F))
              (nat_trans.mk fun (i : J) => hom_of_le (finset.le_sup (fintype.complete i))))
            (is_colimit.mk
              fun (s : cocone F) =>
                hom_of_le
                  (finset.sup_le
                    fun (j : J) (_x : j ∈ finset.univ) => plift.down (ulift.down (nat_trans.app (cocone.ι s) j)))))

/--
The limit cone over any functor into a complete lattice.
-/
def limit_cone {α : Type u} {J : Type u} [small_category J] [complete_lattice α] (F : J ⥤ α) : limit_cone F :=
  limit_cone.mk (cone.mk (infi (functor.obj F)) (nat_trans.mk fun (j : J) => hom_of_le sorry))
    (is_limit.mk fun (s : cone F) => hom_of_le sorry)

/--
The colimit cocone over any functor into a complete lattice.
-/
def colimit_cocone {α : Type u} {J : Type u} [small_category J] [complete_lattice α] (F : J ⥤ α) : colimit_cocone F :=
  colimit_cocone.mk (cocone.mk (supr (functor.obj F)) (nat_trans.mk fun (j : J) => hom_of_le sorry))
    (is_colimit.mk fun (s : cocone F) => hom_of_le sorry)

-- It would be nice to only use the `Inf` half of the complete lattice, but

-- this seems not to have been described separately.

protected instance has_limits_of_complete_lattice {α : Type u} [complete_lattice α] : has_limits α :=
  has_limits.mk
    fun (J : Type u) (𝒥 : small_category J) => has_limits_of_shape.mk fun (F : J ⥤ α) => has_limit.mk (limit_cone F)

protected instance has_colimits_of_complete_lattice {α : Type u} [complete_lattice α] : has_colimits α :=
  has_colimits.mk
    fun (J : Type u) (𝒥 : small_category J) =>
      has_colimits_of_shape.mk fun (F : J ⥤ α) => has_colimit.mk (colimit_cocone F)

/--
The limit of a functor into a complete lattice is the infimum of the objects in the image.
-/
def limit_iso_infi {α : Type u} {J : Type u} [small_category J] [complete_lattice α] (F : J ⥤ α) : limit F ≅ infi (functor.obj F) :=
  is_limit.cone_point_unique_up_to_iso (limit.is_limit F) (limit_cone.is_limit (limit_cone F))

@[simp] theorem limit_iso_infi_hom {α : Type u} {J : Type u} [small_category J] [complete_lattice α] (F : J ⥤ α) (j : J) : iso.hom (limit_iso_infi F) ≫ hom_of_le (infi_le (functor.obj F) j) = limit.π F j :=
  of_as_true trivial

@[simp] theorem limit_iso_infi_inv {α : Type u} {J : Type u} [small_category J] [complete_lattice α] (F : J ⥤ α) (j : J) : iso.inv (limit_iso_infi F) ≫ limit.π F j = hom_of_le (infi_le (functor.obj F) j) :=
  rfl

/--
The colimit of a functor into a complete lattice is the supremum of the objects in the image.
-/
def colimit_iso_supr {α : Type u} {J : Type u} [small_category J] [complete_lattice α] (F : J ⥤ α) : colimit F ≅ supr (functor.obj F) :=
  is_colimit.cocone_point_unique_up_to_iso (colimit.is_colimit F) (colimit_cocone.is_colimit (colimit_cocone F))

@[simp] theorem colimit_iso_supr_hom {α : Type u} {J : Type u} [small_category J] [complete_lattice α] (F : J ⥤ α) (j : J) : colimit.ι F j ≫ iso.hom (colimit_iso_supr F) = hom_of_le (le_supr (functor.obj F) j) :=
  rfl

@[simp] theorem colimit_iso_supr_inv {α : Type u} {J : Type u} [small_category J] [complete_lattice α] (F : J ⥤ α) (j : J) : hom_of_le (le_supr (functor.obj F) j) ≫ iso.inv (colimit_iso_supr F) = colimit.ι F j :=
  of_as_true trivial


import Lean.Parser.Command
open Lean
open Lean.Parser

def testParser (input : String) : IO Unit :=
do
env ← mkEmptyEnvironment;
cmdPTables ← builtinCommandParsingTable.get;
stx ← IO.ofExcept $ runParser env cmdPTables input "<input>" "command";
IO.println stx

def test (is : List String) : IO Unit :=
is.mfor $ fun input => do
  IO.println input;
  testParser input

def main (xs : List String) : IO Unit :=
do
IO.println Command.declaration.info.firstTokens;
test [
"@[inline] def x := 2",
"protected def length.{u} {α : Type u} : List α → Nat
  | [] := 0
  | (a::as) := 1 + length as",
"/-- doc string test -/   private theorem bla (x : Nat) : x = x := Eq.refl x",
"class Alternative (f : Type u → Type v) extends Applicative f : Type (max (u+1) v) :=
(failure : ∀ {α : Type u}, f α)
(orelse  : ∀ {α : Type u}, f α → f α → f α)
",
"local attribute [instance] foo bla",
"attribute [inline] test",
"open Lean (hiding Name)",
"reserve infixr ` ∨ `:30",
"reserve prefix `¬`:40",
"infixr ` ^ ` := Pow.pow",
"notation f ` $ `:1 a:0 := f a",
"notation `Prop` := Sort 0",
"notation `∅`   := EmptyCollection.emptyc _",
"notation `⟦`:max a `⟧`:0 := Quotient.mk a"
]


import lambda_calculus.utlc.basic
import lambda_calculus.utlc.identities
import lambda_calculus.utlc.reduction

namespace lambda_calculus
namespace utlc
namespace β

local notation a `[` b `:=` c  `]` : 70 := has_substitution.substitution a b c

variables {f g f' g' x y z: utlc}

def head_step : utlc → utlc → Prop
| (↓ _) := λ g, false
| (Λ _) := λ g, false
| (f1 · f2) := match f1 with
  | (↓ _) := λ g, false
  | (Λ f1) := λ g, g = f1[0:=f2]
  | (_ · _) := λ g, false
  end

section
local attribute [simp] head_step

instance head_step.decidable_rel : decidable_rel head_step :=
begin
  intros f _,
  induction f using lambda_calculus.utlc.notation_cases_on,
  repeat { unfold head_step, apply_instance },
  induction f_f using lambda_calculus.utlc.notation_cases_on,
  repeat { unfold head_step, apply_instance }
end

theorem head_step_exists (f g: utlc): head_step f g ↔
  ∃ x y, f = (Λ x)·y ∧ g = x[0:=y] :=
by cases f; try { cases f_f }; simp [and.assoc]
end
attribute [simp] head_step_exists
attribute [irreducible] head_step

instance : has_β_reduction utlc := ⟨ reduction_step_of head_step ⟩

section
@[simp] theorem not_index_step (n: ℕ) (g: utlc): ¬ ↓n →β g := by simp [has_β_reduction.step]

theorem lambda_step_iff (f g: utlc): Λ f →β g ↔ ∃ x, g = Λ x ∧ f →β x := by simp [has_β_reduction.step]

theorem dot_step_iff (f f' g: utlc): f·f' →β g ↔
  (∃ x, g = x[0:=f'] ∧ f = Λ x) ∨
  (∃ x, g = x·f' ∧ f →β x) ∨
  (∃ x, g = f·x ∧ f' →β x) :=
by simp [and.assoc, has_β_reduction.step, @and.comm (g = _[0:=f'])]
end

theorem lambda_step_exists {f g: utlc}: Λ f →β g → ∃ x, g = Λ x ∧ f →β x := (lambda_step_iff _ _).mp

theorem lambda_step_lambda {f g: utlc}: f →β g → Λ f →β Λ g :=
by rw [lambda_step_iff]; intro p; exact ⟨g, rfl, p⟩

@[simp] theorem lambda_step_lambda_iff {f g: utlc}: Λ f →β Λ g ↔ f →β g :=
by simp [lambda_step_iff]

@[simp] theorem step_index_iff (n: ℕ):
  f →β ↓n ↔ f = (Λ ↓0)·↓n ∨ ∃ g, f = (Λ ↓(n+1))·g :=
begin
  cases f;
  try { cases f_f };
  try { cases f_f };
  try { cases f_f };
  simp [and.assoc, lambda_step_iff, dot_step_iff, show 0 ≠ n + 1, by linarith, nat.succ_eq_add_one, @eq_comm _ ↓n],
end

theorem dot_step_dot_left: f →β f' → ∀ g, f·g →β f'·g :=
by intro p; simpa [dot_step_iff] using λ _, or.inr (or.inl p)

theorem dot_step_dot_right: g →β g' → ∀ f, f·g →β f·g' :=
by intro p; simpa [dot_step_iff] using λ _, or.inr (or.inr p)

theorem dot_step_cases: f·f' →β g →
  (∃ x, g = x[0:=f'] ∧ f = Λ x) ∨
  (∃ x, g = x·f' ∧ f →β x) ∨
  (∃ x, g = f·x ∧ f' →β x) := (dot_step_iff f f' g).mp

theorem dot_step_cases': (∀ x, f ≠ Λ x) → f·f' →β g →
  (∃ x, g = x·f' ∧ f →β x) ∨
  (∃ x, g = f·x ∧ f' →β x) :=
begin
  intros p q,
  cases dot_step_cases q with q q,
  { rcases q with ⟨x, q, _⟩,
    specialize p x,
    contradiction },
  assumption
end

theorem lambda_dot_step_substitution (f g: utlc):  (Λ f)·g →β f[0:=g] :=
by simp [dot_step_iff]

theorem down_dot_step_dot {n: ℕ}:
  (↓n·x) →β (↓n·g) ↔ (x →β g) :=
by simp [dot_step_iff]

@[simp] theorem down_dot_step_dot' {n: ℕ}:
  (↓n·x) →β (f·g) ↔ (f = ↓n) ∧ (x →β g) :=
by simp [dot_step_iff, and.assoc]

theorem dot_dot_step_dot:
  (x·y·z) →β (f·g) → (x·y →β f ∧ z = g ∨ x·y = f ∧ z →β g) :=
begin
  intro h,
  obtain h|h|h := dot_step_cases h,
  { revert h, simp },
  all_goals {
    rcases h with ⟨w, hw, h⟩,
    rw [dot_eq_dot_iff] at hw,
    rw [hw.left, hw.right] },
  exact or.inl ⟨h, rfl⟩,
  exact or.inr ⟨rfl, h⟩
end

theorem lambda_reduction_lambda:
  f ↠β g → (Λ f) ↠β (Λ g) := lambda_refl_trans_reduction_step_lambda

theorem dot_reduction_dot:
  f ↠β g → f' ↠β g' → (f·f') ↠β (g·g') := dot_refl_trans_reduction_step_dot

theorem dot_reduction_dot_left:
  f ↠β g → (f·f') ↠β (g·f') :=
by intros p; apply dot_reduction_dot p; refl

theorem dot_reduction_dot_right:
  f' ↠β g' → (f·f') ↠β (f·g') :=
by apply dot_reduction_dot; refl

theorem dot_reduction_substitution:
  f ↠β (Λ g) → f' ↠β g' → (f·f') ↠β g[0:=g'] :=
  λ p q, trans (dot_reduction_dot relation.refl_trans_gen.refl q) $
         trans (dot_reduction_dot p relation.refl_trans_gen.refl) $
         relation.refl_trans_gen.single $
         lambda_dot_step_substitution _ _

theorem uses_zero_head_step: head_step f g → ∀ {n}, f.uses n = 0 → g.uses n = 0 :=
begin
  induction f using lambda_calculus.utlc.notation_cases_on,
  { simp },
  { simp },
  simp only [head_step_exists, dot_uses, add_eq_zero_iff, forall_exists_index, and_imp],
  intros x y p q n hf hg,
  rw [dot_eq_dot_iff] at p,
  rw [q, ← p.right, substitution_uses_le (nat.zero_le _),
    ← lambda_uses, ← p.left, hf, hg, zero_add, mul_zero]
end

theorem uses_zero_step: f →β g → ∀ {n}, f.uses n = 0 → g.uses n = 0 := uses_zero_reduction_step @uses_zero_head_step

theorem shift_head_step_shift {n: ℕ}: head_step (f ↑¹ n) (g ↑¹ n) ↔ head_step f g :=
by induction f; simp [down_shift, and.assoc, shift_eq_lambda_iff, substitution_shift_zero]

theorem shift_head_step_shift' {n: ℕ}: head_step f g ↔ head_step (f ↑¹ n) (g ↑¹ n)  :=
by rw [shift_head_step_shift]

theorem shift_step_shift: f →β g → ∀ n, (f ↑¹ n) →β (g ↑¹ n) :=
by simp [has_β_reduction.step, shift_reduction_step_shift_iff @shift_head_step_shift]

theorem shift_reduction_shift: f ↠β g → ∀ n, (f ↑¹ n) ↠β (g ↑¹ n) :=
  λ p n, shift_refl_trans_reduction_shift (@shift_head_step_shift) p

def head_reduced : utlc → bool
| (↓ _) := true
| (Λ _) := true
| (f·g) := match f with
  | (↓ _) := true
  | (Λ _) := false
  | (f·g) := true
  end

def reduced := λ f, lambda_calculus.utlc.reduced_of head_reduced f

theorem head_reduced_iff_not_head_step: head_reduced f ↔ ∀ g, ¬ head_step f g :=
by cases f; try { cases f_f }; simp[reduced, head_reduced]

@[simp] theorem down_reduced (n: ℕ): reduced (↓n:utlc) := by simp [reduced, head_reduced]

@[simp] theorem lambda_reduced:
  reduced (Λ f) = reduced f := by simp [reduced, head_reduced, reduced_of, utlc.reduced]

@[simp] theorem dot_reduced:
  reduced (f·g) = ((¬ f.is_lambda) ∧ reduced f ∧ reduced g) :=
by cases f; simp [reduced, head_reduced, ← not_exists, reduced_of, utlc.reduced]

def reduced_of_not_reduction (f: utlc): reduced f ↔ ∀ g, ¬ f →β g :=
  reduced_iff_not_reduction_step @head_reduced_iff_not_head_step _

-- inductive hypothesis useful when dealing with β reductions
-- splits f·g up to handle the (Λ f)·g ⇔ f[0:=g] case
theorem induction_on (p: utlc → Prop): Π (f: utlc)
  (down: Π n, p ↓n)
  (lambda: Π x (hx: p x), p (Λ x))
  (dot : Π x y (hx: p x) (hnx: ∀ x', x ≠ Λ x') (hy: p y), p (x·y))
  (lambda_dot: Π x y (hx: p (Λ x)) (hx': p x) (hy: p y), p ((Λ x)·y)),
  (p f)
| (↓n) := λ hn hx hdx hlx, hn n
| (Λ x) := λ hn hx hdx hlx, hx x (induction_on x hn hx hdx hlx)
| (↓n·y) := λ hn hx hdx hlx, hdx (↓n) y (hn n) (by simp) (induction_on y hn hx hdx hlx)
| ((Λ x)·y) := λ hn hx hdx hlx, hlx x y (induction_on (Λ x) hn hx hdx hlx) (induction_on x hn hx hdx hlx) (induction_on y hn hx hdx hlx)
| (x·x'·y) := λ hn hx hdx hlx, hdx (x·x') y (induction_on (x·x') hn hx hdx hlx) (by simp) (induction_on y hn hx hdx hlx)

theorem lambda_of_reduced_and_closed: reduced f → f.closed → ∃ g, f = Λ g :=
begin
  induction f using lambda_calculus.utlc.β.induction_on,
  { simp },
  { simp },
  { simp only [dot_reduced, dot_closed, and_imp, bool.coe_to_bool],
    intros f_hnx hxr hyr hxc hyc,
    cases f_hx hxr hxc with g f_hx,
    revert f_hnx,
    simp [f_hx] },
  { simp [← not_exists] }
end

end β
end utlc
end lambda_calculus