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

import logic.function.basic
import tactic.lint
import tactic.norm_cast

/-!
# Typeclass for a type `F` with an injective map to `A → B`

> THIS FILE IS SYNCHRONIZED WITH MATHLIB4.
> Any changes to this file require a corresponding PR to mathlib4.

This typeclass is primarily for use by homomorphisms like `monoid_hom` and `linear_map`.

## Basic usage of `fun_like`

A typical type of morphisms should be declared as:
```
structure my_hom (A B : Type*) [my_class A] [my_class B] :=
(to_fun : A → B)
(map_op' : ∀ {x y : A}, to_fun (my_class.op x y) = my_class.op (to_fun x) (to_fun y))

namespace my_hom

variables (A B : Type*) [my_class A] [my_class B]

-- This instance is optional if you follow the "morphism class" design below:
instance : fun_like (my_hom A B) A (λ _, B) :=
{ coe := my_hom.to_fun, coe_injective' := λ f g h, by cases f; cases g; congr' }

/-- Helper instance for when there's too many metavariables to apply
`fun_like.has_coe_to_fun` directly. -/
instance : has_coe_to_fun (my_hom A B) (λ _, A → B) := fun_like.has_coe_to_fun

@[simp] lemma to_fun_eq_coe {f : my_hom A B} : f.to_fun = (f : A → B) := rfl

@[ext] theorem ext {f g : my_hom A B} (h : ∀ x, f x = g x) : f = g := fun_like.ext f g h

/-- Copy of a `my_hom` with a new `to_fun` equal to the old one. Useful to fix definitional
equalities. -/
protected def copy (f : my_hom A B) (f' : A → B) (h : f' = ⇑f) : my_hom A B :=
{ to_fun := f',
  map_op' := h.symm ▸ f.map_op' }

end my_hom
```

This file will then provide a `has_coe_to_fun` instance and various
extensionality and simp lemmas.

## Morphism classes extending `fun_like`

The `fun_like` design provides further benefits if you put in a bit more work.
The first step is to extend `fun_like` to create a class of those types satisfying
the axioms of your new type of morphisms.
Continuing the example above:

```
section
set_option old_structure_cmd true

/-- `my_hom_class F A B` states that `F` is a type of `my_class.op`-preserving morphisms.
You should extend this class when you extend `my_hom`. -/
class my_hom_class (F : Type*) (A B : out_param $ Type*) [my_class A] [my_class B]
  extends fun_like F A (λ _, B) :=
(map_op : ∀ (f : F) (x y : A), f (my_class.op x y) = my_class.op (f x) (f y))

end
@[simp] lemma map_op {F A B : Type*} [my_class A] [my_class B] [my_hom_class F A B]
  (f : F) (x y : A) : f (my_class.op x y) = my_class.op (f x) (f y) :=
my_hom_class.map_op

-- You can replace `my_hom.fun_like` with the below instance:
instance : my_hom_class (my_hom A B) A B :=
{ coe := my_hom.to_fun,
  coe_injective' := λ f g h, by cases f; cases g; congr',
  map_op := my_hom.map_op' }

-- [Insert `has_coe_to_fun`, `to_fun_eq_coe`, `ext` and `copy` here]
```

The second step is to add instances of your new `my_hom_class` for all types extending `my_hom`.
Typically, you can just declare a new class analogous to `my_hom_class`:

```
structure cooler_hom (A B : Type*) [cool_class A] [cool_class B]
  extends my_hom A B :=
(map_cool' : to_fun cool_class.cool = cool_class.cool)

section
set_option old_structure_cmd true

class cooler_hom_class (F : Type*) (A B : out_param $ Type*) [cool_class A] [cool_class B]
  extends my_hom_class F A B :=
(map_cool : ∀ (f : F), f cool_class.cool = cool_class.cool)

end

@[simp] lemma map_cool {F A B : Type*} [cool_class A] [cool_class B] [cooler_hom_class F A B]
  (f : F) : f cool_class.cool = cool_class.cool :=
my_hom_class.map_op

-- You can also replace `my_hom.fun_like` with the below instance:
instance : cool_hom_class (cool_hom A B) A B :=
{ coe := cool_hom.to_fun,
  coe_injective' := λ f g h, by cases f; cases g; congr',
  map_op := cool_hom.map_op',
  map_cool := cool_hom.map_cool' }

-- [Insert `has_coe_to_fun`, `to_fun_eq_coe`, `ext` and `copy` here]
```

Then any declaration taking a specific type of morphisms as parameter can instead take the
class you just defined:
```
-- Compare with: lemma do_something (f : my_hom A B) : sorry := sorry
lemma do_something {F : Type*} [my_hom_class F A B] (f : F) : sorry := sorry
```

This means anything set up for `my_hom`s will automatically work for `cool_hom_class`es,
and defining `cool_hom_class` only takes a constant amount of effort,
instead of linearly increasing the work per `my_hom`-related declaration.

-/

-- This instance should have low priority, to ensure we follow the chain
-- `fun_like → has_coe_to_fun`
attribute [instance, priority 10] coe_fn_trans

/-- The class `fun_like F α β` expresses that terms of type `F` have an
injective coercion to functions from `α` to `β`.

This typeclass is used in the definition of the homomorphism typeclasses,
such as `zero_hom_class`, `mul_hom_class`, `monoid_hom_class`, ....
-/
class fun_like (F : Sort*) (α : out_param Sort*) (β : out_param $ α → Sort*) :=
(coe : F → Π a : α, β a)
(coe_injective' : function.injective coe)

section dependent

/-! ### `fun_like F α β` where `β` depends on `a : α` -/

variables (F α : Sort*) (β : α → Sort*)

namespace fun_like

variables {F α β} [i : fun_like F α β]

include i

@[priority 100, -- Give this a priority between `coe_fn_trans` and the default priority
  nolint dangerous_instance] -- `α` and `β` are out_params, so this instance should not be dangerous
instance : has_coe_to_fun F (λ _, Π a : α, β a) := { coe := fun_like.coe }

@[simp]

theorem coe_injective : function.injective (coe_fn : F → Π a : α, β a) :=
fun_like.coe_injective'

@[simp, norm_cast]
theorem coe_fn_eq {f g : F} : (f : Π a : α, β a) = (g : Π a : α, β a) ↔ f = g :=
⟨λ h, @coe_injective _ _ _ i _ _ h, λ h, by cases h; refl⟩

theorem ext' {f g : F} (h : (f : Π a : α, β a) = (g : Π a : α, β a)) : f = g :=
coe_injective h

theorem ext'_iff {f g : F} : f = g ↔ ((f : Π a : α, β a) = (g : Π a : α, β a)) :=
coe_fn_eq.symm

theorem ext (f g : F) (h : ∀ (x : α), f x = g x) : f = g :=
coe_injective (funext h)

theorem ext_iff {f g : F} : f = g ↔ (∀ x, f x = g x) :=
coe_fn_eq.symm.trans function.funext_iff

protected lemma congr_fun {f g : F} (h₁ : f = g) (x : α) : f x = g x :=
congr_fun (congr_arg _ h₁) x

lemma ne_iff {f g : F} : f ≠ g ↔ ∃ a, f a ≠ g a :=
ext_iff.not.trans not_forall

lemma exists_ne {f g : F} (h : f ≠ g) : ∃ x, f x ≠ g x :=
ne_iff.mp h

/-- This is not an instance to avoid slowing down every single `subsingleton` typeclass search.-/
lemma subsingleton_cod [∀ a, subsingleton (β a)] : subsingleton F :=
⟨λ f g, coe_injective $ subsingleton.elim _ _⟩

end fun_like

end dependent

section non_dependent

/-! ### `fun_like F α (λ _, β)` where `β` does not depend on `a : α` -/

variables {F α β : Sort*} [i : fun_like F α (λ _, β)]

include i

namespace fun_like

protected lemma congr {f g : F} {x y : α} (h₁ : f = g) (h₂ : x = y) : f x = g y :=
congr (congr_arg _ h₁) h₂

protected lemma congr_arg (f : F) {x y : α} (h₂ : x = y) : f x = f y :=
congr_arg _ h₂

end fun_like

end non_dependent


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

import FxyLang.Implementation.ASTUtilities

/- Before we proceed, it's important to notice that a function that executes a
program *has* to be `partial` because programs themselves may loop forever.

This file contains two partial functions capable of running Fxy programs:
* `Program.run!` is fast but uses code that can't be reasoned on
* `Program.run` is ~50% slower, but uses a function that implements small step
semantics and thus can be reasoned on

Another important detail is that the computation of a `Program` yields an
intrinsic `Value`:
* `skip` yields `nil`
* `eval` yields the `Value` of the expression being evaluated
* `seq` yields the `Value` of the second `Program`, unless the first one causes
an error
* `fork` yields the `Value` of the child `Program` executed
* `loop` yields `nil` or an error
-/

def cantEvalAsBool (e : Expression) (v : Value) : String :=
  s!"I can't evaluate '{e}' as a 'bool' because it reduces to '{v}', of " ++
    s!"type '{v.typeStr}'"

def notFound (n : String) : String :=
  s!"I can't find the definition of '{n}'"

def notAFunction (e : Expression) (v : Value) : String :=
  s!"I can't apply arguments to '{e}' because it evaluates to '{v}', of " ++
    s!"type '{v.typeStr}'"

def wrongNParameters (e : Expression) (allowed provided : Nat) : String :=
  s!"I can't apply {provided} arguments to '{e}' because the maximum " ++
    s!"allowed is {allowed}"

/-- Takes a list of expressions and matches each element with an element from a
list of strings. For each match, it adds a declaration in the beginning of a
given program, returning such modified program -/
def consume (p : Program) :
    NEList String → NEList Expression →
      Option ((Option (NEList String)) × Program)
  | .cons n ns, .cons e es => consume (.seq (.decl n (.eval e)) p) ns es
  | .cons n ns, .uno  e    => some (some ns, .seq (.decl n (.eval e)) p)
  | .uno  n,    .uno  e    => some (none, .seq (.decl n (.eval e)) p)
  | .uno  _,    .cons ..   => none

/-- Consuming elements from a non-duplicated NEList results in a non-duplicated
NEList -/
theorem noDupOfConsumeNoDup
  (h : ns.noDup) (h' : consume p' ns es = some (some l, p)) :
    l.noDup = true := by
  induction ns generalizing p' es with
  | uno  _      => cases es <;> cases h'
  | cons _ _ hi =>
    simp [NEList.noDup] at h
    cases es with
    | uno  _   => simp [consume] at h'; simp only [h.2, ← h'.1]
    | cons _ _ => exact hi h.2 h'

/- Next we're going to define a pair of mutual functions:
* `reduce` computes over an expression with the goal of extracting a term of
`Result` from it, which signals either a `Value` or an error.
* `Program.run!` is similar to `reduce`, but it processes a `Program` instead

They are mutual because *i*) a program may rely on the resolution of expressions
to move forward (for instance, knowing whether to loop again or not) and *ii*)
an expression can be the application of a function, which may need to trigger
the execution of another term of `Program` (see the `app` case)
-/

