/-
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.valuation.tfae
! leanprover-community/mathlib commit 70fd9563a21e7b963887c9360bd29b2393e6225a
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.RingTheory.Ideal.Cotangent
import Mathbin.RingTheory.DedekindDomain.Basic
import Mathbin.RingTheory.Valuation.ValuationRing
import Mathbin.RingTheory.Nakayama

/-!

# Equivalent conditions for DVR

In `discrete_valuation_ring.tfae`, we show that the following are equivalent for a
noetherian local domain `(R, m, k)`:
- `R` is a discrete valuation ring
- `R` is a valuation ring
- `R` is a dedekind domain
- `R` is integrally closed with a unique prime ideal
- `m` is principal
- `dimₖ m/m² = 1`
- Every nonzero ideal is a power of `m`.

-/

variable (R : Type _) [CommRing R] (K : Type _) [Field K] [Algebra R K] [IsFractionRing R K]

open DiscreteValuation

open LocalRing

open BigOperators

theorem exists_maximalIdeal_pow_eq_of_principal [IsNoetherianRing R] [LocalRing R] [IsDomain R]
    (h : ¬IsField R) (h' : (maximalIdeal R).IsPrincipal) (I : Ideal R) (hI : I ≠ ⊥) :
    ∃ n : ℕ, I = maximalIdeal R ^ n := by
  classical
    obtain ⟨x, hx : _ = Ideal.span _⟩ := h'
    by_cases hI' : I = ⊤
    · use 0
      rw [pow_zero, hI', Ideal.one_eq_top]
    have H : ∀ r : R, ¬IsUnit r ↔ x ∣ r := fun r =>
      (set_like.ext_iff.mp hx r).trans Ideal.mem_span_singleton
    have : x ≠ 0 := by
      rintro rfl
      apply Ring.ne_bot_of_isMaximal_of_not_isField (maximal_ideal.is_maximal R) h
      simp [hx]
    have hx' := DiscreteValuationRing.irreducible_of_span_eq_maximalIdeal x this hx
    have H' : ∀ r : R, r ≠ 0 → r ∈ nonunits R → ∃ n : ℕ, Associated (x ^ n) r :=
      by
      intro r hr₁ hr₂
      obtain ⟨f, hf₁, rfl, hf₂⟩ := (WfDvdMonoid.not_unit_iff_exists_factors_eq r hr₁).mp hr₂
      have : ∀ b ∈ f, Associated x b := by
        intro b hb
        exact Irreducible.associated_of_dvd hx' (hf₁ b hb) ((H b).mp (hf₁ b hb).1)
      clear hr₁ hr₂ hf₁
      induction' f using Multiset.induction with fa fs fh
      · exact (hf₂ rfl).elim
      rcases eq_or_ne fs ∅ with (rfl | hf')
      · use 1
        rw [pow_one, Multiset.prod_cons, Multiset.empty_eq_zero, Multiset.prod_zero, mul_one]
        exact this _ (Multiset.mem_cons_self _ _)
      · obtain ⟨n, hn⟩ := fh hf' fun b hb => this _ (Multiset.mem_cons_of_mem hb)
        use n + 1
        rw [pow_add, Multiset.prod_cons, mul_comm, pow_one]
        exact Associated.mul_mul (this _ (Multiset.mem_cons_self _ _)) hn
    have : ∃ n : ℕ, x ^ n ∈ I :=
      by
      obtain ⟨r, hr₁, hr₂⟩ : ∃ r : R, r ∈ I ∧ r ≠ 0 :=
        by
        by_contra h
        push_neg  at h
        apply hI
        rw [eq_bot_iff]
        exact h
      obtain ⟨n, u, rfl⟩ := H' r hr₂ (le_maximal_ideal hI' hr₁)
      use n
      rwa [← I.unit_mul_mem_iff_mem u.is_unit, mul_comm]
    use Nat.find this
    apply le_antisymm
    · change ∀ s ∈ I, s ∈ _
      by_contra hI''
      push_neg  at hI''
      obtain ⟨s, hs₁, hs₂⟩ := hI''
      apply hs₂
      by_cases hs₃ : s = 0
      · rw [hs₃]
        exact zero_mem _
      obtain ⟨n, u, rfl⟩ := H' s hs₃ (le_maximal_ideal hI' hs₁)
      rw [mul_comm, Ideal.unit_mul_mem_iff_mem _ u.is_unit] at hs₁⊢
      apply Ideal.pow_le_pow (Nat.find_min' this hs₁)
      apply Ideal.pow_mem_pow
      exact (H _).mpr (dvd_refl _)
    · rw [hx, Ideal.span_singleton_pow, Ideal.span_le, Set.singleton_subset_iff]
      exact Nat.find_spec this
#align exists_maximal_ideal_pow_eq_of_principal exists_maximalIdeal_pow_eq_of_principal

theorem maximalIdeal_isPrincipal_of_isDedekindDomain [LocalRing R] [IsDomain R]
    [IsDedekindDomain R] : (maximalIdeal R).IsPrincipal := by
  classical
    by_cases ne_bot : maximal_ideal R = ⊥
    · rw [ne_bot]
      infer_instance
    obtain ⟨a, ha₁, ha₂⟩ : ∃ a ∈ maximal_ideal R, a ≠ (0 : R) :=
      by
      by_contra h'
      push_neg  at h'
      apply ne_bot
      rwa [eq_bot_iff]
    have hle : Ideal.span {a} ≤ maximal_ideal R := by rwa [Ideal.span_le, Set.singleton_subset_iff]
    have : (Ideal.span {a}).radical = maximal_ideal R :=
      by
      rw [Ideal.radical_eq_infₛ]
      apply le_antisymm
      · exact infₛ_le ⟨hle, inferInstance⟩
      · refine'
          le_infₛ fun I hI =>
            (eq_maximal_ideal <| IsDedekindDomain.dimensionLeOne _ (fun e => ha₂ _) hI.2).ge
        rw [← Ideal.span_singleton_eq_bot, eq_bot_iff, ← e]
        exact hI.1
    have : ∃ n, maximal_ideal R ^ n ≤ Ideal.span {a} :=
      by
      rw [← this]
      apply Ideal.exists_radical_pow_le_of_fg
      exact IsNoetherian.noetherian _
    cases hn : Nat.find this
    · have := Nat.find_spec this
      rw [hn, pow_zero, Ideal.one_eq_top] at this
      exact (Ideal.IsMaximal.ne_top inferInstance (eq_top_iff.mpr <| this.trans hle)).elim
    obtain ⟨b, hb₁, hb₂⟩ : ∃ b ∈ maximal_ideal R ^ n, ¬b ∈ Ideal.span {a} :=
      by
      by_contra h'
      push_neg  at h'
      rw [Nat.find_eq_iff] at hn
      exact hn.2 n n.lt_succ_self fun x hx => not_not.mp (h' x hx)
    have hb₃ : ∀ m ∈ maximal_ideal R, ∃ k : R, k * a = b * m :=
      by
      intro m hm
      rw [← Ideal.mem_span_singleton']
      apply Nat.find_spec this
      rw [hn, pow_succ']
      exact Ideal.mul_mem_mul hb₁ hm
    have hb₄ : b ≠ 0 := by
      rintro rfl
      apply hb₂
      exact zero_mem _
    let K := FractionRing R
    let x : K := algebraMap R K b / algebraMap R K a
    let M := Submodule.map (Algebra.ofId R K).toLinearMap (maximal_ideal R)
    have ha₃ : algebraMap R K a ≠ 0 := is_fraction_ring.to_map_eq_zero_iff.not.mpr ha₂
    by_cases hx : ∀ y ∈ M, x * y ∈ M
    · have := isIntegral_of_smul_mem_submodule M _ _ x hx
      · obtain ⟨y, e⟩ := IsIntegrallyClosed.algebraMap_eq_of_integral this
        refine' (hb₂ (ideal.mem_span_singleton'.mpr ⟨y, _⟩)).elim
        apply IsFractionRing.injective R K
        rw [map_mul, e, div_mul_cancel _ ha₃]
      · rw [Submodule.ne_bot_iff]
        refine' ⟨_, ⟨a, ha₁, rfl⟩, _⟩
        exact is_fraction_ring.to_map_eq_zero_iff.not.mpr ha₂
      · apply Submodule.Fg.map
        exact IsNoetherian.noetherian _
    · have :
        (M.map (DistribMulAction.toLinearMap R K x)).comap (Algebra.ofId R K).toLinearMap = ⊤ :=
        by
        by_contra h
        apply hx
        rintro m' ⟨m, hm, rfl : algebraMap R K m = m'⟩
        obtain ⟨k, hk⟩ := hb₃ m hm
        have hk' : x * algebraMap R K m = algebraMap R K k := by
          rw [← mul_div_right_comm, ← map_mul, ← hk, map_mul, mul_div_cancel _ ha₃]
        exact ⟨k, le_maximal_ideal h ⟨_, ⟨_, hm, rfl⟩, hk'⟩, hk'.symm⟩
      obtain ⟨y, hy₁, hy₂⟩ : ∃ y ∈ maximal_ideal R, b * y = a :=
        by
        rw [Ideal.eq_top_iff_one, Submodule.mem_comap] at this
        obtain ⟨_, ⟨y, hy, rfl⟩, hy' : x * algebraMap R K y = algebraMap R K 1⟩ := this
        rw [map_one, ← mul_div_right_comm, div_eq_one_iff_eq ha₃, ← map_mul] at hy'
        exact ⟨y, hy, IsFractionRing.injective R K hy'⟩
      refine' ⟨⟨y, _⟩⟩
      apply le_antisymm
      · intro m hm
        obtain ⟨k, hk⟩ := hb₃ m hm
        rw [← hy₂, mul_comm, mul_assoc] at hk
        rw [← mul_left_cancel₀ hb₄ hk, mul_comm]
        exact ideal.mem_span_singleton'.mpr ⟨_, rfl⟩
      · rwa [Submodule.span_le, Set.singleton_subset_iff]
#align maximal_ideal_is_principal_of_is_dedekind_domain maximalIdeal_isPrincipal_of_isDedekindDomain

/- ./././Mathport/Syntax/Translate/Basic.lean:635:2: warning: expanding binder collection (I «expr ≠ » «expr⊥»()) -/
theorem DiscreteValuationRing.tFAE [IsNoetherianRing R] [LocalRing R] [IsDomain R]
    (h : ¬IsField R) :
    TFAE
      [DiscreteValuationRing R, ValuationRing R, IsDedekindDomain R,
        IsIntegrallyClosed R ∧ ∃! P : Ideal R, P ≠ ⊥ ∧ P.IsPrime, (maximalIdeal R).IsPrincipal,
        FiniteDimensional.finrank (ResidueField R) (CotangentSpace R) = 1,
        ∀ (I) (_ : I ≠ ⊥), ∃ n : ℕ, I = maximalIdeal R ^ n] :=
  by
  have ne_bot := Ring.ne_bot_of_isMaximal_of_not_isField (maximal_ideal.is_maximal R) h
  classical
    rw [finrank_eq_one_iff']
    tfae_have 1 → 2
    · intro
      infer_instance
    tfae_have 2 → 1
    · intro
      haveI := IsBezout.toGcdDomain R
      haveI : UniqueFactorizationMonoid R := ufm_of_gcd_of_wfDvdMonoid
      apply DiscreteValuationRing.of_ufd_of_unique_irreducible
      · obtain ⟨x, hx₁, hx₂⟩ := Ring.exists_not_isUnit_of_not_isField h
        obtain ⟨p, hp₁, hp₂⟩ := WfDvdMonoid.exists_irreducible_factor hx₂ hx₁
        exact ⟨p, hp₁⟩
      · exact ValuationRing.unique_irreducible
    tfae_have 1 → 4
    · intro H
      exact ⟨inferInstance, ((DiscreteValuationRing.iff_pid_with_one_nonzero_prime R).mp H).2⟩
    tfae_have 4 → 3
    · rintro ⟨h₁, h₂⟩
      exact
        ⟨inferInstance, fun I hI hI' =>
          ExistsUnique.unique h₂ ⟨ne_bot, inferInstance⟩ ⟨hI, hI'⟩ ▸ maximal_ideal.is_maximal R, h₁⟩
    tfae_have 3 → 5
    · intro h
      exact maximalIdeal_isPrincipal_of_isDedekindDomain R
    tfae_have 5 → 6
    · rintro ⟨x, hx⟩
      have : x ∈ maximal_ideal R := by
        rw [hx]
        exact Submodule.subset_span (Set.mem_singleton x)
      let x' : maximal_ideal R := ⟨x, this⟩
      use Submodule.Quotient.mk x'
      constructor
      · intro e
        rw [Submodule.Quotient.mk_eq_zero] at e
        apply Ring.ne_bot_of_isMaximal_of_not_isField (maximal_ideal.is_maximal R) h
        apply Submodule.eq_bot_of_le_smul_of_le_jacobson_bot (maximal_ideal R)
        · exact ⟨{x}, (Finset.coe_singleton x).symm ▸ hx.symm⟩
        · conv_lhs => rw [hx]
          rw [Submodule.mem_smul_top_iff] at e
          rwa [Submodule.span_le, Set.singleton_subset_iff]
        · rw [LocalRing.jacobson_eq_maximalIdeal (⊥ : Ideal R) bot_ne_top]
          exact le_refl _
      · refine' fun w => Quotient.inductionOn' w fun y => _
        obtain ⟨y, hy⟩ := y
        rw [hx, Submodule.mem_span_singleton] at hy
        obtain ⟨a, rfl⟩ := hy
        exact ⟨Ideal.Quotient.mk _ a, rfl⟩
    tfae_have 6 → 5
    · rintro ⟨x, hx, hx'⟩
      induction x using Quotient.inductionOn'
      use x
      apply le_antisymm
      swap
      · rw [Submodule.span_le, Set.singleton_subset_iff]
        exact x.prop
      have h₁ :
        (Ideal.span {x} : Ideal R) ⊔ maximal_ideal R ≤
          Ideal.span {x} ⊔ maximal_ideal R • maximal_ideal R :=
        by
        refine' sup_le le_sup_left _
        rintro m hm
        obtain ⟨c, hc⟩ := hx' (Submodule.Quotient.mk ⟨m, hm⟩)
        induction c using Quotient.inductionOn'
        rw [← sub_sub_cancel (c * x) m]
        apply sub_mem _ _
        · infer_instance
        · refine' Ideal.mem_sup_left (ideal.mem_span_singleton'.mpr ⟨c, rfl⟩)
        · have := (Submodule.Quotient.eq _).mp hc
          rw [Submodule.mem_smul_top_iff] at this
          exact Ideal.mem_sup_right this
      have h₂ : maximal_ideal R ≤ (⊥ : Ideal R).jacobson :=
        by
        rw [LocalRing.jacobson_eq_maximalIdeal]
        exacts[le_refl _, bot_ne_top]
      have :=
        Submodule.smul_sup_eq_smul_sup_of_le_smul_of_le_jacobson (IsNoetherian.noetherian _) h₂ h₁
      rw [Submodule.bot_smul, sup_bot_eq] at this
      rw [← sup_eq_left, eq_comm]
      exact le_sup_left.antisymm (h₁.trans <| le_of_eq this)
    tfae_have 5 → 7
    · exact exists_maximalIdeal_pow_eq_of_principal R h
    tfae_have 7 → 2
    · rw [ValuationRing.iff_ideal_total]
      intro H
      constructor
      intro I J
      by_cases hI : I = ⊥
      · subst hI
        left
        exact bot_le
      by_cases hJ : J = ⊥
      · subst hJ
        right
        exact bot_le
      obtain ⟨n, rfl⟩ := H I hI
      obtain ⟨m, rfl⟩ := H J hJ
      cases' le_total m n with h' h'
      · left
        exact Ideal.pow_le_pow h'
      · right
        exact Ideal.pow_le_pow h'
    tfae_finish
#align discrete_valuation_ring.tfae DiscreteValuationRing.tFAE


/-
Copyright (c) 2020 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin
-/
import category_theory.concrete_category.bundled_hom
import algebra.punit_instances
import order.hom.basic
import category_theory.category.Cat
import category_theory.category.preorder

/-!
# Category of preorders

This defines `Preorder`, the category of preorders with monotone maps.
-/

universe u

open category_theory

/-- The category of preorders. -/
def Preorder := bundled preorder

namespace Preorder

instance : bundled_hom @order_hom :=
{ to_fun := @order_hom.to_fun,
  id := @order_hom.id,
  comp := @order_hom.comp,
  hom_ext := @order_hom.ext }

attribute [derive [large_category, concrete_category]] Preorder

instance : has_coe_to_sort Preorder Type* := bundled.has_coe_to_sort

/-- Construct a bundled Preorder from the underlying type and typeclass. -/
def of (α : Type*) [preorder α] : Preorder := bundled.of α

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

instance : inhabited Preorder := ⟨of punit⟩

instance (α : Preorder) : preorder α := α.str

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

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

/-- The equivalence between `Preorder` and itself induced by `order_dual` both ways. -/
@[simps functor inverse] def dual_equiv : Preorder ≌ Preorder :=
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 Preorder

/--
The embedding of `Preorder` into `Cat`.
-/
@[simps]
def Preorder_to_Cat : Preorder.{u} ⥤ Cat :=
{ obj := λ X, Cat.of X.1,
  map := λ X Y f, f.monotone.functor,
  map_id' := λ X, begin apply category_theory.functor.ext, tidy end,
  map_comp' := λ X Y Z f g, begin apply category_theory.functor.ext, tidy end }

instance : faithful Preorder_to_Cat.{u} :=
{ map_injective' := λ X Y f g h, begin ext x, exact functor.congr_obj h x end }

instance : full Preorder_to_Cat.{u} :=
{ preimage := λ X Y f, ⟨f.obj, f.monotone⟩,
  witness' := λ X Y f, begin apply category_theory.functor.ext, tidy end }


import seplog.d_context
import seplog.b_memory

section evaluation
  open Relop open Binop open Val open TypeDecl open Ctx open Val
  open Store
  /-
   - Lemmas needed to fold && over a finset of bools (in struct_eq)
   -/
  section boolean_and

    theorem band_comm: ∀ (a b: bool), a && b  = b && a := begin
      intros, induction a ; induction b; tauto,
    end

    instance: is_commutative bool band := ⟨band_comm⟩

    theorem band_assoc: ∀ (a b c: bool), (a && b) && c  = a && (b && c)
      := begin
      intros, cases a; cases b; cases c; tauto,
    end

    instance: is_associative bool band := ⟨band_assoc⟩

  end boolean_and

  /-
   - Define the behavior of relational operators (none means failure)
   - We are not modeling memory management explicitly, so we throw a
   - failure if comparing non-nil pointers for equality or LEQ, even
   - if these are well-defined in Go.
   -/
  def relop_eval: Π{α: TypeDecl},
      Relop → option (Val α) → option (Val α) → option bool
   | _        _   none      _       := none
   | _        _   _        none     := none
   | gBool    EQ  (some x) (some y) := some $ x = y
   | gBool    NEQ (some x) (some y) := some $ ¬ x = y
   | gBool    LEQ (some x) (some y) := some $ (bnot x.bval) || y.bval
   | gInt     EQ  (some x) (some y) := some $ x = y
   | gInt     NEQ (some x) (some y) := some $ ¬ (x = y)
   | gInt     LEQ (some x) (some y) := some $ x.ival <= y.ival
   | gStr     EQ  (some x) (some y) := some $ x = y
   | gStr     NEQ (some x) (some y) := some $ ¬(eq x y)
   | gStr     LEQ (some x) (some y) := some $ x <= y
   | gErr     EQ  (some x) (some y) := some $ x = y
   | gErr     NEQ (some x) (some y) := some $ ¬(eq x y)
   | gErr     LEQ _          _      := none
   | (gRef s) EQ  (some x) (some y) := some $  x = y
   | (gRef s) NEQ (some x) (some y) := some ¬(x = y)
   | (gRef s) LEQ _          _      := none
   | (gPtr s) EQ  (some x) (some y) := some $ x = y
   | (gPtr s) NEQ (some x) (some y) := some $ ¬ x = y
   | (gPtr s) _   _        _        := none
   | (gArr n t) _ _          _      := none

  /-
   - Define thse behavior of binary operators
   -/
  def binop_eval: Π{α: TypeDecl},
    Binop → option (Val α) → option (Val α) → option (Val α)
   | _        _     none       _          := none
   | _        _     _          none       := none
   | (gRef _) _     _          _          := none
   | gErr     _     _          _          := none
   | gBool    OR    (some x) (some y) := some $ pBool $ x.bval || y.bval
   | gBool    AND   (some x) (some y) := some $ pBool $ x.bval && y.bval
   | gBool    _     _          _          := none
   | gInt     PLUS  (some x) (some y) := if  (x+y >  2147483647)
                                              || (x+y < -2147483648)
                                            then none  -- overflow
                                            else some $ x + y
   | gInt     MINUS (some x) (some y) := if  (x-y >  2147483647)
                                              || (x-y < -2147483648)
                                            then none  -- overflow
                                            else some $ x - y
   | gInt     _     _          _          := none
   | gStr     PLUS  (some x) (some y) := some $ x ++ y
   | gStr     _     _          _          := none
   | (gPtr _) _     _          _          := none
   | (gArr _ _) _     _          _          := none

   def unop_eval: Π{α: TypeDecl}, Unop → option (Val α) → option (Val α)
    | gInt   NEG  (some x) := some $ -x
    | gBool  NOT  (some x) := some $ pBool $ bnot x.bval
    | _      _    _        := none

  open Expr
  @[simp]
  def eval: Π{α: TypeDecl}, Expr α → Store → option (Val α)
   | _ (@const _ x)     _     := some x       -- constant
   | _ (getvar v)       e     := get_var v e  -- look to env
   | _ (@relop α o x y) e     := relop_eval o (@eval α x e) (@eval α y e)
                                  >>= some ∘ pBool
   | _ (@binop α o x y) e     := binop_eval o (@eval α x e) (@eval α y e)
   | _ (@unop α o x)    e     := unop_eval o (@eval α x e)
   | _ (@get_field s α x f) e := do t      ← eval x e,
                                    ⟨_, v⟩ ← t.get f,
                                    as_type v α
   | _ (@update_field s α xstr field val) e := do
      structval ← eval xstr e,
      fieldval  ← eval val e,
      structval.update α field fieldval

def eval_generic {α: TypeDecl} (s: Store) (x: Expr α)
                : option (Σ β, Val β) :=
  eval x s >>= λ res, some ⟨_, res⟩

end evaluation

section semantics
  open cmd open TypeDecl open Expr

  /-
   - Typecheck the called arguments against a signature and make a list
   - that can be used by Store.updates
   -/
  def input_updates: Store → list (Σ α, Expr α) → list (string × TypeDecl)
                    → option (list (string × (Σ α, Val α)))
    | _ []                    []              := some []
    | _ []                    _               := none
    | _ _                     []              := none
    | s (⟨vtype, x⟩::vs) ((sname, stype)::ss) := do
      rest <- input_updates s vs ss,
      val ← eval x s,
      if vtype = stype then some $ ((sname, ⟨_, val⟩))::rest  else none

  /-
   - Construct inner context for a method call
   -/
  def method_input_ctx: Ctx → Sig → list (Σ α, Expr α) → Π{struct},
                        Expr (gPtr (gRef struct)) ⊕ Expr (gRef struct)
                        → option Ctx
    | ⟨s,h,d⟩ ⟨sargs, _, rec, ptr⟩ args str callee := do
        updates ← input_updates s args (from_pairmap sargs),
        callee' ← callee.elim (eval_generic s) (eval_generic s),
        let call_type := (if ptr then gPtr (gRef str) else gRef str),
        callee'' ← as_type callee'.2 call_type,
        let s' := Store.from_list ((rec, ⟨_, callee''⟩)::updates),
        some ⟨s', h, d⟩

  /-
   - Given an outer context and a result context from a method call, use the
   - of the method to appropriately update the outer context.
   -/
  def method_update_ctx: Ctx → Ctx → Sig → list (Σ α, Var α) → option Ctx
    | ⟨s, h, d⟩ ⟨s', h', _⟩ ⟨_,ret,_,_⟩ retv := do
      let retlist := from_pairmap ret,
      updates ← input_updates s'
        (retlist.map (λ name_typ,  ⟨_, @getvar name_typ.2 ⟨name_typ.1⟩⟩))
        (retv.map (λ v, (v.2.name,v.1))),
      some ⟨s.updates updates, h', d⟩

  inductive exec: option Ctx → cmd → option Ctx → Prop
    | exec_none: ∀ c, exec none c none

    | exec_skip: ∀ s, exec (some s) skip (some s)
    /-
     - Assign
     -/
      | exec_assign: ∀ {α:TypeDecl} (s:Store) (h:Heap) (d: Decls) (x: Var α)
                          (e: Expr α) (v: Val α),
        (eval e s) = some v
              → exec (some (s, h, d)) (x ⇐ e) (some (s.update v x.name, h, d))

      | exec_assign_fail: ∀ {α:TypeDecl} (s:Store) (h:Heap) (d: Decls)
                            (x: Var α) (e: Expr α),
        (eval e s) = none
              → exec (some (s, h, d)) (x ⇐ e) none
    /-
     - Lookup
     -/
      | exec_lookup: ∀ {α: TypeDecl} (s: Store) (h: Heap) (x: Var α) (d: Decls)
                          (e: Expr (gPtr α)) (p: Address) (v: Val α),
        val2loc (eval e s) = some p → -- the relative int is cast to a location
        h.lookup p = some v →         -- extract the corresponding cell contents
        exec (some (s, h, d)) (x ↩ e) (some (s.update v x.name, h, d))

      | exec_lookup_err: ∀ {α: TypeDecl} (s: Store) (h: Heap) (x: Var α)
                              (e: Expr (gPtr α)) (p: Address) (d: Decls),
        val2loc (eval e s) = some p →
        h.lookup p = @none (Val α) → -- mem location not allocated
        exec (some (s, h, d)) (x ↩ e) none

      -- Lookup fails due to pointer expression failing
      | exec_lookup_err_px: ∀ {α: TypeDecl} (s: Store) (h: Heap) (x: Var α)
                              (e: Expr (gPtr α)) (d: Decls),
        val2loc (eval e s) = none → exec (some (s, h, d)) (x ↩ e) none
    /-
     - Mutation
     -/
      -- Successful mutation defined by heap.update
      | exec_mutation: ∀ {α: TypeDecl} (s: Store) (h: Heap)
                            (e: Expr (gPtr α)) (e': Expr α)
                            (p: Address) (v v2: Val α) (d: Decls),
        val2loc (eval e s) = some p → -- compute the address
        h.lookup p = some v2 → -- Check the address is assigned (ignore val)
        (eval e' s) = some v → -- compute the new value to point to\

        exec (some (s, h, d)) (e ≪ e') (some (s, h.update v p, d))

        -- Mutation fails because of looking at null pointer
      | exec_mutation_err: ∀ {α: TypeDecl} (s: Store) (h: Heap) (d: Decls)
                            (e: Expr (gPtr α)) (e': Expr α) (p: Address),
        val2loc (eval e s) = some p →
        h.lookup p = @none (Val α) →
        exec (some (s, h, d)) (e ≪ e') none

        -- Mutation fails due to pointer expression failing
      | exec_mutation_err_px: ∀ {α: TypeDecl} (s: Store) (h: Heap) (d: Decls)
                            (e: Expr (gPtr α)) (e': Expr α),
        val2loc (eval e s) = none → exec (some (s, h, d)) (e ≪ e') none

      | exec_seq: ∀ s s' s'' c d,
        exec s c s' → exec s' d s'' → exec s (c ∣ d) s''

    /-
     - While
     -/
      | exec_while_true: ∀ (s: Store) (h: Heap) (d: Decls) (s' s'': Ctx)
                            (b: Expr gBool) (c: cmd) ,
        eval b s = some tt →
        exec (some (s, h, d)) c s' →
        exec s' (while b c) s'' →
        exec (some (s, h, d)) (while b c) s''

      | exec_while_false: ∀ (s: Store) (h: Heap) (d: Decls) (b: Expr gBool)
                            (c: cmd),
        eval b s = some ff →
        exec (some (s, h, d)) (while b c) (some (s, h, d))

      | exec_while_err: ∀ (s: Store) (h: Heap) (d: Decls) (b: Expr gBool)
                          (c: cmd),
        eval b s = none → exec (some (s, h, d)) (while b c) none
    /-
     - If then else
     -/
      | exec_ifte_true: ∀ (b: Expr gBool) (x y: cmd) (s: Store) (h: Heap)
                          (d: Decls) s',
        eval b s = some tt →
        exec (some (s, h, d)) x s' →
        exec (some (s, h, d)) (ifte b x y) s'

      | exec_ifte_false: ∀ (b: Expr gBool) (c d: cmd) (s: Store) (h: Heap)
                          (d': Decls) s',
        eval b s = some ff →
        exec (some (s, h, d')) d s' →
        exec (some (s, h, d')) (ifte b  c  d) s'

      | exec_ifte_err: ∀ (b: Expr gBool) (c d: cmd) (s: Store) (h: Heap)
                        (d': Decls),
        eval b s = none →
        exec (some (s, h, d')) (ifte b  c  d) none

  /- Needed if malloc and free are included

    | exec_malloc: ∀ {α: TypeDecl} (s :Store) (h: Heap ) (x: Var (gPtr α))
                      (e: Expr α) (n: Address) (v: Val α),
      eval e s = some v →
      (h # Heap.singleton n v) →
      exec (some (s, h)) (malloc x e)
          (some (@Store.update s (gPtr α) n.val x.name,
                h ++ Heap.singleton n v))

    | exec_malloc_err: ∀ {α: TypeDecl} (s :Store) (h: Heap ) (x: Var (gPtr α))
                        (e: Expr α) (n: Address) (v: Val α),
      eval e s = none →  exec (some (s, h)) (malloc x e) none

    | exec_free: ∀ {α: TypeDecl} (s :Store) (h: Heap ) (e: Expr (gPtr α))
                  (val: Val α) (ptr: Address),
      val2loc (eval e s) = some ptr  → h.lookup ptr = some val →
        exec (some (s, h))  (free e) (some (s, h.erase ptr))

    -- Free fails because there is nothing in the heap at the pointer
    | exec_free_err: ∀ {α: TypeDecl} (s :Store) (h: Heap ) (e: Expr (gPtr α))
                      (val: Val α) (ptr: Address),
      val2loc (eval e s) = some ptr  → h.lookup ptr = some val →
        exec (some (s, h))  (free e) (some (s, h.erase ptr))

    -- Free fails because the pointer expression is erroneous
    | exec_free_err_px: ∀ {α: TypeDecl} (s: Store) (h: Heap)
                          (e: Expr (gPtr α)),
      val2loc (eval e s) = none →
        exec (some (s, h))  (free e) none
  -/

  /-
   - Alternative to "exec" which actually runs a program. Because this may not
   - terminate, it is tagged as "meta".
   -/
  meta def compute: Ctx → cmd → option Ctx
    | s skip := some s

    | s (v ⇐ x) := eval x s.1 >>= λ xv, s.update_store
                                         (s.1.update xv v.name)

    | s (v ↩ x) := do  p ← val2loc (eval x s.1),
                       z ← @Heap.lookup v.gotype s.2.1 p,
                       s.update_store (s.1.update z v.name)

    | s (v ≪ x) := do p ← val2loc (eval v s.1),
                       _ ← @Heap.lookup x.gotype s.2.1 p,
                       v ← @eval x.gotype x s.1,
                       s.update_heap (s.2.1.update v p)

    | s (c ∣ d) := compute s c >>= λ s', compute s' d

    | s (while b c) := eval b s.1 >>= λ bv, if bv = tt
          then (compute s c) >>= λ c', compute c' (while b c)
          else s

    | s (ifte b c d) := eval b s.1 >>= λ bv, compute s (if bv = tt
                                                        then c else d)

    | s (@declare (α) x) := do dval ← default α s.2.2,
                               s.update_store (s.1.update dval x.name)

    | s (@new (α) x) := do
      pval ← default α s.2.2,            -- create a value to initialize with
      val  ← as_type pval α,             -- enforce correct type
      let (h,p) := s.2.1.insert α val,   -- insert into heap + get ptr value
      compute (s.update_heap h)          -- store the value to the ptr
              (x ⇐ (@Expr.const (gPtr α) p.val))

     | s (@call str callee meth args ret) := do
        (sig, prog) ← s.method str meth,
        input_ctx   ← method_input_ctx s sig args callee,
        new_ctx     ← compute input_ctx prog ,
        method_update_ctx s new_ctx sig ret

end semantics

section cmd_properties
  open TypeDecl
  /-
  - inversion lemmas
  -/

  lemma from_none' : ∀ s0 c s, exec s0 c s → s0 = none → s = none := sorry

  lemma from_none : ∀ c s, exec none c s → s = none := sorry.

  lemma assign_inv: ∀ α d s h (v: Var α) (x: Expr α) s' h' val,
    exec (some (s, h, d)) (v ⇐ x) (some (s', h', d))
    → (eval x s) = some val
    →  h = h' ∧ s' = s.update val v.name := sorry .

  lemma lookup_not_none: ∀ α s h d (v: Var α) (e: Expr (gPtr α)),
    ¬ (exec (some (s, h, d)) (v ↩ e) none)
      → ∃ p, val2loc (eval e s) = some p
        ∧ ∃ (z: Val α), h.lookup p = some z

  lemma mutation_not_none: ∀ α s h d (e: Expr α) (e': Expr (gPtr α)),
   ¬ exec (some (s,h,d)) (e' ≪ e) none
     → ∃ p, val2loc (eval e' s) = some p
      ∧ ∃ (z: Val α), h.lookup p = some z
      ∧ eval e s = some z := sorry

  lemma terminates : ∀ (c : cmd) s, ∃ s', exec (some s) c s' := sorry.

end cmd_properties


/-
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 category_theory.Fintype
import order.category.PartOrd

/-!
# The category of finite partial orders

This defines `FinPartOrd`, the category of finite partial orders.

Note: `FinPartOrd` is NOT a subcategory of `BddOrd` because its morphisms do not
preserve `⊥` and `⊤`.

## TODO

`FinPartOrd` is equivalent to a small category.
-/

universes u v

open category_theory

/-- The category of finite partial orders with monotone functions. -/
structure FinPartOrd :=
(to_PartOrd : PartOrd)
[is_fintype : fintype to_PartOrd]

namespace FinPartOrd

instance : has_coe_to_sort FinPartOrd Type* := ⟨λ X, X.to_PartOrd⟩
instance (X : FinPartOrd) : partial_order X := X.to_PartOrd.str
attribute [instance]  FinPartOrd.is_fintype

@[simp] lemma coe_to_PartOrd (X : FinPartOrd) : ↥X.to_PartOrd = ↥X := rfl

/-- Construct a bundled `FinPartOrd` from `fintype` + `partial_order`. -/
def of (α : Type*) [partial_order α] [fintype α] : FinPartOrd := ⟨⟨α⟩⟩

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

instance : inhabited FinPartOrd := ⟨of punit⟩

instance large_category : large_category FinPartOrd :=
induced_category.category FinPartOrd.to_PartOrd

instance concrete_category : concrete_category FinPartOrd :=
induced_category.concrete_category FinPartOrd.to_PartOrd

instance has_forget_to_PartOrd : has_forget₂ FinPartOrd PartOrd :=
induced_category.has_forget₂ FinPartOrd.to_PartOrd

instance has_forget_to_Fintype : has_forget₂ FinPartOrd Fintype :=
{ forget₂ := { obj := λ X, ⟨X⟩, map := λ X Y, coe_fn } }

/-- Constructs an isomorphism of finite partial orders from an order isomorphism between them. -/
@[simps] def iso.mk {α β : FinPartOrd.{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 : FinPartOrd ⥤ FinPartOrd :=
{ obj := λ X, of Xᵒᵈ, map := λ X Y, order_hom.dual }

/-- The equivalence between `FinPartOrd` and itself induced by `order_dual` both ways. -/
@[simps functor inverse] def dual_equiv : FinPartOrd ≌ FinPartOrd :=
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 FinPartOrd

lemma FinPartOrd_dual_comp_forget_to_PartOrd :
  FinPartOrd.dual ⋙ forget₂ FinPartOrd PartOrd =
    forget₂ FinPartOrd PartOrd ⋙ PartOrd.dual := rfl


import coprod.basic
import data.int.basic
import algebra.group_power
import logic.embedding
import data.equiv.mul_add
import group_theory.subgroup

notation `C∞` := multiplicative ℤ

@[reducible] def free_group (ι : Type*) := coprod (λ i : ι, C∞)

namespace free_group
variables {ι : Type*} [decidable_eq ι] {M : Type*} [monoid M] {G : Type*} [group G]
variables {α : Type*} {β : Type*} {γ : Type*} [decidable_eq α] [decidable_eq β] [decidable_eq γ]

open function coprod coprod.pre multiplicative

instance : group (free_group ι) := @coprod.group ι (λ i : ι, C∞) _ _ _
instance : decidable_eq (free_group ι) := coprod.decidable_eq

def of (i : ι) : free_group ι := ⟨[⟨i, of_add 1⟩], reduced_singleton dec_trivial⟩

def of' (i : ι) : C∞ →* free_group ι := coprod.of i

def length : free_group α → ℕ :=
λ w, (w.to_list.map (λ a : Σ i : α, C∞, a.2.to_add.nat_abs)).sum

@[simp] lemma cons_eq_of'_mul (l : list (Σ i : ι, C∞))
  (g : Σ i : ι, C∞) (h) :
  @eq (free_group ι) ⟨g :: l, h⟩ (of' g.1 g.2 * ⟨l, reduced_of_reduced_cons h⟩) :=
coprod.cons_eq_of_mul _ _

@[simp] lemma append_eq_mul {l₁ l₂ : list (Σ i : ι, C∞)} (hl : reduced (l₁ ++ l₂)) :
  @eq (free_group ι) ⟨l₁ ++ l₂, hl⟩ (⟨l₁, reduced_of_reduced_append_left hl⟩ *
    ⟨l₂, reduced_of_reduced_append_right hl⟩) :=
coprod.append_eq_mul _

lemma of'_eq_of_pow (i : ι) (n : C∞) : of' i n = (of i) ^ n.to_add :=
calc of' i n = gpowers_hom _ (of i) n : congr_fun (congr_arg _ (monoid_hom.ext_int rfl)) _
... = _ : rfl

@[simp] lemma nil_eq_one (h): @eq (free_group ι) ⟨[], h⟩ 1 := rfl

@[simp] lemma eta (w : free_group ι) : (⟨w.1, w.2⟩ : free_group ι) = w := by cases w; refl

lemma of_eq_of' (i : ι) : of i = of' i (of_add 1) := rfl

def lift' (f : Π i : ι, C∞ →* M) : free_group ι →* M :=
coprod.lift f

def lift (f : ι → G) : free_group ι →* G :=
lift' (λ i, gpowers_hom _ (f i))

@[simp] lemma lift'_of' (f : Π i : ι, C∞ →* M) (i : ι) (n : C∞) :
  lift' f (of' i n) = f i n := by simp [lift', of']

@[simp] lemma lift_of (f : Π i : ι, G) (i : ι) :
  lift f (of i) = f i := by simp [lift, of_eq_of', gpowers_hom]

@[simp] lemma lift'_comp_of' (f : Π i : ι, C∞ →* M) (i : ι) :
  (lift' f).comp (of' i) = f i := by ext; simp

@[elab_as_eliminator]
def rec_on' {C : free_group ι → Prop}
  (g : free_group ι)
  (h1 : C 1)
  (hof : ∀ i n, C (of' i n))
  (f : Π (i : ι) (n : C∞) (h : free_group ι), C (of' i n) → C h → C (of' i n * h)) : C g :=
coprod.rec_on g h1 hof f

@[elab_as_eliminator]
lemma rec_on {C : free_group ι → Prop}
  (g : free_group ι)
  (h1 : C (1 : free_group ι))
  (hof : ∀ i, C (of i))
  (hinv : ∀ i, C ((of i)⁻¹))
  (hmul : Π (a b : free_group ι), C a → C b → C (a * b)) :
  C g :=
free_group.rec_on' g h1 (begin
  assume i n,
  refine int.induction_on n _ _ _,
  { change (0 : ℤ) with (1 : C∞), simpa },
  { assume n h,
    change (n + 1 : ℤ) with (of_add (n + 1 : ℤ)),
    rw [of_add_add, monoid_hom.map_mul],
    exact hmul _ _ h (hof _) },
  { assume n h,
    change (-n - 1 : ℤ) with (of_add (-n - 1 : ℤ)),
    erw [sub_eq_add_neg, of_add_add, of_add_neg, of_add_neg,
      monoid_hom.map_mul, monoid_hom.map_inv (of' i) (of_add 1), ← of_eq_of'],
    exact hmul _ _ h (hinv _) },
end)
(λ i a h , hmul _ _)

lemma hom_ext {f g : free_group ι →* M} (h : ∀ i, f (of i) = g (of i)) : f = g :=
coprod.hom_ext (λ i, monoid_hom.ext_int (h i))

@[simp] lemma lift_of₂ : lift (of : ι → free_group ι) = monoid_hom.id _ :=
free_group.hom_ext (by simp)

lemma lift'_eq_lift (f : Π i : ι, C∞ →* G) : lift' f = lift (λ i, f i (of_add 1)) :=
hom_ext (λ i, by rw [lift_of, of_eq_of', lift'_of'])

section map

variables {κ : Type*} [decidable_eq κ] (f : ι → κ)

def map : free_group ι →* free_group κ := lift' (λ i, of' (f i))

@[simp] lemma map_of (i : ι): map f (of i) = of (f i) := by simp [map, of_eq_of']

@[simp] lemma map_of' (i : ι) (n : C∞) : map f (of' i n) = of' (f i) n :=
by simp [map, of_eq_of']

@[simp] lemma map_comp_of' (i : ι) : (map f).comp (of' i) = of' (f i) :=
by simp [map, of_eq_of']

lemma lift_comp_map (g : κ → G) : (lift g).comp (map f) = lift (λ x, g (f x)) :=
hom_ext (by simp)

lemma lift_map (g : κ → G) (w : free_group ι) : lift g (map f w) = lift (λ x, g (f x)) w :=
by rw [← monoid_hom.comp_apply, lift_comp_map]

@[simp] lemma map_id : map (λ x, x : ι → ι) = monoid_hom.id _ :=
free_group.hom_ext (by simp [map, of_eq_of'])

end map

protected def embedding (e : α ↪ β) : free_group α →* free_group β :=
{ to_fun := λ x, ⟨pre.embedding e.1 (λ _, monoid_hom.id _) x.1,
    pre.reduced_embedding _ e.2 _ (by simp) x.2⟩,
  map_one' := rfl,
  map_mul' := λ _ _, subtype.eq (by dsimp; exact pre.embedding_mul e.1 e.2
    (λ _, monoid_hom.id _) (by simp)) }

@[simp] lemma embedding_of' (e : α ↪ β) (a : α) (n : C∞) :
  free_group.embedding e (of' a n) = of' (e a) n :=
subtype.eq begin
  simp [free_group.embedding, of', coprod.of, coprod.pre.of, pre.embedding],
  split_ifs; simp
end

@[simp] lemma embedding_of (e : α ↪ β) (a : α) :
  free_group.embedding e (of a) = of (e a) :=
by simp [of_eq_of']

@[simp] lemma embedding_id : free_group.embedding (embedding.refl α) = monoid_hom.id _ :=
free_group.hom_ext (λ _, by simp)

@[simp] lemma embedding_trans (e₁ : α ↪ β) (e₂ : β ↪ γ) :
  free_group.embedding (e₁.trans e₂) = (free_group.embedding e₂).comp (free_group.embedding e₁) :=
free_group.hom_ext (λ _, by simp)

protected def equiv (e : α ≃ β) : free_group α ≃* free_group β :=
{ to_fun := free_group.embedding e.to_embedding,
  inv_fun := free_group.embedding e.symm.to_embedding,
  left_inv := λ x, begin
      rw [← monoid_hom.comp_apply],
      conv_rhs { rw ← monoid_hom.id_apply x },
      refine congr_fun (congr_arg _ (free_group.hom_ext (by simp))) _
    end,
  right_inv := λ x, begin
      rw [← monoid_hom.comp_apply],
      conv_rhs { rw ← monoid_hom.id_apply x },
      refine congr_fun (congr_arg _ (free_group.hom_ext (by simp))) _
    end,
  map_mul' := by simp }

@[simp] lemma equiv_refl : free_group.equiv (equiv.refl α) = mul_equiv.refl _ :=
by ext; simp [free_group.equiv]

@[simp] lemma equiv_trans (e₁ : α ≃ β) (e₂ : β ≃ γ) :
  free_group.equiv (e₁.trans e₂) = (free_group.equiv e₁).trans (free_group.equiv e₂) :=
by ext; simp [free_group.equiv]

@[simp] lemma equiv_of' (e : α ≃ β) (a : α) (n : C∞) :
  free_group.equiv e (of' a n) = of' (e a) n :=
by ext; simp [free_group.equiv]

@[simp] lemma equiv_of (e : α ≃ β) (a : α) :
  free_group.equiv e (of a) = of (e a) :=
by simp [free_group.equiv]

def exp_sum (i : ι) : free_group ι →* C∞ :=
free_group.lift' (λ j, if i = j then monoid_hom.id _ else 1)

@[simp] def exp_sum_of' (t i : ι) (n : C∞) : exp_sum t (of' i n) = if t = i then n else 1 :=
by simp [exp_sum]; split_ifs; simp

@[simp] def exp_sum_of (t i : ι) : exp_sum t (of i) = if t = i then of_add (1 : ℤ) else 1 :=
by simp [exp_sum]; split_ifs; simp [of_eq_of', *]

end free_group


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import algebraic_geometry.Spec
import algebra.category.Ring.constructions

/-!
# The category of schemes

A scheme is a locally ringed space such that every point is contained in some open set
where there is an isomorphism of presheaves between the restriction to that open set,
and the structure sheaf of `Spec R`, for some commutative ring `R`.

A morphism of schemes is just a morphism of the underlying locally ringed spaces.

-/

noncomputable theory

open topological_space
open category_theory
open Top
open opposite

namespace algebraic_geometry

/--
We define `Scheme` as a `X : LocallyRingedSpace`,
along with a proof that every point has an open neighbourhood `U`
so that that the restriction of `X` to `U` is isomorphic,
as a locally ringed space, to `Spec.to_LocallyRingedSpace.obj (op R)`
for some `R : CommRing`.
-/
structure Scheme extends to_LocallyRingedSpace : LocallyRingedSpace :=
(local_affine : ∀ x : to_LocallyRingedSpace, ∃ (U : open_nhds x) (R : CommRing),
  nonempty (to_LocallyRingedSpace.restrict U.open_embedding ≅
    Spec.to_LocallyRingedSpace.obj (op R)))

namespace Scheme

/-- A morphism between schemes is a morphism between the underlying locally ringed spaces. -/
@[nolint has_nonempty_instance] -- There isn't nessecarily a morphism between two schemes.
def hom (X Y : Scheme) : Type* :=
X.to_LocallyRingedSpace ⟶ Y.to_LocallyRingedSpace

/--
Schemes are a full subcategory of locally ringed spaces.
-/
instance : category Scheme :=
{ hom := hom, ..(induced_category.category Scheme.to_LocallyRingedSpace) }

/-- The structure sheaf of a Scheme. -/
protected abbreviation sheaf (X : Scheme) := X.to_SheafedSpace.sheaf

/-- The forgetful functor from `Scheme` to `LocallyRingedSpace`. -/
@[simps, derive[full, faithful]]
def forget_to_LocallyRingedSpace : Scheme ⥤ LocallyRingedSpace :=
  induced_functor _

@[simp] lemma forget_to_LocallyRingedSpace_preimage {X Y : Scheme} (f : X ⟶ Y) :
  Scheme.forget_to_LocallyRingedSpace.preimage f = f := rfl

/-- The forgetful functor from `Scheme` to `Top`. -/
@[simps]
def forget_to_Top : Scheme ⥤ Top :=
  Scheme.forget_to_LocallyRingedSpace ⋙ LocallyRingedSpace.forget_to_Top

@[simp]
lemma id_val_base (X : Scheme) : (𝟙 X : _).1.base = 𝟙 _ := rfl

@[simp] lemma id_app {X : Scheme} (U : (opens X.carrier)ᵒᵖ) :
  (𝟙 X : _).val.c.app U = X.presheaf.map
    (eq_to_hom (by { induction U using opposite.rec, cases U, refl })) :=
PresheafedSpace.id_c_app X.to_PresheafedSpace U

@[reassoc]
lemma comp_val {X Y Z : Scheme} (f : X ⟶ Y) (g : Y ⟶ Z) :
  (f ≫ g).val = f.val ≫ g.val := rfl

@[reassoc, simp]
lemma comp_coe_base {X Y Z : Scheme} (f : X ⟶ Y) (g : Y ⟶ Z) :
  (f ≫ g).val.base = f.val.base ≫ g.val.base := rfl

@[reassoc, elementwise]
lemma comp_val_base {X Y Z : Scheme} (f : X ⟶ Y) (g : Y ⟶ Z) :
  (f ≫ g).val.base = f.val.base ≫ g.val.base := rfl

@[reassoc, simp]
lemma comp_val_c_app {X Y Z : Scheme} (f : X ⟶ Y) (g : Y ⟶ Z) (U) :
  (f ≫ g).val.c.app U = g.val.c.app U ≫ f.val.c.app _ := rfl

lemma congr_app {X Y : Scheme} {f g : X ⟶ Y} (e : f = g) (U) :
  f.val.c.app U = g.val.c.app U ≫ X.presheaf.map (eq_to_hom (by subst e)) :=
by { subst e, dsimp, simp }

lemma app_eq {X Y : Scheme} (f : X ⟶ Y) {U V : opens Y.carrier} (e : U = V) :
  f.val.c.app (op U) = Y.presheaf.map (eq_to_hom e.symm).op ≫
    f.val.c.app (op V) ≫ X.presheaf.map (eq_to_hom (congr_arg (opens.map f.val.base).obj e)).op :=
begin
  rw [← is_iso.inv_comp_eq, ← functor.map_inv, f.val.c.naturality, presheaf.pushforward_obj_map],
  congr
end
instance is_LocallyRingedSpace_iso {X Y : Scheme} (f : X ⟶ Y) [is_iso f] :
  @is_iso LocallyRingedSpace _ _ _ f :=
forget_to_LocallyRingedSpace.map_is_iso f

@[simp]
lemma inv_val_c_app {X Y : Scheme} (f : X ⟶ Y) [is_iso f] (U : opens X.carrier) :
  (inv f).val.c.app (op U) = X.presheaf.map (eq_to_hom $ by { rw is_iso.hom_inv_id, ext1, refl } :
    (opens.map (f ≫ inv f).1.base).obj U ⟶ U).op ≫
      inv (f.val.c.app (op $ (opens.map _).obj U)) :=
begin
  rw [is_iso.eq_comp_inv],
  erw ← Scheme.comp_val_c_app,
  rw [Scheme.congr_app (is_iso.hom_inv_id f),
    Scheme.id_app, ← functor.map_comp, eq_to_hom_trans, eq_to_hom_op],
  refl
end

/-- Given a morphism of schemes `f : X ⟶ Y`, and open sets `U ⊆ Y`, `V ⊆ f ⁻¹' U`,
this is the induced map `Γ(Y, U) ⟶ Γ(X, V)`. -/
abbreviation hom.app_le {X Y : Scheme}
  (f : X ⟶ Y) {V : opens X.carrier} {U : opens Y.carrier} (e : V ≤ (opens.map f.1.base).obj U) :
    Y.presheaf.obj (op U) ⟶ X.presheaf.obj (op V) :=
f.1.c.app (op U) ≫ X.presheaf.map (hom_of_le e).op

/--
The spectrum of a commutative ring, as a scheme.
-/
def Spec_obj (R : CommRing) : Scheme :=
{ local_affine := λ x,
  ⟨⟨⊤, trivial⟩, R, ⟨(Spec.to_LocallyRingedSpace.obj (op R)).restrict_top_iso⟩⟩,
  to_LocallyRingedSpace := Spec.LocallyRingedSpace_obj R }

@[simp] lemma Spec_obj_to_LocallyRingedSpace (R : CommRing) :
  (Spec_obj R).to_LocallyRingedSpace = Spec.LocallyRingedSpace_obj R := rfl

/--
The induced map of a ring homomorphism on the ring spectra, as a morphism of schemes.
-/
def Spec_map {R S : CommRing} (f : R ⟶ S) :
  Spec_obj S ⟶ Spec_obj R :=
(Spec.LocallyRingedSpace_map f : Spec.LocallyRingedSpace_obj S ⟶ Spec.LocallyRingedSpace_obj R)

@[simp] lemma Spec_map_id (R : CommRing) :
  Spec_map (𝟙 R) = 𝟙 (Spec_obj R) :=
Spec.LocallyRingedSpace_map_id R

lemma Spec_map_comp {R S T : CommRing} (f : R ⟶ S) (g : S ⟶ T) :
  Spec_map (f ≫ g) = Spec_map g ≫ Spec_map f :=
Spec.LocallyRingedSpace_map_comp f g

/--
The spectrum, as a contravariant functor from commutative rings to schemes.
-/
@[simps] def Spec : CommRingᵒᵖ ⥤ Scheme :=
{ obj := λ R, Spec_obj (unop R),
  map := λ R S f, Spec_map f.unop,
  map_id' := λ R, by rw [unop_id, Spec_map_id],
  map_comp' := λ R S T f g, by rw [unop_comp, Spec_map_comp] }

/--
The empty scheme.
-/
@[simps]
def {u} empty : Scheme.{u} :=
{ carrier := Top.of pempty,
  presheaf := (category_theory.functor.const _).obj (CommRing.of punit),
  is_sheaf := presheaf.is_sheaf_of_is_terminal _ CommRing.punit_is_terminal,
  local_ring := λ x, pempty.elim x,
  local_affine := λ x, pempty.elim x }

instance : has_emptyc Scheme := ⟨empty⟩

instance : inhabited Scheme := ⟨∅⟩

/--
The global sections, notated Gamma.
-/
def Γ : Schemeᵒᵖ ⥤ CommRing :=
(induced_functor Scheme.to_LocallyRingedSpace).op ⋙ LocallyRingedSpace.Γ

lemma Γ_def : Γ = (induced_functor Scheme.to_LocallyRingedSpace).op ⋙ LocallyRingedSpace.Γ := rfl

@[simp] lemma Γ_obj (X : Schemeᵒᵖ) : Γ.obj X = (unop X).presheaf.obj (op ⊤) := rfl

lemma Γ_obj_op (X : Scheme) : Γ.obj (op X) = X.presheaf.obj (op ⊤) := rfl

@[simp] lemma Γ_map {X Y : Schemeᵒᵖ} (f : X ⟶ Y) :
  Γ.map f = f.unop.1.c.app (op ⊤) := rfl

lemma Γ_map_op {X Y : Scheme} (f : X ⟶ Y) :
  Γ.map f.op = f.1.c.app (op ⊤) := rfl

section basic_open

variables (X : Scheme) {V U : opens X.carrier} (f g : X.presheaf.obj (op U))

/-- The subset of the underlying space where the given section does not vanish. -/
def basic_open : opens X.carrier := X.to_LocallyRingedSpace.to_RingedSpace.basic_open f

@[simp]
lemma mem_basic_open (x : U) : ↑x ∈ X.basic_open f ↔ is_unit (X.presheaf.germ x f) :=
RingedSpace.mem_basic_open _ _ _

@[simp]
lemma mem_basic_open_top (f : X.presheaf.obj (op ⊤)) (x : X.carrier) :
  x ∈ X.basic_open f ↔ is_unit (X.presheaf.germ (⟨x, trivial⟩ : (⊤ : opens _)) f) :=
RingedSpace.mem_basic_open _ f ⟨x, trivial⟩

@[simp]
lemma basic_open_res (i : op U ⟶ op V) :
  X.basic_open (X.presheaf.map i f) = V ⊓ X.basic_open f :=
RingedSpace.basic_open_res _ i f

-- This should fire before `basic_open_res`.
@[simp, priority 1100]
lemma basic_open_res_eq (i : op U ⟶ op V) [is_iso i] :
  X.basic_open (X.presheaf.map i f) = X.basic_open f :=
RingedSpace.basic_open_res_eq _ i f

@[sheaf_restrict]

@[simp]
lemma preimage_basic_open {X Y : Scheme} (f : X ⟶ Y) {U : opens Y.carrier}
  (r : Y.presheaf.obj $ op U) :
  (opens.map f.1.base).obj (Y.basic_open r) =
    @Scheme.basic_open X ((opens.map f.1.base).obj U) (f.1.c.app _ r) :=
LocallyRingedSpace.preimage_basic_open f r

@[simp]
lemma basic_open_zero (U : opens X.carrier) : X.basic_open (0 : X.presheaf.obj $ op U) = ⊥ :=
LocallyRingedSpace.basic_open_zero _ U

@[simp]
lemma basic_open_mul : X.basic_open (f * g) = X.basic_open f ⊓ X.basic_open g :=
RingedSpace.basic_open_mul _ _ _

lemma basic_open_of_is_unit {f : X.presheaf.obj (op U)} (hf : is_unit f) : X.basic_open f = U :=
RingedSpace.basic_open_of_is_unit _ hf

end basic_open

end Scheme

lemma basic_open_eq_of_affine {R : CommRing} (f : R) :
  (Scheme.Spec.obj $ op R).basic_open ((Spec_Γ_identity.app R).inv f) =
    prime_spectrum.basic_open f :=
begin
  ext,
  erw Scheme.mem_basic_open_top,
  suffices : is_unit (structure_sheaf.to_stalk R x f) ↔ f ∉ prime_spectrum.as_ideal x,
  { exact this },
  erw [← is_unit_map_iff (structure_sheaf.stalk_to_fiber_ring_hom R x),
    structure_sheaf.stalk_to_fiber_ring_hom_to_stalk],
  exact (is_localization.at_prime.is_unit_to_map_iff
    (localization.at_prime (prime_spectrum.as_ideal x)) (prime_spectrum.as_ideal x) f : _)
end

@[simp]
lemma basic_open_eq_of_affine' {R : CommRing}
  (f : (Spec.to_SheafedSpace.obj (op R)).presheaf.obj (op ⊤)) :
  (Scheme.Spec.obj $ op R).basic_open f =
    prime_spectrum.basic_open ((Spec_Γ_identity.app R).hom f) :=
begin
  convert basic_open_eq_of_affine ((Spec_Γ_identity.app R).hom f),
  exact (iso.hom_inv_id_apply _ _).symm
end

end algebraic_geometry


example (x y : ℕ) (h : x = y) : y = x :=
begin
  revert h,
  intro h₁,
  symmetry,
  assumption
end


/-
Copyright (c) 2019 Floris van Doorn. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Floris van Doorn
-/
import tactic.rcases
/-!
# lift tactic

This file defines the `lift` tactic, allowing the user to lift elements from one type to another
under a specified condition.

## Tags

lift, tactic
-/

/-- A class specifying that you can lift elements from `α` to `β` assuming `cond` is true.
  Used by the tactic `lift`. -/
class can_lift (α β : Sort*) :=
(coe : β → α)
(cond : α → Prop)
(prf : ∀(x : α), cond x → ∃(y : β), coe y = x)

open tactic

/--
A user attribute used internally by the `lift` tactic.
This should not be applied by hand.
-/
@[user_attribute]
meta def can_lift_attr : user_attribute (list name) :=
{ name := "_can_lift",
  descr := "internal attribute used by the lift tactic",
  parser := failed,
  cache_cfg :=
  { mk_cache := λ _,
      do { ls ← attribute.get_instances `instance,
          ls.mfilter $ λ l,
          do { (_,t) ← mk_const l >>= infer_type >>= open_pis,
          return $ t.is_app_of `can_lift } },
    dependencies := [`instance] } }

instance : can_lift ℤ ℕ :=
⟨coe, λ n, 0 ≤ n, λ n hn, ⟨n.nat_abs, int.nat_abs_of_nonneg hn⟩⟩

/-- Enable automatic handling of pi types in `can_lift`. -/
instance pi.can_lift (ι : Type*) (α : Π i : ι, Type*) (β : Π i : ι, Type*)
  [Π i : ι, can_lift (α i) (β i)] :
  can_lift (Π i : ι, α i) (Π i : ι, β i) :=
{ coe := λ f i, can_lift.coe (f i),
  cond := λ f, ∀ i, can_lift.cond (β i) (f i),
  prf := λ f hf, ⟨λ i, classical.some (can_lift.prf (f i) (hf i)), funext $ λ i,
    classical.some_spec (can_lift.prf (f i) (hf i))⟩ }

instance pi_subtype.can_lift (ι : Type*) (α : Π i : ι, Type*) [ne : Π i, nonempty (α i)]
  (p : ι → Prop) :
  can_lift (Π i : subtype p, α i) (Π i, α i) :=
{ coe := λ f i, f i,
  cond := λ _, true,
  prf :=
    begin
      classical,
      refine λ f _, ⟨λ i, if hi : p i then f ⟨i, hi⟩ else classical.choice (ne i), funext _⟩,
      rintro ⟨i, hi⟩,
      exact dif_pos hi
    end }

instance pi_subtype.can_lift' (ι : Type*) (α : Type*) [ne : nonempty α] (p : ι → Prop) :
  can_lift (subtype p → α) (ι → α) :=
pi_subtype.can_lift ι (λ _, α) p

namespace tactic

/--
Construct the proof of `cond x` in the lift tactic.
*  `e` is the expression being lifted and `h` is the specified proof of `can_lift.cond e`.
*  `old_tp` and `new_tp` are the arguments to `can_lift` and `inst` is the `can_lift`-instance.
*  `s` and `to_unfold` contain the information of the simp set used to simplify.

If the proof was specified, we check whether it has the correct type.
If it doesn't have the correct type, we display an error message
(but first call dsimp on the expression in the message).

If the proof was not specified, we create assert it as a local constant.
(The name of this local constant doesn't matter, since `lift` will remove it from the context.)
-/
meta def get_lift_prf (h : option pexpr) (old_tp new_tp inst e : expr)
  (s : simp_lemmas) (to_unfold : list name) : tactic expr := do
  expected_prf_ty ← mk_app `can_lift.cond [old_tp, new_tp, inst, e],
  expected_prf_ty ← s.dsimplify to_unfold expected_prf_ty,
  if h_some : h.is_some then
    decorate_error "lift tactic failed." $ i_to_expr ``((%%(option.get h_some) : %%expected_prf_ty))
  else do
    prf_nm ← get_unused_name,
    prf ← assert prf_nm expected_prf_ty,
    swap,
    return prf

/-- Lift the expression `p` to the type `t`, with proof obligation given by `h`.
  The list `n` is used for the two newly generated names, and to specify whether `h` should
  remain in the local context. See the doc string of `tactic.interactive.lift` for more information.
  -/
meta def lift (p : pexpr) (t : pexpr) (h : option pexpr) (n : list name) : tactic unit :=
do
  propositional_goal <|>
    fail "lift tactic failed. Tactic is only applicable when the target is a proposition.",
  e ← i_to_expr p,
  old_tp ← infer_type e,
  new_tp ← i_to_expr ``(%%t : Sort*),
  inst_type ← mk_app ``can_lift [old_tp, new_tp],
  inst ← mk_instance inst_type <|>
    pformat!"Failed to find a lift from {old_tp} to {new_tp}. Provide an instance of\n  {inst_type}"
    >>= fail,
  /- make the simp set to get rid of `can_lift` projections -/
  can_lift_instances ← can_lift_attr.get_cache >>= λ l, l.mmap resolve_name,
  (s, to_unfold) ← mk_simp_set tt [] $ can_lift_instances.map simp_arg_type.expr,
  prf_cond ← get_lift_prf h old_tp new_tp inst e s to_unfold,
  let prf_nm := if prf_cond.is_local_constant then some prf_cond.local_pp_name else none,
  /- We use mk_mapp to apply `can_lift.prf` to all but one argument, and then just use expr.app
  for the last argument. For some reason we get an error when applying mk_mapp it to all
  arguments. -/
  prf_ex0 ← mk_mapp `can_lift.prf [old_tp, new_tp, inst, e],
  let prf_ex := prf_ex0 prf_cond,
  /- Find the name of the new variable -/
  new_nm ← if n ≠ [] then return n.head
    else if e.is_local_constant then return e.local_pp_name
    else get_unused_name,
  /- Find the name of the proof of the equation -/
  eq_nm ← if hn : 1 < n.length then return (n.nth_le 1 hn)
    else if e.is_local_constant then return `rfl
    else get_unused_name `h,
  /- We add the proof of the existential statement to the context and then apply
  `dsimp` to it, unfolding all `can_lift` instances. -/
  temp_nm ← get_unused_name,
  temp_e ← note temp_nm none prf_ex,
  dsimp_hyp temp_e s to_unfold {},
  /- We case on the existential. We use `rcases` because `eq_nm` could be `rfl`. -/
  rcases none (pexpr.of_expr temp_e) $ rcases_patt.tuple ([new_nm, eq_nm].map rcases_patt.one),
  /- If the lifted variable is not a local constant,
    try to rewrite it away using the new equality. -/
  when (¬ e.is_local_constant) (get_local eq_nm >>=
    λ e, interactive.rw ⟨[⟨⟨0, 0⟩, tt, (pexpr.of_expr e)⟩], none⟩ interactive.loc.wildcard),
  /- If the proof `prf_cond` is a local constant, remove it from the context,
    unless `n` specifies to keep it. -/
  if h_prf_nm : prf_nm.is_some ∧ n.nth 2 ≠ prf_nm then
    get_local (option.get h_prf_nm.1) >>= clear else skip

setup_tactic_parser

/-- Parses an optional token "using" followed by a trailing `pexpr`. -/
meta def using_texpr := (tk "using" *> texpr)?

/-- Parses a token "to" followed by a trailing `pexpr`. -/
meta def to_texpr := (tk "to" *> texpr)

namespace interactive

/--
Lift an expression to another type.
* Usage: `'lift' expr 'to' expr ('using' expr)? ('with' id (id id?)?)?`.
* If `n : ℤ` and `hn : n ≥ 0` then the tactic `lift n to ℕ using hn` creates a new
  constant of type `ℕ`, also named `n` and replaces all occurrences of the old variable `(n : ℤ)`
  with `↑n` (where `n` in the new variable). It will remove `n` and `hn` from the context.
  + So for example the tactic `lift n to ℕ using hn` transforms the goal
    `n : ℤ, hn : n ≥ 0, h : P n ⊢ n = 3` to `n : ℕ, h : P ↑n ⊢ ↑n = 3`
    (here `P` is some term of type `ℤ → Prop`).
* The argument `using hn` is optional, the tactic `lift n to ℕ` does the same, but also creates a
  new subgoal that `n ≥ 0` (where `n` is the old variable).
  + So for example the tactic `lift n to ℕ` transforms the goal
    `n : ℤ, h : P n ⊢ n = 3` to two goals
    `n : ℕ, h : P ↑n ⊢ ↑n = 3` and `n : ℤ, h : P n ⊢ n ≥ 0`.
* You can also use `lift n to ℕ using e` where `e` is any expression of type `n ≥ 0`.
* Use `lift n to ℕ with k` to specify the name of the new variable.
* Use `lift n to ℕ with k hk` to also specify the name of the equality `↑k = n`. In this case, `n`
  will remain in the context. You can use `rfl` for the name of `hk` to substitute `n` away
  (i.e. the default behavior).
* You can also use `lift e to ℕ with k hk` where `e` is any expression of type `ℤ`.
  In this case, the `hk` will always stay in the context, but it will be used to rewrite `e` in
  all hypotheses and the target.
  + So for example the tactic `lift n + 3 to ℕ using hn with k hk` transforms the goal
    `n : ℤ, hn : n + 3 ≥ 0, h : P (n + 3) ⊢ n + 3 = 2 * n` to the goal
    `n : ℤ, k : ℕ, hk : ↑k = n + 3, h : P ↑k ⊢ ↑k = 2 * n`.
* The tactic `lift n to ℕ using h` will remove `h` from the context. If you want to keep it,
  specify it again as the third argument to `with`, like this: `lift n to ℕ using h with n rfl h`.
* More generally, this can lift an expression from `α` to `β` assuming that there is an instance
  of `can_lift α β`. In this case the proof obligation is specified by `can_lift.cond`.
* Given an instance `can_lift β γ`, it can also lift `α → β` to `α → γ`; more generally, given
  `β : Π a : α, Type*`, `γ : Π a : α, Type*`, and `[Π a : α, can_lift (β a) (γ a)]`, it
  automatically generates an instance `can_lift (Π a, β a) (Π a, γ a)`.

`lift` is in some sense dual to the `zify` tactic. `lift (z : ℤ) to ℕ` will change the type of an
integer `z` (in the supertype) to `ℕ` (the subtype), given a proof that `z ≥ 0`;
propositions concerning `z` will still be over `ℤ`. `zify` changes propositions about `ℕ` (the
subtype) to propositions about `ℤ` (the supertype), without changing the type of any variable.
-/
meta def lift (p : parse texpr) (t : parse to_texpr) (h : parse using_texpr)
  (n : parse with_ident_list) : tactic unit :=
tactic.lift p t h n

add_tactic_doc
{ name       := "lift",
  category   := doc_category.tactic,
  decl_names := [`tactic.interactive.lift],
  tags       := ["coercions"] }

end interactive
end tactic


import topology.homotopy.equiv
import fun_groupoid_preserves_homotopic_3
import groupoid_properties
import category_theory.thin

noncomputable theory

section
class contractible (X : Type*) [topological_space X] : Prop :=
(hequiv_unit : nonempty (continuous_map.homotopy_equiv X punit))

variables {X Y Z : Type*} [topological_space X] [contractible X]
  [topological_space Y] [topological_space Z]

instance nonempty_of_contractible : nonempty X :=
begin
  refine nonempty.map (λ hequiv : continuous_map.homotopy_equiv X punit, _) contractible.hequiv_unit,
  exact hequiv.inv_fun punit.star,
end

def nullhomotopic (f : C(Y, Z)) : Prop := ∃ z : Z, continuous_map.homotopic f (continuous_map.const z)

lemma contractible_iff_id_nullhomotopic [nonempty Y] :
  contractible Y ↔ nullhomotopic (continuous_map.id : C(Y, Y))  :=
begin
  split,
  { rintro ⟨⟨hequiv_unit⟩⟩,
    use hequiv_unit.inv_fun punit.star,
    have : continuous_map.const (hequiv_unit.inv_fun punit.star) = hequiv_unit.inv_fun.comp hequiv_unit.to_fun :=
    by { ext, simp, congr, },
    simp only [continuous_map.id_coe, id.def, this],
    exact hequiv_unit.left_inv.symm, },
  { rintro ⟨y, id_to_y⟩,
    refine {hequiv_unit := ⟨_⟩},
    refine_struct
    { to_fun := continuous_map.const punit.star,
      inv_fun := continuous_map.const y, },
    { convert id_to_y.symm, },
    { convert continuous_map.homotopic.refl (continuous_map.id : C(punit, punit)), ext, } }
end

instance path_connected_space_of_contractible : path_connected_space X :=
begin
  have id_null : nullhomotopic (continuous_map.id : C(X, X)) := contractible_iff_id_nullhomotopic.mp infer_instance,
  cases id_null with b id_to_b,
  refine { nonempty := infer_instance, joined := _, },
  intros x y,
  transitivity b,
  { refine nonempty.map (λ H, _) id_to_b,
    exact H.to_path x, },
  { refine nonempty.map (λ H, _) id_to_b.symm,
    exact H.to_path y, },
end

lemma nullhomotopic_comp_left {Z' : Type*} [topological_space Z'] (f : C(Y, Z)) (nhf : nullhomotopic f) (g : C(Z, Z')) :
  nullhomotopic (g.comp f) :=
begin
  cases nhf with b f_to_const_b,
  use g b,
  exact continuous_map.homotopic.hcomp f_to_const_b (continuous_map.homotopic.refl g),
end
end

namespace fundamental_groupoid
universe u

variables {X : Top.{u}}

section
instance [nonempty X] : nonempty (fundamental_groupoid X) := by assumption
instance [subsingleton X] : subsingleton (fundamental_groupoid X) := by assumption

section
local attribute [instance] path.homotopic.setoid
instance [subsingleton X] {x₀ x₁ : fundamental_groupoid X} : subsingleton (x₀ ⟶ x₁) :=
begin
  rw subsingleton_iff,
  intros f g,
  apply quotient.induction_on₂ f g,
  intros a b,
  congr, ext, simp only [eq_iff_true_of_subsingleton],
end

end

end

section nonempty
local attribute [instance] path.homotopic.setoid
lemma nonempty_path_of_hompath {X : Type*} [topological_space X] {x₀ x₁ : X} (p : path.homotopic.quotient x₀ x₁) :
  joined x₀ x₁ := quotient.induction_on p nonempty.intro

lemma nonempty_hompath_of_path {X : Type*} [topological_space X] {x₀ x₁ : X} (p : joined x₀ x₁) :
  nonempty (path.homotopic.quotient x₀ x₁) := nonempty.map quotient.mk p
end nonempty

theorem fgrpd_connected_iff_path_connected :
  category_theory.is_connected (fundamental_groupoid X) ↔ path_connected_space X :=
begin
  split,
  { introI grpd_conn,
    refine { nonempty := grpd_conn.is_nonempty, joined := _ },
    intros x y,
    rw category_theory.groupoid.groupoid_connected_iff_hom at grpd_conn,
    apply nonempty_path_of_hompath,
    exact (grpd_conn x y).some, },
  { introI x_conn,
    haveI : nonempty (fundamental_groupoid X) := nonempty.map id x_conn.nonempty,
    rw category_theory.groupoid.groupoid_connected_iff_hom,
    intros a b,
    apply nonempty_hompath_of_path (path_connected_space.joined (to_top a : X) b), },
end

section
class simply_connected (X  : Top.{u}) : Prop :=
(equiv_punit : nonempty ((fundamental_groupoid X) ≌ category_theory.discrete punit))

variables [simply_connected X]

theorem thin_of_simply_connected (x y : fundamental_groupoid X) : subsingleton (x ⟶ y) :=
begin
  apply subsingleton.intro,
  intros a b,
  obtain ⟨equiv_punit : ((fundamental_groupoid X) ≌ category_theory.discrete punit)⟩ := simply_connected.equiv_punit,
  rw ← category_theory.equivalence.functor_map_inj_iff equiv_punit a b,
  ext, { apply_instance, },
end

section
local attribute [instance] path.homotopic.setoid

theorem all_paths_homotopic_of_simply_connect (x y : X) (p₁ p₂ : path x y) : path.homotopic p₁ p₂ :=
quotient.eq.mp (subsingleton_iff.mp (thin_of_simply_connected x y) ⟦p₁⟧ ⟦p₂⟧)

end

instance nonempty_of_simply_connected : nonempty X :=
begin
  refine nonempty.map (λ equiv_punit, _) (@simply_connected.equiv_punit X _),
  exact equiv_punit.inverse.obj punit.star,
end

instance : path_connected_space X :=
begin
  rw ← fgrpd_connected_iff_path_connected,
  rw category_theory.groupoid.groupoid_connected_iff_hom,
  intros a b,
  refine nonempty.map (λ equiv_punit, _) (@simply_connected.equiv_punit X _),
  have ax := (equiv_punit.unit_iso.app a).hom,
  have bx := (equiv_punit.unit_iso.app b).inv,
  simp [punit_eq_star (equiv_punit.functor.obj a)] at ax,
  simp [punit_eq_star (equiv_punit.functor.obj b)] at bx,
  exact ax ≫ bx,
end

variables {Y : Top.{u}} [contractible.{u u} Y]

set_option pp.universes true
section punit
private def π := fundamental_groupoid.fundamental_groupoid_functor

def fgrpd_to_unit : (fundamental_groupoid (Top.of punit : Top.{u})) ⥤ (category_theory.discrete punit : Type u) :=
{ obj := λ a, a,
  map := λ a a' f, category_theory.eq_to_hom (punit_eq a a'),
  map_id' := λ a, by simp,
  map_comp' := λ a a' a'', by simp, }

def unit_to_fgrpd : (category_theory.discrete punit) ⥤ (fundamental_groupoid (Top.of punit)) :=
{ obj := λ a, a,
  map := λ a a' f, category_theory.eq_to_hom (punit_eq a a'),
  map_id' := λ a, by simp,
  map_comp' := λ a a' a'', by simp, }

lemma top_punit_subsingleton : subsingleton (Top.of punit) :=
begin
  rw subsingleton_iff, intros,
  exact punit_eq x y,
end

local attribute [instance] top_punit_subsingleton

def punit_fgrpd : fundamental_groupoid (Top.of punit) ≌ category_theory.discrete punit.{u+1} :=
begin
  apply category_theory.equivalence.mk fgrpd_to_unit unit_to_fgrpd;
  refine category_theory.eq_to_iso _;
  apply category_theory.functor.ext;
  { intros, simp, },
end

instance simply_connected_punit : simply_connected (Top.of punit.{u+1}) :=
{ equiv_punit := nonempty.intro punit_fgrpd, }

end punit

instance simply_connected_of_contractible : simply_connected.{u} Y :=
begin
  refine { equiv_punit := nonempty.map (λ hequiv_unit, _) (@contractible.hequiv_unit Y _ _), },
  suffices : fundamental_groupoid Y ≌ fundamental_groupoid (Top.of punit.{u+1}),
  { exact this.trans punit_fgrpd, },
  refine equivalent_fundamental_groupoids Y (Top.of punit : Top.{u}) _,
  exact hequiv_unit,
end

end

end fundamental_groupoid


import Lean
structure A :=
  x : Nat
  a' : x = 1 := by trivial

#check A.a'

example (z : A) : z.x = 1 := by
  have := z.a'
  trace_state
  exact this

example (z : A) : z.x = 1 := by
  have := z.2
  trace_state
  exact this

#check A.rec

example (z : A) : z.x = 1 := by
  have ⟨x, a'⟩ := z
  trace_state
  subst a'
  rfl

example (z : A) : z.x = 1 := by
  induction z with
  | mk x a' =>
    trace_state
    subst a'
    rfl

structure B :=
  x : Nat
  y : Nat := 2

example (b : B) : b = { x := b.x, y := b.y } := by
  cases b with
  | mk x y => trace_state; rfl

open Lean
open Lean.Meta

def tst : MetaM Unit :=
  withLocalDeclD `a (mkConst ``A) fun a => do
    let e := mkProj ``A 1 a
    IO.println (← Meta.ppExpr (← inferType e))

#eval tst

example (z : A) : z.x = 1 := by
  match z with
  | { a' := h } => trace_state; exact h

example (z : A) : z.x = 1 := by
  match z with
  | A.mk x a' => trace_state; exact a'

example : A :=
  { x := 1, a' := _ }

example : A :=
  A.mk 1 _

def f (x : Nat) (h : x = 1) : A := A.mk x h

example : A :=
  f 2 _

example : A := by
  apply f
  done


import Mathlib.Init.Algebra.Order

/-  disjunctive syllogism -/
theorem mtp {p q : Prop} (hpq: p ∨ q)(hnp: ¬ p):  q :=  by cases hpq ; contradiction ; assumption

----------------------

inductive FamilyMembers where | father | mother | son | daughter open FamilyMembers
inductive Roles where | Murderer | Victim | Witness | Accessory open Roles

variable { role: FamilyMembers → Roles }

------------------

inductive Sexes where | male | female open Sexes

-- lemma eq_female_of_ne_male :∀ (s : Sexes) (_: s≠male),  s=female  | female, _ => rfl

def sex: FamilyMembers → Sexes
  | father => male
  | mother => female
  | son => male
  | daughter => female

-----------------

-- variable [LE FamilyMembers] [LT FamilyMembers]
variable [po:Preorder FamilyMembers]

variable { youngest oldest: FamilyMembers }
variable ( isYoungest: ∀ x, x ≠ youngest → youngest < x )
variable ( isOldest: ∀ x, x ≠ oldest → oldest > x )

axiom mother_older_then_children: mother > daughter ∧ mother > son

----------------------------------
variable { murderer victim witness accessory: FamilyMembers }

variable ( isMurderer: role murderer = Murderer )
variable ( isVictim: role victim = Victim )
variable ( isWitness: role witness = Witness )
variable ( isAccessory: role accessory = Accessory )

variable ( a1: (sex accessory) ≠ (sex witness) ) #check @a1
variable ( a2: (sex oldest) ≠ (sex witness) ) #check @a2
variable ( a3: (sex youngest) ≠ (sex victim) ) #check @a3
variable ( a4: accessory > victim )  #check @a4
variable ( a5: oldest = father ) #check @a5
variable ( a6: murderer ≠ youngest ) #check @a6

-------------------------------
lemma W_is_Female: (sex witness) = female := by
  have h1: (sex father) ≠ (sex witness) := a5 ▸ a2
  have h2: (sex father) = male := rfl
  have h3: (sex witness) ≠ male := Ne.symm (h2 ▸ h1)

  cases witness
  . exact False.elim (h3 rfl) -- father
  . rfl -- mother
  . exact False.elim (h3 rfl) -- son
  . rfl -- daughter

lemma A_is_Male: (sex accessory) = male := by
  have h: (sex accessory) ≠ female:= ( W_is_Female isWitness a1 a2 a5 ) ▸ a1

  cases accessory
  . rfl
  . apply False.elim ; rw [sex] at h ; contradiction
  . rfl
  . apply False.elim ; rw [sex] at h ; contradiction

lemma MW_or_DW : witness=mother ∨ witness=daughter :=   by
  have h4: (sex witness) = female := W_is_Female isWitness a1 a2 a5

  cases witness
  · apply False.elim ; simp [sex] at h4
  · apply Or.inl ; rfl
  · apply False.elim ; simp [sex] at h4
  · apply Or.inr ; rfl

  -- have h1: (sex father) ≠ (sex witness) := a5 ▸ a2
  -- have h2: (sex father) = male := rfl
  -- have h3: (sex witness) ≠ male := Ne.symm (h2 ▸ h1)
  -- have h4: (sex witness) = female := eq_female_of_ne_male (sex witness) h3

  -- match witness with
  -- | mother =>
  --   have h : mother = mother := rfl
  --   show mother=mother ∨ mother=daughter from Or.inl h
  -- | daughter =>
  --   have h : daughter = daughter := rfl
  --   show daughter=mother ∨ daughter=daughter from Or.inr h
  -- | son =>
  --   have h1 : sex son = male := rfl
  --   have h2 : male ≠ female := Sexes.noConfusion -- or by simp
  --   have h3 := Eq.trans h1.symm ( W_is_Female isWitness a1 a2 a5 )
  --   show son=mother ∨ son=daughter from absurd h3 h2
  -- | father =>
  --   have h1 : sex father = male := rfl
  --   have h2 : male ≠ female := Sexes.noConfusion -- or by simp
  --   have h3 := Eq.trans h1.symm ( W_is_Female isWitness a1 a2 a5 )
  --   show father=mother ∨ father=daughter from absurd h3 h2

lemma FA_or_SA : accessory=father ∨ accessory=son  := by
  cases accessory with
  | father => apply Or.inl; rfl
  | son => apply Or.inr; rfl
  | _ =>
    apply False.elim
    . cases (MW_or_DW isWitness a1 a2 a5) with
      | _ h => apply (h ▸ a1); exact Eq.refl (sex _)

-- youngest_is_daughter {role} [preorder] {youngest} {oldest} (isYoungest) (isOldest) {murderer}{victim}{witness}{accessory} (isMurderer) (isVictim) (isWitness) (isAccessory) (a1) (a2) (a3) (a4) (a5) (a6)
theorem youngest_is_daughter: youngest = daughter  := by
  cases youngest with
  | daughter => rfl
  | father =>
    apply False.elim
    . have h1 : father ≤ daughter := le_of_lt (isYoungest daughter noConfusion)
      have h2 : ¬ (father ≤ daughter) := not_le_of_gt ((a5 ▸ isOldest) daughter noConfusion)
      exact h2 h1
  | mother =>
    apply False.elim
    . have h1 : mother ≤ daughter := le_of_lt (isYoungest daughter noConfusion)
      have h2 : ¬ (mother ≤ daughter) := not_le_of_gt (mother_older_then_children.left)
      exact h2 h1
  | son =>
    cases victim with
    | father => exact False.elim (a3 rfl)
    | son => exact False.elim (a3 rfl)
    | mother =>
      have h0: role mother=Victim := isVictim
      have h1: role mother ≠ Witness := h0 ▸ noConfusion
      have h2: Witness = role witness := isWitness.symm
      have h3: role mother ≠ role witness  := h2 ▸ h1
      have h4:  mother ≠ witness  := mt (congrArg role) h3

      have h5:  witness=daughter  := match (MW_or_DW isWitness a1 a2 a5) with
        | .inr h => h
        | .inl h => False.elim ((Ne.symm h4) h)

      have h6 : murderer ≠ son := a6
      have h7 : murderer=father ∨ murderer=son := by
        cases murderer with
        | father => apply Or.inl; rfl
        | mother => exact Roles.noConfusion (h0 ▸ isMurderer)
        | son => apply Or.inr; rfl
        | daughter =>  exact Roles.noConfusion (isWitness ▸ h5.symm ▸ isMurderer)
      have h8 : murderer=father := mtp h7.symm h6

      have h9 : accessory=son := by
        cases accessory with
        | father => exact Roles.noConfusion (isMurderer ▸ h8.symm ▸ isAccessory)
        | mother => exact Roles.noConfusion (h0 ▸ isAccessory)
        | son => rfl
        | daughter =>  exact Roles.noConfusion (isWitness ▸ h5.symm ▸ isAccessory)

      ------------------------
      exact absurd mother_older_then_children.right (lt_asymm (h9 ▸  a4))
    | daughter =>
      have h0: role daughter=Victim := isVictim
      have h1: role daughter ≠ Witness := h0 ▸ noConfusion
      have h2: Witness = role witness := isWitness.symm
      have h3: role daughter ≠ role witness  := h2 ▸ h1
      have h4:  daughter ≠ witness  := mt (congrArg role) h3

      have h5:  witness=mother  := match (MW_or_DW isWitness a1 a2 a5) with
        | .inl h => h
        | .inr h => False.elim ((Ne.symm h4) h)

      -- have h6 : murderer ≠ son := a6
      have h7 : murderer=father ∨ murderer=son := by
        cases murderer with
        | father => apply Or.inl; rfl
        | daughter => exact Roles.noConfusion (h0 ▸ isMurderer)
        | son => exact False.elim (a6 rfl)
        | mother =>  exact Roles.noConfusion (isWitness ▸ h5.symm ▸ isMurderer)
      have h8 : murderer=father := mtp h7.symm a6

      have h9 : accessory=son := by
        cases accessory with
        | father => exact Roles.noConfusion (isMurderer ▸ h8.symm ▸ isAccessory)
        | daughter => exact Roles.noConfusion (h0 ▸ isAccessory)
        | son => rfl
        | mother =>  exact Roles.noConfusion (isWitness ▸ h5.symm ▸ isAccessory)

      ------------------------
      have h10 : ¬son < daughter:= lt_asymm (h9 ▸ a4)
      have h11 : son < daughter := (isYoungest daughter) noConfusion
      exact absurd h11 h10

theorem solution : witness = daughter ∧ victim = son ∧ accessory = father ∧ murderer = mother  := by
    have yyy : youngest = daughter := youngest_is_daughter isYoungest isOldest isMurderer isVictim isWitness isAccessory a1 a2 a3 a4 a5 a6

    cases victim with
    | daughter => exact False.elim (a3 (yyy ▸ rfl))
    | mother => exact False.elim (a3 (yyy ▸ rfl))
    | father =>
      have h0: role father=Victim := isVictim
      have h1: role father ≠ Accessory := h0 ▸ noConfusion
      have h2: Accessory = role accessory := isAccessory.symm
      have h3: role father ≠ role accessory  := h2 ▸ h1
      have h4:  father ≠ accessory  := mt (congrArg role) h3

      have h5:  accessory=son  := match (FA_or_SA isWitness isAccessory a1 a2 a4 a5) with
        | .inr h => h
        | .inl h => False.elim ((Ne.symm h4) h)

      -- have h6 : murderer ≠ daughter := yyy ▸ a6
      -- -- have h6 : witness ≠ mother := sorry
      -- have h7 : murderer=daughter ∨ murderer=mother := by
      --   cases murderer with
      --   | daughter => apply Or.inl; rfl
      --   | father => exact Roles.noConfusion (h0 ▸ isMurderer)
      --   | mother => apply Or.inr; rfl
      --   | son =>  exact Roles.noConfusion (isAccessory ▸ h5.symm ▸ isMurderer)
      -- have h8 : murderer=mother := mtp h7 h6

      -- have h9 : witness=daughter := by
      --   cases witness with
      --   | daughter => rfl
      --   | father => exact Roles.noConfusion (h0 ▸ isWitness)
      --   | mother => exact Roles.noConfusion (isMurderer ▸ h8.symm ▸ isWitness)
      --   | son =>  exact Roles.noConfusion (isAccessory ▸ h5.symm ▸ isWitness)

      ------------------------

      have hnlt : ¬(son < father):= lt_asymm (h5 ▸  a4)
      have hlt : (father > son) := (a5 ▸ (isOldest son)) noConfusion
      exact absurd hlt hnlt

    | son =>
      have h0: role son=Victim := isVictim
      have h1: role son ≠ Accessory := h0 ▸ noConfusion
      have h2: Accessory = role accessory := isAccessory.symm
      have h3: role son ≠ role accessory  := h2 ▸ h1
      have h4:  son ≠ accessory  := mt (congrArg role) h3

      have h5:  accessory=father  := match (FA_or_SA isWitness isAccessory a1 a2 a4 a5) with
        | .inl h => h
        | .inr h => False.elim ((Ne.symm h4) h)

      have h6 : murderer ≠ daughter := yyy ▸ a6
      -- have h6 : witness ≠ mother := sorry
      have h7 : murderer=daughter ∨ murderer=mother := by
        cases murderer with
        | daughter => apply Or.inl; rfl
        | son => exact Roles.noConfusion (h0 ▸ isMurderer)
        | mother => apply Or.inr; rfl
        | father =>  exact Roles.noConfusion (isAccessory ▸ h5.symm ▸ isMurderer)
      have h8 : murderer=mother := mtp h7 h6

      have h9 : witness=daughter := by
        cases witness with
        | daughter => rfl
        | son => exact Roles.noConfusion (h0 ▸ isWitness)
        | mother => exact Roles.noConfusion (isMurderer ▸ h8.symm ▸ isWitness)
        | father =>  exact Roles.noConfusion (isAccessory ▸ h5.symm ▸ isWitness)

      exact ⟨h9, rfl, h5, h8⟩

def hello := s!"world. You are using Lean version {Lean.versionString} "
#eval hello
#eval "PROOVED!!!"


import Duck

open Math.CommutativeAlgebra
open Math.AlgebraicGeometry
open Math.CategoryTheory

set_option trace.debug true
-- set_option trace.aesop.steps true          -- displays all the steps Aesop takes
-- set_option trace.aesop.steps.tree true -- displays the search tree after each step

-- PASSING
#query : (A : Ring) (f : ZZ ⟶ ZZ)
#query : (A : Ring) (f : A ⟶ ZZ)
#query : (A : Ring) (f : RingHom A A)
#query : (R : Ring) (h : R.domain)
#query : (X : Scheme) (h : X.affine)
#query (X : Scheme) (h : X.affine) : (q : X.quasi_compact)
#query (X : Scheme) (h : X.affine) : (q : X.quasi_separated)
#query (X : Scheme) (h : X.affine) : (q : SchemeHom.affine (SchemeId X))
#query (X : Scheme) (h : X.affine) : (q : SchemeHom.quasi_compact (𝟙 X))
#query (X Y : Scheme) (f : X ⟶ Y) (h : SchemeHom.closed_immersion f) : (q : SchemeHom.locally_finite_type f)
#query (X Y: Scheme) (f : X ⟶ Y) (h : SchemeHom.etale f) : (h : SchemeHom.unramified f)
#query (X Y Z : Scheme) (f : X ⟶ Y) (g : Y ⟶ Z) (hf : SchemeHom.proper f) (hg : SchemeHom.proper g) : (h : SchemeHom.proper (g ≫ f))
#query (X Y : Scheme) (f : X ⟶ Y) (hf : SchemeHom.finite f) : (h : SchemeHom.proper f)
#query (X Y Z : Scheme) (f : X ⟶ Y) (g : Y ⟶ Z) (hf : SchemeHom.proper f) (hg : SchemeHom.proper g) : (h : SchemeHom.proper (g ≫ f))
#query (X Y Z : Scheme) (f : X ⟶ Y) (g : Y ⟶ Z) (hf : SchemeHom.finite f) (hg : SchemeHom.finite g) : (h : SchemeHom.proper (g ≫ f))
#query (A B : Prop) (h : A → B) (a : A) : (b : B)
#query (A B : Prop) (h : A → B) (a₁ a₂ : A) : (b : B)
#query : (h : (affine_line (Spec QQ)).locally_noetherian)
#query : (X : Scheme) (h : X.integral)
#query : (R : Ring) (h : (Spec R).integral)
#query : (X Y : Scheme) (f : X ⟶ Y)
#query (U V W : Scheme) (g : U ⟶ V) (h : V ⟶ W) (hg : SchemeHom.closed_immersion g) (hh : SchemeHom.closed_immersion h) : (hc : SchemeHom.proper (h ≫ g))
#query : (R : Ring) (M N : Module R) (f : M ⟶ N)
#query : (X Y : Scheme) (f : X ⟶ Y) (h : ¬ SchemeHom.zariski_cover f)
#query : (P : {A B : Prop} → (h : A → B) → (x : A) → B)
#query : (P : {A B : Prop} → (h : A → B) → (a1 : A) → (a2 : A) →  B)
#query : (P : {A B : Prop} → (h : A → B) → (hb : ¬ B) → ¬ A)
#query (A B : Prop) (h : A → B) (hb : ¬ B) : (h : ¬ A)

-- FAILING

#query : (T : Type) (t : T)

-- FAILING

#query : (X : Scheme) (h₁ : X.affine) (h₂ : X.affine)

example : ∃ (X : Scheme) (h₁ : X.affine) (h₂ : X.affine), True := by {
  aesop;
}

example : ∃ (X : Scheme) (h₁ : X.affine) (h₂ : X.affine), True := by {
  apply Exists.intro (Spec ZZ);
  apply Exists.intro (spec_affine ZZ);
  apply Exists.intro (spec_affine ZZ);
  apply True.intro;
}

-- Fail for the same reason
-- #query : (X : Scheme) (h₁ : X.affine) (h₂ : X.quasi_compact)

-- FAILING

#query (X : Scheme) (h₁ : ¬ X.quasi_compact) : (h₂ : ¬ X.affine)

example : ∀ (X : Scheme) (h₁ : ¬ X.quasi_compact) , ∃ (h₂ : ¬ X.affine), True := by {
  aesop;
}

example : ∀ (X : Scheme) (h₁ : ¬ X.quasi_compact) , ∃ (h₂ : ¬ X.affine), True := by {
  intro X h₁;
  apply Exists.intro;
  apply True.intro;
  apply mt; -- modus tollens
  apply qc_of_af;
  apply h₁;
}

-- Fail for the same reason
-- #query (X Y : Scheme) (f : X ⟶ Y) (h : ¬ SchemeHom.universally_closed f) : (h : ¬ SchemeHom.proper f)
-- #query (X Y: Scheme) (f : X ⟶ Y) (h : ¬ SchemeHom.unramified f) : (h : ¬ SchemeHom.etale f)

-- FAILING
#query : (h : ¬ (Scheme.zariski_local Scheme.connected))

example : ∃ (h : ¬ (Scheme.zariski_local Scheme.connected)), True := by {
  aesop;
}

example : ∃ (h : ¬ (Scheme.zariski_local Scheme.connected)), True := by {
  apply Exists.intro;
  apply True.intro;
  apply mt; -- modus tollens
  intro arg;
  apply du_zar_lc;
  apply cn_of_int;
  apply spec_integral;
  apply ZZ_domain;
  apply cn_of_int;
  apply spec_integral;
  apply ZZ_domain;
  apply arg;
  apply du_not_cn;
  apply spec_not_empty;
  apply ZZ_not_trivial;
  apply spec_not_empty;
  apply ZZ_not_trivial;
}

-- FAILING (aesop: the goal contains metavariables, which is not currently supported.)

#query : (h : ¬ (SchemeHom.formally_etale (ec_to_P1 QQ_is_field)))

example : ∃ (h : ¬ (SchemeHom.formally_etale (ec_to_P1 QQ_is_field))), True := by {
  aesop;
}

example : ∃ (h : ¬ (SchemeHom.formally_etale (ec_to_P1 QQ_is_field))), True := by {
  apply Exists.intro;
  apply True.intro;
  apply mt; -- modus tollens
  intro arg;
  apply et_of_fet_lfp;
  apply arg;
  apply lfp_of_fp;
  apply ec_to_P1_fp;
  apply ec_to_P1_not_et;
}

-- Failing for the same reason
-- #query : (h : ¬ (scheme_map.open_immersion (ec_to_P1 QQ_is_field)))
-- #query : (h : ¬ (scheme_map.open_immersion (mSpec QQ_to_QQ_sqrt2)))

-- Failing for lack of examples
#query : (R : Ring) (M : Module R) (h₁ : M.flat) (h₂ : ¬ M.free)


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

Transitive reflexive as well as reflexive closure of relations.
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.tactic.basic
import Mathlib.PostPort

universes u_1 u_2 u_3 u_4

namespace Mathlib

namespace relation

/--
The composition of two relations, yielding a new relation.  The result
relates a term of `α` and a term of `γ` if there is an intermediate
term of `β` related to both.
-/
def comp {α : Type u_1} {β : Type u_2} {γ : Type u_3} (r : α → β → Prop) (p : β → γ → Prop) (a : α) (c : γ) :=
  ∃ (b : β), r a b ∧ p b c

theorem comp_eq {α : Type u_1} {β : Type u_2} {r : α → β → Prop} : comp r Eq = r := sorry

theorem eq_comp {α : Type u_1} {β : Type u_2} {r : α → β → Prop} : comp Eq r = r := sorry

theorem iff_comp {α : Type u_1} {r : Prop → α → Prop} : comp Iff r = r := sorry

theorem comp_iff {α : Type u_1} {r : α → Prop → Prop} : comp r Iff = r := sorry

theorem comp_assoc {α : Type u_1} {β : Type u_2} {γ : Type u_3} {δ : Type u_4} {r : α → β → Prop} {p : β → γ → Prop} {q : γ → δ → Prop} : comp (comp r p) q = comp r (comp p q) := sorry

theorem flip_comp {α : Type u_1} {β : Type u_2} {γ : Type u_3} {r : α → β → Prop} {p : β → γ → Prop} : flip (comp r p) = comp (flip p) (flip r) := sorry

/--
The map of a relation `r` through a pair of functions pushes the
relation to the codomains of the functions.  The resulting relation is
defined by having pairs of terms related if they have preimages
related by `r`.
-/
protected def map {α : Type u_1} {β : Type u_2} {γ : Type u_3} {δ : Type u_4} (r : α → β → Prop) (f : α → γ) (g : β → δ) : γ → δ → Prop :=
  fun (c : γ) (d : δ) => ∃ (a : α), ∃ (b : β), r a b ∧ f a = c ∧ g b = d

/-- `refl_trans_gen r`: reflexive transitive closure of `r` -/
inductive refl_trans_gen {α : Type u_1} (r : α → α → Prop) (a : α) : α → Prop
where
| refl : refl_trans_gen r a a
| tail : ∀ {b c : α}, refl_trans_gen r a b → r b c → refl_trans_gen r a c

/-- `refl_gen r`: reflexive closure of `r` -/
inductive refl_gen {α : Type u_1} (r : α → α → Prop) (a : α) : α → Prop
where
| refl : refl_gen r a a
| single : ∀ {b : α}, r a b → refl_gen r a b

/-- `trans_gen r`: transitive closure of `r` -/
inductive trans_gen {α : Type u_1} (r : α → α → Prop) (a : α) : α → Prop
where
| single : ∀ {b : α}, r a b → trans_gen r a b
| tail : ∀ {b c : α}, trans_gen r a b → r b c → trans_gen r a c

theorem refl_gen.to_refl_trans_gen {α : Type u_1} {r : α → α → Prop} {a : α} {b : α} : refl_gen r a b → refl_trans_gen r a b := sorry

namespace refl_trans_gen

theorem trans {α : Type u_1} {r : α → α → Prop} {a : α} {b : α} {c : α} (hab : refl_trans_gen r a b) (hbc : refl_trans_gen r b c) : refl_trans_gen r a c := sorry

theorem single {α : Type u_1} {r : α → α → Prop} {a : α} {b : α} (hab : r a b) : refl_trans_gen r a b :=
  tail refl hab

theorem head {α : Type u_1} {r : α → α → Prop} {a : α} {b : α} {c : α} (hab : r a b) (hbc : refl_trans_gen r b c) : refl_trans_gen r a c := sorry

theorem symmetric {α : Type u_1} {r : α → α → Prop} (h : symmetric r) : symmetric (refl_trans_gen r) := sorry

theorem cases_tail {α : Type u_1} {r : α → α → Prop} {a : α} {b : α} : refl_trans_gen r a b → b = a ∨ ∃ (c : α), refl_trans_gen r a c ∧ r c b :=
  iff.mp (cases_tail_iff r a b)

theorem head_induction_on {α : Type u_1} {r : α → α → Prop} {b : α} {P : (a : α) → refl_trans_gen r a b → Prop} {a : α} (h : refl_trans_gen r a b) (refl : P b refl) (head : ∀ {a c : α} (h' : r a c) (h : refl_trans_gen r c b), P c h → P a (head h' h)) : P a h := sorry

theorem trans_induction_on {α : Type u_1} {r : α → α → Prop} {P : {a b : α} → refl_trans_gen r a b → Prop} {a : α} {b : α} (h : refl_trans_gen r a b) (ih₁ : α → P refl) (ih₂ : ∀ {a b : α} (h : r a b), P (single h)) (ih₃ : ∀ {a b c : α} (h₁ : refl_trans_gen r a b) (h₂ : refl_trans_gen r b c), P h₁ → P h₂ → P (trans h₁ h₂)) : P h := sorry

theorem cases_head {α : Type u_1} {r : α → α → Prop} {a : α} {b : α} (h : refl_trans_gen r a b) : a = b ∨ ∃ (c : α), r a c ∧ refl_trans_gen r c b := sorry

theorem cases_head_iff {α : Type u_1} {r : α → α → Prop} {a : α} {b : α} : refl_trans_gen r a b ↔ a = b ∨ ∃ (c : α), r a c ∧ refl_trans_gen r c b := sorry

theorem total_of_right_unique {α : Type u_1} {r : α → α → Prop} {a : α} {b : α} {c : α} (U : relator.right_unique r) (ab : refl_trans_gen r a b) (ac : refl_trans_gen r a c) : refl_trans_gen r b c ∨ refl_trans_gen r c b := sorry

end refl_trans_gen

namespace trans_gen

theorem to_refl {α : Type u_1} {r : α → α → Prop} {a : α} {b : α} (h : trans_gen r a b) : refl_trans_gen r a b :=
  trans_gen.drec (fun {b : α} (h : r a b) => refl_trans_gen.single h)
    (fun {b c : α} (h_ᾰ : trans_gen r a b) (bc : r b c) (ab : refl_trans_gen r a b) => refl_trans_gen.tail ab bc) h

theorem trans_left {α : Type u_1} {r : α → α → Prop} {a : α} {b : α} {c : α} (hab : trans_gen r a b) (hbc : refl_trans_gen r b c) : trans_gen r a c := sorry

theorem trans {α : Type u_1} {r : α → α → Prop} {a : α} {b : α} {c : α} (hab : trans_gen r a b) (hbc : trans_gen r b c) : trans_gen r a c :=
  trans_left hab (to_refl hbc)

theorem head' {α : Type u_1} {r : α → α → Prop} {a : α} {b : α} {c : α} (hab : r a b) (hbc : refl_trans_gen r b c) : trans_gen r a c :=
  trans_left (single hab) hbc

theorem tail' {α : Type u_1} {r : α → α → Prop} {a : α} {b : α} {c : α} (hab : refl_trans_gen r a b) (hbc : r b c) : trans_gen r a c := sorry

theorem trans_right {α : Type u_1} {r : α → α → Prop} {a : α} {b : α} {c : α} (hab : refl_trans_gen r a b) (hbc : trans_gen r b c) : trans_gen r a c := sorry

theorem head {α : Type u_1} {r : α → α → Prop} {a : α} {b : α} {c : α} (hab : r a b) (hbc : trans_gen r b c) : trans_gen r a c :=
  head' hab (to_refl hbc)

theorem tail'_iff {α : Type u_1} {r : α → α → Prop} {a : α} {c : α} : trans_gen r a c ↔ ∃ (b : α), refl_trans_gen r a b ∧ r b c := sorry

theorem head'_iff {α : Type u_1} {r : α → α → Prop} {a : α} {c : α} : trans_gen r a c ↔ ∃ (b : α), r a b ∧ refl_trans_gen r b c := sorry

theorem trans_gen_eq_self {α : Type u_1} {r : α → α → Prop} (trans : transitive r) : trans_gen r = r := sorry

theorem transitive_trans_gen {α : Type u_1} {r : α → α → Prop} : transitive (trans_gen r) :=
  fun (a b c : α) => trans

theorem trans_gen_idem {α : Type u_1} {r : α → α → Prop} : trans_gen (trans_gen r) = trans_gen r :=
  trans_gen_eq_self transitive_trans_gen

theorem trans_gen_lift {α : Type u_1} {β : Type u_2} {r : α → α → Prop} {p : β → β → Prop} {a : α} {b : α} (f : α → β) (h : ∀ (a b : α), r a b → p (f a) (f b)) (hab : trans_gen r a b) : trans_gen p (f a) (f b) := sorry

theorem trans_gen_lift' {α : Type u_1} {β : Type u_2} {r : α → α → Prop} {p : β → β → Prop} {a : α} {b : α} (f : α → β) (h : ∀ (a b : α), r a b → trans_gen p (f a) (f b)) (hab : trans_gen r a b) : trans_gen p (f a) (f b) :=
  eq.mpr (id (Eq.refl (trans_gen p (f a) (f b))))
    (eq.mp (congr_fun (congr_fun trans_gen_idem (f a)) (f b)) (trans_gen_lift f h hab))

theorem trans_gen_closed {α : Type u_1} {r : α → α → Prop} {a : α} {b : α} {p : α → α → Prop} : (∀ (a b : α), r a b → trans_gen p a b) → trans_gen r a b → trans_gen p a b :=
  trans_gen_lift' id

end trans_gen

theorem refl_trans_gen_iff_eq {α : Type u_1} {r : α → α → Prop} {a : α} {b : α} (h : ∀ (b : α), ¬r a b) : refl_trans_gen r a b ↔ b = a := sorry

theorem refl_trans_gen_iff_eq_or_trans_gen {α : Type u_1} {r : α → α → Prop} {a : α} {b : α} : refl_trans_gen r a b ↔ b = a ∨ trans_gen r a b := sorry

theorem refl_trans_gen_lift {α : Type u_1} {β : Type u_2} {r : α → α → Prop} {p : β → β → Prop} {a : α} {b : α} (f : α → β) (h : ∀ (a b : α), r a b → p (f a) (f b)) (hab : refl_trans_gen r a b) : refl_trans_gen p (f a) (f b) :=
  refl_trans_gen.trans_induction_on hab (fun (a : α) => refl_trans_gen.refl)
    (fun (a b : α) => refl_trans_gen.single ∘ h a b)
    fun (a b c : α) (_x : refl_trans_gen r a b) (_x : refl_trans_gen r b c) => refl_trans_gen.trans

theorem refl_trans_gen_mono {α : Type u_1} {r : α → α → Prop} {a : α} {b : α} {p : α → α → Prop} : (∀ (a b : α), r a b → p a b) → refl_trans_gen r a b → refl_trans_gen p a b :=
  refl_trans_gen_lift id

theorem refl_trans_gen_eq_self {α : Type u_1} {r : α → α → Prop} (refl : reflexive r) (trans : transitive r) : refl_trans_gen r = r := sorry

theorem reflexive_refl_trans_gen {α : Type u_1} {r : α → α → Prop} : reflexive (refl_trans_gen r) :=
  fun (a : α) => refl_trans_gen.refl

theorem transitive_refl_trans_gen {α : Type u_1} {r : α → α → Prop} : transitive (refl_trans_gen r) :=
  fun (a b c : α) => refl_trans_gen.trans

theorem refl_trans_gen_idem {α : Type u_1} {r : α → α → Prop} : refl_trans_gen (refl_trans_gen r) = refl_trans_gen r :=
  refl_trans_gen_eq_self reflexive_refl_trans_gen transitive_refl_trans_gen

theorem refl_trans_gen_lift' {α : Type u_1} {β : Type u_2} {r : α → α → Prop} {p : β → β → Prop} {a : α} {b : α} (f : α → β) (h : ∀ (a b : α), r a b → refl_trans_gen p (f a) (f b)) (hab : refl_trans_gen r a b) : refl_trans_gen p (f a) (f b) :=
  eq.mpr (id (Eq.refl (refl_trans_gen p (f a) (f b))))
    (eq.mp (congr_fun (congr_fun refl_trans_gen_idem (f a)) (f b)) (refl_trans_gen_lift f h hab))

theorem refl_trans_gen_closed {α : Type u_1} {r : α → α → Prop} {a : α} {b : α} {p : α → α → Prop} : (∀ (a b : α), r a b → refl_trans_gen p a b) → refl_trans_gen r a b → refl_trans_gen p a b :=
  refl_trans_gen_lift' id

/--
The join of a relation on a single type is a new relation for which
pairs of terms are related if there is a third term they are both
related to.  For example, if `r` is a relation representing rewrites
in a term rewriting system, then *confluence* is the property that if
`a` rewrites to both `b` and `c`, then `join r` relates `b` and `c`
(see `relation.church_rosser`).
-/
def join {α : Type u_1} (r : α → α → Prop) : α → α → Prop :=
  fun (a b : α) => ∃ (c : α), r a c ∧ r b c

theorem church_rosser {α : Type u_1} {r : α → α → Prop} {a : α} {b : α} {c : α} (h : ∀ (a b c : α), r a b → r a c → ∃ (d : α), refl_gen r b d ∧ refl_trans_gen r c d) (hab : refl_trans_gen r a b) (hac : refl_trans_gen r a c) : join (refl_trans_gen r) b c := sorry

theorem join_of_single {α : Type u_1} {r : α → α → Prop} {a : α} {b : α} (h : reflexive r) (hab : r a b) : join r a b :=
  Exists.intro b { left := hab, right := h b }

theorem symmetric_join {α : Type u_1} {r : α → α → Prop} : symmetric (join r) := sorry

theorem reflexive_join {α : Type u_1} {r : α → α → Prop} (h : reflexive r) : reflexive (join r) :=
  fun (a : α) => Exists.intro a { left := h a, right := h a }

theorem transitive_join {α : Type u_1} {r : α → α → Prop} (ht : transitive r) (h : ∀ (a b c : α), r a b → r a c → join r b c) : transitive (join r) := sorry

theorem equivalence_join {α : Type u_1} {r : α → α → Prop} (hr : reflexive r) (ht : transitive r) (h : ∀ (a b c : α), r a b → r a c → join r b c) : equivalence (join r) :=
  { left := reflexive_join hr, right := { left := symmetric_join, right := transitive_join ht h } }

theorem equivalence_join_refl_trans_gen {α : Type u_1} {r : α → α → Prop} (h : ∀ (a b c : α), r a b → r a c → ∃ (d : α), refl_gen r b d ∧ refl_trans_gen r c d) : equivalence (join (refl_trans_gen r)) :=
  equivalence_join reflexive_refl_trans_gen transitive_refl_trans_gen fun (a b c : α) => church_rosser h

theorem join_of_equivalence {α : Type u_1} {r : α → α → Prop} {a : α} {b : α} {r' : α → α → Prop} (hr : equivalence r) (h : ∀ (a b : α), r' a b → r a b) : join r' a b → r a b := sorry

theorem refl_trans_gen_of_transitive_reflexive {α : Type u_1} {r : α → α → Prop} {a : α} {b : α} {r' : α → α → Prop} (hr : reflexive r) (ht : transitive r) (h : ∀ (a b : α), r' a b → r a b) (h' : refl_trans_gen r' a b) : r a b :=
  refl_trans_gen.drec (hr a)
    (fun {b c : α} (hab : refl_trans_gen r' a b) (hbc : r' b c) (ih : r a b) => ht ih (h b c hbc)) h'

theorem refl_trans_gen_of_equivalence {α : Type u_1} {r : α → α → Prop} {a : α} {b : α} {r' : α → α → Prop} (hr : equivalence r) : (∀ (a b : α), r' a b → r a b) → refl_trans_gen r' a b → r a b :=
  refl_trans_gen_of_transitive_reflexive (and.left hr) (and.right (and.right hr))

theorem eqv_gen_iff_of_equivalence {α : Type u_1} {r : α → α → Prop} {a : α} {b : α} (h : equivalence r) : eqv_gen r a b ↔ r a b := sorry

theorem eqv_gen_mono {α : Type u_1} {a : α} {b : α} {r : α → α → Prop} {p : α → α → Prop} (hrp : ∀ (a b : α), r a b → p a b) (h : eqv_gen r a b) : eqv_gen p a b := sorry


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

Supplementary theorems about the `string` type.
-/
import data.list.basic
import data.char

namespace string

def ltb : iterator → iterator → bool
| s₁ s₂ := begin
  cases s₂.has_next, {exact ff},
  cases h₁ : s₁.has_next, {exact tt},
  exact if s₁.curr = s₂.curr then
    have s₁.next.2.length < s₁.2.length, from
    match s₁, h₁ with ⟨_, a::l⟩, h := nat.lt_succ_self _ end,
    ltb s₁.next s₂.next
  else s₁.curr < s₂.curr,
end
using_well_founded {rel_tac :=
  λ _ _, `[exact ⟨_, measure_wf (λ s, s.1.2.length)⟩]}

instance has_lt' : has_lt string :=
⟨λ s₁ s₂, ltb s₁.mk_iterator s₂.mk_iterator⟩

instance decidable_lt : @decidable_rel string (<) :=
by apply_instance -- short-circuit type class inference

@[simp] theorem lt_iff_to_list_lt :
  ∀ {s₁ s₂ : string}, s₁ < s₂ ↔ s₁.to_list < s₂.to_list
| ⟨i₁⟩ ⟨i₂⟩ :=
  suffices ∀ {p₁ p₂ s₁ s₂}, ltb ⟨p₁, s₁⟩ ⟨p₂, s₂⟩ ↔ s₁ < s₂, from this,
  begin
    intros,
    induction s₁ with a s₁ IH generalizing p₁ p₂ s₂;
      cases s₂ with b s₂; rw ltb; simp [iterator.has_next],
    { refl, },
    { exact iff_of_true rfl list.lex.nil },
    { exact iff_of_false bool.ff_ne_tt (not_lt_of_lt list.lex.nil) },
    { dsimp [iterator.has_next,
        iterator.curr, iterator.next],
      split_ifs,
      { subst b, exact IH.trans list.lex.cons_iff.symm },
      { simp, refine ⟨list.lex.rel, λ e, _⟩,
        cases e, {cases h rfl}, assumption } }
  end

instance has_le : has_le string := ⟨λ s₁ s₂, ¬ s₂ < s₁⟩

instance decidable_le : @decidable_rel string (≤) :=
by apply_instance -- short-circuit type class inference

@[simp] theorem le_iff_to_list_le
  {s₁ s₂ : string} : s₁ ≤ s₂ ↔ s₁.to_list ≤ s₂.to_list :=
(not_congr lt_iff_to_list_lt).trans not_lt

theorem to_list_inj : ∀ {s₁ s₂}, to_list s₁ = to_list s₂ ↔ s₁ = s₂
| ⟨s₁⟩ ⟨s₂⟩ := ⟨congr_arg _, congr_arg _⟩

lemma nil_as_string_eq_empty : [].as_string = "" := rfl

@[simp] lemma to_list_empty : "".to_list = [] := rfl

lemma as_string_inv_to_list (s : string) : s.to_list.as_string = s :=
by { cases s, refl }

@[simp] lemma to_list_singleton (c : char) : (string.singleton c).to_list = [c] := rfl

lemma to_list_nonempty : ∀ {s : string}, s ≠ string.empty →
  s.to_list = s.head :: (s.popn 1).to_list
| ⟨s⟩ h := by cases s; [cases h rfl, refl]

@[simp] lemma head_empty : "".head = default _ := rfl

@[simp] lemma popn_empty {n : ℕ} : "".popn n = "" :=
begin
  induction n with n hn,
  { refl },
  { rcases hs : "" with ⟨_ | ⟨hd, tl⟩⟩,
    { rw hs at hn,
      conv_rhs { rw ←hn },
      simp only [popn, mk_iterator, iterator.nextn, iterator.next] },
    { simpa only [←to_list_inj] using hs } }
end

instance : linear_order string :=
by refine_struct {
    lt := (<), le := (≤),
    decidable_lt := by apply_instance,
    decidable_le := string.decidable_le,
    decidable_eq := by apply_instance, .. };
  { simp only [le_iff_to_list_le, lt_iff_to_list_lt, ← to_list_inj], introv,
    apply_field }

end string

open string

lemma list.to_list_inv_as_string (l : list char) : l.as_string.to_list = l :=
by { cases hl : l.as_string, exact string_imp.mk.inj hl.symm }

@[simp] lemma list.length_as_string (l : list char) : l.as_string.length = l.length := rfl

@[simp] lemma list.as_string_inj {l l' : list char} : l.as_string = l'.as_string ↔ l = l' :=
⟨λ h, by rw [←list.to_list_inv_as_string l, ←list.to_list_inv_as_string l', to_list_inj, h],
 λ h, h ▸ rfl⟩

@[simp] lemma string.length_to_list (s : string) : s.to_list.length = s.length :=
by rw [←string.as_string_inv_to_list s, list.to_list_inv_as_string, list.length_as_string]

lemma list.as_string_eq {l : list char} {s : string} :
  l.as_string = s ↔ l = s.to_list :=
by rw [←as_string_inv_to_list s, list.as_string_inj, as_string_inv_to_list s]


import Mathlib.PrePort
import Mathlib.Lean3Lib.init.meta.default
import Mathlib.Lean3Lib.init.logic
import Mathlib.Lean3Lib.init.data.nat.lemmas
import Mathlib.Lean3Lib.init.data.char.basic

namespace Mathlib

namespace char

theorem val_of_nat_eq_of_is_valid {n : ℕ} : is_valid_char n → val (of_nat n) = n := sorry

theorem val_of_nat_eq_of_not_is_valid {n : ℕ} : ¬is_valid_char n → val (of_nat n) = 0 := sorry

theorem of_nat_eq_of_not_is_valid {n : ℕ} : ¬is_valid_char n → of_nat n = of_nat 0 :=
  fun (h : ¬is_valid_char n) =>
    eq_of_veq
      (eq.mpr (id (Eq._oldrec (Eq.refl (val (of_nat n) = val (of_nat 0))) (val_of_nat_eq_of_not_is_valid h))) (Eq.refl 0))

theorem of_nat_ne_of_ne {n₁ : ℕ} {n₂ : ℕ} (h₁ : n₁ ≠ n₂) (h₂ : is_valid_char n₁) (h₃ : is_valid_char n₂) : of_nat n₁ ≠ of_nat n₂ :=
  ne_of_vne
    (eq.mpr (id (Eq._oldrec (Eq.refl (val (of_nat n₁) ≠ val (of_nat n₂))) (val_of_nat_eq_of_is_valid h₂)))
      (eq.mpr (id (Eq._oldrec (Eq.refl (n₁ ≠ val (of_nat n₂))) (val_of_nat_eq_of_is_valid h₃))) h₁))