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

! This file was ported from Lean 3 source module control.equiv_functor
! leanprover-community/mathlib commit d6aae1bcbd04b8de2022b9b83a5b5b10e10c777d
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Logic.Equiv.Defs
import Mathlib.Tactic.Convert

/-!
# Functions functorial with respect to equivalences

An `EquivFunctor` is a function from `Type → Type` equipped with the additional data of
coherently mapping equivalences to equivalences.

In categorical language, it is an endofunctor of the "core" of the category `Type`.
-/

universe u₀ u₁ u₂ v₀ v₁ v₂

open Function

/-- An `EquivFunctor` is only functorial with respect to equivalences.

To construct an `EquivFunctor`, it suffices to supply just the function `f α → f β` from
an equivalence `α ≃ β`, and then prove the functor laws. It's then a consequence that
this function is part of an equivalence, provided by `EquivFunctor.mapEquiv`.
-/
class EquivFunctor (f : Type u₀ → Type u₁) where
  /-- The action of `f` on isomorphisms. -/
  map : ∀ {α β}, α ≃ β → f α → f β
  /-- `map` of `f` preserves the identity morphism. -/
  map_refl' : ∀ α, map (Equiv.refl α) = @id (f α) := by rfl
  /-- `map` is functorial on equivalences. -/
  map_trans' : ∀ {α β γ} (k : α ≃ β) (h : β ≃ γ), map (k.trans h) = map h ∘ map k := by rfl
#align equiv_functor EquivFunctor

attribute [simp] EquivFunctor.map_refl'

namespace EquivFunctor

section

variable (f : Type u₀ → Type u₁) [EquivFunctor f] {α β : Type u₀} (e : α ≃ β)