mutual

  /-- Since we're already in the `partial` realm, let's allow ourselves to be
  carelessly recursive, always believing that `reduce` will compute *any*
  expression for us! -/
  partial def reduce (c : Context) : Expression → Result
    | .lit  l => .val $ .lit  l
    | .list l => .val $ .list l
    | .lam  l => .val $ .lam  l
    | .var  n => match c[n] with
      | none   => .err .name $ notFound n
      | some v => .val $ v
    | .app e es => match reduce c e with
      | .val $ .lam $ .mk ns h p => match h' : consume p ns es with
        | some (some l, p) => .val $ .lam $ .mk l (noDupOfConsumeNoDup h h') p
        | some (none, p) => (p.run! c).2
        | none => .err .runTime $ wrongNParameters e ns.length es.length
      | .val v                   => .err .type $ notAFunction e v
      | er@(.err ..)             => er
    | .unOp o e => match reduce c e with
      | .val v      => match v.unOp o with
        | .ok    v => .val v
        | .error m => .err .type m
      | er@(.err ..) => er
    | .binOp o eₗ eᵣ => match (reduce c eₗ, reduce c eᵣ) with
      | (.val vₗ, .val vᵣ) => match vₗ.binOp vᵣ o with
        | .ok    v => .val v
        | .error m => .err .type m
      | (er@(.err ..), _)        => er
      | (_, er@(.err ..))        => er

  /-- And here we can allow ourselves to be careless too, trusting on `reduce`
  as well as on `run!`! -/
  partial def Program.run! (c : Context := default) :
      Program → Context × Result
    | skip      => (c, .val .nil)
    | eval e => (c, (reduce c e))
    | seq p₁ p₂ =>
      let res := p₁.run! c
      match res.2 with
      | .err .. => res
      | _       => p₂.run! res.1
    | decl n p => match (p.run! c).2 with
      | er@(.err ..) => (c, er)
      | .val v => (c.insert n v, .val .nil)
    | fork e pT pF => match reduce c e with
      | .val $ .lit $ .bool b => if b then pT.run! c else pF.run! c
      | .val v                => (c, .err .type $ cantEvalAsBool e v)
      | er@(.err ..)          => (c, er)
    | loop e p  => match reduce c e with
      | .val $ .lit $ .bool b =>
        if !b then (c, .val .nil) else
          match p.run! c with
          | er@(_, .err ..) => er
          | (c, _)        => (loop e p).run! c
      | .val v       => (c, .err .type $ cantEvalAsBool e v)
      | er@(.err ..) => (c, er)
    | print e   => match reduce c e with
      | .val v       => dbg_trace v; (c, .val .nil)
      | er@(.err ..) => (c, er)

end

/-- This is the function that will allow us to prove results about the semantics
of Fxy. Let's dive into its details. -/
def State.step : State → State
  /- `skip` just goes straight into returning `nil` -/
  | prog c k .skip => ret c k .nil

  /- `eval` enters the `expr` state for expression evaluation -/
  | prog c k (.eval e) => expr c k e

  /- `seq` runs the first program and stacks the second -/
  | prog c k (.seq p₁ p₂) => prog c (.seq p₂ k) p₁

  /- `decl` calls for the execution of the innermost program and then stores the
  current context with the `block` continuation, which is recovered later on.
  This allows us to have functions running with their own contexts, being able
  to write on them as they need as they will be discarded anyway -/
  | prog c k (.decl n p) => prog c (.block c (.decl n k)) p

  /- `fork`, `loop` and `print` go to the expression evaluation step, keeping
  track of what needs to be done with the returned value later on -/
  | prog c k (.fork e pT pF) => expr c (.fork e pT pF k) e
  | prog c k (.loop e p) => expr c (.loop e p k) e
  | prog c k (.print e) => expr c (.print k) e

  /- If the expression resulted in a literal, a list or a function, just return
  them -/
  | expr c k (.lit l) => ret c k (.lit l)
  | expr c k (.list l) => ret c k (.list l)
  | expr c k (.lam l) => ret c k (.lam l)

  /- If we're supposed to extract the value of a variable, we need to check
  whether it's available in the context or not -/
  | expr c k (.var nm) => match c[nm] with
    | none   => error c k .name $ notFound nm
    | some v => ret c k v

  /- For an application we need to evaluate what we're using to apply. We expect
  it to be a function! -/
  | expr c k (.app e es) => expr c (.app e es k) e

  /- For the unary operator we have to evaluate the (only) expression first -/
  | expr c k (.unOp o e) => expr c (.unOp o k) e

  /- For the binary operator, we need to evaluate the first expression first and
  stack up the evaluation of the second one -/
  | expr c k (.binOp o e₁ e₂) => expr c (.binOp₁ o e₂ k) e₁

  /- The `Continuation.exit` signals that there's nothing else to do -/
  | ret c .exit v => done c .exit v

  /- Here we print the returned value and then return `nil` -/
  | ret c (.print k) v => dbg_trace v; ret c k .nil

  /- When returning from the execution of the first program in a `seq`, we
  ignore the value and go straight to the execution of the second program -/
  | ret c (.seq p k) _ => prog c k p

  /- Here we do what we promised and recover the original context stacked with
  the `Continuation.block` constructor -/
  | ret _ (.block c k) v => ret c k v

  /- When returning from an `app` continuation, we need to inspect the value
  that was returned from the evaluation of the first expression -/
  | ret c (.app e es k) v => match v with

    /- The desired case: it's a function! Let's consume it's parameters -/
    | .lam $ .mk ns h p => match h' : consume p ns es with

      /- When `consume` didn't eat up all the arguments we return an
      yet-to-be-uncurried function -/
      | some (some l, p) =>
        ret c k (.lam $ .mk l (noDupOfConsumeNoDup h h') p)

      /- All arguments were consumed: let's run the lambda program and use
      `block` to save up the context -/
      | some (none, p) => prog c (.block c k) p

      /- This signals that too many arguments were provided -/
      | none => error c k .runTime $ wrongNParameters e ns.length es.length

    /- Anything but a function. Error! -/
    | v                 => error c k .type $ notAFunction e v

  /- Now we need to resolve a `fork` given the value returned from the
  expression. We expext it to be a boolean -/
  | ret c (.fork _ pT _ k) (.lit $ .bool true)  => prog c k pT
  | ret c (.fork _ _ pF k) (.lit $ .bool false) => prog c k pF

  /- Not a boolean. Error! -/
  | ret c (.fork e _ _ k) v  => error c k .type $ cantEvalAsBool e v

  /- Resolving a `loop` is similar to a `fork`. We should expect a boolean, at
  least. The difference is that in case of `true`, we run the program and stack
  up the same loop expression and program. In case of `false`, just break the
  loop and return `nil` -/
  | ret c (.loop e p k) (.lit $ .bool true) => prog c k (.seq p (.loop e p))
  | ret c (.loop _ _ k) (.lit $ .bool false) => ret c k .nil
  | ret c (.loop e _ k) v => error c k .type $ cantEvalAsBool e v

  /- The execution of the `decl` program is returning a value. We can finally
  add it to the context under the name recovered from the `Continuation.decl` -/
  | ret c (.decl nm k) v => ret (c.insert nm v) k .nil

  /- In the unary operator, let's compute it right away -/
  | ret c (.unOp o k) v => match v.unOp o with
    | .error m => error c k .type m
    | .ok    v => ret c k v

  /- The binary operator is a bit more laborious. When returning from the
  evaluation of the first expression, we stack the result and call the
  evaluation of the second expression -/
  | ret c (.binOp₁ o e₂ k) v₁ => expr c (.binOp₂ o v₁ k) e₂

  /- Once the second evaluation is complete, we're good to go -/
  | ret c (.binOp₂ o v₁ k) v₂ => match v₁.binOp v₂ o with
    | .error m => error c k .type m
    | .ok    v => ret c k v

  /- `error` and `done` states just loop into themselves! -/
  | s@(error ..) => s
  | s@(done ..)  => s

/-- And now we can finally define our partial function to run a program using
`step`. It's really simple: call `step` until it yields a value or an error! -/
partial def Program.run (p : Program) : Context × Result :=
  let rec run' (s : State) : Context × Result :=
    match s.step with
    | .error c _ t m => (c, .err t m)
    | .done  c _ v   => (c, .val v)
    | s              => run' s
  run' $ State.prog default default p


/-
Copyright (c) 2021 Gabriel Ebner. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Gabriel Ebner
-/
import Lean

/-!
# Irreducible definitions

This file defines an `irreducible_def` command,
which works almost like the `def` command
except that the introduced definition
does not reduce to the value.
Instead, the command
adds a `_def` lemma
which can be used for rewriting.

```
irreducible_def frobnicate (a b : Nat) :=
  a + b

example : frobnicate a 0 = a := by
  simp [frobnicate_def]
```

-/

namespace Lean.Elab.Command

open Term Meta

/-- `delta% t` elaborates to a head-delta reduced version of `t`. -/
elab "delta% " t:term : term <= expectedType => do
  let t ← elabTerm t expectedType
  synthesizeSyntheticMVars
  let t ← instantiateMVars t
  let some t ← delta? t | throwError "cannot delta reduce {t}"
  pure t

/- `eta_helper f = (· + 3)` elabs to `∀ x, f x = x + 3` -/
local elab "eta_helper " t:term : term => do
  let t ← elabTerm t none
  let some (_, lhs, rhs) := t.eq? | throwError "not an equation: {t}"
  synthesizeSyntheticMVars
  let rhs ← instantiateMVars rhs
  lambdaLetTelescope rhs fun xs rhs ↦ do
    let lhs := (mkAppN lhs xs).headBeta
    mkForallFVars xs <|← mkEq lhs rhs

/-- `value_proj x` elabs to `@x.value` -/
local elab "value_proj " e:term : term => do
  let e ← elabTerm e none
  mkProjection e `value

/--
Executes the commands,
and stops after the first error.
In short, S-A-F-E.
-/
local syntax "stop_at_first_error" command* : command
open Command in elab_rules : command
  | `(stop_at_first_error $[$cmds]*) => do
    for cmd in cmds do
      elabCommand cmd.raw
      if (← get).messages.hasErrors then break

/--
Introduces an irreducible definition.
`irreducible_def foo := 42` generates
a constant `foo : Nat` as well as
a theorem `foo_def : foo = 42`.
-/
macro mods:declModifiers "irreducible_def" n_id:declId declSig:optDeclSig val:declVal :
    command => do
  let (n, us) ← match n_id with
    | `(Parser.Command.declId| $n:ident $[.{$us,*}]?) => pure (n, us)
    | _ => Macro.throwUnsupported
  let us' := us.getD { elemsAndSeps := #[] }
  let n_def := mkIdent <| (·.review) <|
    let scopes := extractMacroScopes n.getId
    { scopes with name := scopes.name.appendAfter "_def" }
  `(stop_at_first_error
    def definition$[.{$us,*}]? $declSig:optDeclSig $val
    set_option genInjectivity false in -- generates awful simp lemmas
    structure Wrapper$[.{$us,*}]? where
      value : type_of% @definition.{$us',*}
      prop : Eq @value @(delta% @definition)
    opaque wrapped$[.{$us,*}]? : Wrapper.{$us',*} := ⟨_, rfl⟩
    $mods:declModifiers def $n:ident$[.{$us,*}]? := value_proj @wrapped.{$us',*}
    theorem $n_def:ident $[.{$us,*}]? : eta_helper Eq @$n.{$us',*} @(delta% @definition) := by
      intros
      simp only [$n:ident]
      rw [wrapped.prop])


/-
Copyright (c) 2014 Parikshit Khanna. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Parikshit Khanna, Jeremy Avigad, Leonardo de Moura, Floris van Doorn
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.data.list.basic
import Mathlib.Lean3Lib.init.function
import Mathlib.Lean3Lib.init.meta.default
import Mathlib.Lean3Lib.init.data.nat.lemmas
import Mathlib.Lean3Lib.init.meta.interactive
import Mathlib.Lean3Lib.init.meta.smt.rsimp

universes u v w w₂ w₁

namespace Mathlib

namespace list

/- append -/

@[simp] theorem nil_append {α : Type u} (s : List α) : [] ++ s = s :=
  rfl

@[simp] theorem cons_append {α : Type u} (x : α) (s : List α) (t : List α) : x :: s ++ t = x :: (s ++ t) :=
  rfl

@[simp] theorem append_nil {α : Type u} (t : List α) : t ++ [] = t := sorry

@[simp] theorem append_assoc {α : Type u} (s : List α) (t : List α) (u : List α) : s ++ t ++ u = s ++ (t ++ u) := sorry

/- length -/

theorem length_cons {α : Type u} (a : α) (l : List α) : length (a :: l) = length l + 1 :=
  rfl

@[simp] theorem length_append {α : Type u} (s : List α) (t : List α) : length (s ++ t) = length s + length t := sorry

@[simp] theorem length_repeat {α : Type u} (a : α) (n : ℕ) : length (repeat a n) = n := sorry

@[simp] theorem length_tail {α : Type u} (l : List α) : length (tail l) = length l - 1 :=
  list.cases_on l (Eq.refl (length (tail []))) fun (l_hd : α) (l_tl : List α) => Eq.refl (length (tail (l_hd :: l_tl)))

-- TODO(Leo): cleanup proof after arith dec proc

@[simp] theorem length_drop {α : Type u} (i : ℕ) (l : List α) : length (drop i l) = length l - i := sorry

/- map -/

theorem map_cons {α : Type u} {β : Type v} (f : α → β) (a : α) (l : List α) : map f (a :: l) = f a :: map f l :=
  rfl

@[simp] theorem map_append {α : Type u} {β : Type v} (f : α → β) (l₁ : List α) (l₂ : List α) : map f (l₁ ++ l₂) = map f l₁ ++ map f l₂ := sorry

theorem map_singleton {α : Type u} {β : Type v} (f : α → β) (a : α) : map f [a] = [f a] :=
  rfl

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

@[simp] theorem map_map {α : Type u} {β : Type v} {γ : Type w} (g : β → γ) (f : α → β) (l : List α) : map g (map f l) = map (g ∘ f) l := sorry

@[simp] theorem length_map {α : Type u} {β : Type v} (f : α → β) (l : List α) : length (map f l) = length l := sorry

/- bind -/

@[simp] theorem nil_bind {α : Type u} {β : Type v} (f : α → List β) : list.bind [] f = [] := sorry

@[simp] theorem cons_bind {α : Type u} {β : Type v} (x : α) (xs : List α) (f : α → List β) : list.bind (x :: xs) f = f x ++ list.bind xs f := sorry

@[simp] theorem append_bind {α : Type u} {β : Type v} (xs : List α) (ys : List α) (f : α → List β) : list.bind (xs ++ ys) f = list.bind xs f ++ list.bind ys f := sorry

/- mem -/

@[simp] theorem mem_nil_iff {α : Type u} (a : α) : a ∈ [] ↔ False :=
  iff.rfl

@[simp] theorem not_mem_nil {α : Type u} (a : α) : ¬a ∈ [] :=
  iff.mp (mem_nil_iff a)

@[simp] theorem mem_cons_self {α : Type u} (a : α) (l : List α) : a ∈ a :: l :=
  Or.inl rfl

@[simp] theorem mem_cons_iff {α : Type u} (a : α) (y : α) (l : List α) : a ∈ y :: l ↔ a = y ∨ a ∈ l :=
  iff.rfl

theorem mem_cons_eq {α : Type u} (a : α) (y : α) (l : List α) : a ∈ y :: l = (a = y ∨ a ∈ l) :=
  rfl

theorem mem_cons_of_mem {α : Type u} (y : α) {a : α} {l : List α} : a ∈ l → a ∈ y :: l :=
  fun (H : a ∈ l) => Or.inr H

theorem eq_or_mem_of_mem_cons {α : Type u} {a : α} {y : α} {l : List α} : a ∈ y :: l → a = y ∨ a ∈ l :=
  fun (h : a ∈ y :: l) => h

@[simp] theorem mem_append {α : Type u} {a : α} {s : List α} {t : List α} : a ∈ s ++ t ↔ a ∈ s ∨ a ∈ t := sorry

theorem mem_append_eq {α : Type u} (a : α) (s : List α) (t : List α) : a ∈ s ++ t = (a ∈ s ∨ a ∈ t) :=
  propext mem_append

theorem mem_append_left {α : Type u} {a : α} {l₁ : List α} (l₂ : List α) (h : a ∈ l₁) : a ∈ l₁ ++ l₂ :=
  iff.mpr mem_append (Or.inl h)

theorem mem_append_right {α : Type u} {a : α} (l₁ : List α) {l₂ : List α} (h : a ∈ l₂) : a ∈ l₁ ++ l₂ :=
  iff.mpr mem_append (Or.inr h)

@[simp] theorem not_bex_nil {α : Type u} (p : α → Prop) : ¬∃ (x : α), ∃ (H : x ∈ []), p x := sorry

@[simp] theorem ball_nil {α : Type u} (p : α → Prop) (x : α) (H : x ∈ []) : p x :=
  false.elim

@[simp] theorem bex_cons {α : Type u} (p : α → Prop) (a : α) (l : List α) : (∃ (x : α), ∃ (H : x ∈ a :: l), p x) ↔ p a ∨ ∃ (x : α), ∃ (H : x ∈ l), p x := sorry

@[simp] theorem ball_cons {α : Type u} (p : α → Prop) (a : α) (l : List α) : (∀ (x : α), x ∈ a :: l → p x) ↔ p a ∧ ∀ (x : α), x ∈ l → p x := sorry

/- list subset -/

protected def subset {α : Type u} (l₁ : List α) (l₂ : List α) :=
  ∀ {a : α}, a ∈ l₁ → a ∈ l₂

protected instance has_subset {α : Type u} : has_subset (List α) :=
  has_subset.mk list.subset

@[simp] theorem nil_subset {α : Type u} (l : List α) : [] ⊆ l :=
  fun (b : α) (i : b ∈ []) => false.elim (iff.mp (mem_nil_iff b) i)

@[simp] theorem subset.refl {α : Type u} (l : List α) : l ⊆ l :=
  fun (b : α) (i : b ∈ l) => i

theorem subset.trans {α : Type u} {l₁ : List α} {l₂ : List α} {l₃ : List α} (h₁ : l₁ ⊆ l₂) (h₂ : l₂ ⊆ l₃) : l₁ ⊆ l₃ :=
  fun (b : α) (i : b ∈ l₁) => h₂ (h₁ i)

@[simp] theorem subset_cons {α : Type u} (a : α) (l : List α) : l ⊆ a :: l :=
  fun (b : α) (i : b ∈ l) => Or.inr i

theorem subset_of_cons_subset {α : Type u} {a : α} {l₁ : List α} {l₂ : List α} : a :: l₁ ⊆ l₂ → l₁ ⊆ l₂ :=
  fun (s : a :: l₁ ⊆ l₂) (b : α) (i : b ∈ l₁) => s (mem_cons_of_mem a i)

theorem cons_subset_cons {α : Type u} {l₁ : List α} {l₂ : List α} (a : α) (s : l₁ ⊆ l₂) : a :: l₁ ⊆ a :: l₂ :=
  fun (b : α) (hin : b ∈ a :: l₁) =>
    or.elim (eq_or_mem_of_mem_cons hin) (fun (e : b = a) => Or.inl e) fun (i : b ∈ l₁) => Or.inr (s i)

@[simp] theorem subset_append_left {α : Type u} (l₁ : List α) (l₂ : List α) : l₁ ⊆ l₁ ++ l₂ :=
  fun (b : α) => mem_append_left l₂

@[simp] theorem subset_append_right {α : Type u} (l₁ : List α) (l₂ : List α) : l₂ ⊆ l₁ ++ l₂ :=
  fun (b : α) => mem_append_right l₁

theorem subset_cons_of_subset {α : Type u} (a : α) {l₁ : List α} {l₂ : List α} : l₁ ⊆ l₂ → l₁ ⊆ a :: l₂ :=
  fun (s : l₁ ⊆ l₂) (a_1 : α) (i : a_1 ∈ l₁) => Or.inr (s i)

theorem eq_nil_of_length_eq_zero {α : Type u} {l : List α} : length l = 0 → l = [] := sorry

theorem ne_nil_of_length_eq_succ {α : Type u} {l : List α} {n : ℕ} : length l = Nat.succ n → l ≠ [] := sorry

@[simp] theorem length_map₂ {α : Type u} {β : Type v} {γ : Type w} (f : α → β → γ) (l₁ : List α) (l₂ : List β) : length (map₂ f l₁ l₂) = min (length l₁) (length l₂) := sorry

@[simp] theorem length_take {α : Type u} (i : ℕ) (l : List α) : length (take i l) = min i (length l) := sorry

theorem length_take_le {α : Type u} (n : ℕ) (l : List α) : length (take n l) ≤ n := sorry

theorem length_remove_nth {α : Type u} (l : List α) (i : ℕ) : i < length l → length (remove_nth l i) = length l - 1 := sorry

@[simp] theorem partition_eq_filter_filter {α : Type u} (p : α → Prop) [decidable_pred p] (l : List α) : partition p l = (filter p l, filter (Not ∘ p) l) := sorry

/- sublists -/

inductive sublist {α : Type u} : List α → List α → Prop
where
| slnil : sublist [] []
| cons : ∀ (l₁ l₂ : List α) (a : α), sublist l₁ l₂ → sublist l₁ (a :: l₂)
| cons2 : ∀ (l₁ l₂ : List α) (a : α), sublist l₁ l₂ → sublist (a :: l₁) (a :: l₂)

infixl:50 " <+ " => Mathlib.list.sublist

theorem length_le_of_sublist {α : Type u} {l₁ : List α} {l₂ : List α} : l₁ <+ l₂ → length l₁ ≤ length l₂ := sorry

/- filter -/

@[simp] theorem filter_nil {α : Type u} (p : α → Prop) [h : decidable_pred p] : filter p [] = [] :=
  rfl

@[simp] theorem filter_cons_of_pos {α : Type u} {p : α → Prop} [h : decidable_pred p] {a : α} (l : List α) : p a → filter p (a :: l) = a :: filter p l :=
  fun (pa : p a) => if_pos pa

@[simp] theorem filter_cons_of_neg {α : Type u} {p : α → Prop} [h : decidable_pred p] {a : α} (l : List α) : ¬p a → filter p (a :: l) = filter p l :=
  fun (pa : ¬p a) => if_neg pa

@[simp] theorem filter_append {α : Type u} {p : α → Prop} [h : decidable_pred p] (l₁ : List α) (l₂ : List α) : filter p (l₁ ++ l₂) = filter p l₁ ++ filter p l₂ := sorry

@[simp] theorem filter_sublist {α : Type u} {p : α → Prop} [h : decidable_pred p] (l : List α) : filter p l <+ l := sorry

/- map_accumr -/

-- This runs a function over a list returning the intermediate results and a

-- a final result.

def map_accumr {α : Type u} {β : Type v} {σ : Type w₂} (f : α → σ → σ × β) : List α → σ → σ × List β :=
  sorry

@[simp] theorem length_map_accumr {α : Type u} {β : Type v} {σ : Type w₂} (f : α → σ → σ × β) (x : List α) (s : σ) : length (prod.snd (map_accumr f x s)) = length x := sorry

-- This runs a function over two lists returning the intermediate results and a

-- a final result.

def map_accumr₂ {α : Type u} {β : Type v} {φ : Type w₁} {σ : Type w₂} (f : α → β → σ → σ × φ) : List α → List β → σ → σ × List φ :=
  sorry

@[simp] theorem length_map_accumr₂ {α : Type u} {β : Type v} {φ : Type w₁} {σ : Type w₂} (f : α → β → σ → σ × φ) (x : List α) (y : List β) (c : σ) : length (prod.snd (map_accumr₂ f x y c)) = min (length x) (length y) := sorry


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

/-!
# The category of bipointed types

This defines `Bipointed`, the category of bipointed types.

## TODO

Monoidal structure
-/

open category_theory

universes u
variables {α β : Type*}

/-- The category of bipointed types. -/
structure Bipointed : Type.{u + 1} :=
(X : Type.{u})
(to_prod : X × X)

namespace Bipointed

instance : has_coe_to_sort Bipointed Type* := ⟨X⟩

attribute [protected] Bipointed.X

/-- Turns a bipointing into a bipointed type. -/
def of {X : Type*} (to_prod : X × X) : Bipointed := ⟨X, to_prod⟩

@[simp] lemma coe_of {X : Type*} (to_prod : X × X) : ↥(of to_prod) = X := rfl

alias of ← _root_.prod.Bipointed

instance : inhabited Bipointed := ⟨of ((), ())⟩

/-- Morphisms in `Bipointed`. -/
@[ext] protected structure hom (X Y : Bipointed.{u}) : Type u :=
(to_fun : X → Y)
(map_fst : to_fun X.to_prod.1 = Y.to_prod.1)
(map_snd : to_fun X.to_prod.2 = Y.to_prod.2)

namespace hom

/-- The identity morphism of `X : Bipointed`. -/
@[simps] def id (X : Bipointed) : hom X X := ⟨id, rfl, rfl⟩

instance (X : Bipointed) : inhabited (hom X X) := ⟨id X⟩

/-- Composition of morphisms of `Bipointed`. -/
@[simps] def comp {X Y Z : Bipointed.{u}} (f : hom X Y) (g : hom Y Z) : hom X Z :=
⟨g.to_fun ∘ f.to_fun, by rw [function.comp_apply, f.map_fst, g.map_fst],
  by rw [function.comp_apply, f.map_snd, g.map_snd]⟩

end hom

instance large_category : large_category Bipointed :=
{ hom := hom,
  id := hom.id,
  comp := @hom.comp,
  id_comp' := λ _ _ _, hom.ext _ _ rfl,
  comp_id' := λ _ _ _, hom.ext _ _ rfl,
  assoc' := λ _ _ _ _ _ _ _, hom.ext _ _ rfl }

instance concrete_category : concrete_category Bipointed :=
{ forget := { obj := Bipointed.X, map := @hom.to_fun },
  forget_faithful := ⟨@hom.ext⟩ }

/-- Swaps the pointed elements of a bipointed type. `prod.swap` as a functor. -/
@[simps] def swap : Bipointed ⥤ Bipointed :=
{ obj := λ X, ⟨X, X.to_prod.swap⟩, map := λ X Y f, ⟨f.to_fun, f.map_snd, f.map_fst⟩ }

/-- The equivalence between `Bipointed` and itself induced by `prod.swap` both ways. -/
@[simps] def swap_equiv : Bipointed ≌ Bipointed :=
equivalence.mk swap swap
  (nat_iso.of_components (λ X, { hom := ⟨id, rfl, rfl⟩, inv := ⟨id, rfl, rfl⟩ }) $ λ X Y f, rfl)
  (nat_iso.of_components (λ X, { hom := ⟨id, rfl, rfl⟩, inv := ⟨id, rfl, rfl⟩ }) $ λ X Y f, rfl)

@[simp] lemma swap_equiv_symm : swap_equiv.symm = swap_equiv := rfl

end Bipointed

/-- The forgetful functor from `Bipointed` to `Pointed` which forgets about the second point. -/
def Bipointed_to_Pointed_fst : Bipointed ⥤ Pointed :=
{ obj := λ X, ⟨X, X.to_prod.1⟩, map := λ X Y f, ⟨f.to_fun, f.map_fst⟩ }

/-- The forgetful functor from `Bipointed` to `Pointed` which forgets about the first point. -/
def Bipointed_to_Pointed_snd : Bipointed ⥤ Pointed :=
{ obj := λ X, ⟨X, X.to_prod.2⟩, map := λ X Y f, ⟨f.to_fun, f.map_snd⟩ }

@[simp] lemma Bipointed_to_Pointed_fst_comp_forget :
  Bipointed_to_Pointed_fst ⋙ forget Pointed = forget Bipointed := rfl

@[simp] lemma Bipointed_to_Pointed_snd_comp_forget :
  Bipointed_to_Pointed_snd ⋙ forget Pointed = forget Bipointed := rfl

@[simp] lemma swap_comp_Bipointed_to_Pointed_fst :
  Bipointed.swap ⋙ Bipointed_to_Pointed_fst = Bipointed_to_Pointed_snd := rfl

@[simp] lemma swap_comp_Bipointed_to_Pointed_snd :
  Bipointed.swap ⋙ Bipointed_to_Pointed_snd = Bipointed_to_Pointed_fst := rfl

/-- The functor from `Pointed` to `Bipointed` which bipoints the point. -/
def Pointed_to_Bipointed : Pointed.{u} ⥤ Bipointed :=
{ obj := λ X, ⟨X, X.point, X.point⟩, map := λ X Y f, ⟨f.to_fun, f.map_point, f.map_point⟩ }

/-- The functor from `Pointed` to `Bipointed` which adds a second point. -/
def Pointed_to_Bipointed_fst : Pointed.{u} ⥤ Bipointed :=
{ obj := λ X, ⟨option X, X.point, none⟩,
  map := λ X Y f, ⟨option.map f.to_fun, congr_arg _ f.map_point, rfl⟩,
  map_id' := λ X, Bipointed.hom.ext _ _ option.map_id,
  map_comp' := λ X Y Z f g, Bipointed.hom.ext _ _ (option.map_comp_map  _ _).symm }

/-- The functor from `Pointed` to `Bipointed` which adds a first point. -/
def Pointed_to_Bipointed_snd : Pointed.{u} ⥤ Bipointed :=
{ obj := λ X, ⟨option X, none, X.point⟩,
  map := λ X Y f, ⟨option.map f.to_fun, rfl, congr_arg _ f.map_point⟩,
  map_id' := λ X, Bipointed.hom.ext _ _ option.map_id,
  map_comp' := λ X Y Z f g, Bipointed.hom.ext _ _ (option.map_comp_map  _ _).symm }

@[simp] lemma Pointed_to_Bipointed_fst_comp_swap :
  Pointed_to_Bipointed_fst ⋙ Bipointed.swap = Pointed_to_Bipointed_snd := rfl

@[simp] lemma Pointed_to_Bipointed_snd_comp_swap :
  Pointed_to_Bipointed_snd ⋙ Bipointed.swap = Pointed_to_Bipointed_fst := rfl

/-- `Bipointed_to_Pointed_fst` is inverse to `Pointed_to_Bipointed`. -/
@[simps] def Pointed_to_Bipointed_comp_Bipointed_to_Pointed_fst :
  Pointed_to_Bipointed ⋙ Bipointed_to_Pointed_fst ≅ 𝟭 _ :=
nat_iso.of_components (λ X, { hom := ⟨id, rfl⟩, inv := ⟨id, rfl⟩ }) $ λ X Y f, rfl

/-- `Bipointed_to_Pointed_snd` is inverse to `Pointed_to_Bipointed`. -/
@[simps] def Pointed_to_Bipointed_comp_Bipointed_to_Pointed_snd :
  Pointed_to_Bipointed ⋙ Bipointed_to_Pointed_snd ≅ 𝟭 _ :=
nat_iso.of_components (λ X, { hom := ⟨id, rfl⟩, inv := ⟨id, rfl⟩ }) $ λ X Y f, rfl

/-- The free/forgetful adjunction between `Pointed_to_Bipointed_fst` and `Bipointed_to_Pointed_fst`.
-/
def Pointed_to_Bipointed_fst_Bipointed_to_Pointed_fst_adjunction :
  Pointed_to_Bipointed_fst ⊣ Bipointed_to_Pointed_fst :=
adjunction.mk_of_hom_equiv
{ hom_equiv := λ X Y, { to_fun := λ f, ⟨f.to_fun ∘ option.some, f.map_fst⟩,
                        inv_fun := λ f, ⟨λ o, o.elim Y.to_prod.2 f.to_fun, f.map_point, rfl⟩,
                        left_inv := λ f, by { ext, cases x, exact f.map_snd.symm, refl },
                        right_inv := λ f, Pointed.hom.ext _ _ rfl },
  hom_equiv_naturality_left_symm' := λ X' X Y f g, by { ext, cases x; refl } }

/-- The free/forgetful adjunction between `Pointed_to_Bipointed_snd` and `Bipointed_to_Pointed_snd`.
-/
def Pointed_to_Bipointed_snd_Bipointed_to_Pointed_snd_adjunction :
  Pointed_to_Bipointed_snd ⊣ Bipointed_to_Pointed_snd :=
adjunction.mk_of_hom_equiv
{ hom_equiv := λ X Y, { to_fun := λ f, ⟨f.to_fun ∘ option.some, f.map_snd⟩,
                        inv_fun := λ f, ⟨λ o, o.elim Y.to_prod.1 f.to_fun, rfl, f.map_point⟩,
                        left_inv := λ f, by { ext, cases x, exact f.map_fst.symm, refl },
                        right_inv := λ f, Pointed.hom.ext _ _ rfl },
  hom_equiv_naturality_left_symm' := λ X' X Y f g, by { ext, cases x; refl } }


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

import meta.expr

/-
Lean currently uses the name ᾰ for binders which aren't given a name explicitly
(e.g. when using a function arrow to define a Π type). This test is here to make
sure that should this change in the future,
`name.is_likely_generated_binder_name` will be updated accordingly.
-/

example : ℕ → ℕ → ℕ :=
begin
  intros,
  guard_hyp ᾰ : ℕ,
  guard_hyp ᾰ_1 : ℕ,
  (do guard $ name.is_likely_generated_binder_name `ᾰ,
      guard $ name.is_likely_generated_binder_name `ᾰ_1
  ),
  exact ᾰ
end


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

/-!

# Properties of morphisms from properties of ring homs.

We provide the basic framework for talking about properties of morphisms that come from properties
of ring homs. For `P` a property of ring homs, we have two ways of defining a property of scheme
morphisms:

Let `f : X ⟶ Y`,
- `target_affine_locally (affine_and P)`: the preimage of an affine open `U = Spec A` is affine
  (`= Spec B`) and `A ⟶ B` satisfies `P`. (TODO)
- `affine_locally P`: For each pair of affine open `U = Spec A ⊆ X` and `V = Spec B ⊆ f ⁻¹' U`,
  the ring hom `A ⟶ B` satisfies `P`.

For these notions to be well defined, we require `P` be a sufficient local property. For the former,
`P` should be local on the source (`ring_hom.respects_iso P`, `ring_hom.localization_preserves P`,
`ring_hom.of_localization_span`), and `target_affine_locally (affine_and P)` will be local on
the target. (TODO)

For the latter `P` should be local on the target (`ring_hom.property_is_local P`), and
`affine_locally P` will be local on both the source and the target.

Further more, these properties are stable under compositions (resp. base change) if `P` is. (TODO)

-/

universe u

open category_theory opposite topological_space category_theory.limits algebraic_geometry

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

namespace ring_hom

include P

variable {P}

lemma respects_iso.basic_open_iff (hP : respects_iso @P) {X Y : Scheme}
  [is_affine X] [is_affine Y] (f : X ⟶ Y) (r : Y.presheaf.obj (opposite.op ⊤)) :
  P (Scheme.Γ.map (f ∣_ Y.basic_open r).op) ↔
  P (@is_localization.away.map (Y.presheaf.obj (opposite.op ⊤)) _
      (Y.presheaf.obj (opposite.op $ Y.basic_open r)) _ _
      (X.presheaf.obj (opposite.op ⊤)) _ (X.presheaf.obj
      (opposite.op $ X.basic_open (Scheme.Γ.map f.op r))) _ _ (Scheme.Γ.map f.op) r _ _) :=
begin
  rw [Γ_map_morphism_restrict, hP.cancel_left_is_iso, hP.cancel_right_is_iso,
    ← (hP.cancel_right_is_iso (f.val.c.app (opposite.op (Y.basic_open r))) (X.presheaf.map
      (eq_to_hom (Scheme.preimage_basic_open f r).symm).op)), ← eq_iff_iff],
  congr,
  delta is_localization.away.map,
  refine is_localization.ring_hom_ext (submonoid.powers r) _,
  convert (is_localization.map_comp _).symm using 1,
  change Y.presheaf.map _ ≫ _ = _ ≫ X.presheaf.map _,
  rw f.val.c.naturality_assoc,
  erw ← X.presheaf.map_comp,
  congr,
end

lemma respects_iso.basic_open_iff_localization (hP : respects_iso @P)
  {X Y : Scheme} [is_affine X] [is_affine Y] (f : X ⟶ Y) (r : Y.presheaf.obj (opposite.op ⊤)) :
  P (Scheme.Γ.map (f ∣_ Y.basic_open r).op) ↔
  P (localization.away_map (Scheme.Γ.map f.op) r) :=
(hP.basic_open_iff _ _).trans (hP.is_localization_away_iff _ _ _ _).symm

lemma respects_iso.of_restrict_morphism_restrict_iff (hP : ring_hom.respects_iso @P)
  {X Y : Scheme} [is_affine Y] (f : X ⟶ Y) (r : Y.presheaf.obj (opposite.op ⊤))
  (U : opens X.carrier) (hU : is_affine_open U) {V : opens _}
  (e : V = (opens.map (X.of_restrict ((opens.map f.1.base).obj _).open_embedding).1.base).obj U) :
  P (Scheme.Γ.map ((X.restrict ((opens.map f.1.base).obj _).open_embedding).of_restrict
    V.open_embedding ≫ f ∣_ Y.basic_open r).op) ↔
    P (localization.away_map (Scheme.Γ.map (X.of_restrict U.open_embedding ≫ f).op) r) :=
begin
  subst e,
  convert (hP.is_localization_away_iff _ _ _ _).symm,
  rotate,
  { apply_instance },
  { apply ring_hom.to_algebra,
    refine X.presheaf.map
      (@hom_of_le _ _ ((is_open_map.functor _).obj _) ((is_open_map.functor _).obj _) _).op,
    rw [opens.le_def],
    dsimp,
    change coe '' (coe '' set.univ) ⊆ coe '' set.univ,
    rw [subtype.coe_image_univ, subtype.coe_image_univ],
    exact set.image_preimage_subset _ _ },
  { exact algebraic_geometry.Γ_restrict_is_localization Y r },
  { rw ← U.open_embedding_obj_top at hU,
    dsimp [Scheme.Γ_obj_op, Scheme.Γ_map_op, Scheme.restrict],
    apply algebraic_geometry.is_localization_of_eq_basic_open _ hU,
    rw [opens.open_embedding_obj_top, opens.functor_obj_map_obj],
    convert (X.basic_open_res (Scheme.Γ.map f.op r) (hom_of_le le_top).op).symm using 1,
    rw [opens.open_embedding_obj_top, opens.open_embedding_obj_top, inf_comm,
      Scheme.Γ_map_op, ← Scheme.preimage_basic_open] },
  { apply is_localization.ring_hom_ext (submonoid.powers r) _,
    swap, { exact algebraic_geometry.Γ_restrict_is_localization Y r },
    rw [is_localization.away.map, is_localization.map_comp, ring_hom.algebra_map_to_algebra,
      ring_hom.algebra_map_to_algebra, op_comp, functor.map_comp, op_comp, functor.map_comp],
    refine (@category.assoc CommRing _ _ _ _ _ _ _ _).symm.trans _,
    refine eq.trans _ (@category.assoc CommRing _ _ _ _ _ _ _ _),
    dsimp only [Scheme.Γ_map, quiver.hom.unop_op],
    rw [morphism_restrict_c_app, category.assoc, category.assoc, category.assoc],
    erw [f.1.c.naturality_assoc, ← X.presheaf.map_comp, ← X.presheaf.map_comp,
      ← X.presheaf.map_comp],
    congr },
end

lemma stable_under_base_change.Γ_pullback_fst
  (hP : stable_under_base_change @P) (hP' : respects_iso @P) {X Y S : Scheme}
  [is_affine X] [is_affine Y] [is_affine S]
  (f : X ⟶ S) (g : Y ⟶ S) (H : P (Scheme.Γ.map g.op)) :
    P (Scheme.Γ.map (pullback.fst : pullback f g ⟶ _).op) :=
begin
  rw [← preserves_pullback.iso_inv_fst AffineScheme.forget_to_Scheme
    (AffineScheme.of_hom f) (AffineScheme.of_hom g), op_comp, functor.map_comp,
    hP'.cancel_right_is_iso, AffineScheme.forget_to_Scheme_map],
  have := _root_.congr_arg quiver.hom.unop (preserves_pullback.iso_hom_fst AffineScheme.Γ.right_op
    (AffineScheme.of_hom f) (AffineScheme.of_hom g)),
  simp only [quiver.hom.unop_op, functor.right_op_map, unop_comp] at this,
  delta AffineScheme.Γ at this,
  simp only [quiver.hom.unop_op, functor.comp_map, AffineScheme.forget_to_Scheme_map,
    functor.op_map] at this,
  rw [← this, hP'.cancel_right_is_iso,
    ← pushout_iso_unop_pullback_inl_hom (quiver.hom.unop _) (quiver.hom.unop _),
    hP'.cancel_right_is_iso],
  exact hP.pushout_inl _ hP' _ _ H
end

end ring_hom

namespace algebraic_geometry

/-- For `P` a property of ring homomorphisms, `source_affine_locally P` holds for `f : X ⟶ Y`
whenever `P` holds for the restriction of `f` on every affine open subset of `X`. -/
def source_affine_locally : affine_target_morphism_property :=
λ X Y f hY, ∀ (U : X.affine_opens), P (Scheme.Γ.map (X.of_restrict U.1.open_embedding ≫ f).op)

/-- For `P` a property of ring homomorphisms, `affine_locally P` holds for `f : X ⟶ Y` if for each
affine open `U = Spec A ⊆ Y` and `V = Spec B ⊆ f ⁻¹' U`, the ring hom `A ⟶ B` satisfies `P`.
Also see `affine_locally_iff_affine_opens_le`. -/
abbreviation affine_locally : morphism_property Scheme :=
target_affine_locally (source_affine_locally @P)

variable {P}

lemma source_affine_locally_respects_iso (h₁ : ring_hom.respects_iso @P) :
  (source_affine_locally @P).to_property.respects_iso :=
begin
  apply affine_target_morphism_property.respects_iso_mk,
  { introv H U,
    rw [← h₁.cancel_right_is_iso _ (Scheme.Γ.map (Scheme.restrict_map_iso e.inv U.1).hom.op),
      ← functor.map_comp, ← op_comp],
    convert H ⟨_, U.prop.map_is_iso e.inv⟩ using 3,
    rw [is_open_immersion.iso_of_range_eq_hom, is_open_immersion.lift_fac_assoc,
      category.assoc, e.inv_hom_id_assoc],
    refl },
  { introv H U,
    rw [← category.assoc, op_comp, functor.map_comp, h₁.cancel_left_is_iso],
    exact H U }
end

lemma affine_locally_mono
  (P₁ P₂ : ∀ ⦃R S : Type u⦄ [comm_ring R] [comm_ring S] (f : by exactI R →+* S), Prop)
  (H : ∀ {R S : Type u} [comm_ring R] [comm_ring S], by exactI ∀ (f : R →+* S), P₁ f → P₂ f) :
  affine_locally P₁ ≤ affine_locally P₂ :=
begin
  refine target_affine_locally_mono _,
  intros X Y f hY hf U,
  exact H _ (hf _),
end
lemma affine_locally_respects_iso (h : ring_hom.respects_iso @P) :
  (affine_locally @P).respects_iso :=
target_affine_locally_respects_iso (source_affine_locally_respects_iso h)

lemma affine_locally_iff_affine_opens_le
  (hP : ring_hom.respects_iso @P) {X Y : Scheme} (f : X ⟶ Y) :
  affine_locally @P f ↔
  (∀ (U : Y.affine_opens) (V : X.affine_opens) (e : V.1 ≤ (opens.map f.1.base).obj U.1),
    P (f.app_le e)) :=
begin
  apply forall_congr,
  intro U,
  delta source_affine_locally,
  simp_rw [op_comp, Scheme.Γ.map_comp, Γ_map_morphism_restrict, category.assoc, Scheme.Γ_map_op,
    hP.cancel_left_is_iso],
  split,
  { intros H V e,
    let U' := (opens.map f.val.base).obj U.1,
    have e' : U'.open_embedding.is_open_map.functor.obj ((opens.map U'.inclusion).obj V.1) = V.1,
    { ext1, refine set.image_preimage_eq_inter_range.trans (set.inter_eq_left_iff_subset.mpr _),
      convert e, exact subtype.range_coe },
    have := H ⟨(opens.map (X.of_restrict (U'.open_embedding)).1.base).obj V.1, _⟩,
    erw ← X.presheaf.map_comp at this,
    rw [← hP.cancel_right_is_iso _ (X.presheaf.map (eq_to_hom _)), category.assoc,
      ← X.presheaf.map_comp],
    convert this using 1,
    { dsimp only [functor.op, unop_op], rw opens.open_embedding_obj_top, congr' 1, exact e'.symm },
    { apply_instance },
    { apply (is_affine_open_iff_of_is_open_immersion (X.of_restrict _) _).mp,
      convert V.2,
      apply_instance } },
  { intros H V,
    specialize H ⟨_, V.2.image_is_open_immersion (X.of_restrict _)⟩ (subtype.coe_image_subset _ _),
    erw ← X.presheaf.map_comp,
    rw [← hP.cancel_right_is_iso _ (X.presheaf.map (eq_to_hom _)), category.assoc,
      ← X.presheaf.map_comp],
    convert H,
    { dsimp only [functor.op, unop_op], rw opens.open_embedding_obj_top, refl },
    { apply_instance } }
end

lemma Scheme_restrict_basic_open_of_localization_preserves
  (h₁ : ring_hom.respects_iso @P)
  (h₂ : ring_hom.localization_preserves @P)
  {X Y : Scheme} [is_affine Y] (f : X ⟶ Y) (r : Y.presheaf.obj (op ⊤))
  (H : source_affine_locally @P f)
  (U : (X.restrict ((opens.map f.1.base).obj $ Y.basic_open r).open_embedding).affine_opens) :
  P (Scheme.Γ.map
    ((X.restrict ((opens.map f.1.base).obj $ Y.basic_open r).open_embedding).of_restrict
      U.1.open_embedding ≫ f ∣_ Y.basic_open r).op) :=
begin
  specialize H ⟨_, U.2.image_is_open_immersion (X.of_restrict _)⟩,
  convert (h₁.of_restrict_morphism_restrict_iff _ _ _ _ _).mpr _ using 1,
  swap 5,
  { exact h₂.away r H },
  { apply_instance },
  { exact U.2.image_is_open_immersion _},
  { ext1, exact (set.preimage_image_eq _ subtype.coe_injective).symm }
end

lemma source_affine_locally_is_local
  (h₁ : ring_hom.respects_iso @P)
  (h₂ : ring_hom.localization_preserves @P)
  (h₃ : ring_hom.of_localization_span @P) : (source_affine_locally @P).is_local :=
begin
  constructor,
  { exact source_affine_locally_respects_iso h₁ },
  { introv H U,
    apply Scheme_restrict_basic_open_of_localization_preserves h₁ h₂; assumption },
  { introv hs hs' U,
    resetI,
    apply h₃ _ _ hs,
    intro r,
    have := hs' r ⟨(opens.map (X.of_restrict _).1.base).obj U.1, _⟩,
    rwa h₁.of_restrict_morphism_restrict_iff at this,
    { exact U.2 },
    { refl },
    { apply_instance },
    { suffices : ∀ (V = (opens.map f.val.base).obj (Y.basic_open r.val)),
        is_affine_open ((opens.map (X.of_restrict V.open_embedding).1.base).obj U.1),
      { exact this _ rfl, },
      intros V hV,
      rw Scheme.preimage_basic_open at hV,
      subst hV,
      exact U.2.map_restrict_basic_open (Scheme.Γ.map f.op r.1) } }
end

variables {P} (hP : ring_hom.property_is_local @P)

lemma source_affine_locally_of_source_open_cover_aux
  (h₁ : ring_hom.respects_iso @P)
  (h₃ : ring_hom.of_localization_span_target @P)
  {X Y : Scheme} (f : X ⟶ Y) (U : X.affine_opens)
  (s : set (X.presheaf.obj (op U.1))) (hs : ideal.span s = ⊤)
  (hs' : ∀ (r : s), P (Scheme.Γ.map (X.of_restrict (X.basic_open r.1).open_embedding ≫ f).op)) :
    P (Scheme.Γ.map (X.of_restrict U.1.open_embedding ≫ f).op) :=
begin
  apply_fun ideal.map (X.presheaf.map (eq_to_hom U.1.open_embedding_obj_top).op) at hs,
  rw [ideal.map_span, ideal.map_top] at hs,
  apply h₃ _ _ hs,
  rintro ⟨s, r, hr, hs⟩,
  have := (@@localization.alg_equiv _ _ _ _ _ (@@algebraic_geometry.Γ_restrict_is_localization
    _ U.2 s)).to_ring_equiv.to_CommRing_iso,
  refine (h₁.cancel_right_is_iso _ (@@localization.alg_equiv _ _ _ _ _
    (@@algebraic_geometry.Γ_restrict_is_localization _ U.2 s))
      .to_ring_equiv.to_CommRing_iso.hom).mp _,
  subst hs,
  rw [CommRing.comp_eq_ring_hom_comp, ← ring_hom.comp_assoc],
  erw [is_localization.map_comp, ring_hom.comp_id],
  rw [ring_hom.algebra_map_to_algebra, op_comp, functor.map_comp, ← CommRing.comp_eq_ring_hom_comp,
    Scheme.Γ_map_op, Scheme.Γ_map_op, Scheme.Γ_map_op, category.assoc],
  erw ← X.presheaf.map_comp,
  rw [← h₁.cancel_right_is_iso _ (X.presheaf.map (eq_to_hom _))],
  convert hs' ⟨r, hr⟩ using 1,
  { erw category.assoc, rw [← X.presheaf.map_comp, op_comp, Scheme.Γ.map_comp,
    Scheme.Γ_map_op, Scheme.Γ_map_op], congr },
  { dsimp [functor.op],
    conv_lhs { rw opens.open_embedding_obj_top },
    conv_rhs { rw opens.open_embedding_obj_top },
    erw Scheme.image_basic_open (X.of_restrict U.1.open_embedding),
    erw PresheafedSpace.is_open_immersion.of_restrict_inv_app_apply,
    rw Scheme.basic_open_res_eq },
  { apply_instance }
end

lemma is_open_immersion_comp_of_source_affine_locally (h₁ : ring_hom.respects_iso @P)
  {X Y Z : Scheme} [is_affine X] [is_affine Z] (f : X ⟶ Y) [is_open_immersion f] (g : Y ⟶ Z)
  (h₂ : source_affine_locally @P g) :
  P (Scheme.Γ.map (f ≫ g).op) :=
begin
  rw [← h₁.cancel_right_is_iso _ (Scheme.Γ.map (is_open_immersion.iso_of_range_eq
    (Y.of_restrict _) f _).hom.op), ← functor.map_comp, ← op_comp],
  convert h₂ ⟨_, range_is_affine_open_of_open_immersion f⟩ using 3,
  { rw [is_open_immersion.iso_of_range_eq_hom, is_open_immersion.lift_fac_assoc] },
  { apply_instance },
  { exact subtype.range_coe },
  { apply_instance }
end

end algebraic_geometry

open algebraic_geometry

namespace ring_hom.property_is_local

variables {P} (hP : ring_hom.property_is_local @P)

include hP

lemma source_affine_locally_of_source_open_cover
  {X Y : Scheme} (f : X ⟶ Y) [is_affine Y]
  (𝒰 : X.open_cover) [∀ i, is_affine (𝒰.obj i)] (H : ∀ i, P (Scheme.Γ.map (𝒰.map i ≫ f).op)) :
  source_affine_locally @P f :=
begin
  let S := λ i, (⟨⟨set.range (𝒰.map i).1.base, (𝒰.is_open i).base_open.open_range⟩,
    range_is_affine_open_of_open_immersion (𝒰.map i)⟩ : X.affine_opens),
  intros U,
  apply of_affine_open_cover U,
  swap 5, { exact set.range S },
  { intros U r H,
    convert hP.stable_under_composition _ _ H _ using 1,
    swap,
    { refine X.presheaf.map
        (@hom_of_le _ _ ((is_open_map.functor _).obj _) ((is_open_map.functor _).obj _) _).op,
      rw [unop_op, unop_op, opens.open_embedding_obj_top, opens.open_embedding_obj_top],
      exact X.basic_open_le _ },
    { rw [op_comp, op_comp, functor.map_comp, functor.map_comp],
      refine (eq.trans _ (category.assoc _ _ _).symm : _),
      congr' 1,
      refine eq.trans _ (X.presheaf.map_comp _ _),
      change X.presheaf.map _ = _,
      congr },
    convert hP.holds_for_localization_away _
      (X.presheaf.map (eq_to_hom U.1.open_embedding_obj_top).op r),
    { exact (ring_hom.algebra_map_to_algebra _).symm },
    { dsimp [Scheme.Γ],
      have := U.2,
      rw ← U.1.open_embedding_obj_top at this,
      convert is_localization_basic_open this _ using 6;
        rw opens.open_embedding_obj_top; exact (Scheme.basic_open_res_eq _ _ _).symm } },
  { introv hs hs',
    exact source_affine_locally_of_source_open_cover_aux hP.respects_iso hP.2 _ _ _ hs hs' },
  { rw set.eq_univ_iff_forall,
    intro x,
    rw set.mem_Union,
    exact ⟨⟨_, 𝒰.f x, rfl⟩, 𝒰.covers x⟩ },
  { rintro ⟨_, i, rfl⟩,
    specialize H i,
    rw ← hP.respects_iso.cancel_right_is_iso _ (Scheme.Γ.map (is_open_immersion.iso_of_range_eq
      (𝒰.map i) (X.of_restrict (S i).1.open_embedding) subtype.range_coe.symm).inv.op) at H,
    rwa [← Scheme.Γ.map_comp, ← op_comp, is_open_immersion.iso_of_range_eq_inv,
      is_open_immersion.lift_fac_assoc] at H }
end

lemma affine_open_cover_tfae {X Y : Scheme.{u}}
  [is_affine Y] (f : X ⟶ Y) :
  tfae [source_affine_locally @P f,
    ∃ (𝒰 : Scheme.open_cover.{u} X) [∀ i, is_affine (𝒰.obj i)],
      ∀ (i : 𝒰.J), P (Scheme.Γ.map (𝒰.map i ≫ f).op),
    ∀ (𝒰 : Scheme.open_cover.{u} X) [∀ i, is_affine (𝒰.obj i)] (i : 𝒰.J),
      P (Scheme.Γ.map (𝒰.map i ≫ f).op),
    ∀ {U : Scheme} (g : U ⟶ X) [is_affine U] [is_open_immersion g],
      P (Scheme.Γ.map (g ≫ f).op)] :=
begin
  tfae_have : 1 → 4,
  { intros H U g _ hg,
    resetI,
    specialize H ⟨⟨_, hg.base_open.open_range⟩,
      range_is_affine_open_of_open_immersion g⟩,
    rw [← hP.respects_iso.cancel_right_is_iso _ (Scheme.Γ.map (is_open_immersion.iso_of_range_eq
      g (X.of_restrict (opens.open_embedding ⟨_, hg.base_open.open_range⟩))
      subtype.range_coe.symm).hom.op), ← Scheme.Γ.map_comp, ← op_comp,
      is_open_immersion.iso_of_range_eq_hom] at H,
    erw is_open_immersion.lift_fac_assoc at H,
    exact H },
  tfae_have : 4 → 3,
  { intros H 𝒰 _ i, resetI, apply H },
  tfae_have : 3 → 2,
  { intro H, refine ⟨X.affine_cover, infer_instance, H _⟩ },
  tfae_have : 2 → 1,
  { rintro ⟨𝒰, _, h𝒰⟩,
    exactI hP.source_affine_locally_of_source_open_cover f 𝒰 h𝒰 },
  tfae_finish
end

lemma open_cover_tfae {X Y : Scheme.{u}} [is_affine Y] (f : X ⟶ Y) :
  tfae [source_affine_locally @P f,
    ∃ (𝒰 : Scheme.open_cover.{u} X), ∀ (i : 𝒰.J), source_affine_locally @P (𝒰.map i ≫ f),
    ∀ (𝒰 : Scheme.open_cover.{u} X) (i : 𝒰.J), source_affine_locally @P (𝒰.map i ≫ f),
    ∀ {U : Scheme} (g : U ⟶ X) [is_open_immersion g], source_affine_locally @P (g ≫ f)] :=
begin
  tfae_have : 1 → 4,
  { intros H U g hg V,
    resetI,
    rw (hP.affine_open_cover_tfae f).out 0 3 at H,
    haveI : is_affine _ := V.2,
    rw ← category.assoc,
    apply H },
  tfae_have : 4 → 3,
  { intros H 𝒰 _ i, resetI, apply H },
  tfae_have : 3 → 2,
  { intro H, refine ⟨X.affine_cover, H _⟩ },
  tfae_have : 2 → 1,
  { rintro ⟨𝒰, h𝒰⟩,
    rw (hP.affine_open_cover_tfae f).out 0 1,
    refine ⟨𝒰.bind (λ _, Scheme.affine_cover _), _, _⟩,
    { intro i, dsimp, apply_instance },
    { intro i,
      specialize h𝒰 i.1,
      rw (hP.affine_open_cover_tfae (𝒰.map i.fst ≫ f)).out 0 3 at h𝒰,
      erw category.assoc,
      apply @@h𝒰 _ (show _, from _),
      dsimp, apply_instance } },
  tfae_finish
end

lemma source_affine_locally_comp_of_is_open_immersion
  {X Y Z : Scheme.{u}} [is_affine Z] (f : X ⟶ Y) (g : Y ⟶ Z) [is_open_immersion f]
  (H : source_affine_locally @P g) : source_affine_locally @P (f ≫ g) :=
by apply ((hP.open_cover_tfae g).out 0 3).mp H

lemma source_affine_open_cover_iff {X Y : Scheme.{u}} (f : X ⟶ Y)
  [is_affine Y] (𝒰 : Scheme.open_cover.{u} X) [∀ i, is_affine (𝒰.obj i)] :
  source_affine_locally @P f ↔ (∀ i, P (Scheme.Γ.map (𝒰.map i ≫ f).op)) :=
⟨λ H, let h := ((hP.affine_open_cover_tfae f).out 0 2).mp H in h 𝒰,
  λ H, let h := ((hP.affine_open_cover_tfae f).out 1 0).mp in h ⟨𝒰, infer_instance, H⟩⟩

lemma is_local_source_affine_locally :
  (source_affine_locally @P).is_local :=
source_affine_locally_is_local hP.respects_iso hP.localization_preserves
  (@ring_hom.property_is_local.of_localization_span _ hP)

lemma is_local_affine_locally :
  property_is_local_at_target (affine_locally @P) :=
hP.is_local_source_affine_locally.target_affine_locally_is_local

lemma affine_open_cover_iff {X Y : Scheme.{u}} (f : X ⟶ Y)
  (𝒰 : Scheme.open_cover.{u} Y) [∀ i, is_affine (𝒰.obj i)]
  (𝒰' : ∀ i, Scheme.open_cover.{u} ((𝒰.pullback_cover f).obj i)) [∀ i j, is_affine ((𝒰' i).obj j)] :
  affine_locally @P f ↔
    (∀ i j, P (Scheme.Γ.map ((𝒰' i).map j ≫ pullback.snd).op)) :=
(hP.is_local_source_affine_locally.affine_open_cover_iff f 𝒰).trans
    (forall_congr (λ i, hP.source_affine_open_cover_iff _ (𝒰' i)))

lemma source_open_cover_iff {X Y : Scheme.{u}} (f : X ⟶ Y)
  (𝒰 : Scheme.open_cover.{u} X) :
  affine_locally @P f ↔ ∀ i, affine_locally @P (𝒰.map i ≫ f) :=
begin
  split,
  { intros H i U,
    rw morphism_restrict_comp,
    delta morphism_restrict,
    apply hP.source_affine_locally_comp_of_is_open_immersion,
    apply H },
  { intros H U,
    haveI : is_affine _ := U.2,
    apply ((hP.open_cover_tfae (f ∣_ U.1)).out 1 0).mp,
    use 𝒰.pullback_cover (X.of_restrict _),
    intro i,
    specialize H i U,
    rw morphism_restrict_comp at H,
    delta morphism_restrict at H,
    have := source_affine_locally_respects_iso hP.respects_iso,
    rw [category.assoc, affine_cancel_left_is_iso this, ← affine_cancel_left_is_iso
      this (pullback_symmetry _ _).hom, pullback_symmetry_hom_comp_snd_assoc] at H,
    exact H }
end

lemma affine_locally_of_is_open_immersion (hP : ring_hom.property_is_local @P) {X Y : Scheme}
  (f : X ⟶ Y) [hf : is_open_immersion f] : affine_locally @P f :=
begin
  intro U,
  haveI H : is_affine _ := U.2,
  rw ← category.comp_id (f ∣_ U),
  apply hP.source_affine_locally_comp_of_is_open_immersion,
  rw hP.source_affine_open_cover_iff _ (Scheme.open_cover_of_is_iso (𝟙 _)),
  { intro i, erw [category.id_comp, op_id, Scheme.Γ.map_id],
    convert hP.holds_for_localization_away _ (1 : Scheme.Γ.obj _),
    { exact (ring_hom.algebra_map_to_algebra _).symm },
    { apply_instance },
    { refine is_localization.away_of_is_unit_of_bijective _ is_unit_one function.bijective_id } },
  { intro i, exact H }
end

lemma affine_locally_of_comp
  (H : ∀ {R S T : Type.{u}} [comm_ring R] [comm_ring S] [comm_ring T], by exactI
    ∀ (f : R →+* S) (g : S →+* T), P (g.comp f) → P g)
  {X Y Z : Scheme} {f : X ⟶ Y} {g : Y ⟶ Z} (h : affine_locally @P (f ≫ g)) :
  affine_locally @P f :=
begin
  let 𝒰 : ∀ i, ((Z.affine_cover.pullback_cover (f ≫ g)).obj i).open_cover,
  { intro i,
    refine Scheme.open_cover.bind _ (λ i, Scheme.affine_cover _),
    apply Scheme.open_cover.pushforward_iso _
    (pullback_right_pullback_fst_iso g (Z.affine_cover.map i) f).hom,
    apply Scheme.pullback.open_cover_of_right,
    exact (pullback g (Z.affine_cover.map i)).affine_cover },
  haveI h𝒰 : ∀ i j, is_affine ((𝒰 i).obj j), by { dsimp, apply_instance },
  let 𝒰' := (Z.affine_cover.pullback_cover g).bind (λ i, Scheme.affine_cover _),
  haveI h𝒰' : ∀ i, is_affine (𝒰'.obj i), by { dsimp, apply_instance },
  rw hP.affine_open_cover_iff f 𝒰' (λ i, Scheme.affine_cover _),
  rw hP.affine_open_cover_iff (f ≫ g) Z.affine_cover 𝒰 at h,
  rintros ⟨i, j⟩ k,
  dsimp at i j k,
  specialize h i ⟨j, k⟩,
  dsimp only [Scheme.open_cover.bind_map, Scheme.open_cover.pushforward_iso_obj,
    Scheme.pullback.open_cover_of_right_obj, Scheme.open_cover.pushforward_iso_map,
    Scheme.pullback.open_cover_of_right_map, Scheme.open_cover.bind_obj,
    Scheme.open_cover.pullback_cover_obj, Scheme.open_cover.pullback_cover_map] at h ⊢,
  rw [category.assoc, category.assoc, pullback_right_pullback_fst_iso_hom_snd,
    pullback.lift_snd_assoc, category.assoc, ← category.assoc, op_comp, functor.map_comp] at h,
  exact H _ _ h,
end

lemma affine_locally_stable_under_composition :
  (affine_locally @P).stable_under_composition :=
begin
  intros X Y S f g hf hg,
  let 𝒰 : ∀ i, ((S.affine_cover.pullback_cover (f ≫ g)).obj i).open_cover,
  { intro i,
    refine Scheme.open_cover.bind _ (λ i, Scheme.affine_cover _),
    apply Scheme.open_cover.pushforward_iso _
    (pullback_right_pullback_fst_iso g (S.affine_cover.map i) f).hom,
    apply Scheme.pullback.open_cover_of_right,
    exact (pullback g (S.affine_cover.map i)).affine_cover },
  rw hP.affine_open_cover_iff (f ≫ g) S.affine_cover _,
  rotate,
  { exact 𝒰 },
  { intros i j, dsimp at *, apply_instance },
  { rintros i ⟨j, k⟩,
    dsimp at i j k,
    dsimp only [Scheme.open_cover.bind_map, Scheme.open_cover.pushforward_iso_obj,
      Scheme.pullback.open_cover_of_right_obj, Scheme.open_cover.pushforward_iso_map,
      Scheme.pullback.open_cover_of_right_map, Scheme.open_cover.bind_obj],
    rw [category.assoc, category.assoc, pullback_right_pullback_fst_iso_hom_snd,
      pullback.lift_snd_assoc, category.assoc, ← category.assoc, op_comp, functor.map_comp],
    apply hP.stable_under_composition,
    { exact (hP.affine_open_cover_iff _ _ _).mp hg _ _ },
    { delta affine_locally at hf,
      rw (hP.is_local_source_affine_locally.affine_open_cover_tfae f).out 0 3 at hf,
      specialize hf ((pullback g (S.affine_cover.map i)).affine_cover.map j ≫ pullback.fst),
      rw (hP.affine_open_cover_tfae (pullback.snd : pullback f ((pullback g (S.affine_cover.map i))
        .affine_cover.map j ≫ pullback.fst) ⟶ _)).out 0 3 at hf,
      apply hf } }
end

lemma source_affine_locally_stable_under_base_change (h : ring_hom.stable_under_base_change @P) :
  (source_affine_locally @P).stable_under_base_change :=
begin
  intros X Y S hS hX f g H,
  resetI,
  rw (hP.affine_open_cover_tfae (pullback.fst : pullback f g ⟶ _)).out 0 1,
  rw (hP.affine_open_cover_tfae g).out 0 2 at H,
  use Scheme.pullback.open_cover_of_right Y.affine_cover f g,
  split,
  { intro i, dsimp, apply_instance },
  intro i,
  erw pullback.lift_fst,
  rw category.comp_id,
  exact h.Γ_pullback_fst hP.respects_iso _ _ (H Y.affine_cover i),
end

lemma affine_locally_stable_under_base_change (h : ring_hom.stable_under_base_change @P) :
  (affine_locally @P).stable_under_base_change :=
hP.is_local_source_affine_locally.stable_under_base_change
  (source_affine_locally_stable_under_base_change hP h)

lemma affine_locally_local_at_source :
  property_is_local_at_source (affine_locally @P) :=
begin
  constructor,
  { exact target_affine_locally_respects_iso (source_affine_locally_respects_iso hP.respects_iso) },
  { intros, apply affine_locally_stable_under_composition hP,
    { apply affine_locally_of_is_open_immersion hP },
    { assumption } },
  { intros, rwa source_open_cover_iff hP f 𝒰 }
end

end ring_hom.property_is_local

namespace algebraic_geometry

include P

def affine_and : affine_target_morphism_property :=
λ X Y f hY, is_affine X ∧ P (Scheme.Γ.map f.op)

variable {P}

lemma affine_and_target_affine_locally_iff (hP : ring_hom.respects_iso @P)
  {X Y : Scheme} (f : X ⟶ Y) :
  target_affine_locally (affine_and @P) f ↔
    affine f ∧ (∀ U : opens Y.carrier, is_affine_open U → P (f.1.c.app (op U))) :=
begin
  delta target_affine_locally Scheme.affine_opens,
  simp_rw [affine_iff, ← forall_and_distrib, set_coe.forall],
  apply forall₂_congr,
  intros U hU,
  apply and_congr iff.rfl,
  rw [Γ_map_morphism_restrict, hP.cancel_left_is_iso, hP.cancel_right_is_iso],
  refl
end

omit P

variable (P)

lemma target_affine_locally_affine_and_le_affine :
  target_affine_locally (affine_and @P) ≤ @affine :=
begin
  rw affine_eq_affine_property,
  apply target_affine_locally_mono,
  exact λ X Y f hY H, H.1
end

variable {P}

lemma _root_.ring_hom.property_is_local.affine_and_eq (hP : ring_hom.property_is_local @P) :
  target_affine_locally (affine_and @P) = @affine ⊓ affine_locally @P :=
begin
  rw [affine_eq_affine_property, ← target_affine_locally_and],
  congr' 1,
  ext X Y f hY,
  resetI,
  split,
  { intro H, refine ⟨H.1, _⟩,
    rw (hP.affine_open_cover_tfae f).out 0 1,
    refine ⟨Scheme.open_cover_of_is_iso (𝟙 _), λ i, H.1, λ _, _⟩,
    rw [Scheme.open_cover_of_is_iso_map, category.id_comp f],
    exact H.2 },
  { rintros ⟨h₁ : is_affine X, h₂⟩,
    rw (hP.affine_open_cover_tfae f).out 0 2 at h₂,
    have := @h₂ (Scheme.open_cover_of_is_iso (𝟙 _)) (λ _, h₁) punit.star,
    rw [Scheme.open_cover_of_is_iso_map, category.id_comp f] at this,
    refine ⟨h₁, this⟩ }
end

variable (P)

lemma is_local_affine_and
  (hP : ring_hom.respects_iso @P)
  (h₃ : ring_hom.localization_preserves @P)
  (h₄ : ring_hom.of_localization_span @P) : (affine_and @P).is_local :=
begin
  constructor,
  { apply affine_target_morphism_property.respects_iso_mk,
    { rintros X Y Z e f _ ⟨H₁, H₂⟩,
      resetI,
      refine ⟨is_affine_of_iso e.hom, _⟩,
      rw [op_comp, functor.map_comp],
      exact hP.1 (Scheme.Γ.map f.op) (Scheme.Γ.map_iso e.op).CommRing_iso_to_ring_equiv H₂ },
    { rintros X Y Z e f _ ⟨H₁, H₂⟩,
      resetI,
      refine ⟨H₁, _⟩,
      rw [op_comp, functor.map_comp],
      exact hP.2 (Scheme.Γ.map f.op) (Scheme.Γ.map_iso e.op).CommRing_iso_to_ring_equiv H₂ } },
  { rintros X Y hY f r ⟨H₁, H₂⟩,
    resetI,
    refine ⟨affine_affine_property_is_local.2 f r H₁, _⟩,
    rw hP.basic_open_iff,
    apply ring_hom.localization_preserves.away @h₃,
    all_goals { assumption } },
  { rintros X Y hY f s hs H,
    obtain ⟨H₁, H₂⟩ := forall_and_distrib.mp H,
    resetI,
    haveI := affine_affine_property_is_local.3 f s hs H₁,
    refine ⟨_, _⟩,
    swap,
    apply h₄ (Scheme.Γ.map f.op) ↑s hs,
    intro r,
    specialize H₂ r,
    rw hP.basic_open_iff_localization at H₂,
    all_goals { assumption } },
end

lemma affine_and_stable_under_composition (hP' : ring_hom.stable_under_composition @P) :
  (target_affine_locally (affine_and @P)).stable_under_composition :=
begin
  introv X h₁ h₂ U,
  obtain ⟨h₃, h₄⟩ := h₂ U,
  obtain ⟨h₅, h₆⟩ := h₁ ⟨_, h₃⟩,
  split,
  { exact h₅ },
  { rw [morphism_restrict_comp, op_comp, functor.map_comp],
    apply hP'; assumption }
end

lemma affine_and_stable_under_base_change
  (hP : ring_hom.respects_iso @P)
  (h₁ : ring_hom.localization_preserves @P)
  (h₂ : ring_hom.of_localization_span @P)
  (h₃ : _root_.ring_hom.stable_under_base_change @P) :
  (target_affine_locally (affine_and @P)).stable_under_base_change :=
begin
  apply (is_local_affine_and @P hP @h₁ @h₂).stable_under_base_change,
  rintros X Y S hS hX f g ⟨hY, H⟩,
  exactI ⟨infer_instance, h₃.Γ_pullback_fst hP _ _ H⟩
end

lemma affine_and_mono
  (P₁ P₂ : ∀ ⦃R S : Type u⦄ [comm_ring R] [comm_ring S] (f : by exactI R →+* S), Prop)
  (H : ∀ {R S : Type u} [comm_ring R] [comm_ring S], by exactI ∀ (f : R →+* S), P₁ f → P₂ f) :
  target_affine_locally (affine_and P₁) ≤ target_affine_locally (affine_and P₂) :=
begin
  apply target_affine_locally_mono,
  rintros X Y hY f ⟨hX, hf⟩,
  exact ⟨hX, H _ hf⟩,
end

lemma affine_and_Spec_iff {P}
  (h₁ : ring_hom.respects_iso @P) {R S : CommRing} (f : R ⟶ S) :
  affine_and @P (Scheme.Spec.map f.op) ↔ P f :=
begin
  dsimp only [affine_and],
  rw and_iff_right (show is_affine (Scheme.Spec.obj (op S)), by apply_instance),
  have := arrow.iso_w (Γ_Spec_arrow_iso f),
  dsimp only [arrow.mk_hom] at this,
  rw [this, h₁.cancel_left_is_iso, h₁.cancel_right_is_iso],
end

end algebraic_geometry


/-
Copyright (c) 2018 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.Lean3Lib.data.dlist
import Mathlib.PostPort

universes u_1

namespace Mathlib

/-- Concatenates a list of difference lists to form a single
difference list.  Similar to `list.join`. -/
def dlist.join {α : Type u_1} : List (dlist α) → dlist α := sorry

@[simp] theorem dlist_singleton {α : Type u_1} {a : α} :
    dlist.singleton a = dlist.lazy_of_list fun (_ : Unit) => [a] :=
  rfl

@[simp] theorem dlist_lazy {α : Type u_1} {l : List α} :
    (dlist.lazy_of_list fun (_ : Unit) => l) = dlist.of_list l :=
  rfl

end Mathlib


open classical

theorem dne {p : Prop} (h : ¬¬p) : p :=
  or.elim (em p)
    (assume hp : p, hp)
    (assume hnp : ¬p, absurd hnp h)


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

Traversable instance for lazy_lists.
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.control.traversable.equiv
import Mathlib.control.traversable.instances
import Mathlib.Lean3Lib.data.lazy_list
import Mathlib.PostPort

universes u_1 u u_2 u_3

namespace Mathlib

/-!
## Definitions on lazy lists

This file contains various definitions and proofs on lazy lists.

TODO: move the `lazy_list.lean` file from core to mathlib.
-/

namespace thunk

/-- Creates a thunk with a (non-lazy) constant value. -/
def mk {α : Type u_1} (x : α) : thunk α := fun (_x : Unit) => x

protected instance decidable_eq {α : Type u} [DecidableEq α] : DecidableEq (thunk α) := sorry

end thunk

namespace lazy_list

/-- Isomorphism between strict and lazy lists. -/
def list_equiv_lazy_list (α : Type u_1) : List α ≃ lazy_list α :=
  equiv.mk of_list to_list sorry sorry

protected instance inhabited {α : Type u} : Inhabited (lazy_list α) := { default := nil }

protected instance decidable_eq {α : Type u} [DecidableEq α] : DecidableEq (lazy_list α) := sorry

/-- Traversal of lazy lists using an applicative effect. -/
protected def traverse {m : Type u → Type u} [Applicative m] {α : Type u} {β : Type u}
    (f : α → m β) : lazy_list α → m (lazy_list β) :=
  sorry

protected instance traversable : traversable lazy_list := traversable.mk lazy_list.traverse

protected instance is_lawful_traversable : is_lawful_traversable lazy_list :=
  equiv.is_lawful_traversable' list_equiv_lazy_list sorry sorry sorry

/-- `init xs`, if `xs` non-empty, drops the last element of the list.
Otherwise, return the empty list. -/
def init {α : Type u_1} : lazy_list α → lazy_list α := sorry

/-- Return the first object contained in the list that satisfies
predicate `p` -/
def find {α : Type u_1} (p : α → Prop) [decidable_pred p] : lazy_list α → Option α := sorry

/-- `interleave xs ys` creates a list where elements of `xs` and `ys` alternate. -/
def interleave {α : Type u_1} : lazy_list α → lazy_list α → lazy_list α := sorry

/-- `interleave_all (xs::ys::zs::xss)` creates a list where elements of `xs`, `ys`
and `zs` and the rest alternate. Every other element of the resulting list is taken from
`xs`, every fourth is taken from `ys`, every eighth is taken from `zs` and so on. -/
def interleave_all {α : Type u_1} : List (lazy_list α) → lazy_list α := sorry

/-- Monadic bind operation for `lazy_list`. -/
protected def bind {α : Type u_1} {β : Type u_2} : lazy_list α → (α → lazy_list β) → lazy_list β :=
  sorry

/-- Reverse the order of a `lazy_list`.
It is done by converting to a `list` first because reversal involves evaluating all
the list and if the list is all evaluated, `list` is a better representation for
it than a series of thunks. -/
def reverse {α : Type u_1} (xs : lazy_list α) : lazy_list α := of_list (list.reverse (to_list xs))

protected instance monad : Monad lazy_list := sorry

theorem append_nil {α : Type u_1} (xs : lazy_list α) : (append xs fun (_ : Unit) => nil) = xs :=
  sorry

theorem append_assoc {α : Type u_1} (xs : lazy_list α) (ys : lazy_list α) (zs : lazy_list α) :
    (append (append xs fun (_ : Unit) => ys) fun (_ : Unit) => zs) =
        append xs fun (_ : Unit) => append ys fun (_ : Unit) => zs :=
  sorry

theorem append_bind {α : Type u_1} {β : Type u_2} (xs : lazy_list α) (ys : thunk (lazy_list α))
    (f : α → lazy_list β) :
    lazy_list.bind (append xs ys) f =
        append (lazy_list.bind xs f) fun (_ : Unit) => lazy_list.bind (ys Unit.unit) f :=
  sorry

protected instance is_lawful_monad : is_lawful_monad lazy_list := sorry

/-- Try applying function `f` to every element of a `lazy_list` and
return the result of the first attempt that succeeds. -/
def mfirst {m : Type u_1 → Type u_2} [alternative m] {α : Type u_3} {β : Type u_1} (f : α → m β) :
    lazy_list α → m β :=
  sorry

/-- Membership in lazy lists -/
protected def mem {α : Type u_1} (x : α) : lazy_list α → Prop := sorry

protected instance has_mem {α : outParam (Type u_1)} : has_mem α (lazy_list α) :=
  has_mem.mk lazy_list.mem

protected instance mem.decidable {α : Type u_1} [DecidableEq α] (x : α) (xs : lazy_list α) :
    Decidable (x ∈ xs) :=
  sorry

@[simp] theorem mem_nil {α : Type u_1} (x : α) : x ∈ nil ↔ False := iff.rfl

@[simp] theorem mem_cons {α : Type u_1} (x : α) (y : α) (ys : thunk (lazy_list α)) :
    x ∈ cons y ys ↔ x = y ∨ x ∈ ys Unit.unit :=
  iff.rfl

theorem forall_mem_cons {α : Type u_1} {p : α → Prop} {a : α} {l : thunk (lazy_list α)} :
    (∀ (x : α), x ∈ cons a l → p x) ↔ p a ∧ ∀ (x : α), x ∈ l Unit.unit → p x :=
  sorry

/-! ### map for partial functions -/

/-- Partial map. If `f : Π a, p a → β` is a partial function defined on
  `a : α` satisfying `p`, then `pmap f l h` is essentially the same as `map f l`
  but is defined only when all members of `l` satisfy `p`, using the proof
  to apply `f`. -/
@[simp] def pmap {α : Type u_1} {β : Type u_2} {p : α → Prop} (f : (a : α) → p a → β)
    (l : lazy_list α) : (∀ (a : α), a ∈ l → p a) → lazy_list β :=
  sorry

/-- "Attach" the proof that the elements of `l` are in `l` to produce a new `lazy_list`
  with the same elements but in the type `{x // x ∈ l}`. -/
def attach {α : Type u_1} (l : lazy_list α) : lazy_list (Subtype fun (x : α) => x ∈ l) :=
  pmap Subtype.mk l sorry

protected instance has_repr {α : Type u_1} [has_repr α] : has_repr (lazy_list α) :=
  has_repr.mk fun (xs : lazy_list α) => repr (to_list xs)

end Mathlib