/-- An `EquivFunctor` in fact takes every equiv to an equiv. -/
def mapEquiv : f α ≃ f β where
  toFun := EquivFunctor.map e
  invFun := EquivFunctor.map e.symm
  left_inv x := by
    convert (congr_fun (EquivFunctor.map_trans' e e.symm) x).symm
    simp
  right_inv y := by
    convert (congr_fun (EquivFunctor.map_trans' e.symm e) y).symm
    simp
#align equiv_functor.map_equiv EquivFunctor.mapEquiv

@[simp]
theorem mapEquiv_apply (x : f α) : mapEquiv f e x = EquivFunctor.map e x :=
  rfl
#align equiv_functor.map_equiv_apply EquivFunctor.mapEquiv_apply

theorem mapEquiv_symm_apply (y : f β) : (mapEquiv f e).symm y = EquivFunctor.map e.symm y :=
  rfl
#align equiv_functor.map_equiv_symm_apply EquivFunctor.mapEquiv_symm_apply

@[simp]
theorem mapEquiv_refl (α) : mapEquiv f (Equiv.refl α) = Equiv.refl (f α) := by
 simp [EquivFunctor.mapEquiv]; rfl
#align equiv_functor.map_equiv_refl EquivFunctor.mapEquiv_refl

@[simp]
theorem mapEquiv_symm : (mapEquiv f e).symm = mapEquiv f e.symm :=
  Equiv.ext $ mapEquiv_symm_apply f e
#align equiv_functor.map_equiv_symm EquivFunctor.mapEquiv_symm

/-- The composition of `mapEquiv`s is carried over the `EquivFunctor`.
For plain `Functor`s, this lemma is named `map_map` when applied
or `map_comp_map` when not applied.
-/
@[simp]
theorem mapEquiv_trans {γ : Type u₀} (ab : α ≃ β) (bc : β ≃ γ) :
    (mapEquiv f ab).trans (mapEquiv f bc) = mapEquiv f (ab.trans bc) :=
  Equiv.ext $ fun x => by simp [mapEquiv, map_trans']
#align equiv_functor.map_equiv_trans EquivFunctor.mapEquiv_trans

end

instance (priority := 100) ofLawfulFunctor (f : Type u₀ → Type u₁) [Functor f] [LawfulFunctor f] :
    EquivFunctor f where
  map {α β} e := Functor.map e
  map_refl' α := by
    ext
    apply LawfulFunctor.id_map
  map_trans' {α β γ} k h := by
    ext x
    apply LawfulFunctor.comp_map k h x
#align equiv_functor.of_is_lawful_functor EquivFunctor.ofLawfulFunctor

theorem mapEquiv.injective (f : Type u₀ → Type u₁)
    [Applicative f] [LawfulApplicative f] {α β : Type u₀}
    (h : ∀ γ, Function.Injective (pure : γ → f γ)) :
      Function.Injective (@EquivFunctor.mapEquiv f _ α β) :=
  fun e₁ e₂ H =>
    Equiv.ext $ fun x => h β (by simpa [EquivFunctor.map] using Equiv.congr_fun H (pure x))
#align equiv_functor.map_equiv.injective EquivFunctor.mapEquiv.injective

end EquivFunctor


import data.equiv.basic

universes u v w

class transportable (f : Type u → Type v) :=
(on_equiv : Π {α β : Type u} (e : equiv α β), equiv (f α) (f β))
(on_refl  : Π (α : Type u), on_equiv (equiv.refl α) = equiv.refl (f α))
(on_trans : Π {α β γ : Type u} (d : equiv α β) (e : equiv β γ), on_equiv (equiv.trans d e) = equiv.trans (on_equiv d) (on_equiv e))

-- Our goal is an automagic proof of the following (level 20)
theorem group.transportable : transportable group := sorry

-- These next few we might need to define and prove by hand
def Fun : Type u → Type v → Type (max u v) := λ α β, α → β
def Prod : Type u → Type v → Type (max u v) := λ α β, α × β

-- level 1
lemma Const.transportable : (transportable Const) :=
{ on_equiv := λ α β e, equiv.punit_equiv_punit,
  on_refl  := λ α, equiv.ext _ _ $ λ ⟨⟩, rfl,
  on_trans := λ α β γ e1 e2, equiv.ext _ _ $ λ ⟨⟩, rfl }

lemma Fun.transportable (α : Type u) : (transportable (Fun α)) :=
{ on_equiv := λ β γ e, equiv.arrow_congr (equiv.refl α) e,
  on_refl  := λ β, equiv.ext _ _ $ λ f, rfl,
  on_trans := λ β γ δ e1 e2, equiv.ext _ _ $ λ f, funext $ λ x,
    by cases e1; cases e2; refl }

theorem prod.ext' {α β : Type*} {p q : α × β} (H1 : p.1 = q.1) (H2 : p.2 = q.2) : p = q :=
prod.ext.2 ⟨H1, H2⟩

lemma Prod.transportable (α : Type u) : (transportable (Prod α)) :=
{ on_equiv := λ β γ e, equiv.prod_congr (equiv.refl α) e,
  on_refl  := λ β, equiv.ext _ _ $ λ ⟨x, y⟩, by simp,
  on_trans := λ β γ δ e1 e2, equiv.ext _ _ $ λ ⟨x, y⟩, by simp }

lemma Swap.transportable (α : Type u) : (transportable (Swap α)) :=
{ on_equiv := λ β γ e, equiv.prod_congr e (equiv.refl α),
  on_refl  := λ β, equiv.ext _ _ $ λ ⟨x, y⟩, by simp,
  on_trans := λ β γ δ e1 e2, equiv.ext _ _ $ λ ⟨x, y⟩, by simp }

-- And then we can define
def Hom1 (α : Type u) : Type v → Type (max u v) := λ β, α → β
def Hom2 (β : Type v) : Type u → Type (max u v) := λ α, α → β
def Aut : Type u → Type u := λ α, α → α

-- And hopefully automagically derive
lemma Hom1.transportable (α : Type u) : (transportable (Hom1 α)) :=
Fun.transportable α

lemma Hom2.transportable (β : Type v) : (transportable (Hom2 β)) :=
{ on_equiv := λ α γ e, equiv.arrow_congr e (equiv.refl β),
  on_refl  := λ β, equiv.ext _ _ $ λ f, rfl,
  on_trans := λ β γ δ e1 e2, equiv.ext _ _ $ λ f, funext $ λ x,
    by cases e1; cases e2; refl }

lemma Aut.transportable : (transportable Aut) :=
{ on_equiv := λ α β e, equiv.arrow_congr e e,
  on_refl  := λ α, equiv.ext _ _ $ λ f, funext $ λ x, rfl,
  on_trans := λ α β γ e1 e2, equiv.ext _ _ $ λ f, funext $ λ x,
    by cases e1; cases e2; refl }

-- If we have all these in place...
-- A bit of magic might actually be able to derive `group.transportable` on line 11.
-- After all, a group just is a type plus some functions... and we can now transport functions.

lemma distrib.transportable : (transportable distrib) :=
{ on_equiv := λ α β Hαβ,⟨λ ⟨a,m,d1,d2⟩,⟨_,_,_,_⟩,_,_,_⟩,
  on_refl := sorry,
  on_trans := sorry
}


/-
Copyright (c) 2022 Yaël Dillies. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies
-/
import order.category.Lattice

/-!
# The category of distributive lattices

This file defines `DistribLattice`, the category of distributive lattices.

Note that [`DistLat`](https://ncatlab.org/nlab/show/DistLat) in the literature doesn't always
correspond to `DistribLattice` as we don't require bottom or top elements. Instead, this `DistLat`
corresponds to `BoundedDistribLattice`.
-/

universes u

open category_theory

/-- The category of distributive lattices. -/
def DistribLattice := bundled distrib_lattice

namespace DistribLattice

instance : has_coe_to_sort DistribLattice Type* := bundled.has_coe_to_sort
instance (X : DistribLattice) : distrib_lattice X := X.str

/-- Construct a bundled `DistribLattice` from a `distrib_lattice` underlying type and typeclass. -/
def of (α : Type*) [distrib_lattice α] : DistribLattice := bundled.of α

@[simp] lemma coe_of (α : Type*) [distrib_lattice α] : ↥(of α) = α := rfl

instance : inhabited DistribLattice := ⟨of punit⟩

instance : bundled_hom.parent_projection @distrib_lattice.to_lattice := ⟨⟩

attribute [derive [large_category, concrete_category]] DistribLattice

instance has_forget_to_Lattice : has_forget₂ DistribLattice Lattice := bundled_hom.forget₂ _ _

/-- Constructs an equivalence between distributive lattices from an order isomorphism between them.
-/
@[simps] def iso.mk {α β : DistribLattice.{u}} (e : α ≃o β) : α ≅ β :=
{ hom := e,
  inv := e.symm,
  hom_inv_id' := by { ext, exact e.symm_apply_apply _ },
  inv_hom_id' := by { ext, exact e.apply_symm_apply _ } }

/-- `order_dual` as a functor. -/
@[simps] def dual : DistribLattice ⥤ DistribLattice :=
{ obj := λ X, of Xᵒᵈ, map := λ X Y, lattice_hom.dual }

/-- The equivalence between `DistribLattice` and itself induced by `order_dual` both ways. -/
@[simps functor inverse] def dual_equiv : DistribLattice ≌ DistribLattice :=
equivalence.mk dual dual
  (nat_iso.of_components (λ X, iso.mk $ order_iso.dual_dual X) $ λ X Y f, rfl)
  (nat_iso.of_components (λ X, iso.mk $ order_iso.dual_dual X) $ λ X Y f, rfl)

end DistribLattice

lemma DistribLattice_dual_comp_forget_to_Lattice :
  DistribLattice.dual ⋙ forget₂ DistribLattice Lattice =
    forget₂ DistribLattice Lattice ⋙ Lattice.dual := rfl


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

! This file was ported from Lean 3 source module ring_theory.ring_hom_properties
! leanprover-community/mathlib commit b5aecf07a179c60b6b37c1ac9da952f3b565c785
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Algebra.Category.Ring.Constructions
import Mathbin.Algebra.Category.Ring.Colimits
import Mathbin.CategoryTheory.Isomorphism
import Mathbin.RingTheory.Localization.Away
import Mathbin.RingTheory.IsTensorProduct

/-!
# Properties of ring homomorphisms

We provide the basic framework for talking about properties of ring homomorphisms.
The following meta-properties of predicates on ring homomorphisms are defined

* `ring_hom.respects_iso`: `P` respects isomorphisms if `P f → P (e ≫ f)` and
  `P f → P (f ≫ e)`, where `e` is an isomorphism.
* `ring_hom.stable_under_composition`: `P` is stable under composition if `P f → P g → P (f ≫ g)`.
* `ring_hom.stable_under_base_change`: `P` is stable under base change if `P (S ⟶ Y)`
  implies `P (X ⟶ X ⊗[S] Y)`.

-/

universe u

open CategoryTheory Opposite CategoryTheory.Limits

namespace RingHom

variable (P : ∀ {R S : Type u} [CommRing R] [CommRing S] (f : R →+* S), Prop)

include P

section RespectsIso

/-- A property `respects_iso` if it still holds when composed with an isomorphism -/
def RespectsIso : Prop :=
  (∀ {R S T : Type u} [CommRing R] [CommRing S] [CommRing T],
      ∀ (f : R →+* S) (e : S ≃+* T) (hf : P f), P (e.to_ring_hom.comp f)) ∧
    ∀ {R S T : Type u} [CommRing R] [CommRing S] [CommRing T],
      ∀ (f : S →+* T) (e : R ≃+* S) (hf : P f), P (f.comp e.toRingHom)
#align ring_hom.respects_iso RingHom.RespectsIso

variable {P}

theorem RespectsIso.cancel_left_isIso (hP : RespectsIso @P) {R S T : CommRingCat} (f : R ⟶ S)
    (g : S ⟶ T) [IsIso f] : P (f ≫ g) ↔ P g :=
  ⟨fun H => by
    convert hP.2 (f ≫ g) (as_iso f).symm.commRingIsoToRingEquiv H
    exact (is_iso.inv_hom_id_assoc _ _).symm, hP.2 g (asIso f).commRingIsoToRingEquiv⟩
#align ring_hom.respects_iso.cancel_left_is_iso RingHom.RespectsIso.cancel_left_isIso

theorem RespectsIso.cancel_right_isIso (hP : RespectsIso @P) {R S T : CommRingCat} (f : R ⟶ S)
    (g : S ⟶ T) [IsIso g] : P (f ≫ g) ↔ P f :=
  ⟨fun H => by
    convert hP.1 (f ≫ g) (as_iso g).symm.commRingIsoToRingEquiv H
    change f = f ≫ g ≫ inv g
    simp, hP.1 f (asIso g).commRingIsoToRingEquiv⟩
#align ring_hom.respects_iso.cancel_right_is_iso RingHom.RespectsIso.cancel_right_isIso

theorem RespectsIso.is_localization_away_iff (hP : RingHom.RespectsIso @P) {R S : Type _}
    (R' S' : Type _) [CommRing R] [CommRing S] [CommRing R'] [CommRing S'] [Algebra R R']
    [Algebra S S'] (f : R →+* S) (r : R) [IsLocalization.Away r R'] [IsLocalization.Away (f r) S'] :
    P (Localization.awayMap f r) ↔ P (IsLocalization.Away.map R' S' f r) :=
  by
  let e₁ : R' ≃+* Localization.Away r :=
    (IsLocalization.algEquiv (Submonoid.powers r) _ _).toRingEquiv
  let e₂ : Localization.Away (f r) ≃+* S' :=
    (IsLocalization.algEquiv (Submonoid.powers (f r)) _ _).toRingEquiv
  refine' (hP.cancel_left_is_iso e₁.to_CommRing_iso.hom (CommRingCat.ofHom _)).symm.trans _
  refine' (hP.cancel_right_is_iso (CommRingCat.ofHom _) e₂.to_CommRing_iso.hom).symm.trans _
  rw [← eq_iff_iff]
  congr 1
  dsimp [CommRingCat.ofHom, CommRingCat.of, bundled.of]
  refine' IsLocalization.ringHom_ext (Submonoid.powers r) _
  ext1
  revert e₁ e₂
  dsimp [RingEquiv.toRingHom, IsLocalization.Away.map]
  simp only [CategoryTheory.comp_apply, RingEquiv.refl_apply, IsLocalization.algEquiv_apply,
    IsLocalization.ringEquivOfRingEquiv_apply, RingHom.coe_mk, [anonymous],
    IsLocalization.ringEquivOfRingEquiv_eq, IsLocalization.map_eq]
#align ring_hom.respects_iso.is_localization_away_iff RingHom.RespectsIso.is_localization_away_iff

end RespectsIso

section StableUnderComposition

/-- A property is `stable_under_composition` if the composition of two such morphisms
still falls in the class. -/
def StableUnderComposition : Prop :=
  ∀ ⦃R S T⦄ [CommRing R] [CommRing S] [CommRing T],
    ∀ (f : R →+* S) (g : S →+* T) (hf : P f) (hg : P g), P (g.comp f)
#align ring_hom.stable_under_composition RingHom.StableUnderComposition

variable {P}

theorem StableUnderComposition.respectsIso (hP : RingHom.StableUnderComposition @P)
    (hP' : ∀ {R S : Type _} [CommRing R] [CommRing S] (e : R ≃+* S), P e.to_ring_hom) :
    RingHom.RespectsIso @P := by
  constructor
  · introv H
    skip
    apply hP
    exacts[H, hP' e]
  · introv H
    skip
    apply hP
    exacts[hP' e, H]
#align ring_hom.stable_under_composition.respects_iso RingHom.StableUnderComposition.respectsIso

end StableUnderComposition

section StableUnderBaseChange

/-- A morphism property `P` is `stable_under_base_change` if `P(S →+* A)` implies
`P(B →+* A ⊗[S] B)`. -/
def StableUnderBaseChange : Prop :=
  ∀ (R S R' S') [CommRing R] [CommRing S] [CommRing R'] [CommRing S'],
    ∀ [Algebra R S] [Algebra R R'] [Algebra R S'] [Algebra S S'] [Algebra R' S'],
      ∀ [IsScalarTower R S S'] [IsScalarTower R R' S'],
        ∀ [Algebra.IsPushout R S R' S'], P (algebraMap R S) → P (algebraMap R' S')
#align ring_hom.stable_under_base_change RingHom.StableUnderBaseChange

theorem StableUnderBaseChange.mk (h₁ : RespectsIso @P)
    (h₂ :
      ∀ ⦃R S T⦄ [CommRing R] [CommRing S] [CommRing T],
        ∀ [Algebra R S] [Algebra R T],
          P (algebraMap R T) →
            P (algebra.tensor_product.include_left.to_ring_hom : S →+* TensorProduct R S T)) :
    StableUnderBaseChange @P := by
  introv R h H
  skip
  let e := h.symm.1.Equiv
  let f' :=
    Algebra.TensorProduct.productMap (IsScalarTower.toAlgHom R R' S')
      (IsScalarTower.toAlgHom R S S')
  have : ∀ x, e x = f' x := by
    intro x
    change e.to_linear_map.restrict_scalars R x = f'.to_linear_map x
    congr 1
    apply TensorProduct.ext'
    intro x y
    simp [IsBaseChange.equiv_tmul, Algebra.smul_def]
  convert h₁.1 _ _ (h₂ H : P (_ : R' →+* _))
  swap
  · refine' { e with map_mul' := fun x y => _ }
    change e (x * y) = e x * e y
    simp_rw [this]
    exact map_mul f' _ _
  · ext
    change _ = e (x ⊗ₜ[R] 1)
    dsimp only [e]
    rw [h.symm.1.equiv_tmul, Algebra.smul_def, AlgHom.toLinearMap_apply, map_one, mul_one]
#align ring_hom.stable_under_base_change.mk RingHom.StableUnderBaseChange.mk

omit P

attribute [local instance] Algebra.TensorProduct.rightAlgebra

theorem StableUnderBaseChange.pushout_inl (hP : RingHom.StableUnderBaseChange @P)
    (hP' : RingHom.RespectsIso @P) {R S T : CommRingCat} (f : R ⟶ S) (g : R ⟶ T) (H : P g) :
    P (pushout.inl : S ⟶ pushout f g) :=
  by
  rw [←
    show _ = pushout.inl from
      colimit.iso_colimit_cocone_ι_inv ⟨_, CommRingCat.pushoutCoconeIsColimit f g⟩
        walking_span.left,
    hP'.cancel_right_is_iso]
  letI := f.to_algebra
  letI := g.to_algebra
  dsimp only [CommRingCat.pushoutCocone_inl, pushout_cocone.ι_app_left]
  apply hP R T S (TensorProduct R S T)
  exact H
#align ring_hom.stable_under_base_change.pushout_inl RingHom.StableUnderBaseChange.pushout_inl

end StableUnderBaseChange

end RingHom


import Lean.Elab.Tactic
import MathlibTactics
import Mathlib.Data.Set.Basic
import Mathlib.Data.Set.Lattice
import Mathlib.Data.Rel
import Mathlib.Data.Nat.Basic
import Mathlib.Data.Int.Basic
import Mathlib.Data.Rat.Basic
import Mathlib.Data.Real.Basic
import Mathlib.Data.ZMod.Defs

def Iff.ltr {p q : Prop} (h : p ↔ q) := h.mp
def Iff.rtl {p q : Prop} (h : p ↔ q) := h.mpr

/-To allow use of "termination_hint" in recursive definitions.  Don't use?
syntax withPosition("termination_hint : " term " := " term Lean.Parser.semicolonOrLinebreak) term : term

macro_rules
  | `(termination_hint : $t := $p; $b) => `(have : $t := $p; $b)
-/

--New set theory notation.
--Lower priority than all other set theory notation
macro (priority := low-1) "{ " pat:term " : " t:term " | " p:term " }" : term =>
  `({ x : $t | match x with | $pat => $p })

macro (priority := low-1) "{ " pat:term " | " p:term " }" : term =>
  `({ x | match x with | $pat => $p })

@[app_unexpander setOf]
def setOf.unexpander : Lean.PrettyPrinter.Unexpander
  | `($_ fun $x:ident => match $y:ident with | $pat => $p) =>
      if x == y then
        `({ $pat:term | $p:term })
      else
        throw ()  --Or could use `({ $x:ident | match $y:ident with | $pat => $p})
  | `($_ fun ($x:ident : $ty:term) => match $y:ident with | $pat => $p) =>
      if x == y then
        `({ $pat:term : $ty:term | $p:term })
      else
        throw ()
  -- Next line needed because of bug in Mathlib/Init/Set.lean
  | `($_ fun ($x:ident : $ty:term) => $p) => `({ $x:ident : $ty:term | $p })
  | _ => throw ()

--Make sure Lean understands {x} and ∅ as Sets, not Finsets
attribute [default_instance] Set.instSingletonSet
attribute [default_instance] Set.instEmptyCollectionSet

/- No longer needed
@[app_unexpander Function.comp] def unexpandFunctionComp : Lean.PrettyPrinter.Unexpander
  | `($(_) $f:term $g:term $x:term) => `(($f ∘ $g) $x)
  | _ => throw ()
-/

-- Set theory notation that should be in library.  Will it be added eventually?
-- Copying similar in:  Mathlib/Init/Set.lean, lean4/Init/Notation.lean, std4/Std/Classes/SetNotation.lean
notation:50 a:50 " ⊈ " b:50 => ¬ (a ⊆ b)

--Note:  Mathlib.Order.SymmDiff.lean defines this with ∆ (\increment) instead of △ (\bigtriangleup).
--Switch to that??  But display of symmDiff seems to use △.
infixl:100 " △ " => symmDiff

namespace HTPI
--Some theorems not in library
theorem not_not_and_distrib {p q : Prop} : ¬(¬ p ∧ q) ↔ (p ∨ ¬ q) := by
  rw [not_and_or, Classical.not_not]

theorem not_and_not_distrib {p q : Prop} : ¬(p ∧ ¬ q) ↔ (¬ p ∨ q) := by
  rw [not_and_or, Classical.not_not]

theorem not_not_or_distrib {p q : Prop} : ¬(¬ p ∨ q) ↔ (p ∧ ¬ q) := by
  rw [not_or, Classical.not_not]

theorem not_or_not_distrib {p q : Prop} : ¬(p ∨ ¬ q) ↔ (¬ p ∧ q) := by
  rw [not_or, Classical.not_not]

theorem not_imp_not_iff_and {p q : Prop} : ¬ (p → ¬ q) ↔ p ∧ q := by
  rw [not_imp, Classical.not_not]

theorem not_imp_iff_not_and {p q : Prop} : ¬ (q → p) ↔ ¬ p ∧ q := by
  rw [not_imp]
  exact And.comm

theorem not_not_iff {p q : Prop} : ¬(¬p ↔ q) ↔ (p ↔ q) := by
  rw [not_iff, Classical.not_not]

def Pred (t : Type u) : Type u := t → Prop
--def Rel (s t : Type u) : Type u := s → t → Prop   --Defined in Mathlib.Data.Rel
def BinRel (t : Type u) : Type u := Rel t t

--Definitions of tactics
section tactic_defs
open Lean Elab Tactic Expr MVarId

--Syntax for arguments to tactics
syntax oneLoc := " at " ident
syntax colonTerm := " : " term
syntax withId := " with " ident
syntax with2Ids := " with " ident (", " ident)?
syntax idOrTerm := ident <|> ("(" term ")")
syntax idOrTerm?Type := ident <|> ("(" term (" : " term)? ")")

abbrev OneLoc := TSyntax ``oneLoc
abbrev ColonTerm := TSyntax ``colonTerm
abbrev WithId := TSyntax ``withId
abbrev With2Ids := TSyntax ``with2Ids
abbrev IdOrTerm := TSyntax ``idOrTerm
abbrev IdOrTerm?Type := TSyntax ``idOrTerm?Type

--Get formula from identifier
def formFromIdent (h : Syntax) : TacticM Expr := do
  instantiateMVars (← Meta.getLocalDeclFromUserName h.getId).type

--Get formula from optional location.  Note both formFromIdent and getMainTarget call instantiateMVars
def formFromLoc (l : Option OneLoc) : TacticM Expr := do
  match l with
    | some h => formFromIdent h.raw[1]
    | none => getMainTarget

--For debugging:
def myTrace (msg : String) : TacticM Unit := do
  let m := Syntax.mkStrLit msg
  evalTactic (← `(tactic| trace $m))

partial def SyntaxToString (s : Syntax) : String :=
match s with
  | .missing => "(missing)"
  | .node _ k as => "(node " ++ toString k ++ (SyntaxListToString as.data) ++ ")"
  | .atom _ v => "(atom " ++ toString v ++ ")"
  | .ident _ rv v _ => "(ident " ++ (toString rv) ++ " " ++ (toString v) ++ ")"
where SyntaxListToString (ss : List Syntax) : String :=
  match ss with
    | (s :: rest) => " " ++ (SyntaxToString s) ++ (SyntaxListToString rest)
    | [] => ""

def traceThisSyntax (s : Syntax) : TacticM Unit := myTrace (SyntaxToString s)

def binderString (bi : BinderInfo) : String :=
  match bi with
    | .default => "default"
    | _ => "not default"

def ExprToString (e : Expr) : String :=
match e with
  | .bvar n => "(bvar " ++ (toString n) ++ ")" -- bound variables
  | .fvar f => "(fvar " ++ (toString f.name) ++ ")"  -- free variables
  | .mvar m => "(mvar " ++ (toString m.name) ++ ")"   -- meta variables
  | .sort l => "(sort " ++ (toString l) ++ ")"   -- Sort
  | .const n ls => "(const " ++ (toString n) ++ " " ++ (toString ls) ++ ")"   -- constants
  | .app a b => "(app " ++ (ExprToString a) ++ " " ++ (ExprToString b) ++ ")" -- application
  | .lam n t b bi => "(lam " ++ (toString n) ++ " " ++ (ExprToString t) ++ " " ++ (ExprToString b) ++ " " ++ (binderString bi) ++ ")"    -- lambda abstraction
  | .forallE n t b bi => "(forallE " ++ (toString n) ++ " " ++ (ExprToString t) ++ " " ++ (ExprToString b) ++ " " ++ (binderString bi) ++ ")"  -- (dependent) arrow
  | .letE n t v b _ => "(let " ++ (toString n) ++ " " ++ (ExprToString t) ++ " "
        ++ (ExprToString v) ++ " " ++ (ExprToString b) ++ ")" -- let expressions
  | .lit _ => "(lit)"  -- literals
  | .mdata m e => "(mdata " ++ (toString m) ++ " " ++ (ExprToString e) ++ ")"   -- metadata
  | .proj t i c => "(proj " ++ (toString t) ++ " " ++ (toString i) ++ " " ++ (ExprToString c) ++ ")" -- projection

def traceThisExpr (e : Expr) : TacticM Unit := myTrace (ExprToString e)

elab "traceExpr" t:(colonTerm)? l:(oneLoc)? : tactic =>
  withMainContext do
    match t with
      | some tstx => do
        traceThisSyntax tstx.raw[1]
        let e ← elabTerm tstx.raw[1] none
        traceThisExpr e
      | none =>
        let e ← formFromLoc l
        traceThisExpr e

-- Get head and arg list
def getHeadData (e : Expr) : Expr × List Expr :=
  match e with
    | app f a =>
      let (h, as) := getHeadData f
      (h, a :: as)
    | mdata _ e' => getHeadData e'
    | _ => (e, [])

-- Recover expression from head and arg list
def mkAppList (h : Expr) (args : List Expr) : Expr :=
  match args with
    | a :: rest => mkApp (mkAppList h rest) a
    | [] => h

--Determine if e is a proposition, in current local context
def exprIsProp (e : Expr) : TacticM Bool :=
  return (← Meta.inferType e).isProp

--Logical form of a proposition.
inductive PropForm where
  | not     : Expr → PropForm
  | and     : Expr → Expr → PropForm
  | or      : Expr → Expr → PropForm
  | implies : Expr → Expr → PropForm
  | iff     : Expr → Expr → PropForm
  | all     : Name → Expr → Expr → BinderInfo → PropForm
  | ex      : Level → Name → Expr → Expr → BinderInfo → PropForm
  | exun    : Level → Name → Expr → Expr → BinderInfo → PropForm
  | f       : PropForm
  | t       : PropForm
  | none    : PropForm

/- Try to unfold definition, and if result is negative, return PropForm.not
Note:  Uses constants but not fvars with let declarations.  Also, only unfolds once.
This might be best--only detect expressions immediately recognized as negative by def.
-/
def findNegPropAll (e : Expr) : TacticM PropForm := do
  match (← Meta.unfoldDefinition? (consumeMData e)) with
    | some e' =>
      match getHeadData e' with
        | (const ``Not _, [l]) => return PropForm.not l
        | _ => return PropForm.none
    | none => return PropForm.none

--Apply a function to data for an existential.  Existentials usually apply to a
--lambda expression, but allow for others
def applyToExData {α : Type} (f : Level → Name → Expr → Expr → BinderInfo → α)
  (lev : Level) (l r : Expr) : α :=
  let r' := consumeMData r
  match r' with
    | lam v t b bi => f lev v t b bi
    | _ => f lev `x l (mkApp r' (bvar 0)) BinderInfo.default

-- Get logical form of a proposition.
-- Recognizes negative predicates by one of two methods from above.
def getPropForm (e : Expr) : TacticM PropForm := do
  if !(← exprIsProp e) then return PropForm.none
  let (h, args) := getHeadData e
  match h with
    | const c levs =>
      match (c, levs, args) with
        | (``False, _, _) => return PropForm.f
        | (``True, _, _) => return PropForm.t
        | (``Not, _, [l]) => return PropForm.not l
        | (``And, _, [r, l]) => return PropForm.and l r
        | (``Or, _, [r, l]) => return PropForm.or l r
        | (``Iff, _, [r, l]) => return PropForm.iff l r
        | (``Exists, [lev], [r, l]) => return applyToExData PropForm.ex lev l r
        | (``ExistsUnique, [lev], [r, l]) => return applyToExData PropForm.exun lev l r
        | _ => findNegPropAll e     --or:  return findNegPropList c levs args
    | forallE v t b bi =>
      if (b.hasLooseBVars || !(← exprIsProp t)) then
        return PropForm.all v t b bi
      else
        return PropForm.implies t b
    | _ => return PropForm.none

--mkNot, mkAnd, mkOr, and mkForall are already defined.  Also mkArrow and Meta.mkEq
def mkIff (l r : Expr) : Expr :=
  mkApp2 (mkConst ``Iff) l r

--Need to supply level--I always have it, so easiest to use it.
def mkExists (l : Level) (x : Name) (bi : BinderInfo) (t b : Expr) : Expr :=
  mkApp2 (mkConst ``Exists [l]) t (mkLambda x bi t b)

def myFail {α} (tac : Name) (msg : String) : TacticM α := do
  Meta.throwTacticEx tac (← getMainGoal) msg

/- Functions for unfolding head -/

--Unfold ExistsUnique; default version doesn't do a good job of naming variables
def unfoldExUn (lev : Level) (v : Name) (t b : Expr) (_ : BinderInfo) : Expr :=
  let v1 := Name.appendIndexAfter v 1
  let eqn := mkApp3 (mkConst ``Eq [lev]) t (bvar 1) (bvar 2)
  let body := mkAnd b (mkForall v1 BinderInfo.default t (mkForall `x BinderInfo.default b eqn))
  mkExists lev v BinderInfo.default t body

/- Unfold head in current context--must set local context before call.
If first = true, then unfold ExistsUnique using my def; else don't unfold it.
Also, if first = true, then unfold ite and dite; otherwise don't.
If rep = true, unfold repeatedly.
Let whnfCore handle everything except unfolding of constants.
Do all normalization up to first unfolding of a definition; on next call do that unfolding
-/
partial def unfoldHead (e : Expr) (tac : Name) (first rep : Bool) : TacticM Expr := do
  let e1 := consumeMData e
  let (h, args) := getHeadData e1
  -- First let e2 = result of one unfolding, or handle negation, or fail
  let e2 ← match h with
    | const c levs =>
      match (c, levs, args) with
        | (``Not, _, [l]) => return mkNot (← unfoldHead l tac first rep) --Return from function call, bypassing e2
        | (``ExistsUnique, [lev], [r, l]) =>
          if first then
            pure (applyToExData unfoldExUn lev l r)
          else
            myFail tac "failed to unfold definition"
        | _ =>
          if !first && ((c == ``ite) || (c == ``dite)) then
            myFail tac "failed to unfold definition"
          let edo ← Meta.unfoldDefinition? e1
          match edo with
            | some ed => pure ed
            | none => myFail tac "failed to unfold definition"
    | _ =>
      let ew ← Meta.whnfCore e1
      if ew == e1 then
        myFail tac "failed to unfold definition"
      else
        pure ew
  if rep then
    let e3 ← try
        unfoldHead e2 tac false true
      catch _ =>
        pure e2
    match e1 with
      | (app (app (app (app (app (const ``Membership.mem _) _) (app (const ``Set _) _))
        (app (const ``Set.instMembershipSet _) _)) x) y) =>
        if (e3 == app y x) then
          myFail tac "failed to unfold definition"  --Don't unfold `x ∈ y` to `y x`
        else
          return e3
      | (app (app (const ``setOf _) _) f) =>
        if (e3 == f) then
          myFail tac "failed to unfold definition"  --Don't unfold `{ x | p }` to `fun x => p`
        else
          return e3
      | _ => return e3
  else
    return e2

-- whnf, but don't unfold ``ExistsUnique
def whnfNotExUn (e : Expr) : TacticM Expr :=
  Meta.whnfHeadPred e (fun x => return !(x.isAppOf ``ExistsUnique))

-- w = 0 : no whnf, w = 1 : whnfNotExun, w = 2 : full whnf
def exprFromPf (t : Term) (w : Nat) : TacticM Expr := do
  let p ← elabTerm t none
  let e ← instantiateMVars (← Meta.inferType p)
  match w with
    | 0 => return e
    | 1 => whnfNotExUn e
    | _ => Meta.whnf e

--Add new hypothesis with name n, asserting form, proven by pfstx.
def doHave (n : Name) (form : Expr) (pfstx : Syntax) : TacticM Unit := do
  let goal ← getMainGoal
  let oldtar ← getType goal
  let pf ← elabTermEnsuringType pfstx form
  let mvarIdNew ← assert goal n form pf
  let (_, newGoal) ← intro1P mvarIdNew    --blank is FVarId of new hyp.
  let newtar ← getType newGoal
  if (oldtar != newtar) && (← Meta.isExprDefEq oldtar newtar) then
    --intro1P sometimes changes target to something def. equal.  Put it back to original
    replaceMainGoal [← newGoal.replaceTargetDefEq oldtar]
  else
    replaceMainGoal [newGoal]

--Add n : (Type) := val to context.
/- **Not used
def doLet (n : Name) (val : Expr) : TacticM Unit := do
  let goal ← getMainGoal
  withContext goal do
    let valType ← Meta.inferType val
    let mvarIdNew ← define goal n valType val
    let (_, newGoal) ← intro1P mvarIdNew
    replaceMainGoal [newGoal]
-/

--Set goal to be form; pfstx is proof that it suffices.
def doSuffices (form : Expr) (pfstx : Syntax) : TacticM Unit := do
  let goal ← getMainGoal
  let tag ← getTag goal
  let target ← getType goal
  let imp ← mkArrow form target
  let pf ← elabTermEnsuringType pfstx imp
  let newTarget ← Meta.mkFreshExprSyntheticOpaqueMVar form tag
  assign goal (mkApp pf newTarget)
  replaceMainGoal [newTarget.mvarId!]

--Do rewrite; symm says whether to reverse direction, rule is Term for rule, l is optional location
def doRewrite (symm : Bool) (rule : Term) (l : Option OneLoc) : TacticM Unit := do
  match l with
    | some id =>
        let idstx : Ident := ⟨id.raw[1]⟩
        if symm then
          evalTactic (← `(tactic| rewrite [← $rule:term] at $idstx:ident))
        else
          evalTactic (← `(tactic| rewrite [$rule:term] at $idstx:ident))
    | none =>
        if symm then
          evalTactic (← `(tactic| rewrite [← $rule:term]))
        else
          evalTactic (← `(tactic| rewrite [$rule:term]))

--Swap first two goals, if there are at least two
def doSwap : TacticM Unit := do
  let g ← getGoals
  let ng := match g with
    | g1 :: (g2 :: rest) => g2 :: (g1 :: rest)
    | _ => g
  setGoals ng

/- Functions for all equivalence tactics: contrapos, demorgan, quant_neg, conditional, double_neg -/
def ruleType := Name × Expr

def equivMakeRule (f : Expr)
  (ruleFunc : Expr → TacticM ruleType) : TacticM ruleType := do
  let (rule, res) ← ruleFunc f
  return (rule, mkIff f res)

def equivRuleFromForm (p : Expr)
  (ruleFunc : Expr → TacticM ruleType) : TacticM ruleType := do
    try
      equivMakeRule p ruleFunc
    catch ex =>
      match (← getPropForm p) with
        | PropForm.iff l r =>
          try
            equivMakeRule l ruleFunc
          catch _ =>
            equivMakeRule r ruleFunc
        | _ => throw ex

def equivRule (f : Option ColonTerm) (l : Option OneLoc)
  (ruleFunc : Expr → TacticM ruleType) : TacticM ruleType := do
  match f with
    | some fs => equivMakeRule (← elabTerm fs.raw[1] none) ruleFunc
    | none => equivRuleFromForm (← formFromLoc l) ruleFunc

def doReplace (tac : Name) (l : Option OneLoc) (res : Expr) (pf : Syntax) : TacticM Unit := do
    let hn ← mkFreshUserName `h
    doHave hn res pf
    let h := mkIdent hn
    let ht : Term := ⟨h.raw⟩
    try
      doRewrite false ht l
      evalTactic (← `(tactic| clear $h:ident)) -- Could also do: (try apply Iff.refl); try assumption
    catch _ =>
      evalTactic (← `(tactic| clear $h:ident))
      myFail tac  "target expression not found"

def doEquivTac (f : Option ColonTerm) (l : Option OneLoc)
  (tac : Name) (ruleFunc : Expr → TacticM ruleType) : TacticM Unit :=
  withMainContext do
    let (rule, res) ← equivRule f l ruleFunc
    doReplace tac l res (mkIdent rule)

/- contrapos tactic -/
def cpRule (form : Expr) : TacticM ruleType := do
  match (← getPropForm form) with
    | PropForm.implies l r => match (← getPropForm l) with
      | PropForm.not nl => match (← getPropForm r) with
        | PropForm.not nr =>
          return (`not_imp_not, (← mkArrow nr nl))
        | _ =>
          return (`not_imp_comm, (← mkArrow (mkNot r) nl))
      | _ => match (← getPropForm r) with
        | PropForm.not nr =>
          return (`imp_not_comm, (← mkArrow nr (mkNot l)))
        | _ =>
          return (`not_imp_not.symm, (← mkArrow (mkNot r) (mkNot l)))
    | _ => myFail `contrapos "contrapositive law doesn't apply"

elab "contrapos" f:(colonTerm)? l:(oneLoc)? : tactic => doEquivTac f l `contrapos cpRule

/- demorgan tactic -/
def dmRuleFromInfoNoNeg (l r : Expr) (conn : Expr → Expr → Expr) (rs : Array Name) : TacticM ruleType := do
  match (← getPropForm l) with
  | PropForm.not nl =>
      match (← getPropForm r) with
        | PropForm.not nr => return (rs[0]!, conn nl nr)
        | _ => return (rs[1]!, conn nl (mkNot r))
  | _ =>
      match (← getPropForm r) with
        | PropForm.not nr => return (rs[2]!, conn (mkNot l) nr)
        | _ => return (rs[3]!, conn (mkNot l) (mkNot r))

def dmRuleFromInfo (l r : Expr) (conn : Expr → Expr → Expr) (n : Bool) (rs : Array Name) : TacticM ruleType := do
  let p ← dmRuleFromInfoNoNeg l r conn rs
  if n then
    return (p.1, mkNot p.2)
  else
    return p

def dmRule (form : Expr) : TacticM ruleType := do
  match (← getPropForm form) with
    | PropForm.not a => match (← getPropForm a) with
      | PropForm.and l r =>
        dmRuleFromInfo l r mkOr false
          #[`or_iff_not_and_not.symm, `not_not_and_distrib, `not_and_not_distrib, `not_and_or]
      | PropForm.or l r =>
        dmRuleFromInfo l r mkAnd false
          #[`and_iff_not_or_not.symm, `not_not_or_distrib, `not_or_not_distrib, `not_or]
      | _ => myFail `demorgan "De Morgan's laws don't apply"
    | PropForm.and l r =>
        dmRuleFromInfo l r mkOr true
          #[`not_or.symm, `not_or_not_distrib.symm, `not_not_or_distrib.symm, `and_iff_not_or_not]
    | PropForm.or l r =>
      dmRuleFromInfo l r mkAnd true
        #[`not_and_or.symm, `not_and_not_distrib.symm, `not_not_and_distrib.symm, `or_iff_not_and_not]
    | _ => myFail `demorgan "De Morgan's laws don't apply"

elab "demorgan" f:(colonTerm)? l:(oneLoc)? : tactic => doEquivTac f l `demorgan dmRule

/- quant_neg tactic -/
def qnRuleFromInfoNoNeg (v : Name) (t b : Expr) (qf : Name → BinderInfo → Expr → Expr → Expr)
  (rs : Name × Name) : TacticM ruleType := do
  let f := mkLambda `x BinderInfo.default t b
  let negres ← Meta.lambdaTelescope f fun fvs e => do
    match (← getPropForm e) with
      | PropForm.not ne => return some (← Meta.mkLambdaFVars fvs ne)
      | _ => return none
  match negres with
    | some ne => match ne with
      | lam _ _ nb _ => return (rs.1, qf v BinderInfo.default t nb)
      | _ => return (rs.2, qf v BinderInfo.default t (mkNot b))
    | none => return (rs.2, qf v BinderInfo.default t (mkNot b))

def qnRuleFromInfo (v : Name) (t b : Expr) (qf : Name → BinderInfo → Expr → Expr → Expr)
  (n : Bool) (rs : Name × Name) : TacticM ruleType := do
  let p ← qnRuleFromInfoNoNeg v t b qf rs
  if n then
    return (p.1, mkNot p.2)
  else
    return p

def qnRule (form : Expr) : TacticM ruleType := do
  match (← getPropForm form) with
    | PropForm.not p => match (← getPropForm p) with
      | PropForm.all v t b _ =>
        qnRuleFromInfo v t b (mkExists (← Meta.getLevel t)) false
          (`not_forall_not, `not_forall)
      | PropForm.ex _ v t b _ =>
        qnRuleFromInfo v t b mkForall false
          (`not_exists_not, `not_exists)
      | _ => myFail `quant_neg "quantifier negation laws don't apply"
    | PropForm.all v t b _ =>
      qnRuleFromInfo v t b (mkExists (← Meta.getLevel t)) true
        (`not_exists.symm, `not_exists_not.symm)
    | PropForm.ex _ v t b _ =>
      qnRuleFromInfo v t b mkForall true
        (`not_forall.symm, `not_forall_not.symm)
    | _ => myFail `quant_neg "quantifier negation laws don't apply"

elab "quant_neg" f:(colonTerm)? l:(oneLoc)? : tactic => doEquivTac f l `quant_neg qnRule

/- conditional tactic -/
def cdlRule (form : Expr) : TacticM ruleType := do
  match (← getPropForm form) with
    | PropForm.not p => match (← getPropForm p) with
      | PropForm.implies l r => match (← getPropForm r) with
        | PropForm.not nr => return (`not_imp_not_iff_and, mkAnd l nr)
        | _ => return (`not_imp, mkAnd l (mkNot r))
      | _ => myFail `conditional "conditional laws don't apply"
    | PropForm.implies l r => match (← getPropForm l) with
      | PropForm.not nl => return (`or_iff_not_imp_left.symm, mkOr nl r)
      | _ => return (`imp_iff_not_or, mkOr (mkNot l) r)
    | PropForm.and l r => match (← getPropForm r) with
      | PropForm.not nr => return (`not_imp.symm, mkNot (← mkArrow l nr))
      | _ => match (← getPropForm l) with
        | PropForm.not nl => return (`not_imp_iff_not_and.symm, mkNot (← mkArrow r nl))
        | _ => return (`not_imp_not_iff_and.symm, mkNot (← mkArrow l (mkNot r)))
    | PropForm.or l r => match (← getPropForm l) with
      | PropForm.not nl => return (`imp_iff_not_or.symm, (← mkArrow nl r))
      | _ => match (← getPropForm r) with
        | PropForm.not nr => return (`imp_iff_or_not.symm, (← mkArrow nr l))
        | _ => return (`or_iff_not_imp_left, (← mkArrow (mkNot l) r))
    | _ => myFail `conditional "conditional laws don't apply"

elab "conditional" f:(colonTerm)? l:(oneLoc)? : tactic => doEquivTac f l `conditional cdlRule

/- double_neg tactic -/
def dnRule (form : Expr) : TacticM ruleType := do
  match (← getPropForm form) with
    | PropForm.not p1 => match (← getPropForm p1) with
      | PropForm.not p2 => return (`Classical.not_not, p2)
      | _ => myFail `double_neg "double negation law doesn't apply"
    | _ => myFail `double_neg "double negation law doesn't apply"

elab "double_neg" f:(colonTerm)? l:(oneLoc)? : tactic => doEquivTac f l `double_neg dnRule

/- bicond_neg tactic
Note converts P ↔ Q to ¬(¬P ↔ Q).
So to convert only one side of ↔, must use : [term to convert] -/
def binegRule (form : Expr) : TacticM ruleType := do
  match (← getPropForm form) with
    | PropForm.not p => match (← getPropForm p) with
      | PropForm.iff l r => match (← getPropForm l) with
        | PropForm.not nl => return (`not_not_iff, mkIff nl r)
        | _ => return (`not_iff, mkIff (mkNot l) r)
      | _ => myFail `bicond_neg "biconditional negation law doesn't apply"
    | PropForm.iff l r => match (← getPropForm l) with
      | PropForm.not nl => return (`not_iff.symm, mkNot (mkIff nl r))
      | _ => return (`not_not_iff.symm, mkNot (mkIff (mkNot l) r))
    | _ => myFail `bicond_neg "biconditional negation law doesn't apply"

elab "bicond_neg" f:(colonTerm)? l:(oneLoc)? : tactic => doEquivTac f l `bicond_neg binegRule

-- Give error if any ident in i is already in use.  Is this right thing to do in all cases?
partial def checkIdUsed (tac : Name) (i : Syntax) : TacticM Unit := do
  match i with
    | .missing => return ()
    | .node _ _ as => for a in as do checkIdUsed tac a
    | .atom _ _ => return ()
    | .ident _ _ v _ =>
        if (← getLCtx).usesUserName v then
          myFail tac ("identifier " ++ (toString v) ++ " already in use")
        else
          return ()

-- Get label from "with" clause, or default label.  Used by several tactics
def getLabel (tac : Name) (w : Option WithId) (dflt : Ident := mkIdent `this) : TacticM Ident := do
  match w with
    | some h =>
      let i := h.raw[1]
      checkIdUsed tac i
      return ⟨i⟩
    | none => return dflt

def isLocalVar (s : Syntax) : TacticM Bool := do
  match s with
    | .ident _ _ v _ => return (← getLCtx).usesUserName v
    | _ => return False

/- or_left and or_right tactics -/
def negData (e : Expr) : TacticM (Expr × Bool) := do
  match (← getPropForm e) with
    | PropForm.not ne => return (ne, true)
    | _ => return (e, false)

def orstrat (tac : Name) (w : Option WithId) (left : Bool) : TacticM Unit :=
  withMainContext do
    let label ← getLabel tac w
    let d ← getMainDecl
    let t ← Meta.whnf (← instantiateMVars d.type)
    match (← getPropForm t) with
      | PropForm.or l r => do
          let (form, neg) ← negData (if left then r else l)
          let goalName := d.userName
          let emn ← mkFreshUserName `h
          let emi := mkIdent emn
          doHave emn (mkOr form (mkNot form)) (← `(em _))
          evalTactic (← `(tactic|refine Or.elim $emi:ident ?_ ?_))
          if neg then doSwap
          let (rule1, rule2) :=
            if left then
              (mkIdent ``Or.inr, mkIdent ``Or.inl)
            else
              (mkIdent ``Or.inl, mkIdent ``Or.inr)
          evalTactic (← `(tactic| exact fun x => $rule1:ident x))
          evalTactic (← `(tactic| intro $label:ident; refine $rule2:ident ?_; clear $emi:ident))
          let newGoal ← getMainGoal
          setUserName newGoal goalName
      | _ => myFail tac "goal is not a disjunction"

elab "or_left" w:(withId)? : tactic => orstrat `or_left w true
elab "or_right" w:(withId)? : tactic => orstrat `or_right w false

/- disj_syll tactic -/
def matchFirstNeg (e1 e2 : Expr) : TacticM Bool := do
  match (← getPropForm e1) with
    | PropForm.not ne1 => Meta.isExprDefEq ne1 e2
    | _ => return false

--1st coord:  does one match neg of other?  2nd coord:  does first match neg of second?
def matchNeg (e1 e2 : Expr) : TacticM (Bool × Bool) := do
  if (← matchFirstNeg e1 e2) then
    return (true, true)
  else
    return ((← matchFirstNeg e2 e1), false)

--1st coord:  Does neg contradict right side of disj?  (else left side)
--2nd coord:  Is disjunct negation of neg?  (else neg is negation of disj)
def DisjSyllData (disj neg : Expr) : TacticM (Bool × Bool) := do
  match (← getPropForm disj) with
    | PropForm.or l r =>
      let (isneg, disjneg) ← matchNeg l neg
      if isneg then
        return (false, disjneg)
      else
        let (isneg, disjneg) ← matchNeg r neg
        if isneg then
          return (true, disjneg)
        else
          myFail `disj_syll "disjunctive syllogism rule doesn't apply"
    | _ => myFail `disj_syll "disjunctive syllogism rule doesn't apply"

def parseIdOrTerm (it : IdOrTerm) : Term :=
  let s := it.raw[0]
  match s with
    | .ident .. => ⟨s⟩
    | _ => ⟨s[1]⟩

elab "disj_syll" dIOrT:idOrTerm nIOrT:idOrTerm w:(withId)? : tactic =>
  withMainContext do
    let d := parseIdOrTerm dIOrT
    let n := parseIdOrTerm nIOrT
    let disj ← exprFromPf d 2
    let neg ← exprFromPf n 0
    let (dId, deflabel) :=
      if (← isLocalVar d.raw) then
        (true, ⟨d.raw⟩)
      else
        (false, mkIdent `this)
    let label ← getLabel `disj_syll w deflabel
    let (conright, disjneg) ← DisjSyllData disj neg
    let goalName := (← getMainDecl).userName
    evalTactic (← `(tactic| refine Or.elim $d ?_ ?_))
    if conright then doSwap
    if disjneg then
      evalTactic (← `(tactic| exact fun x => absurd $n x))
    else
      evalTactic (← `(tactic| exact fun x => absurd x $n))
    if (dId && (w == none)) then evalTactic (← `(tactic| clear $label:ident))
    evalTactic (← `(tactic| intro $label:ident))
    let newGoal ← getMainGoal
    setUserName newGoal goalName

/- contradict tactic -/
def ensureContra (w : Option WithId) : TacticM Unit :=
  withMainContext do
    let label ← getLabel `contradict w
    let t ← getMainTarget
    match (← getPropForm t) with
      | PropForm.f => return ()
      | _ => evalTactic (← `(tactic| by_contra $label:ident))

elab "contradict" h:term w:(withId)? : tactic => do
  ensureContra w
  withMainContext do
    --let tocon ← formFromIdent h.raw
    let tocon ← exprFromPf h 0
    match (← getPropForm tocon) with
      | PropForm.not p =>
        doSuffices p (← `(fun x => $h x))
      | _ =>
        doSuffices (mkNot tocon) (← `(fun x => x $h))

/- define, def_step, and whnf tactics
Probably want to use define, but include whnf to be able to compare
-/
def unfoldOrWhnf (tac: Name) (e : Expr) (w rep : Bool) : TacticM Expr := do
  if w then
    match (← getPropForm e) with
      | PropForm.exun lev v t b bi => return unfoldExUn lev v t b bi
      | _ => whnfNotExUn e
  else
    unfoldHead e tac true rep

def doDefine (tac : Name) (f : Option ColonTerm) (l : Option OneLoc) (w rep : Bool) : TacticM Unit :=
  withMainContext do
    let e ← match f with
      | some fs => elabTerm fs.raw[1] none
      | none => formFromLoc l
    let e' ← unfoldOrWhnf tac e w rep
    doReplace tac l (← Meta.mkEq e e') (← `(Eq.refl _))

elab "define" f:(colonTerm)? l:(oneLoc)? : tactic => doDefine `define f l false true
elab "whnf" f:(colonTerm)? l:(oneLoc)? : tactic => doDefine `whnf f l true true
elab "def_step" f:(colonTerm)? l:(oneLoc)? : tactic => doDefine `def_step f l false false

/- definition and definition! tactics -/
--Context set in doDefinition, which calls these functions
def getDefineFormLabel (f : Option ColonTerm) (l : Option OneLoc) : TacticM (Expr × Name) := do
  match f with
    | some t => return (← elabTerm t.raw[1] none, `this)
    | none => match l with
      | some h => do
        let hs := h.raw[1]
        return (← formFromIdent hs, Name.mkStr hs.getId "def")
      | none => return (← getMainTarget, `goal.def)

-- use Iff for propositions, = for other types
def mkRel (e1 e2 : Expr) (prop : Bool) : TacticM Expr :=
  if prop then
    return mkIff e1 e2
  else
    Meta.mkEq e1 e2

-- repeatedly assert definition equivalences or equations, numbering steps
partial def doDefinitionRep (label : Name) (e e1 : Expr) (prop : Bool) (rule : Ident) (firstNum : Nat) : TacticM Unit := do
  --let e' ← unfoldHead e1 `definition (firstNum == 1)
  let e' ← unfoldHead e1 `definition (firstNum == 1) false
  let res ← mkRel e e' prop
  doHave (Name.appendIndexAfter label firstNum) res (← `($rule _))
  try
    withMainContext (doDefinitionRep label e e' prop rule (firstNum + 1))  -- Context changes each time through
  catch _ =>
    return ()

def doDefinition (all : Bool) (f : Option ColonTerm) (l : Option OneLoc) (wid : Option WithId) : TacticM Unit :=
  withMainContext do
    let (e, deflabel) ← getDefineFormLabel f l
    let label ← getLabel `definition wid (mkIdent deflabel)
    let labeln := label.getId
    let (prop, rule) := if (← exprIsProp e) then
        (true, mkIdent ``Iff.refl)
      else
        (false, mkIdent ``Eq.refl)
    if all then
      doDefinitionRep labeln e e prop rule 1
    else
      --let e' ← unfoldHeadRep e `definition true
      let e' ← unfoldHead e `definition true true
      let res ← mkRel e e' prop
      doHave labeln res (← `($rule _))

elab "definition" f:(colonTerm) wid:(withId)? : tactic => doDefinition false (some f) none wid
elab "definition" l:(oneLoc)? wid:(withId)? : tactic => doDefinition false none l wid
elab "definition!" f:(colonTerm) wid:(withId)? : tactic => doDefinition true (some f) none wid
elab "definition!" l:(oneLoc)? wid:(withId)? : tactic => doDefinition true none l wid

def addToName (n : Name) (s : String) : Name :=
  Name.modifyBase n (fun x => Name.mkStr x s)

--Bool is whether or not to clear "or" given; Idents for two cases
def setUpCases (t : Term) (wids : Option With2Ids) : TacticM (Bool × Ident × Ident) := do
  match wids with
    | some ids =>
      let id1s := ids.raw[1]
      checkIdUsed `by_cases id1s
      let id1 : Ident := ⟨id1s⟩
      match ids.raw[2].getArgs[1]? with
        | some id2 =>
          checkIdUsed `by_cases id2
          return (false, id1, ⟨id2⟩)
        | none => return (false, id1, id1)
    | none =>
      if (← isLocalVar t.raw) then
        let tid : Ident := ⟨t.raw⟩
        return (true, tid, tid)
      else
        let thisId := mkIdent `this
        return (false, thisId, thisId)

def fixCase (clear : Bool) (label : Ident) (g : Name) (c : String) : TacticM Unit := do
  if clear then
    evalTactic (← `(tactic| clear $label))
  evalTactic (← `(tactic| intro $label:ident))
  setUserName (← getMainGoal) (addToName g c)
  doSwap

elab "by_cases" "on" t:term wids:(with2Ids)? : tactic =>
  withMainContext do
    let e ← exprFromPf t 2
    match (← getPropForm e) with
      | PropForm.or _ _ =>
        let (clear, label1, label2) ← setUpCases t wids
        let goalname :=  (← getMainDecl).userName
        evalTactic (← `(tactic| refine Or.elim $t ?_ ?_))
        fixCase clear label1 goalname "Case_1"
        fixCase clear label2 goalname "Case_2"
      | _ => myFail `by_cases "hypothesis is not a disjunction"

/- exists_unique tactic -/
def mkUn (lev: Level) (v : Name) (t b : Expr) : TacticM Expr := do
  let v1 := Name.appendIndexAfter v 1
  let v2 := Name.appendIndexAfter v 2
  let f1 := mkLambda v1 BinderInfo.default t b
  let f2 := mkLambda v2 BinderInfo.default t b
  Meta.lambdaTelescope f1 fun fv1 e1 =>
    Meta.lambdaTelescope f2 fun fv2 e2 => do
      let body ← mkArrow e1 (← mkArrow e2
        (mkApp3 (const ``Eq [lev]) t fv1[0]! fv2[0]!))
      Meta.mkForallFVars (fv1.push fv2[0]!) body

elab "exists_unique" : tactic => do
  let goal ← getMainGoal
  withContext goal do
    let d ← getDecl goal
    let goalname := d.userName
    let tar ← instantiateMVars d.type
    match (← getPropForm tar) with
      | PropForm.exun lev v t b _ =>
        let un ← mkUn lev v t b
        let ex := mkExists lev v BinderInfo.default t b
        let h ← mkFreshUserName `h
        let hid := mkIdent h
        let hex := (mkForall `a BinderInfo.default ex
          (mkForall `b BinderInfo.default un tar))
        doHave h hex (← `(exists_unique_of_exists_of_unique))
        evalTactic (← `(tactic| refine $hid ?_ ?_; clear $hid))
        setUserName (← getMainGoal) (addToName goalname "Existence")
        doSwap
        evalTactic (← `(tactic| clear $hid))
        setUserName (← getMainGoal) (addToName goalname "Uniqueness")
        doSwap
      | _ => myFail `exists_unique "goal is not a unique existence statement"

/- obtain tactic -/
def parseIdOrTerm?Type (tac : Name) (it : IdOrTerm?Type) : TacticM (Term × (Option Term)) := do
  let s := it.raw[0]
  let res := match s with
    | .ident .. => (⟨s⟩, none)
    | _ => match s[2].getArgs[1]? with
      | some t => (⟨s[1]⟩, some ⟨t⟩)
      | none => (⟨s[1]⟩, none)
  checkIdUsed tac res.1.raw
  return res

def doIntroOption (i : Term) (t : Option Term) : TacticM Unit := do
  match t with
    | some tt => --evalTactic (← `(tactic| intro ($i : $tt)))
      evalTactic (← `(tactic| intro h; match @h with | ($i : $tt) => ?_; try clear h))
    | none => evalTactic (← `(tactic| intro $i:term))

def doObtain (itw ith : IdOrTerm?Type) (tm : Term) : TacticM Unit :=
  withMainContext do
    --let e ← whnfNotExUn (← formFromIdent l.raw)
    let e ← exprFromPf tm 1
    match (← getPropForm e) with
      | PropForm.ex _ _ _ _ _ =>
        let (wi, wt) ← parseIdOrTerm?Type `obtain itw
        let (hi, ht) ← parseIdOrTerm?Type `obtain ith
        evalTactic (← `(tactic| refine Exists.elim $tm ?_))
        doIntroOption wi wt
        doIntroOption hi ht
      | _ => myFail `obtain "hypothesis is not an existence statement"

theorem exun_elim {α : Sort u} {p : α → Prop} {b : Prop}
    (h2 : ∃! x, p x) (h1 : ∀ x, p x → (∀ y z, p y → p z → y = z) → b) : b := by
      apply ExistsUnique.elim h2
      intro x h3 h4
      apply h1 x h3
      intro y z h5 h6
      have h7 := h4 y h5
      have h8 := h4 z h6
      rw [h7,h8]

def doObtainExUn (itw ith1 ith2 : IdOrTerm?Type) (tm : Term) : TacticM Unit :=
  withMainContext do
    let e ← exprFromPf tm 1
    match (← getPropForm e) with
      | PropForm.exun lev v t b _ =>
        let (wi, wt) ← parseIdOrTerm?Type `obtain itw
        let (h1i, h1t) ← parseIdOrTerm?Type `obtain ith1
        let (h2i, h2t) ← parseIdOrTerm?Type `obtain ith2
        let tar ← getMainTarget
        let un ← mkUn lev v t b
        let exun := mkForall v BinderInfo.default t (← mkArrow b (← mkArrow un tar))
        let h ← mkFreshUserName `h
        let hid := mkIdent h
        doHave h (← mkArrow exun tar) (← `(exun_elim $tm))
        evalTactic (← `(tactic| refine $hid ?_; clear $hid))
        doIntroOption wi wt
        doIntroOption h1i h1t
        doIntroOption h2i h2t
      | _ => myFail `obtain "hypothesis is not a unique existence statement"

--Make 1 assertion for existential, 2 for unique existential
elab "obtain" itw:idOrTerm?Type ith:idOrTerm?Type " from " t:term : tactic =>
  doObtain itw ith t
elab "obtain" itw:idOrTerm?Type ith1:idOrTerm?Type ith2:idOrTerm?Type " from " t:term : tactic =>
  doObtainExUn itw ith1 ith2 t

/- assume and fix tactics -/
def doAssume (w : Term) (t : Option Term) : TacticM Unit :=
  withMainContext do
    checkIdUsed `assume w
    match (← getPropForm (← Meta.whnf (← getMainTarget))) with
      | PropForm.implies _ _ => doIntroOption w t
      --| PropForm.not _ => doIntroOption w t  --Not necessary--whnf will have changed to implies
      | _ => myFail `assume "goal is not a conditional statement"

def doFix (w : Term) (t : Option Term) : TacticM Unit :=
  withMainContext do
    checkIdUsed `fix w
    match (← getPropForm (← Meta.whnf (← getMainTarget))) with
      | PropForm.all _ _ _ _ => doIntroOption w t
      | _ => myFail `fix "goal is not a universally quantified statement"

elab "assume" w:term : tactic => doAssume w none
elab "assume" w:term " : " t:term : tactic => doAssume w (some t)
elab "fix" w:term : tactic => doFix w none
elab "fix" w:term " : " t:term : tactic => doFix w (some t)

/- show tactic: allow either "from" or ":="  Probably best to stick to "from" -/
macro "show " c:term " from " p:term : tactic => `(tactic| {show $c; exact $p})
macro "show " c:term " := " p:term : tactic => `(tactic| {show $c; exact $p})

/- Not needed anymore--use Nat.strongRec' in Mathlib.Data.Nat.Basic.lean
theorem str_induc (P : Nat → Prop)
    (h : ∀ (n : Nat), (∀ n_1 < n, P n_1)→ P n) : ∀ (n : Nat), P n := by
  have h2 : ∀ (n : Nat), ∀ k < n, P k := by
    apply @Nat.rec
    fix k
    assume h2
    contradict h2
    exact Bool.of_decide_true rfl
    fix n
    assume ih
    fix k
    assume h2
    by_cases h3 : k = n
    rewrite [h3]
    exact h n ih
    have h4 : k < n := by
      have h5 : k ≤ n := Nat.le_of_succ_le_succ h2
      have h6 : k < n ∨ k = n := LE.le.lt_or_eq_dec h5
      disj_syll h6 h3
      exact h6
    exact ih k h4
  fix n
  have h3 := h2 (n+1) n
  apply h3
  exact Nat.lt_succ_self n
-/

theorem induc_from (P : Nat → Prop) (k : Nat) (h1 : P k) (h2 : (∀ n ≥ k, P n → P (n+1))) :
    ∀ n ≥ k, P n := by
  apply @Nat.rec
  assume h3
  have h4 : k = 0 := Nat.eq_zero_of_le_zero h3
  rewrite [h4] at h1
  exact h1
  fix n
  assume h3
  assume h4
  have h5 : k < n + 1 ∨ k = n + 1 := LE.le.lt_or_eq_dec h4
  by_cases on h5
  have h6 : k ≤ n := Nat.le_of_lt_succ h5
  have h7 := h3 h6
  exact h2 n h6 h7
  rewrite [h5] at h1
  exact h1

-- New version:  For ordinary induction, uses a different base if appropriate
def doInduc (strong : Bool) : TacticM Unit := do
  let goal ← getMainGoal
  withContext goal do
    let d ← getDecl goal
    let tag := d.userName
    let target ← instantiateMVars d.type
    match (← getPropForm target) with
      | PropForm.all v t b _ =>
        match t with
          | (.const ``Nat _) =>
            let m := Expr.lam v t b BinderInfo.default  --motive
            let vid := mkIdent v
            if strong then
              let v1 := Name.appendIndexAfter v 1
              let v1id := mkIdent v1
              let m1 := Expr.lam v1 t m BinderInfo.default
              let newtar ← Meta.lambdaTelescope m1 fun fvs Pv => do
                let fv1 := fvs[0]!
                let fv := fvs[1]!
                let Pv1 := replaceFVar Pv fv fv1
                let v1lv ← elabTerm (← `($v1id < $vid)) none
                let ih ← Meta.mkForallFVars #[fv1] (← mkArrow v1lv Pv1)
                Meta.mkForallFVars #[fv] (← mkArrow ih Pv)
              let newgoal ← Meta.mkFreshExprSyntheticOpaqueMVar newtar tag
              assign goal (mkApp2 (Expr.const ``Nat.strongRec' [Level.zero]) m newgoal)
              replaceMainGoal [newgoal.mvarId!]
            else
              let (base, ind, rule) ← Meta.lambdaTelescope m fun fvs Pv => do
                -- fvs.size should be 1.  Could it ever be larger?
                let fv := fvs[0]!
                let PFPv ← getPropForm Pv
                let (fr, Qv) := match PFPv with
                  | PropForm.implies l r => match (consumeMData l) with
                    | (app (app (app (app (const ``GE.ge _) (const ``Nat _)) _) a) min) =>
                      if (a == fv) && !(containsFVar min (fvarId! fv)) then
                        (some (min, l), r)
                      else
                        (none, Pv)
                    | (app (app (app (app (const ``LE.le _) (const ``Nat _)) _) min) a) =>
                      if (a == fv) && !(containsFVar min (fvarId! fv)) then
                        (some (min, l), r)
                      else
                        (none, Pv)
                    | _ => (none, Pv)
                  | _ => (none, Pv)
                let fvp1 ← elabTerm (← `($vid:ident + 1)) none
                let Qimp ← mkArrow Qv (replaceFVar Qv fv fvp1)
                match fr with
                  | some (min, cond) =>
                    let base := replaceFVar Qv fv min
                    let ind ← Meta.mkForallFVars fvs (← mkArrow cond Qimp)
                    let m' ← Meta.mkLambdaFVars fvs Qv
                    pure (base, ind, mkApp2 (const ``induc_from []) m' min)
                  | none =>
                    let base := replaceFVar Qv fv (Expr.lit (.natVal 0))
                    let ind ← Meta.mkForallFVars fvs Qimp
                    pure (base, ind, app (const ``Nat.rec [Level.zero]) m)
              let baseGoal ← Meta.mkFreshExprSyntheticOpaqueMVar base (addToName tag "Base_Case")
              let indGoal ← Meta.mkFreshExprSyntheticOpaqueMVar ind (addToName tag "Induction_Step")
              assign goal (mkApp2 rule baseGoal indGoal)
              replaceMainGoal [baseGoal.mvarId!, indGoal.mvarId!]
          | _ => myFail `by_induc "mathematical induction doesn't apply"
      | _ => myFail `by_induc "mathematical induction doesn't apply"

elab "by_induc" : tactic => doInduc false
elab "by_strong_induc" : tactic => doInduc true
end tactic_defs

--Constructing a function from its graph:
def graph {A B : Type} (f : A → B) : Set (A × B) :=
    { (a, b) : A × B | f a = b }

def is_func_graph {A B : Type} (G : Set (A × B)) : Prop :=
    ∀ (x : A), ∃! (y : B), (x, y) ∈ G

theorem func_from_graph {A B : Type} (F : Set (A × B)) :
    (∃ (f : A → B), graph f = F) ↔ is_func_graph F := by
  apply Iff.intro
  assume h1
  obtain f h2 from h1
  define
  fix x : A
  rewrite [←h2]
  exists_unique
  apply Exists.intro (f x)
  define
  rfl
  fix y1; fix y2
  assume h3; assume h4
  define at h3; define at h4
  rewrite [h3] at h4
  exact h4
  assume h1
  have h2 : ∀ (x : A), Nonempty { y : B // (x, y) ∈ F } := by
    define at h1
    fix x : A
    obtain y h2 _h3 from h1 x
    exact ⟨⟨y, h2⟩⟩
  let ff : (x : A) → { y : B // (x, y) ∈ F } := fun (x : A) => Classical.choice (h2 x)
  let f : A → B := fun (x : A) => (ff x).val
  apply Exists.intro f
  apply Set.ext
  fix (x, y) : A × B
  have h3 : (x, f x) ∈ F := (ff x).property
  apply Iff.intro
  assume h4
  define at h4
  rewrite [h4] at h3
  exact h3
  assume h4
  define
  define at h1
  obtain z _h5 h6 from h1 x
  exact h6 (f x) y h3 h4

def sum_less {A : Type} [AddZeroClass A] (m : Nat) (f : Nat → A) : A :=
  match m with
    | 0 => 0
    | n + 1 => sum_less n f + f n

def sum_from_to {A : Type} [AddZeroClass A] (k n : Nat) (f : Nat → A) : A :=
  sum_less (n + 1 - k) (fun (j : Nat) => f (k + j))

syntax (name := sumFromTo) "Sum " ident " from " term " to " term ", " term:51 : term
macro_rules (kind := sumFromTo)
  | `(Sum $i from $k to $n, $p) => `(sum_from_to $k $n (fun $i => $p))

@[app_unexpander sum_from_to] def unexpandSumFromTo : Lean.PrettyPrinter.Unexpander
  | `($_ $k:term $n:term fun $i:ident => $b) => `(Sum $i from $k to $n, $b)
  | `($_ $k:term $n:term fun ($i:ident : $_) => $b) => `(Sum $i from $k to $n, $b)
  | _ => throw ()

theorem sum_base {A : Type} [AddZeroClass A] {k : Nat} {f : Nat → A} :
    Sum i from k to k, f i = f k := by
  define : Sum i from k to k, f i
  rewrite [Nat.add_sub_cancel_left]
  unfold sum_less; unfold sum_less
  rewrite [zero_add, add_zero]
  rfl
  done

theorem sum_step {A : Type} [AddZeroClass A] {k n : Nat} {f : Nat → A}
    (h : k ≤ n) : Sum i from k to (n + 1), f i = (Sum i from k to n, f i) + f (n + 1) := by
  define : Sum i from k to (n+1), f i
  obtain j h1 from Nat.le.dest h
  have h2 : n + 1 + 1 - k = n + 1 - k + 1 := by
    rewrite [←h1, add_assoc, add_assoc, Nat.add_sub_cancel_left, add_assoc, Nat.add_sub_cancel_left, add_assoc]
    rfl
  have h3 : f (n + 1) = f (k + (n + 1 - k)) := by
    rewrite [←h1, add_assoc, Nat.add_sub_cancel_left]
    rfl
  rewrite [h2, h3]
  rfl
  done

theorem sum_from_zero_step {A : Type} [AddZeroClass A] {n : Nat} {f : Nat → A} :
    Sum i from 0 to (n + 1), f i = (Sum i from 0 to n, f i) + f (n + 1) :=
  sum_step (Nat.zero_le n)

theorem sum_empty {A : Type} [AddZeroClass A] {k n : Nat} {f : Nat → A}
    (h : n < k) : Sum i from k to n, f i = 0 := by
  define : Sum i from k to n, f i
  have h2 : n + 1 - k = 0 := Nat.sub_eq_zero_of_le h
  rewrite [h2]
  rfl
  done

def prod_less {A : Type} [MulOneClass A] (m : Nat) (f : Nat → A) : A :=
  match m with
    | 0 => 1
    | n + 1 => prod_less n f * f n

def prod_from_to {A : Type} [MulOneClass A] (k n : Nat) (f : Nat → A) : A :=
  prod_less (n + 1 - k) (fun (j : Nat) => f (k + j))

syntax (name := prodFromTo) "Prod " ident " from " term " to " term ", " term:51 : term
macro_rules (kind := prodFromTo)
  | `(Prod $i from $k to $n, $p) => `(prod_from_to $k $n (fun $i => $p))

@[app_unexpander prod_from_to] def unexpandProdFromTo : Lean.PrettyPrinter.Unexpander
  | `($_ $k:term $n:term fun $i:ident => $b) => `(Prod $i from $k to $n, $b)
  | `($_ $k:term $n:term fun ($i:ident : $_) => $b) => `(Prod $i from $k to $n, $b)
  | _ => throw ()

theorem prod_base {A : Type} [MulOneClass A] {k : Nat} {f : Nat → A} :
    Prod i from k to k, f i = f k := by
  define : Prod i from k to k, f i
  rewrite [Nat.add_sub_cancel_left]
  unfold prod_less; unfold prod_less
  rewrite [one_mul, add_zero]
  rfl
  done

theorem prod_step {A : Type} [MulOneClass A] {k n : Nat} {f : Nat → A}
    (h : k ≤ n) : Prod i from k to (n + 1), f i = (Prod i from k to n, f i) * f (n + 1) := by
  define : Prod i from k to (n+1), f i
  obtain j h1 from Nat.le.dest h
  have h2 : n + 1 + 1 - k = n + 1 - k + 1 := by
    rewrite [←h1, add_assoc, add_assoc, Nat.add_sub_cancel_left, add_assoc, Nat.add_sub_cancel_left, add_assoc]
    rfl
  have h3 : f (n + 1) = f (k + (n + 1 - k)) := by
    rewrite [←h1, add_assoc, Nat.add_sub_cancel_left]
    rfl
  rewrite [h2, h3]
  rfl
  done

theorem prod_from_zero_step {A : Type} [MulOneClass A] {n : Nat} {f : Nat → A} :
    Prod i from 0 to (n + 1), f i = (Prod i from 0 to n, f i) * f (n + 1) :=
  prod_step (Nat.zero_le n)

theorem prod_empty {A : Type} [MulOneClass A] {k n : Nat} {f : Nat → A}
    (h : n < k) : Prod i from k to n, f i = 1 := by
  define : Prod i from k to n, f i
  have h2 : n + 1 - k = 0 := Nat.sub_eq_zero_of_le h
  rewrite [h2]
  rfl
  done


import Smt

theorem falsum : ¬False := by
  smt


import data.real.basic

variables a b c : ℝ

-- example : max a b = max b a :=
-- begin
--   sorry
-- end
--
-- example : min (min a b) c = min a (min b c) :=
-- sorry


/-
Copyright (c) 2018 Jeremy Avigad. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Jeremy Avigad
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.W
import Mathlib.PostPort

universes u l u_1 u_2 u_3

namespace Mathlib

/-!
# Polynomial functors

This file defines polynomial functors and the W-type construction as a
polynomial functor.  (For the M-type construction, see
pfunctor/M.lean.)
-/

/--
A polynomial functor `P` is given by a type `A` and a family `B` of types over `A`. `P` maps
any type `α` to a new type `P.obj α`, which is defined as the sigma type `Σ x, P.B x → α`.

An element of `P.obj α` is a pair `⟨a, f⟩`, where `a` is an element of a type `A` and
`f : B a → α`. Think of `a` as the shape of the object and `f` as an index to the relevant
elements of `α`.
-/
structure pfunctor
where
  A : Type u
  B : A → Type u

namespace pfunctor

protected instance inhabited : Inhabited pfunctor :=
  { default := mk Inhabited.default Inhabited.default }

/-- Applying `P` to an object of `Type` -/
def obj (P : pfunctor) (α : Type u_2) :=
  sigma fun (x : A P) => B P x → α

/-- Applying `P` to a morphism of `Type` -/
def map (P : pfunctor) {α : Type u_2} {β : Type u_3} (f : α → β) : obj P α → obj P β :=
  fun (_x : obj P α) => sorry

protected instance obj.inhabited (P : pfunctor) {α : Type u} [Inhabited (A P)] [Inhabited α] : Inhabited (obj P α) :=
  { default := sigma.mk Inhabited.default fun (_x : B P Inhabited.default) => Inhabited.default }

protected instance obj.functor (P : pfunctor) : Functor (obj P) :=
  { map := map P, mapConst := fun (α β : Type u_2) => map P ∘ function.const β }

protected theorem map_eq (P : pfunctor) {α : Type u_2} {β : Type u_2} (f : α → β) (a : A P) (g : B P a → α) : f <$> sigma.mk a g = sigma.mk a (f ∘ g) :=
  rfl

protected theorem id_map (P : pfunctor) {α : Type u_2} (x : obj P α) : id <$> x = id x := sorry

protected theorem comp_map (P : pfunctor) {α : Type u_2} {β : Type u_2} {γ : Type u_2} (f : α → β) (g : β → γ) (x : obj P α) : (g ∘ f) <$> x = g <$> f <$> x := sorry

protected instance obj.is_lawful_functor (P : pfunctor) : is_lawful_functor (obj P) :=
  is_lawful_functor.mk (pfunctor.id_map P) (pfunctor.comp_map P)

/-- re-export existing definition of W-types and
adapt it to a packaged definition of polynomial functor -/
def W (P : pfunctor) :=
  W_type (B P)

/- inhabitants of W types is awkward to encode as an instance
assumption because there needs to be a value `a : P.A`
such that `P.B a` is empty to yield a finite tree -/

/-- root element  of a W tree -/
def W.head {P : pfunctor} : W P → A P :=
  sorry

/-- children of the root of a W tree -/
def W.children {P : pfunctor} (x : W P) : B P (W.head x) → W P :=
  sorry

/-- destructor for W-types -/
def W.dest {P : pfunctor} : W P → obj P (W P) :=
  sorry

/-- constructor for W-types -/
def W.mk {P : pfunctor} : obj P (W P) → W P :=
  sorry

@[simp] theorem W.dest_mk {P : pfunctor} (p : obj P (W P)) : W.dest (W.mk p) = p :=
  sigma.cases_on p fun (p_fst : A P) (p_snd : B P p_fst → W P) => Eq.refl (W.dest (W.mk (sigma.mk p_fst p_snd)))

@[simp] theorem W.mk_dest {P : pfunctor} (p : W P) : W.mk (W.dest p) = p :=
  W_type.cases_on p fun (p_a : A P) (p_f : B P p_a → W_type (B P)) => Eq.refl (W.mk (W.dest (W_type.mk p_a p_f)))

/-- `Idx` identifies a location inside the application of a pfunctor.
For `F : pfunctor`, `x : F.obj α` and `i : F.Idx`, `i` can designate
one part of `x` or is invalid, if `i.1 ≠ x.1` -/
def Idx (P : pfunctor) :=
  sigma fun (x : A P) => B P x

protected instance Idx.inhabited (P : pfunctor) [Inhabited (A P)] [Inhabited (B P Inhabited.default)] : Inhabited (Idx P) :=
  { default := sigma.mk Inhabited.default Inhabited.default }

/-- `x.iget i` takes the component of `x` designated by `i` if any is or returns
a default value -/
def obj.iget {P : pfunctor} [DecidableEq (A P)] {α : Type u_2} [Inhabited α] (x : obj P α) (i : Idx P) : α :=
  dite (sigma.fst i = sigma.fst x) (fun (h : sigma.fst i = sigma.fst x) => sigma.snd x (cast sorry (sigma.snd i)))
    fun (h : ¬sigma.fst i = sigma.fst x) => Inhabited.default

@[simp] theorem fst_map {P : pfunctor} {α : Type u} {β : Type u} (x : obj P α) (f : α → β) : sigma.fst (f <$> x) = sigma.fst x :=
  sigma.cases_on x fun (x_fst : A P) (x_snd : B P x_fst → α) => Eq.refl (sigma.fst (f <$> sigma.mk x_fst x_snd))

@[simp] theorem iget_map {P : pfunctor} [DecidableEq (A P)] {α : Type u} {β : Type u} [Inhabited α] [Inhabited β] (x : obj P α) (f : α → β) (i : Idx P) (h : sigma.fst i = sigma.fst x) : obj.iget (f <$> x) i = f (obj.iget x i) := sorry

end pfunctor

/-
Composition of polynomial functors.
-/

namespace pfunctor

/-- functor composition for polynomial functors -/
def comp (P₂ : pfunctor) (P₁ : pfunctor) : pfunctor :=
  mk (sigma fun (a₂ : A P₂) => B P₂ a₂ → A P₁)
    fun (a₂a₁ : sigma fun (a₂ : A P₂) => B P₂ a₂ → A P₁) =>
      sigma fun (u : B P₂ (sigma.fst a₂a₁)) => B P₁ (sigma.snd a₂a₁ u)

/-- constructor for composition -/
def comp.mk (P₂ : pfunctor) (P₁ : pfunctor) {α : Type} (x : obj P₂ (obj P₁ α)) : obj (comp P₂ P₁) α :=
  sigma.mk (sigma.mk (sigma.fst x) (sigma.fst ∘ sigma.snd x))
    fun (a₂a₁ : B (comp P₂ P₁) (sigma.mk (sigma.fst x) (sigma.fst ∘ sigma.snd x))) =>
      sigma.snd (sigma.snd x (sigma.fst a₂a₁)) (sigma.snd a₂a₁)

/-- destructor for composition -/
def comp.get (P₂ : pfunctor) (P₁ : pfunctor) {α : Type} (x : obj (comp P₂ P₁) α) : obj P₂ (obj P₁ α) :=
  sigma.mk (sigma.fst (sigma.fst x))
    fun (a₂ : B P₂ (sigma.fst (sigma.fst x))) =>
      sigma.mk (sigma.snd (sigma.fst x) a₂) fun (a₁ : B P₁ (sigma.snd (sigma.fst x) a₂)) => sigma.snd x (sigma.mk a₂ a₁)

end pfunctor

/-
Lifting predicates and relations.
-/

namespace pfunctor

theorem liftp_iff {P : pfunctor} {α : Type u} (p : α → Prop) (x : obj P α) : functor.liftp p x ↔ ∃ (a : A P), ∃ (f : B P a → α), x = sigma.mk a f ∧ ∀ (i : B P a), p (f i) := sorry

theorem liftp_iff' {P : pfunctor} {α : Type u} (p : α → Prop) (a : A P) (f : B P a → α) : functor.liftp p (sigma.mk a f) ↔ ∀ (i : B P a), p (f i) := sorry

theorem liftr_iff {P : pfunctor} {α : Type u} (r : α → α → Prop) (x : obj P α) (y : obj P α) : functor.liftr r x y ↔
  ∃ (a : A P),
    ∃ (f₀ : B P a → α), ∃ (f₁ : B P a → α), x = sigma.mk a f₀ ∧ y = sigma.mk a f₁ ∧ ∀ (i : B P a), r (f₀ i) (f₁ i) := sorry

theorem supp_eq {P : pfunctor} {α : Type u} (a : A P) (f : B P a → α) : functor.supp (sigma.mk a f) = f '' set.univ := sorry


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

Parallel computation of a computable sequence of computations by
a diagonal enumeration.
The important theorems of this operation are proven as
terminates_parallel and exists_of_mem_parallel.
(This operation is nondeterministic in the sense that it does not
honor sequence equivalence (irrelevance of computation time).)
-/
import data.seq.wseq
universes u v

namespace computation
open stream.wseq as wseq
open stream.seq as seq
variables {α : Type u} {β : Type v}

def parallel.aux2 : list (computation α) → α ⊕ list (computation α) :=
list.foldr (λ c o, match o with
| sum.inl a  := sum.inl a
| sum.inr ls := rmap (λ c', c' :: ls) (destruct c)
end) (sum.inr [])

def parallel.aux1 : list (computation α) × wseq (computation α) →
  α ⊕ list (computation α) × wseq (computation α)
| (l, S) := rmap (λ l', match seq.destruct S with
  | none := (l', seq.nil)
  | some (none, S') := (l', S')
  | some (some c, S') := (c::l', S')
  end) (parallel.aux2 l)

/-- Parallel computation of an infinite stream of computations,
  taking the first result -/
def parallel (S : wseq (computation α)) : computation α :=
corec parallel.aux1 ([], S)

theorem terminates_parallel.aux : ∀ {l : list (computation α)} {S c},
  c ∈ l → terminates c → terminates (corec parallel.aux1 (l, S)) :=
begin
  have lem1 : ∀ l S, (∃ (a : α), parallel.aux2 l = sum.inl a) →
    terminates (corec parallel.aux1 (l, S)),
  { intros l S e, cases e with a e,
    have this : corec parallel.aux1 (l, S) = return a,
    { apply destruct_eq_ret, simp [parallel.aux1], rw e, simp [rmap] },
    rw this, apply_instance },
  intros l S c m T, revert l S,
  apply @terminates_rec_on _ _ c T _ _,
  { intros a l S m, apply lem1,
    induction l with c l IH generalizing m; simp at m, { contradiction },
    cases m with e m,
    { rw ←e, simp [parallel.aux2],
      cases list.foldr parallel.aux2._match_1 (sum.inr list.nil) l with a' ls,
      exacts [⟨a', rfl⟩, ⟨a, rfl⟩] },
    { cases IH m with a' e,
      simp [parallel.aux2], simp [parallel.aux2] at e,
      rw e, exact ⟨a', rfl⟩ } },
  { intros s IH l S m,
    have H1 : ∀ l', parallel.aux2 l = sum.inr l' → s ∈ l',
    { induction l with c l IH' generalizing m;
      intros l' e'; simp at m, { contradiction },
      cases m with e m; simp [parallel.aux2] at e',
      { rw ←e at e',
        cases list.foldr parallel.aux2._match_1 (sum.inr list.nil) l with a' ls;
        injection e' with e', rw ←e', simp },
      { induction e : list.foldr parallel.aux2._match_1 (sum.inr list.nil) l with a' ls;
        rw e at e', { contradiction },
        have := IH' m _ e,
        simp [parallel.aux2] at e',
        cases destruct c; injection e' with h',
        rw ←h', simp [this] } },
    induction h : parallel.aux2 l with a l',
    { exact lem1 _ _ ⟨a, h⟩ },
    { have H2 : corec parallel.aux1 (l, S) = think _,
      { apply destruct_eq_think,
        simp [parallel.aux1],
        rw h, simp [rmap] },
      rw H2, apply @computation.think_terminates _ _ _,
      have := H1 _ h,
      rcases seq.destruct S with _ | ⟨_|c, S'⟩;
      simp [parallel.aux1]; apply IH; simp [this] } }
end

theorem terminates_parallel {S : wseq (computation α)}
   {c} (h : c ∈ S) [T : terminates c] : terminates (parallel S) :=
suffices ∀ n (l : list (computation α)) S c,
  c ∈ l ∨ some (some c) = seq.nth S n →
  terminates c → terminates (corec parallel.aux1 (l, S)),
from let ⟨n, h⟩ := h in this n [] S c (or.inr h) T,
begin
  intro n, induction n with n IH; intros l S c o T,
  { cases o with a a, { exact terminates_parallel.aux a T },
    have H : seq.destruct S = some (some c, _),
    { unfold seq.destruct functor.map, rw ← a, simp },
    induction h : parallel.aux2 l with a l';
    have C : corec parallel.aux1 (l, S) = _,
    { apply destruct_eq_ret, simp [parallel.aux1], rw [h], simp [rmap] },
    { rw C, resetI, apply_instance },
    { apply destruct_eq_think, simp [parallel.aux1], rw [h, H], simp [rmap] },
    { rw C, apply @computation.think_terminates _ _ _,
      apply terminates_parallel.aux _ T, simp } },
  { cases o with a a, { exact terminates_parallel.aux a T },
    induction h : parallel.aux2 l with a l';
    have C : corec parallel.aux1 (l, S) = _,
    { apply destruct_eq_ret, simp [parallel.aux1], rw [h], simp [rmap] },
    { rw C, resetI, apply_instance },
    { apply destruct_eq_think, simp [parallel.aux1], rw [h], simp [rmap] },
    { rw C, apply @computation.think_terminates _ _ _,
      have TT : ∀ l', terminates (corec parallel.aux1 (l', S.tail)),
      { intro, apply IH _ _ _ (or.inr _) T, rw a, cases S with f al, refl },
      induction e : seq.nth S 0 with o,
      { have D : seq.destruct S = none,
        { dsimp [seq.destruct], rw e, refl },
        rw D, simp [parallel.aux1], have TT := TT l',
        rwa [seq.destruct_eq_nil D, seq.tail_nil] at TT },
      { have D : seq.destruct S = some (o, S.tail),
        { dsimp [seq.destruct], rw e, refl },
        rw D, cases o with c; simp [parallel.aux1, TT] } } }
end

theorem exists_of_mem_parallel {S : wseq (computation α)}
   {a} (h : a ∈ parallel S) : ∃ c ∈ S, a ∈ c :=
suffices ∀ C, a ∈ C → ∀ (l : list (computation α)) S,
  corec parallel.aux1 (l, S) = C → ∃ c, (c ∈ l ∨ c ∈ S) ∧ a ∈ c,
from let ⟨c, h1, h2⟩ := this _ h [] S rfl in ⟨c, h1.resolve_left id, h2⟩,
begin
  let F : list (computation α) → α ⊕ list (computation α) → Prop,
  { intros l a, cases a with a l',
    exact ∃ c ∈ l, a ∈ c,
    exact ∀ a', (∃ c ∈ l', a' ∈ c) → (∃ c ∈ l, a' ∈ c) },
  have lem1 : ∀ (l : list (computation α)), F l (parallel.aux2 l),
  { intro l, induction l with c l IH; simp [parallel.aux2],
    { intros a h, rcases h with ⟨c, hn, _⟩,
      exact false.elim hn },
    { simp [parallel.aux2] at IH,
      cases list.foldr parallel.aux2._match_1 (sum.inr list.nil) l with a ls;
      simp [parallel.aux2],
      { rcases IH with ⟨c', cl, ac⟩,
        refine ⟨c', or.inr cl, ac⟩ },
      { induction h : destruct c with a c'; simp [rmap],
        { refine ⟨c, list.mem_cons_self _ _, _⟩,
          rw destruct_eq_ret h,
          apply ret_mem },
        { intros a' h, rcases h with ⟨d, dm, ad⟩,
          simp at dm, cases dm with e dl,
          { rw e at ad, refine ⟨c, list.mem_cons_self _ _, _⟩,
            rw destruct_eq_think h,
            exact think_mem ad },
          { cases IH a' ⟨d, dl, ad⟩ with d dm, cases dm with dm ad,
            exact ⟨d, or.inr dm, ad⟩ } } } } },
  intros C aC, refine mem_rec_on aC _ (λ C' IH, _);
  intros l S e; have e' := congr_arg destruct e; have := lem1 l;
  simp [parallel.aux1] at e'; cases parallel.aux2 l with a' l'; injection e' with h',
  { rw h' at this, rcases this with ⟨c, cl, ac⟩,
    exact ⟨c, or.inl cl, ac⟩ },
  { induction e : seq.destruct S with a; rw e at h',
    { exact let ⟨d, o, ad⟩ := IH _ _ h',
        ⟨c, cl, ac⟩ := this a ⟨d, o.resolve_right (wseq.not_mem_nil _), ad⟩ in
      ⟨c, or.inl cl, ac⟩ },
    { cases a with o S', cases o with c; simp [parallel.aux1] at h';
      rcases IH _ _ h' with ⟨d, dl | dS', ad⟩,
      { exact let ⟨c, cl, ac⟩ := this a ⟨d, dl, ad⟩ in ⟨c, or.inl cl, ac⟩ },
      { refine ⟨d, or.inr _, ad⟩,
        rw seq.destruct_eq_cons e,
        exact seq.mem_cons_of_mem _ dS' },
      { simp at dl, cases dl with dc dl,
        { rw dc at ad, refine ⟨c, or.inr _, ad⟩,
          rw seq.destruct_eq_cons e,
          apply seq.mem_cons },
        { exact let ⟨c, cl, ac⟩ := this a ⟨d, dl, ad⟩ in ⟨c, or.inl cl, ac⟩ } },
      { refine ⟨d, or.inr _, ad⟩,
        rw seq.destruct_eq_cons e,
        exact seq.mem_cons_of_mem _ dS' } } }
end

theorem map_parallel (f : α → β) (S) : map f (parallel S) = parallel (S.map (map f)) :=
begin
  refine eq_of_bisim (λ c1 c2, ∃ l S,
    c1 = map f (corec parallel.aux1 (l, S)) ∧
    c2 = corec parallel.aux1 (l.map (map f), S.map (map f))) _ ⟨[], S, rfl, rfl⟩,
  intros c1 c2 h, exact match c1, c2, h with ._, ._, ⟨l, S, rfl, rfl⟩ := begin
    clear _match,
    have : parallel.aux2 (l.map (map f)) = lmap f (rmap (list.map (map f)) (parallel.aux2 l)),
    { simp [parallel.aux2],
      induction l with c l IH; simp, rw [IH],
      cases list.foldr parallel.aux2._match_1 (sum.inr list.nil) l; simp [parallel.aux2],
      cases destruct c; simp },
    simp [parallel.aux1], rw this, cases parallel.aux2 l with a l'; simp,
    apply S.rec_on _ (λ c S, _) (λ S, _); simp; simp [parallel.aux1];
    exact ⟨_, _, rfl, rfl⟩
  end end
end

theorem parallel_empty (S : wseq (computation α)) (h : S.head ~> none) :
parallel S = empty _ :=
eq_empty_of_not_terminates $ λ ⟨⟨a, m⟩⟩,
let ⟨c, cs, ac⟩ := exists_of_mem_parallel m,
    ⟨n, nm⟩ := wseq.exists_nth_of_mem cs,
    ⟨c', h'⟩ := wseq.head_some_of_nth_some nm in by injection h h'

-- The reason this isn't trivial from exists_of_mem_parallel is because it eliminates to Sort
def parallel_rec {S : wseq (computation α)} (C : α → Sort v)
  (H : ∀ s ∈ S, ∀ a ∈ s, C a) {a} (h : a ∈ parallel S) : C a :=
begin
  let T : wseq (computation (α × computation α)) :=
    S.map (λ c, c.map (λ a, (a, c))),
  have : S = T.map (map (λ c, c.1)),
  { rw [←wseq.map_comp], refine (wseq.map_id _).symm.trans (congr_arg (λ f, wseq.map f S) _),
    funext c, dsimp [id, function.comp], rw [←map_comp], exact (map_id _).symm },
  have pe := congr_arg parallel this, rw ←map_parallel at pe,
  have h' := h, rw pe at h',
  haveI : terminates (parallel T) := (terminates_map_iff _ _).1 ⟨⟨_, h'⟩⟩,
  induction e : get (parallel T) with a' c,
  have : a ∈ c ∧ c ∈ S,
  { rcases exists_of_mem_map h' with ⟨d, dT, cd⟩,
    rw get_eq_of_mem _ dT at e, cases e, dsimp at cd, cases cd,
    rcases exists_of_mem_parallel dT with ⟨d', dT', ad'⟩,
    rcases wseq.exists_of_mem_map dT' with ⟨c', cs', e'⟩,
    rw ←e' at ad',
    rcases exists_of_mem_map ad' with ⟨a', ac', e'⟩, injection e' with i1 i2,
    constructor, rwa [i1, i2] at ac', rwa i2 at cs' },
  cases this with ac cs, apply H _ cs _ ac
end

theorem parallel_promises {S : wseq (computation α)} {a}
  (H : ∀ s ∈ S, s ~> a) : parallel S ~> a :=
λ a' ma', let ⟨c, cs, ac⟩ := exists_of_mem_parallel ma' in H _ cs ac

theorem mem_parallel {S : wseq (computation α)} {a}
  (H : ∀ s ∈ S, s ~> a) {c} (cs : c ∈ S) (ac : a ∈ c) : a ∈ parallel S :=
by haveI := terminates_of_mem ac; haveI := terminates_parallel cs;
   exact mem_of_promises _ (parallel_promises H)

theorem parallel_congr_lem {S T : wseq (computation α)} {a}
  (H : S.lift_rel equiv T) : (∀ s ∈ S, s ~> a) ↔ (∀ t ∈ T, t ~> a) :=
⟨λ h1 t tT, let ⟨s, sS, se⟩ := wseq.exists_of_lift_rel_right H tT in
  (promises_congr se _).1 (h1 _ sS),
λ h2 s sS, let ⟨t, tT, se⟩ := wseq.exists_of_lift_rel_left H sS in
  (promises_congr se _).2 (h2 _ tT)⟩

-- The parallel operation is only deterministic when all computation paths lead to the same value
theorem parallel_congr_left {S T : wseq (computation α)} {a}
  (h1 : ∀ s ∈ S, s ~> a) (H : S.lift_rel equiv T) : parallel S ~ parallel T :=
let h2 := (parallel_congr_lem H).1 h1 in
λ a', ⟨λ h, by have aa := parallel_promises h1 h; rw ←aa; rw ←aa at h; exact
  let ⟨s, sS, as⟩ := exists_of_mem_parallel h,
      ⟨t, tT, st⟩ := wseq.exists_of_lift_rel_left H sS,
      aT := (st _).1 as in mem_parallel h2 tT aT,
λ h, by have aa := parallel_promises h2 h; rw ←aa; rw ←aa at h; exact
  let ⟨s, sS, as⟩ := exists_of_mem_parallel h,
      ⟨t, tT, st⟩ := wseq.exists_of_lift_rel_right H sS,
      aT := (st _).2 as in mem_parallel h1 tT aT⟩

theorem parallel_congr_right {S T : wseq (computation α)} {a}
  (h2 : ∀ t ∈ T, t ~> a) (H : S.lift_rel equiv T) : parallel S ~ parallel T :=
parallel_congr_left ((parallel_congr_lem H).2 h2) H

end computation


lemma le_refl (x : mynat) : x ≤ x :=
begin
use 0,
symmetry,
exact add_zero x,
end


/-
Copyright (c) 2022 Joël Riou. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Joël Riou
-/

import for_mathlib.algebraic_topology.homotopical_algebra.cylinder

noncomputable theory

open category_theory category_theory.category category_theory.limits

namespace algebraic_topology

namespace model_category

variables {C : Type*} [category C] [model_category C] {A A' B B' : C}

structure left_homotopy (P : precylinder A) (f₀ f₁ : A ⟶ B) :=
(h : P.I ⟶ B) (h₀' : P.d₀ ≫ h = f₀ . obviously) (h₁' : P.d₁ ≫ h = f₁ . obviously)

namespace left_homotopy

restate_axiom h₀'
restate_axiom h₁'
attribute [simp, reassoc] h₀ h₁

def refl (P : precylinder A) (f : A ⟶ B) : left_homotopy P f f :=
{ h := P.σ ≫ f, }

instance (P : precylinder A) (f : A ⟶ B) : inhabited (left_homotopy P f f) := ⟨refl P f⟩

def symm {P : precylinder A} {f g : A ⟶ B} (H : left_homotopy P f g) :
  left_homotopy P.symm g f :=
{ h := H.h, }

def trans [is_cofibrant A] {P P' : cylinder A} {f₁ f₂ f₃ : A ⟶ B}
  (H₁ : left_homotopy P.pre f₁ f₂) (H₂ : left_homotopy P'.pre f₂ f₃) :
    left_homotopy (P.trans P').pre f₁ f₃ :=
{ h := pushout.desc H₁.h H₂.h (by simp only [h₁, h₀]), }

def comp_right {P : precylinder A} {f f' : A ⟶ B}
  (H : left_homotopy P f f') (g : B ⟶ B') : left_homotopy P (f ≫ g) (f' ≫ g) :=
{ h := H.h ≫ g, }

end left_homotopy

structure right_homotopy (P : pre_path_object B) (f₀ f₁ : A ⟶ B) :=
(h : A ⟶ P.I) (h₀' : h ≫ P.d₀ = f₀ . obviously) (h₁' : h ≫ P.d₁ = f₁ . obviously)

namespace right_homotopy

restate_axiom h₀'
restate_axiom h₁'
attribute [simp, reassoc] h₀ h₁

@[simps]
def op {P : pre_path_object B} {f g : A ⟶ B} (H : right_homotopy P f g) : left_homotopy P.op f.op g.op :=
{ h := H.h.op,
  h₀' := by { dsimp [pre_path_object.op], rw [← op_comp, H.h₀], },
  h₁' := by { dsimp [pre_path_object.op], rw [← op_comp, H.h₁], }, }

@[simps]
def unop {A B : Cᵒᵖ} {P : pre_path_object B} {f g : A ⟶ B} (H : right_homotopy P f g) : left_homotopy P.unop f.unop g.unop :=
{ h := H.h.unop,
  h₀' := by { dsimp [pre_path_object.unop], rw [← unop_comp, H.h₀], },
  h₁' := by { dsimp [pre_path_object.unop], rw [← unop_comp, H.h₁], }, }

@[simps]
def of_hom {P : pre_path_object B} (h : A ⟶ P.I) : right_homotopy P (h ≫ P.d₀) (h ≫ P.d₁) :=
{ h := h,
  h₀' := rfl,
  h₁' := rfl, }
end right_homotopy

namespace left_homotopy

@[simps]
def op {P : precylinder A} {f g : A ⟶ B} (H : left_homotopy P f g) : right_homotopy P.op f.op g.op :=
{ h := H.h.op,
  h₀' := by { dsimp [precylinder.op], rw [← op_comp, H.h₀], },
  h₁' := by { dsimp [precylinder.op], rw [← op_comp, H.h₁], }, }

@[simps]
def unop {A B : Cᵒᵖ} {P : precylinder A} {f g : A ⟶ B} (H : left_homotopy P f g) : right_homotopy P.unop f.unop g.unop :=
{ h := H.h.unop,
  h₀' := by { dsimp [precylinder.unop], rw [← unop_comp, H.h₀], },
  h₁' := by { dsimp [precylinder.unop], rw [← unop_comp, H.h₁], }, }

@[simps]
def of_hom {P : precylinder A} (h : P.I ⟶ B) : left_homotopy P (P.d₀ ≫ h) (P.d₁ ≫ h) :=
{ h := h,
  h₀' := rfl,
  h₁' := rfl, }

end left_homotopy

namespace right_homotopy

def refl (P : pre_path_object B) (f : A ⟶ B) : right_homotopy P f f :=
{ h := f ≫ P.σ, }

instance (P : pre_path_object B) (f : A ⟶ B) : inhabited (right_homotopy P f f) := ⟨refl P f⟩

def symm {P : pre_path_object B} {f g : A ⟶ B} (H : right_homotopy P f g) :
  right_homotopy P.symm g f :=
{ h := H.h, }

def trans {A B : C} [is_fibrant B] {P P' : path_object B} {f₁ f₂ f₃ : A ⟶ B}
  (H₁ : right_homotopy P.pre f₁ f₂) (H₂ : right_homotopy P'.pre f₂ f₃) :
    right_homotopy (P.trans P').pre f₁ f₃ :=
begin
  haveI : is_cofibrant (opposite.op B) := is_fibrant.op infer_instance,
  let H₁' : left_homotopy P.op.pre f₁.op f₂.op := H₁.op,
  let H₂' : left_homotopy P'.op.pre f₂.op f₃.op := H₂.op,
  exact (left_homotopy.trans H₁' H₂').unop,
end

def comp_left {P : pre_path_object B} {f f' : A ⟶ B}
  (H : right_homotopy P f f') (g : A' ⟶ A) : right_homotopy P (g ≫ f) (g ≫ f') :=
{ h := g ≫ H.h, }

lemma with_cof_σ_of_right_homotopy {A B : C} [hA : is_cofibrant A] {f f' : A ⟶ B}
  {P : path_object B} (H : right_homotopy P.pre f f') : ∃ (P' : path_object B)
  (H' : right_homotopy P'.pre f f'), cofibration P'.σ :=
begin
  let P' := P.change_I (CM5b.fac (P.σ)),
  have sq : comm_sq (initial.to _) (initial.to _) (CM5b.p (P.σ)) H.h :=
    comm_sq.mk (is_initial.hom_ext initial_is_initial _ _),
  refine ⟨P.change_I (CM5b.fac (P.σ)), _, by { dsimp, apply_instance, }⟩,
  exact
  { h := sq.lift,
    h₀' := by { dsimp [path_object.change_I], rw [sq.fac_right_assoc, H.h₀], },
    h₁' := by { dsimp [path_object.change_I], rw [sq.fac_right_assoc, H.h₁], }, },
end

lemma extension_exists {X X' Y : C} {P : path_object Y} {f₀ f₁ : X' ⟶ Y} (i : X ⟶ X')
  [cofibration i] [weak_eq i] (H : right_homotopy P.pre (i ≫ f₀) (i ≫ f₁)) :
  ∃ (H' : right_homotopy P.pre f₀ f₁), i ≫ H'.h = H.h :=
begin
  have sq : comm_sq H.h i P.pre.π (prod.lift f₀ f₁) := by tidy,
  have eq₀ := congr_arg (λ f, f ≫ limits.prod.fst) sq.fac_right,
  have eq₁ := congr_arg (λ f, f ≫ limits.prod.snd) sq.fac_right,
  simp only [pre_path_object.π, prod.comp_lift, prod.lift_snd, prod.lift_fst] at eq₀ eq₁,
  use
  { h := sq.lift,
    h₀' := eq₀,
    h₁' := eq₁, },
  exact sq.fac_left,
end

def extension {X X' Y : C} {P : path_object Y} {f₀ f₁ : X' ⟶ Y} (i : X ⟶ X')
  [cofibration i] [weak_eq i] (H : right_homotopy P.pre (i ≫ f₀) (i ≫ f₁)) :
  right_homotopy P.pre f₀ f₁ := (H.extension_exists i).some

lemma extension_fac {X X' Y : C} {P : path_object Y} {f₀ f₁ : X' ⟶ Y}
  (i : X ⟶ X') [cofibration i] [weak_eq i] (H : right_homotopy P.pre (i ≫ f₀) (i ≫ f₁)) :
  i ≫ (H.extension i).h = H.h :=
(H.extension_exists i).some_spec

end right_homotopy

namespace left_homotopy

def to_right_homotopy {A B : C} [is_cofibrant A] {Cyl : cylinder A} {f₁ f₂ : A ⟶ B}
  (H : left_homotopy Cyl.pre f₁ f₂) (P : path_object B) : right_homotopy P.pre f₁ f₂ :=
begin
  have sq : comm_sq (f₁ ≫ P.σ) Cyl.d₀ P.π (prod.lift (Cyl.σ ≫ f₁) H.h) := by tidy,
  have hr₀ := congr_arg (λ f, f ≫ limits.prod.fst) sq.fac_right,
  have hr₁ := congr_arg (λ f, f ≫ limits.prod.snd) sq.fac_right,
  simp only [pre_path_object.π, prod.comp_lift, prod.lift_snd, prod.lift_fst] at hr₀ hr₁,
  exact
  { h := Cyl.d₁ ≫ sq.lift,
    h₀' := by { simp only [hr₀, pre_path_object.π, assoc, precylinder.σd₁_assoc], },
    h₁' := by { simp only [pre_path_object.π, assoc, hr₁, H.h₁], }, },
end

end left_homotopy

namespace right_homotopy

def to_left_homotopy {A B : C} [hB : is_fibrant B] {P : path_object B} {f₁ f₂ : A ⟶ B}
  (H : right_homotopy P.pre f₁ f₂) (Cyl : cylinder A) : left_homotopy Cyl.pre f₁ f₂ :=
begin
  haveI : is_cofibrant (opposite.op B) := hB.op,
  let H₁ : left_homotopy P.op.pre _ _ := H.op,
  let H₂ : right_homotopy Cyl.pre.op _ _ := H₁.to_right_homotopy Cyl.op,
  simpa only [Cyl.pre.unop_op] using H₂.unop,
end

def change_path_object {A B : C} [hA : is_cofibrant A] [hB : is_fibrant B]
  {P : path_object B} {f₁ f₂ : A ⟶ B} (H : right_homotopy P.pre f₁ f₂) (P' : path_object B) :
  right_homotopy P'.pre f₁ f₂ :=
(H.to_left_homotopy (cylinder.some A)).to_right_homotopy P'

end right_homotopy

namespace left_homotopy

def change_cylinder {A B : C} [hA : is_cofibrant A] [hB : is_fibrant B]
  {Cyl : cylinder A} {f₁ f₂ : A ⟶ B} (H : left_homotopy Cyl.pre f₁ f₂) (Cyl' : cylinder A) :
  left_homotopy Cyl'.pre f₁ f₂ :=
(H.to_right_homotopy (path_object.some B)).to_left_homotopy Cyl'

end left_homotopy

end model_category

end algebraic_topology


import tactic

namespace fifteen
/-
  You take a deep breath
  And you walk through the doors
  It's the morning of your very first day
  ...
-/

section defenestration -- definitions

-- why in the world did I use an enumerated type instead of fin 4 × fin 4?
-- unfortunately this way is not easily scalable to other dimensions
-- at least it looks pretty :)
@[derive [decidable_eq, has_reflect, fintype]]
inductive tile : Type
| aa | ab | ac | ad
| ba | bb | bc | bd
| ca | cb | cc | cd
| da | db | dc | dd
-- not really using fintype rn but it's there anyways

open tile

instance : has_to_string tile :=
⟨ λ t, match t with
  | aa := "aa"
  | ab := "ab"
  | ac := "ac"
  | ad := "ad"
  | ba := "ba"
  | bb := "bb"
  | bc := "bc"
  | bd := "bd"
  | ca := "ca"
  | cb := "cb"
  | cc := "cc"
  | cd := "cd"
  | da := "da"
  | db := "db"
  | dc := "dc"
  | dd := "dd"
  end
⟩

-- TODO: use `fin_range` and `univ` ?
def tiles_list : list tile := [aa, ab, ac, ad, ba, bb, bc, bd, ca, cb, cc, cd, da, db, dc, dd]

def get_adjacent : tile → list tile
| aa := [ab, ba]
| ab := [aa, ac, bb]
| ac := [ab, ad, bc]
| ad := [ac, bd]
| ba := [aa, bb, ca]
| bb := [ab, ba, bc, cb]
| bc := [ac, bb, bd, cc]
| bd := [ad, bc, cd]
| ca := [ba, cb, da]
| cb := [bb, ca, cc, db]
| cc := [bc, cb, cd, dc]
| cd := [bd, cc, dd]
| da := [ca, db]
| db := [cb, da, dc]
| dc := [cc, db, dd]
| dd := [cd, dc]

def is_adjacent (t₁ t₂ : tile) : Prop := t₁ ∈ (get_adjacent t₂)

@[ext] structure position :=
(map : tile → fin 16)
-- (bij : function.bijective map)
-- don't know if bijective is helpful,
-- but it makes things more complicated so taking it out for now

-- Mario Carneiro's Magic!
-- I still don't know what @[ext] and this instance does...
instance : decidable_eq position :=
λ a b, decidable_of_iff' _ (position.ext_iff _ _)

-- zero denotes the hole
@[derive decidable]
def hole (t : tile) (p : position) : Prop := p.map t = 0

def valid_slide' (t : tile) (p : position) : Prop :=
∃ t' ∈ get_adjacent t, hole t' p

def valid_slide (t h : tile) (p : position) : Prop :=
h ∈ get_adjacent t ∧ hole h p

def slide (t h : tile) (p : position) : position :=
⟨ λ t',
  if t' = t then p.map h
  else if t' = h then p.map t
  else p.map t'
⟩

def goal_position : position :=
⟨ λ t, match t with
  | aa := 1 | ab := 2 | ac := 3 | ad := 4
  | ba := 5 | bb := 6 | bc := 7 | bd := 8
  | ca := 9 | cb := 10| cc := 11| cd := 12
  | da := 13| db := 14| dc := 15| dd := 0
  end
⟩

#eval goal_position.map dc
#eval (slide dc dd goal_position).map dc

-- this is really lookin like hanoi but with sliding
inductive can_slide_to : position → position → Prop
| self : ∀ (p : position), can_slide_to p p
| one : ∀ (p₁ p₂ : position), (∃ (t e : tile), (valid_slide t e p₁) ∧ (slide t e p₁) = p₂) → can_slide_to p₁ p₂
| trans : ∀ (p₁ p₂ p₃ : position), can_slide_to p₁ p₂ → can_slide_to p₂ p₃ → can_slide_to p₁ p₃

-- we are assuming start is a solvable position
def game (start : position) := can_slide_to start goal_position

end defenestration

section limabeans -- lemmas

-- symmetry for adjacency
lemma sym_adj (t₁ t₂ : tile) : is_adjacent t₁ t₂ ↔ is_adjacent t₂ t₁ :=
begin
  split; intros h; cases t₁; cases t₂; try {exact h},
  all_goals {unfold is_adjacent at *; unfold get_adjacent at *; try {dec_trivial} },
  all_goals { exfalso; finish },
end

lemma slide_one_step (p₁ p₂ : position) : (∃ (t e : tile), (valid_slide t e p₁) ∧ can_slide_to (slide t e p₁) p₂) → can_slide_to p₁ p₂ :=
begin
  rintros ⟨t, e, h₁, h₂⟩,
  apply can_slide_to.trans p₁ (slide t e p₁) p₂,
  apply can_slide_to.one,
  use [t, e],
  split,
  { exact h₁ },
  { refl },
  exact h₂,
end

-- more of Mario Carneiro's Magic
lemma can_slide_to.of_eq : ∀ {p₁ p₂ : position} (h : p₁ = p₂), can_slide_to p₁ p₂
| p _ rfl := can_slide_to.self p

end limabeans

end fifteen